## ********************************************************
## 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-)
