## ********************************************************
## 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.
##
## When the stack being manipulated is at global scope,
## remember to refer to it as ::name, or the error handler
## will complain about scoping problems.
## ********************************************************
;#barecode
package provide stack 2.0
namespace eval stack {
variable nodebug 0
}
## ********************************************************
## Name: stack::getItem
##
## Description:
## Retrieves an item from stack and returns index into stack.
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 {} ]
}
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::popvector
##
## 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::popvector { { stack "" } { n 1 } } {
set s [ uplevel 1 [ list set $stack ] ]
stack::errorTest
incr n -1
set data [ lrange $s 0 $n ]
incr n 1
set s [ lrange $s $n end ]
uplevel 1 [ list set $stack $s ]
set data
}
## ********************************************************
## ********************************************************
## Name: stack::pop
##
## Description:
## Pop a single item from the "top" of the list/stack.
## Equivalent to [lindex [stack::popvector $stackName 1] 0]
proc stack::pop {{stack {}}} {
stack::errorTest
set s [ uplevel 1 [ list set $stack ]]
uplevel 1 [ list set $stack [ lrange $s 1 end ]]
lindex $s 0
}
## ********************************************************
## ********************************************************
## 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 } {
stack::errorTest
set s [ uplevel 1 [ list set $stack ] ]
uplevel 1 [ list set $stack [ concat $args $s ] ]
}
## ********************************************************
## ********************************************************
## Name: stack::shift
##
## Description:
## Shift items onto bottom of list/stack.
##
## Notes:
## Equivalent to lappend.
proc stack::shift { { stack "" } args } {
stack::errorTest
uplevel 1 [concat [list lappend $stack] $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
uplevel 1 [ list set $stack [ lrange $s 0 end-$n ] ]
lrange $s end-[ expr {$n-1} ] end
}
## ********************************************************
## ********************************************************
## 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 } {
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
eval [list stack::push s] [stack::unshift s $n]
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
eval [list stack::shift s ] [stack::popvector s $n]
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]
for {set i [expr {[llength $s]-1}]} {$i>=0} {incr i -1} {
lappend rev [lindex $s $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} {incr length -1} {
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::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] && ![llength $args]} {
return -code error "No extra values 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" } } {
return [ lindex [ info level $level ] 0 ]
}
## ********************************************************With regard to shuffle above, see Shuffle a list. Timing results are available too through that page.
KBK: Thanks for the plug. 8-)