diff options
Diffstat (limited to 'library/struct1.0')
-rw-r--r-- | library/struct1.0/pkgIndex.tcl | 11 | ||||
-rw-r--r-- | library/struct1.0/queue.tcl | 239 | ||||
-rw-r--r-- | library/struct1.0/stack.tcl | 276 | ||||
-rw-r--r-- | library/struct1.0/struct.tcl | 8 |
4 files changed, 534 insertions, 0 deletions
diff --git a/library/struct1.0/pkgIndex.tcl b/library/struct1.0/pkgIndex.tcl new file mode 100644 index 0000000..c1c4b4e --- /dev/null +++ b/library/struct1.0/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded struct 1.0 [list source [file join $dir struct.tcl]] diff --git a/library/struct1.0/queue.tcl b/library/struct1.0/queue.tcl new file mode 100644 index 0000000..22cf939 --- /dev/null +++ b/library/struct1.0/queue.tcl @@ -0,0 +1,239 @@ +# queue.tcl -- +# +# Queue implementation for Tcl. +# +# Copyright (c) 1998-2000 by Scriptics Corporation. +# All rights reserved. +# +# RCS: @(#) $Id: queue.tcl,v 1.1 2000/02/05 03:20:20 ericm Exp $ + +namespace eval ::struct {} + +namespace eval ::struct::queue { + # The queues array holds all of the queues you've made + variable queues + + # counter is used to give a unique name for unnamed queues + variable counter 0 + + # commands is the list of subcommands recognized by the queue + variable commands [list \ + "clear" \ + "destroy" \ + "get" \ + "peek" \ + "put" \ + "size" \ + ] + + # Only export one command, the one used to instantiate a new queue + namespace export queue +} + +# ::struct::queue::queue -- +# +# Create a new queue with a given name; if no name is given, use +# queueX, where X is a number. +# +# Arguments: +# name name of the queue; if null, generate one. +# +# Results: +# name name of the queue created + +proc ::struct::queue::queue {{name ""}} { + variable queues + variable counter + + if { [llength [info level 0]] == 1 } { + incr counter + set name "queue${counter}" + } + + if { ![string equal [info commands ::$name] ""] } { + error "command \"$name\" already exists, unable to create queue" + } + + # Initialize the queue as empty + set queues($name) [list ] + + # Create the command to manipulate the queue + interp alias {} ::$name {} ::struct::queue::QueueProc $name + + return $name +} + +########################## +# Private functions follow + +# ::struct::queue::QueueProc -- +# +# Command that processes all queue object commands. +# +# Arguments: +# name name of the queue object to manipulate. +# args command name and args for the command +# +# Results: +# Varies based on command to perform + +proc ::struct::queue::QueueProc {name {cmd ""} args} { + # Make sure this queue exists + if { ![info exists ::struct::queue::queues($name)] } { + error "unknown queue \"$name\"" + } + + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + if { [string equal [info commands ::struct::queue::_$cmd] ""] } { + variable commands + set optlist [join $commands ", "] + set optlist [linsert $optlist "end-1" "or"] + error "bad option \"$cmd\": must be $optlist" + } + return [uplevel 1 [list ::struct::queue::_$cmd $name] $args] +} + +# ::struct::queue::_clear -- +# +# Clear a queue. +# +# Arguments: +# name name of the queue object. +# +# Results: +# None. + +proc ::struct::queue::_clear {name} { + variable queues + set queues($name) [list ] + return +} + +# ::struct::queue::_destroy -- +# +# Destroy a queue object by removing it's storage space and +# eliminating it's proc. +# +# Arguments: +# name name of the queue object. +# +# Results: +# None. + +proc ::struct::queue::_destroy {name} { + variable queues + unset queues($name) + interp alias {} ::$name {} + return +} + +# ::struct::queue::_get -- +# +# Get an item from a queue. +# +# Arguments: +# name name of the queue object. +# count number of items to get; defaults to 1 +# +# Results: +# item first count items from the queue; if there are not enough +# items in the queue, throws an error. + +proc ::struct::queue::_get {name {count 1}} { + variable queues + if { $count < 1 } { + error "invalid item count $count" + } + + if { $count > [llength $queues($name)] } { + error "insufficient items in queue to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item gets aren't listified + set item [lindex $queues($name) 0] + set queues($name) [lreplace $queues($name) 0 0] + return $item + } + + # Otherwise, return a list of items + set index [expr {$count - 1}] + set result [lrange $queues($name) 0 $index] + set queues($name) [lreplace $queues($name) 0 $index] + + return $result +} + +# ::struct::queue::_peek -- +# +# Retrive the value of an item on the queue without removing it. +# +# Arguments: +# name name of the queue object. +# count number of items to peek; defaults to 1 +# +# Results: +# items top count items from the queue; if there are not enough items +# to fufill the request, throws an error. + +proc ::struct::queue::_peek {name {count 1}} { + variable queues + if { $count < 1 } { + error "invalid item count $count" + } + + if { $count > [llength $queues($name)] } { + error "insufficient items in queue to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item pops aren't listified + return [lindex $queues($name) 0] + } + + # Otherwise, return a list of items + set index [expr {$count - 1}] + return [lrange $queues($name) 0 $index] +} + +# ::struct::queue::_put -- +# +# Put an item into a queue. +# +# Arguments: +# name name of the queue object +# args items to put. +# +# Results: +# None. + +proc ::struct::queue::_put {name args} { + variable queues + if { [llength $args] == 0 } { + error "wrong # args: should be \"$name put item ?item ...?\"" + } + foreach item $args { + lappend queues($name) $item + } + return +} + +# ::struct::queue::_size -- +# +# Return the number of objects on a queue. +# +# Arguments: +# name name of the queue object. +# +# Results: +# count number of items on the queue. + +proc ::struct::queue::_size {name} { + variable queues + return [llength $queues($name)] +} diff --git a/library/struct1.0/stack.tcl b/library/struct1.0/stack.tcl new file mode 100644 index 0000000..50272b7 --- /dev/null +++ b/library/struct1.0/stack.tcl @@ -0,0 +1,276 @@ +# stack.tcl -- +# +# Stack implementation for Tcl. +# +# Copyright (c) 1998-2000 by Scriptics Corporation. +# All rights reserved. +# +# RCS: @(#) $Id: stack.tcl,v 1.1 2000/02/05 03:20:20 ericm Exp $ + +namespace eval ::struct {} + +namespace eval ::struct::stack { + # The stacks array holds all of the stacks you've made + variable stacks + + # counter is used to give a unique name for unnamed stacks + variable counter 0 + + # commands is the list of subcommands recognized by the stack + variable commands [list \ + "clear" \ + "destroy" \ + "peek" \ + "pop" \ + "push" \ + "rotate" \ + "size" \ + ] + + # Only export one command, the one used to instantiate a new stack + namespace export stack +} + +# ::struct::stack::stack -- +# +# 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 {{name ""}} { + variable stacks + variable counter + + if { [llength [info level 0]] == 1 } { + incr counter + set name "stack${counter}" + } + + if { ![string equal [info commands ::$name] ""] } { + 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 + +proc ::struct::stack::StackProc {name {cmd ""} args} { + # Make sure this stack exists + if { ![info exists ::struct::stack::stacks($name)] } { + error "unknown stack \"$name\"" + } + + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + if { [llength [info commands ::struct::stack::_$cmd]] == 0 } { + variable commands + set optlist [join $commands ", "] + set optlist [linsert $optlist "end-1" "or"] + error "bad option \"$cmd\": must be $optlist" + } + return [eval [list ::struct::stack::_$cmd $name] $args] +} + +# ::struct::stack::_clear -- +# +# Clear a stack. +# +# Arguments: +# name name of the stack object. +# +# Results: +# None. + +proc ::struct::stack::_clear {name} { + set ::struct::stack::stacks($name) [list ] + return +} + +# ::struct::stack::_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::_destroy {name} { + unset ::struct::stack::stacks($name) + interp alias {} ::$name {} + return +} + +# ::struct::stack::_peek -- +# +# Retrive 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 fufill the request, throws an error. + +proc ::struct::stack::_peek {name {count 1}} { + variable stacks + if { $count < 1 } { + error "invalid item count $count" + } + + if { $count > [llength $stacks($name)] } { + error "insufficient items on stack to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item pops aren't listified + set item [lindex $stacks($name) end] + return $item + } + + # Otherwise, return a list of items + set result [list ] + for {set i 0} {$i < $count} {incr i} { + lappend result [lindex $stacks($name) "end-${i}"] + } + return $result +} + +# ::struct::stack::_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::_pop {name {count 1}} { + variable stacks + if { $count > [llength $stacks($name)] } { + error "insufficient items on stack to fill request" + } elseif { $count < 1 } { + error "invalid item count $count" + } + + if { $count == 1 } { + # Handle this as a special case, so single item pops aren't listified + set item [lindex $stacks($name) end] + set stacks($name) [lreplace $stacks($name) end end] + return $item + } + + # Otherwise, return a list of items + set result [list ] + for {set i 0} {$i < $count} {incr i} { + lappend result [lindex $stacks($name) "end-${i}"] + } + + # Remove these items from the stack + incr i -1 + set stacks($name) [lreplace $stacks($name) "end-${i}" end] + + return $result +} + +# ::struct::stack::_push -- +# +# Push an item onto a stack. +# +# Arguments: +# name name of the stack object +# args items to push. +# +# Results: +# None. + +proc ::struct::stack::_push {name args} { + if { [llength $args] == 0 } { + error "wrong # args: should be \"$name push item ?item ...?\"" + } + foreach item $args { + lappend ::struct::stack::stacks($name) $item + } + return +} + +# ::struct::stack::_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::_rotate {name count steps} { + variable stacks + set len [llength $stacks($name)] + if { $count > $len } { + 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}] + for {set i 0} {$i < $steps} {incr i} { + set item [lindex $stacks($name) end] + set stacks($name) [lreplace $stacks($name) end end] + set stacks($name) [linsert $stacks($name) $start $item] + } + return +} + +# ::struct::stack::_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::_size {name} { + return [llength $::struct::stack::stacks($name)] +} diff --git a/library/struct1.0/struct.tcl b/library/struct1.0/struct.tcl new file mode 100644 index 0000000..ecacdba --- /dev/null +++ b/library/struct1.0/struct.tcl @@ -0,0 +1,8 @@ +package provide struct 1.0 +source [file join [file dirname [info script]] stack.tcl] +source [file join [file dirname [info script]] queue.tcl] +namespace eval struct { + namespace export * + namespace import stack::* + namespace import queue::* +} |