505 lines
12 KiB
505 lines
12 KiB
# stack.tcl -- |
|
# |
|
# Stack implementation for Tcl. |
|
# |
|
# Copyright (c) 1998-2000 by Ajuba Solutions. |
|
# |
|
# See the file "license.terms" for information on usage and redistribution |
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
|
# |
|
# RCS: @(#) $Id: stack_tcl.tcl,v 1.3 2010/03/15 17:17:38 andreas_kupries Exp $ |
|
|
|
namespace eval ::struct::stack { |
|
# counter is used to give a unique name for unnamed stacks |
|
variable counter 0 |
|
|
|
# Only export one command, the one used to instantiate a new stack |
|
namespace export stack_tcl |
|
} |
|
|
|
# ::struct::stack::stack_tcl -- |
|
# |
|
# Create a new stack with a given name; if no name is given, use |
|
# stackX, where X is a number. |
|
# |
|
# Arguments: |
|
# name name of the stack; if null, generate one. |
|
# |
|
# Results: |
|
# name name of the stack created |
|
|
|
proc ::struct::stack::stack_tcl {args} { |
|
variable I::stacks |
|
variable counter |
|
|
|
switch -exact -- [llength [info level 0]] { |
|
1 { |
|
# Missing name, generate one. |
|
incr counter |
|
set name "stack${counter}" |
|
} |
|
2 { |
|
# Standard call. New empty stack. |
|
set name [lindex $args 0] |
|
} |
|
default { |
|
# Error. |
|
return -code error \ |
|
"wrong # args: should be \"stack ?name?\"" |
|
} |
|
} |
|
|
|
# FIRST, qualify the name. |
|
if {![string match "::*" $name]} { |
|
# Get caller's namespace; append :: if not global namespace. |
|
set ns [uplevel 1 [list namespace current]] |
|
if {"::" != $ns} { |
|
append ns "::" |
|
} |
|
|
|
set name "$ns$name" |
|
} |
|
if {[llength [info commands $name]]} { |
|
return -code error \ |
|
"command \"$name\" already exists, unable to create stack" |
|
} |
|
|
|
set stacks($name) [list ] |
|
|
|
# Create the command to manipulate the stack |
|
interp alias {} $name {} ::struct::stack::StackProc $name |
|
|
|
return $name |
|
} |
|
|
|
########################## |
|
# Private functions follow |
|
|
|
# ::struct::stack::StackProc -- |
|
# |
|
# Command that processes all stack object commands. |
|
# |
|
# Arguments: |
|
# name name of the stack object to manipulate. |
|
# args command name and args for the command |
|
# |
|
# Results: |
|
# Varies based on command to perform |
|
|
|
if {[package vsatisfies [package provide Tcl] 8.5]} { |
|
# In 8.5+ we can do an ensemble for fast dispatch. |
|
|
|
proc ::struct::stack::StackProc {name cmd args} { |
|
# Shuffle method to front and then simply run the ensemble. |
|
# Dispatch, argument checking, and error message generation |
|
# are all done in the C-level. |
|
|
|
I $cmd $name {*}$args |
|
} |
|
|
|
namespace eval ::struct::stack::I { |
|
namespace export clear destroy get getr peek peekr \ |
|
trim trim* pop push rotate size |
|
namespace ensemble create |
|
} |
|
|
|
} else { |
|
# Before 8.5 we have to code our own dispatch, including error |
|
# checking. |
|
|
|
proc ::struct::stack::StackProc {name cmd args} { |
|
# Do minimal args checks here |
|
if { [llength [info level 0]] == 2 } { |
|
return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" |
|
} |
|
|
|
# Split the args into command and args components |
|
if {![llength [info commands ::struct::stack::I::$cmd]]} { |
|
set optlist [lsort [info commands ::struct::stack::I::*]] |
|
set xlist {} |
|
foreach p $optlist { |
|
set p [namespace tail $p] |
|
if {($p eq "K") || ($p eq "lreverse")} continue |
|
lappend xlist $p |
|
} |
|
set optlist [linsert [join $xlist ", "] "end-1" "or"] |
|
return -code error \ |
|
"bad option \"$cmd\": must be $optlist" |
|
} |
|
|
|
uplevel 1 [linsert $args 0 ::struct::stack::I::$cmd $name] |
|
} |
|
} |
|
|
|
# ### ### ### ######### ######### ######### |
|
|
|
namespace eval ::struct::stack::I { |
|
# The stacks array holds all of the stacks you've made |
|
variable stacks |
|
} |
|
|
|
# ### ### ### ######### ######### ######### |
|
|
|
# ::struct::stack::I::clear -- |
|
# |
|
# Clear a stack. |
|
# |
|
# Arguments: |
|
# name name of the stack object. |
|
# |
|
# Results: |
|
# None. |
|
|
|
proc ::struct::stack::I::clear {name} { |
|
variable stacks |
|
set stacks($name) {} |
|
return |
|
} |
|
|
|
# ::struct::stack::I::destroy -- |
|
# |
|
# Destroy a stack object by removing it's storage space and |
|
# eliminating it's proc. |
|
# |
|
# Arguments: |
|
# name name of the stack object. |
|
# |
|
# Results: |
|
# None. |
|
|
|
proc ::struct::stack::I::destroy {name} { |
|
variable stacks |
|
unset stacks($name) |
|
interp alias {} $name {} |
|
return |
|
} |
|
|
|
# ::struct::stack::I::get -- |
|
# |
|
# Retrieve the whole contents of the stack. |
|
# |
|
# Arguments: |
|
# name name of the stack object. |
|
# |
|
# Results: |
|
# items list of all items in the stack. |
|
|
|
proc ::struct::stack::I::get {name} { |
|
variable stacks |
|
return [lreverse $stacks($name)] |
|
} |
|
|
|
proc ::struct::stack::I::getr {name} { |
|
variable stacks |
|
return $stacks($name) |
|
} |
|
|
|
# ::struct::stack::I::peek -- |
|
# |
|
# Retrieve the value of an item on the stack without popping it. |
|
# |
|
# Arguments: |
|
# name name of the stack object. |
|
# count number of items to pop; defaults to 1 |
|
# |
|
# Results: |
|
# items top count items from the stack; if there are not enough items |
|
# to fulfill the request, throws an error. |
|
|
|
proc ::struct::stack::I::peek {name {count 1}} { |
|
variable stacks |
|
upvar 0 stacks($name) mystack |
|
|
|
if { $count < 1 } { |
|
return -code error "invalid item count $count" |
|
} elseif { $count > [llength $mystack] } { |
|
return -code error "insufficient items on stack to fill request" |
|
} |
|
|
|
if { $count == 1 } { |
|
# Handle this as a special case, so single item peeks are not |
|
# listified |
|
return [lindex $mystack end] |
|
} |
|
|
|
# Otherwise, return a list of items |
|
incr count -1 |
|
return [lreverse [lrange $mystack end-$count end]] |
|
} |
|
|
|
proc ::struct::stack::I::peekr {name {count 1}} { |
|
variable stacks |
|
upvar 0 stacks($name) mystack |
|
|
|
if { $count < 1 } { |
|
return -code error "invalid item count $count" |
|
} elseif { $count > [llength $mystack] } { |
|
return -code error "insufficient items on stack to fill request" |
|
} |
|
|
|
if { $count == 1 } { |
|
# Handle this as a special case, so single item peeks are not |
|
# listified |
|
return [lindex $mystack end] |
|
} |
|
|
|
# Otherwise, return a list of items, in reversed order. |
|
incr count -1 |
|
return [lrange $mystack end-$count end] |
|
} |
|
|
|
# ::struct::stack::I::trim -- |
|
# |
|
# Pop items off a stack until a maximum size is reached. |
|
# |
|
# Arguments: |
|
# name name of the stack object. |
|
# count requested size of the stack. |
|
# |
|
# Results: |
|
# item List of items trimmed, may be empty. |
|
|
|
proc ::struct::stack::I::trim {name newsize} { |
|
variable stacks |
|
upvar 0 stacks($name) mystack |
|
|
|
if { ![string is integer -strict $newsize]} { |
|
return -code error "expected integer but got \"$newsize\"" |
|
} elseif { $newsize < 0 } { |
|
return -code error "invalid size $newsize" |
|
} elseif { $newsize >= [llength $mystack] } { |
|
# Stack is smaller than requested, do nothing. |
|
return {} |
|
} |
|
|
|
# newsize < [llength $mystack] |
|
# pop '[llength $mystack]' - newsize elements. |
|
|
|
if {!$newsize} { |
|
set result [lreverse [K $mystack [unset mystack]]] |
|
set mystack {} |
|
} else { |
|
set result [lreverse [lrange $mystack $newsize end]] |
|
set mystack [lreplace [K $mystack [unset mystack]] $newsize end] |
|
} |
|
|
|
return $result |
|
} |
|
|
|
proc ::struct::stack::I::trim* {name newsize} { |
|
if { ![string is integer -strict $newsize]} { |
|
return -code error "expected integer but got \"$newsize\"" |
|
} elseif { $newsize < 0 } { |
|
return -code error "invalid size $newsize" |
|
} |
|
|
|
variable stacks |
|
upvar 0 stacks($name) mystack |
|
|
|
if { $newsize >= [llength $mystack] } { |
|
# Stack is smaller than requested, do nothing. |
|
return |
|
} |
|
|
|
# newsize < [llength $mystack] |
|
# pop '[llength $mystack]' - newsize elements. |
|
|
|
# No results, compared to trim. |
|
|
|
if {!$newsize} { |
|
set mystack {} |
|
} else { |
|
set mystack [lreplace [K $mystack [unset mystack]] $newsize end] |
|
} |
|
|
|
return |
|
} |
|
|
|
# ::struct::stack::I::pop -- |
|
# |
|
# Pop an item off a stack. |
|
# |
|
# Arguments: |
|
# name name of the stack object. |
|
# count number of items to pop; defaults to 1 |
|
# |
|
# Results: |
|
# item top count items from the stack; if the stack is empty, |
|
# returns a list of count nulls. |
|
|
|
proc ::struct::stack::I::pop {name {count 1}} { |
|
variable stacks |
|
upvar 0 stacks($name) mystack |
|
|
|
if { $count < 1 } { |
|
return -code error "invalid item count $count" |
|
} |
|
set ssize [llength $mystack] |
|
if { $count > $ssize } { |
|
return -code error "insufficient items on stack to fill request" |
|
} |
|
|
|
if { $count == 1 } { |
|
# Handle this as a special case, so single item pops are not |
|
# listified |
|
set item [lindex $mystack end] |
|
if {$count == $ssize} { |
|
set mystack [list] |
|
} else { |
|
set mystack [lreplace [K $mystack [unset mystack]] end end] |
|
} |
|
return $item |
|
} |
|
|
|
# Otherwise, return a list of items, and remove the items from the |
|
# stack. |
|
if {$count == $ssize} { |
|
set result [lreverse [K $mystack [unset mystack]]] |
|
set mystack [list] |
|
} else { |
|
incr count -1 |
|
set result [lreverse [lrange $mystack end-$count end]] |
|
set mystack [lreplace [K $mystack [unset mystack]] end-$count end] |
|
} |
|
return $result |
|
|
|
# ------------------------------------------------------- |
|
|
|
set newsize [expr {[llength $mystack] - $count}] |
|
|
|
if {!$newsize} { |
|
set result [lreverse [K $mystack [unset mystack]]] |
|
set mystack {} |
|
} else { |
|
set result [lreverse [lrange $mystack $newsize end]] |
|
set mystack [lreplace [K $mystack [unset mystack]] $newsize end] |
|
} |
|
|
|
if {$count == 1} { |
|
set result [lindex $result 0] |
|
} |
|
|
|
return $result |
|
} |
|
|
|
# ::struct::stack::I::push -- |
|
# |
|
# Push an item onto a stack. |
|
# |
|
# Arguments: |
|
# name name of the stack object |
|
# args items to push. |
|
# |
|
# Results: |
|
# None. |
|
|
|
if {[package vsatisfies [package provide Tcl] 8.5]} { |
|
|
|
proc ::struct::stack::I::push {name args} { |
|
if {![llength $args]} { |
|
return -code error "wrong # args: should be \"$name push item ?item ...?\"" |
|
} |
|
|
|
variable stacks |
|
upvar 0 stacks($name) mystack |
|
|
|
lappend mystack {*}$args |
|
return |
|
} |
|
} else { |
|
proc ::struct::stack::I::push {name args} { |
|
if {![llength $args]} { |
|
return -code error "wrong # args: should be \"$name push item ?item ...?\"" |
|
} |
|
|
|
variable stacks |
|
upvar 0 stacks($name) mystack |
|
|
|
if {[llength $args] == 1} { |
|
lappend mystack [lindex $args 0] |
|
} else { |
|
eval [linsert $args 0 lappend mystack] |
|
} |
|
return |
|
} |
|
} |
|
|
|
# ::struct::stack::I::rotate -- |
|
# |
|
# Rotate the top count number of items by step number of steps. |
|
# |
|
# Arguments: |
|
# name name of the stack object. |
|
# count number of items to rotate. |
|
# steps number of steps to rotate. |
|
# |
|
# Results: |
|
# None. |
|
|
|
proc ::struct::stack::I::rotate {name count steps} { |
|
variable stacks |
|
upvar 0 stacks($name) mystack |
|
set len [llength $mystack] |
|
if { $count > $len } { |
|
return -code error "insufficient items on stack to fill request" |
|
} |
|
|
|
# Rotation algorithm: |
|
# do |
|
# Find the insertion point in the stack |
|
# Move the end item to the insertion point |
|
# repeat $steps times |
|
|
|
set start [expr {$len - $count}] |
|
set steps [expr {$steps % $count}] |
|
|
|
if {$steps == 0} return |
|
|
|
for {set i 0} {$i < $steps} {incr i} { |
|
set item [lindex $mystack end] |
|
set mystack [linsert \ |
|
[lreplace \ |
|
[K $mystack [unset mystack]] \ |
|
end end] $start $item] |
|
} |
|
return |
|
} |
|
|
|
# ::struct::stack::I::size -- |
|
# |
|
# Return the number of objects on a stack. |
|
# |
|
# Arguments: |
|
# name name of the stack object. |
|
# |
|
# Results: |
|
# count number of items on the stack. |
|
|
|
proc ::struct::stack::I::size {name} { |
|
variable stacks |
|
return [llength $stacks($name)] |
|
} |
|
|
|
# ### ### ### ######### ######### ######### |
|
|
|
proc ::struct::stack::I::K {x y} { set x } |
|
|
|
if {![llength [info commands lreverse]]} { |
|
proc ::struct::stack::I::lreverse {x} { |
|
# assert (llength(x) > 1) |
|
set l [llength $x] |
|
if {$l <= 1} { return $x } |
|
set r [list] |
|
while {$l} { lappend r [lindex $x [incr l -1]] } |
|
return $r |
|
} |
|
} |
|
|
|
# ### ### ### ######### ######### ######### |
|
## Ready |
|
|
|
namespace eval ::struct { |
|
# Get 'stack::stack' into the general structure namespace for |
|
# pickup by the main management. |
|
namespace import -force stack::stack_tcl |
|
}
|
|
|