## ********************************************************
 ## 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-)
----
[Category Package]