Attachment "prioqueue.tcl" to
ticket [607085ffff]
added by
mic42
2003-04-12 23:27:33.
# prioqueue.tcl --
#
# Priority Queue implementation for Tcl.
#
# adapted from queue.tcl Copyright (c) 1998-2000 by Ajuba Solutions.
# Copyright (c) 2002,2003 Michael Schlenker
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id$
package require Tcl 8.3
namespace eval ::struct {}
namespace eval ::struct::prioqueue {
# 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" \
"peekpriority" \
]
variable sortopt [list \
"-integer" \
"-real" \
"-ascii" \
"-dictionary" \
]
variable sortdir [list \
"-decreasing" \
"-decreasing" \
"-increasing" \
"-increasing" \
]
# Only export one command, the one used to instantiate a new queue
namespace export prioqueue
proc K {x y} {set x} ;# DKF's K combinator
}
# ::struct::prioqueue::prioqueue --
#
# Create a new prioqueue with a given name; if no name is given, use
# prioqueueX, where X is a number.
#
# Arguments:
# sorting sorting option for lsort to use, no -command option
# defaults to integer
# name name of the queue; if null, generate one.
# names may not begin with -
#
#
# Results:
# name name of the queue created
proc ::struct::prioqueue::prioqueue {args} {
variable queues
variable counter
variable queues_sorting
variable sortopt
# check args
if {[llength $args] > 2} {
error "wrong # args: should be \"[lindex [info level 0] 0] ?-ascii|-dictionary|-integer|-real? ?name?\""
}
if {[llength $args] == 0} {
# defaulting to integer priorities
set sorting -integer
} else {
if {[llength $args] == 1} {
if {[string match "-*" [lindex $args 0]]==1} {
set sorting [lindex $args 0]
} else {
set sorting -integer
set name [lindex $args 0]
}
} else {
if {[llength $args] == 2} {
foreach {sorting name} $args {break}
}
}
}
# check option (like lsort sorting options without -command)
if {[lsearch $sortopt $sorting] == -1} {
# if sortoption is unknown, but name is a sortoption we give a better error message
if {[info exists name] && [lsearch $sortopt $name]!=-1} {
error "wrong argument position: should be \"[lindex [info level 0] 0] ?-ascii|-dictionary|-integer|-real? ?name?\""
}
error "unknown sort option \"$sorting\""
}
# create name if not given
if {![info exists name]} {
incr counter
set name "prioqueue${counter}"
}
if { ![string equal [info commands ::$name] ""] } {
error "command \"$name\" already exists, unable to create prioqueue"
}
# Initialize the queue as empty
set queues($name) [list ]
switch -exact -- $sorting {
-integer { set queues_sorting($name) 0}
-real { set queues_sorting($name) 1}
-ascii { set queues_sorting($name) 2}
-dictionary { set queues_sorting($name) 3}
}
# Create the command to manipulate the queue
interp alias {} ::$name {} ::struct::prioqueue::QueueProc $name
return $name
}
##########################
# Private functions follow
# ::struct::prioqueue::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::prioqueue::QueueProc {name {cmd ""} args} {
# 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::prioqueue::_$cmd] ""] } {
variable commands
set optlist [join $commands ", "]
set optlist [linsert $optlist "end-1" "or"]
error "bad option \"$cmd\": must be $optlist"
}
return [eval [list ::struct::prioqueue::_$cmd $name] $args]
}
# ::struct::prioqueue::_clear --
#
# Clear a queue.
#
# Arguments:
# name name of the queue object.
#
# Results:
# None.
proc ::struct::prioqueue::_clear {name} {
variable queues
set queues($name) [list]
return
}
# ::struct::prioqueue::_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::prioqueue::_destroy {name} {
variable queues
variable queues_sorting
unset queues($name)
unset queues_sorting($name)
interp alias {} ::$name {}
return
}
# ::struct::prioqueue::_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::prioqueue::_get {name {count 1}} {
variable queues
if { $count < 1 } {
error "invalid item count $count"
}
if { $count > [llength $queues($name)] } {
error "insufficient items in prioqueue to fill request"
}
if { $count == 1 } {
# Handle this as a special case, so single item gets aren't listified
set item [lindex [lindex $queues($name) 0] 1]
set queues($name) [lreplace [K $queues($name) [set queues($name) ""]] 0 0]
return $item
}
# Otherwise, return a list of items
incr count -1
set items [lrange $queues($name) 0 $count]
foreach item $items {
lappend result [lindex $item 1]
}
set items ""
set queues($name) [lreplace [K $queues($name) [set queues($name) ""]] 0 $count]
return $result
}
# ::struct::prioqueue::_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::prioqueue::_peek {name {count 1}} {
variable queues
if { $count < 1 } {
error "invalid item count $count"
}
if { $count > [llength $queues($name)] } {
error "insufficient items in prioqueue to fill request"
}
if { $count == 1 } {
# Handle this as a special case, so single item pops aren't listified
return [lindex [lindex $queues($name) 0] 1]
}
# Otherwise, return a list of items
set index [expr {$count - 1}]
foreach item [lrange $queues($name) 0 $index] {
lappend result [lindex $item 1]
}
return $result
}
# ::struct::prioqueue::_peekpriority --
#
# Retrive the priority 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::prioqueue::_peekpriority {name {count 1}} {
variable queues
if { $count < 1 } {
error "invalid item count $count"
}
if { $count > [llength $queues($name)] } {
error "insufficient items in prioqueue to fill request"
}
if { $count == 1 } {
# Handle this as a special case, so single item pops aren't listified
return [lindex [lindex $queues($name) 0] 0]
}
# Otherwise, return a list of items
set index [expr {$count - 1}]
foreach item [lrange $queues($name) 0 $index] {
lappend result [lindex $item 0]
}
return $result
}
# ::struct::prioqueue::_put --
#
# Put an item into a queue.
#
# Arguments:
# name name of the queue object
# args list of the form "item1 prio1 item2 prio2 item3 prio3"
#
# Results:
# None.
proc ::struct::prioqueue::_put {name args} {
variable queues
variable queues_sorting
variable sortopt
variable sortdir
if { [llength $args] == 0 || [llength $args] % 2} {
error "wrong # args: should be \"$name put item prio ?item prio ...?\""
}
# check for prio type before adding
switch -exact -- $queues_sorting($name) {
0 {
foreach {item prio} $args {
if {![string is integer -strict $prio]} {
error "priority \"$prio\" is not an integer type value"
}
}
}
1 {
foreach {item prio} $args {
if {![string is double -strict $prio]} {
error "priority \"$prio\" is not a real type value"
}
}
}
default {
#no restrictions for -ascii and -dictionary
}
}
# add only if check has passed
foreach {item prio} $args {
lappend queues($name) [list $prio $item]
}
# sort by priorities
set opt [lindex $sortopt $queues_sorting($name)]
set dir [lindex $sortdir $queues_sorting($name)]
set queues($name) [lsort $opt $dir -index 0 [K $queues($name) [set queues($name) ""]]]
return
}
# ::struct::prioqueue::_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::prioqueue::_size {name} {
variable queues
return [llength $queues($name)]
}
