## ******************************************************** ## stack.tcl version 2.0 ## ## Provides stack-like functions for tcl. ## ## Release Date: 00.04.07. ## ## In all of these functions, a Tcl list is handled like ## a stack. ## ## The caller wishing to use these functions without ## qualifiying the names with stack:: should include the ## line: ## namespace import stack::*. ## after requiring or sourcing this code. Possibly ## qualfying this with: ## namespace forget stack::errorTest. ## ## When speed is more important than exception handling ## the variable "stack::nodebug" can be set to "1" and ## things will go somewhat faster. ## ## When debugging IS enabled, the CALLING function must ## be caught to catch the uplevel'd exceptions. ## ******************************************************** ;#barecode package provide stack 1.0 namespace eval stack { variable nodebug 0 } ## ******************************************************** ## Name: stack::pop ## ## Description: ## Pop items from the "top" of the list/stack. ## "n" is the number of elements to pop. ## Popped items are removed from the list and ## returned. proc stack::pop { { stack "" } { n 1 } } { set s [ uplevel 1 [ list set $stack ] ] stack::errorTest decr n set data [ lrange $s 0 $n ] incr n set s [ lrange $s $n end ] uplevel 1 [ list set $stack $s ] set data } ## ******************************************************** ## ******************************************************** ## Name: stack::push ## ## Description: ## Push items onto the top of the list/stack. ## "args" is a special Tcl variable which collects all ## arguments to a proc which are not explicitly named. proc stack::push { { stack "" } { args "" } } { set s [ uplevel 1 [ list set $stack ] ] stack::errorTest uplevel 1 [ list set $stack [ concat $args $s ] ] } ## ******************************************************** ## ******************************************************** ## Name: stack::shift ## ## Description: ## Shift items onto bottom of list/stack. proc stack::shift { { stack "" } { args "" } } { set s [ uplevel 1 [ list set $stack ] ] stack::errorTest uplevel 1 [ list set $stack [ concat $s $args ] ] } ## ******************************************************** ## ******************************************************** ## Name: stack::unshift ## ## Description: ## Unshifts items from the bottom of the list/stack. ## Unshifted items are removed from the list and returned. proc stack::unshift { { stack "" } { n 1 } } { set s [ uplevel 1 [ list set $stack ] ] stack::errorTest set data [ lrange $s end-[ expr { $n - 1 } ] end ] uplevel 1 [ list set $stack [ lrange $s 0 end-$n ] ] set data } ## ******************************************************** ## ******************************************************** ## Name: stack::prune ## ## Description: ## Prunes a list/stack based on a regular expression. ## "n" here refers to the number of items to associate ## into a group for regexp processing. ## Useful for things like queues where a key is associated ## with a number of entries and you want to strip out all ## entries based on a key. ## Pruned values are removed from the list/stack and ## returned. proc stack::prune { { stack "" } { regex "" } { n 1 } } { set s [ uplevel 1 [ list set $stack ] ] stack::errorTest set twigs [ list ] set i 0 while { 1 } { ;## use -regexp in case items are lists themselves set i [ lsearch -regexp $s $regex ] if { $i < 0 } { break } set j [ expr {$i + $n - 1} ] set data [ lrange $s $i $j ] set twigs [ concat $twigs $data ] set s [ lreplace $s $i $j ] } uplevel 1 [ list set $stack $s ] set twigs } ## ******************************************************** ## ******************************************************** ## ## Name: stack::circB ## ## Description: ## Cause a stack to behave like a circular buffer, or ## like a "history" buffer. ## This function and stack::circF are complementary, ## enabling "forward" and "backward" circulation. proc stack::circB { { stack "" } { n 1 } } { set s [ uplevel 1 [ list set $stack ] ] stack::errorTest for { set data [ list ] } { $n > 0 } { decr n } { set data [ stack::unshift s ] stack::push s $data } uplevel 1 [ list set $stack $s ] } ## ******************************************************** ## ******************************************************** ## ## Name: stack::circF ## ## Description: ## Causes a stack to behave like a circular buffer, or ## like a "history" buffer. ## This function and stack::circB are complementary, ## enabling "forward" and "backward" circulation. proc stack::circF { { stack "" } { n 1 } } { set s [ uplevel 1 [ list set $stack ] ] stack::errorTest for { set data [ list ] } { $n > 0 } { decr n } { set data [ stack::pop s ] eval [ list stack::shift s ] $data } uplevel 1 [ list set $stack $s ] } ## ******************************************************** ## ******************************************************** ## ## Name: stack::flip ## ## Description: ## Reverses the order of elements in a stack or list. proc stack::flip { { stack "" } } { set s [ uplevel 1 [ list set $stack ] ] stack::errorTest set rev [ list ] set i 0 set length [ llength $s ] while { $i < $length } { set rev [ concat $rev [ lindex $s end-$i ] ] incr i } uplevel 1 [ list set $stack $rev ] } ## ******************************************************** ## ******************************************************** ## ## Name: stack::shuffle ## ## Description: ## Randomly reorder items in a list. proc stack::shuffle { { stack "" } } { set s [ uplevel 1 [ list set $stack ] ] stack::errorTest set deck [ list ] expr srand([ clock clicks ]) for { set length [ llength $s ] } { $length > 0 } { decr length } { set i [ expr {int ( rand() * $length )} ] lappend deck [lindex $s $i] set s [ lreplace $s $i $i ] } uplevel 1 [ list set $stack $deck ] } ## ******************************************************** ## ******************************************************** ## Name: stack::getItem ## ## Description: ## Retrieves an item from stack and returns a list of the ## index of the item and the item itself. proc stack::getItem { { stack "" } { regex "" } { n 1 } } { set s [ uplevel 1 [ list set $stack ] ] stack::errorTest set i [ lsearch -regexp $s $regex ] if { $i < 0 } { return [ list -1 [ list ] ] } set j [ expr {$i + $n - 1} ] set data [ lrange $s $i $j ] return [ list $i $data ] } ## ******************************************************** ## ******************************************************** ## Name: stack::updateItem ## ## Description: ## Replace an item from stack. ## Use getItem to locate item ## note that an lreplace on index -1 causes a push! proc stack::updateItem { { stack "" } { index -1 } { newitem "" } } { if { $index < 0 } { return } set s [ uplevel 1 [ list set $stack ] ] stack::errorTest set s [ lreplace $s $index $index $newitem ] uplevel 1 [ list set $stack $s ] } ## ******************************************************** ## ******************************************************** ## ## Name: stack::errorTest ## ## Description: ## Error tests for stack validity. Not rigorous. ## Tests done in level of caller. proc stack::errorTest {} { if { $stack::nodebug } { return {} } uplevel 1 { if { ! [ info exists stack ] } { return -code error "stack::errorTest called externally." } elseif { [ info exists n ] && [ regexp { [^0-9] } $n ] } { return -code error "Second argument must be integer." } elseif { [ info exists args ] && ! [ string length $args ] } { return -code error "Empty argument string passed." } elseif { ! [ string length $stack ] } { return -code error "No stack name given." } elseif { ! [ llength $s ] } { if { ! [ regexp {:push|:shift} [ stack::myName ] ] } { return -code error "Stack \"$stack\" exhausted." } } } } ## ******************************************************** ## ******************************************************** ## ## Name: stack::myName ## ## Description: ## Returns the name of the calling procedure. Does this ## by parsing level info. Level -1 is the immediate ## caller, level -2 is the caller of the caller, etc. proc stack::myName { { level "-1" } } { if { [ catch { set name [ lindex [ info level $level ] 0 ] } err ] } { if { [ info exists ::API ] } { set name $::API } else { set name unknown_caller } } set name } ## ******************************************************** ## ******************************************************** ## ## Name: decr ## ## Description: ## Decrement function, analog for incr. ## ## Parameters: ## ## Usage: ## ## Comments: ## Sign convention is correct relative to incr. proc decr { int { n 1 } } { if { [ catch { uplevel incr $int -$n } err ] } { return -code error "decr: $err" } } ## ********************************************************
With regard to shuffle above, see Shuffle a list. Timing results are available too through that page.KBK: Thanks for the plug. 8-)