# 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)]
}
