pheap

pheap - Priority Queue

A Pairing-heap [1 ] priority queue in Tcl. The aim is to have an illustration and implementation of the pairing-heap data-structure in a readable and practically usable way. The heap is represented by "pointer-like" connected elements. These elements are kept in an tcl-array 'PH'. Instead of pointers, names are used in Tcl. That leaves the details of the algorithm openly visible and makes it easy to re-implement it later in some more low-level language like Java, C#, etc.
Pairing heaps are known to be probably the fastest priority queues when 'decreaseKey' (which is called 'promote' here) is required.

Synopsis

package require Tcl 8.5
package require fm::pheap  ? 0.3 ? 
::pheap::pheap   ? -compare ascii|dictionary|numeric|command ?  ? -decreasing ?  ? pheapName ?  
pheapName clear
pheapName contains item ? prioVar ?
pheapName destroy ? name ?
pheapName hasmin  ? itemVar ?  ? prioVar ?
pheapName popmin  ? itemVar ?  ? prioVar ?  
pheapName remove item  ? prioVar ?
pheapName setp item ? prio ?
pheapName size

Unofficial (internal, less safe)

pheapName demote item prio
pheapName id
pheapName insert item prio
pheapName promote item prio

Description

The command ::pheap::pheap creates a new priority queue with default priority comparison numeric. Inserting all items with insert and removing them with popmin, sorts the data in ascending order (or in descending order if the flag -decreasing has been given).

::pheap::pheap ? -compare ascii|dictionary|numeric|command ? ? -decreasing ? ? pheapName ?
This command creates a new priority queue object with an associated global Tcl command whose name is pheapName, which will be returned. If no name is given, some name will be generated using the format ::pheap$nr. This command may be used to invoke any of the below standing operations on the priority queue. The option -compare selects the comparing function. It can be a userdefined command prefix that gets called with two priorities appended, or one of the predefined functions. ascii does 'string compare', dictionary behaves like 'lsort -dictionary', numeric uses 'expr {$a<$b}'. Default is -compare numeric. To get the inverse comparison you may use the flag -decreasing. Example: set q [::pheap::pheap]

pheapName clear
Remove all items from this priority queue.
pheapName contains item ? prioVar ?
Return 1 if the selected item is in this priority queue and set prioVar to its priority when present, else return 0 and leave prioVar unchanged.
pheapName destroy ? name ?
Destroy the priority queue, including its storage space and associated command. In the case of a rename on pheapName, give the now current command name as parameter name. Example: $q destroy $q
pheapName hasmin ? itemVar ? ? prioVar ?
Returns 0 if priority queue is empty, else sets itemVar and prioVar to the respective values and returns 1.
pheapName popmin ? itemVar ? ? prioVar ?
Return 1 if there was an item in the priority queue and variables itemVar and prioVar have been set to the respective value of the former root item and its priority, or return 0 if there was no item in the priority queue and itemVar and prioVar are unchanged. - Example: while {[$q popmin item prio]} { ... }
pheapName remove item ? prioVar ?
Remove the selected item from this priority queue and return whether item has been in the priority queue. If item was in the priority queue variable prioVar gets its priority, else prioVar is left unchanged. - Example: if {[$q remove $item prio]} { ... }
pheapName setp item ? prio ?
Get or set the priority of the item. If called with one argument, it just returns the priority of item. If prio is given, it does a "pheapName promote|demote|insert item prio", depending on whether the item already is in the priority queue and whether the new prio is smaller or bigger than before. Then prio is returned.
pheapName size
Return the number of items in the priority queue.

Unofficial internal Functions

Since promote is one of the most important functions in literature about priority queues, usually called 'decreaseKey' or similar, I didn't want to leave it out. But since it does not check whether the new priority is indeed smaller, it is less safe than function setp above. In many algorithms that use priority queues it is known by construction that the new value is smaller and it seems a waste to check again internally. (Opinions?)

pheapName demote item prio
Give the new priority prio to the selected item, which is known(!) to push it further from the root. Unsafe: this function does not check whether the new priority really moves item away from min.
pheapName id
Return the id of this priority-queue. (For internal purposes)
pheapName insert item prio
Add item to the priority queue with priority prio. Unsafe: this function assumes that item is not in the priority queue yet. Example: if {[$q contains $item prio]} { .. } else { $q insert $item $prio }
pheapName promote item prio
Give the new priority prio to the selected item item, which is known(!) to push it closer to the root. Unsafe: this function does not check whether the new priority really moves item closer to min.

Code

package require Tcl 8.5
package provide fm::pheap 0.3
# ########################################################################
namespace eval pheap {
    namespace export pheap sort
    variable counter 0
}
# ########################################################################
# ************************************************************************
    ;# ::pheap::pheap  ?-compare ascii|dictionary|numeric|command?
    ;#                 ?-decreasing?   ?pheapName?
    ;# 
    ;# This command creates a new prioqueue object with an associated
    ;# global Tcl command whose name is pheapName, which will be returned.
    ;# If no name is given, some name will be generated using the
    ;# format ::pheap$nr. This command may be used to invoke any of
    ;# defined operations on the priority queue.
    ;# 
    ;# The option -compare selects the comparing function.
    ;# It can be a userdefined command prefix that gets called with
    ;# two priorities appended, or one of the predefined functions:
    ;#  * 'ascii' does 'string compare'
    ;#  * 'dictionary' behaves like 'lsort -dictionary'
    ;#  * 'numeric' uses 'expr {$a<$b}'
    ;# Default is '-compare numeric'.
    ;# 
    ;# To get the inverse comparison you may use the flag -decreasing.
    ;# 
proc pheap::pheap {args} {
    set len [llength $args]
    variable counter
    set id [incr counter]

    set dir increasing
    set cmp numeric
    set cmdName {}
    
    for {set i 0} {$i < $len} {incr i} {
        switch -- [set opt [lindex $args $i]] {
            -decreasing { set cmp decreasing }
            -compare    { set cmp [lindex $args [incr i]] }
            default {
                if {$i == $len-1} {
                    set cmdName $opt
                } else {
                    set n pheap
                    return -code error "unknown option '$opt': should be \"pheap ?-compare ascii|dictionary|numeric|command?  -decreasing  ?name?\""
                }
            }
        }
    }
    if {$cmdName eq {}} { set cmdName  ::pheap$id }

    if {[info commands $cmdName] ne ""} {
        error "command \"$cmdName\" already exists, unable to create pheap"
    }

    if {$dir eq "increasing"} {  ;# default
        switch -- $cmp {
            ascii      { set cmp "::string compare" }
            dictionary { set cmp "::pheap::cmp-dictionary" }
            numeric    { set cmp "::pheap::cmp-numeric" }
            default    {  ;# keep user-defined cmp.
            }
        }
    } else {  ;# decreasing
        switch -- $cmp {
            ascii      { set cmp "::pheap::cmp-ascii-decr" }
            dictionary { set cmp "::pheap::cmp-dictionary-decr" }
            numeric    { set cmp "::pheap::cmp-numeric-decr" }
            default    { set cmp [list "::pheap::cmp-userdef-decr" $cmp] }
        }
    }


    # create variables containing the data
    array set ::pheap::ph$id {}
    set ::pheap::root$id     {}
    set ::pheap::cmp$id      $cmp
    set ::pheap::cmdName$id  $cmdName


    # Create the command that represents that object
    set map [dict create]
    dict set map clear        [list ::pheap::clear    $id]
    dict set map contains     [list ::pheap::contains $id]
    dict set map destroy      [list ::pheap::destroy  $id]
    dict set map hasmin       [list ::pheap::hasmin   $id]
    dict set map popmin       [list ::pheap::popmin   $id]
    dict set map remove       [list ::pheap::remove   $id]
   #dict set map set          [list ::pheap::setp     $id]
    dict set map setp         [list ::pheap::setp     $id]
    dict set map size         [list ::pheap::size     $id]


    # Special functions (use with care!):
    dict set map demote       [list ::pheap::demote   $id]
    dict set map id           [list ::pheap::id       $id]
    dict set map insert       [list ::pheap::insert   $id]
    dict set map promote      [list ::pheap::promote  $id]


    # Experimental functions:
    #dict set map dump         [list ::pheap::dump     $id]
    #dict set map get          [list ::pheap::get      $id]
    #dict set map index        [list ::pheap::index    $id]
   ##dict set map isempty      [list ::pheap::isempty  $id]
   ##dict set map isfilled     [list ::pheap::isfilled $id]
    #dict set map keep         [list ::pheap::keep     $id]
    #dict set map merge        [list ::pheap::merge    $id]
    #dict set map names        [list ::pheap::names    $id]
    #dict set map peek         [list ::pheap::peek     $id]
    #dict set map pop          [list ::pheap::pop      $id]
    #dict set map priority     [list ::pheap::priority $id]
    #dict set map root         [list ::pheap::root     $id]
    #dict set map top          [list ::pheap::top      $id]
   ##dict set map value        [list ::pheap::value    $id]
   ##dict set map xx           [list ::pheap::xx       $id]

    namespace ensemble create  -map $map  -command $cmdName
    set cmdName
}
# ************************************************************************
proc pheap::cmp-dictionary {a b} {
    if {$a eq $b} { return 0 }
    # need to use lsort to access -dictionary sorting
    set x [lsort -dictionary [list $a $b]]
    if {[lindex $x 0] eq $a} { return -1 }
    return 1
}
# ************************************************************************
proc pheap::cmp-dictionary-decr {a b} {
    if {$a eq $b} { return 0 }
    # need to use lsort to access -dictionary sorting
    set x [lsort -dictionary [list $a $b]]
    if {[lindex $x 0] eq $a} { return 1 }
    return -1
}
# ************************************************************************
proc pheap::cmp-numeric {a b} { expr {($a<$b)?-1:(($a==$b)?0:1)} }
# ************************************************************************
proc pheap::cmp-numeric-decr {a b} { expr {($a<$b)?1:(($a==$b)?0:-1)} }
# ************************************************************************
proc pheap::cmp-ascii-decr {a b} {
    set x [::string compare $a $b]
    expr {($x<0)?1:($x>0)?-1:0}
}
# ************************************************************************
proc pheap::cmp-userdef-decr {cmp a b} {
    set x [{*}$cmp $a $b]
    expr {($x<0)?1:($x>0)?-1:0}
}
# ************************************************************************
proc pheap::size {id} { array size ::pheap::ph$id }
# ************************************************************************
    ;# Remove all items from this priority queue.
proc pheap::clear {id} {
    upvar #0 ::pheap::ph$id PH   ::pheap::root$id root
    unset PH
    array set PH {}
    set root {}
}
# ************************************************************************
    ;# Return 1 if the selected item is in this priority queue, else 0. 
proc pheap::contains {id item {aCost {}}} {
    upvar #0 ::pheap::ph$id PH
    if {[info exists PH($item)]} {
        if {[llength [info level 0]] == 4} {
            upvar $aCost cost
            set cost [lindex $PH($item) 0]
        }
        return 1
    }
    return 0
}
# ************************************************************************
    ;# Destroy the prioqueue, including its storage space and associated command.
    ;# Example:  $q destroy $q
    ;# 
proc pheap::destroy {id {a {}}} {
    set cmdName [set ::pheap::cmdName$id]
    # If there has been a rename to $cmdName then 'rename $cmdName {}' is wrong.
    if {$a eq {}} { catch {rename $cmdName {}} } else { rename $a {} }
    unset -nocomplain \
         ::pheap::ph$id \
         ::pheap::cmp$id \
         ::pheap::root$id \
         ::pheap::cmdName$id
}
# ************************************************************************
    ;# Get or set the priority of the item. If called with one argument,
    ;# it just returns the priority of item. If prio is given, it does a
    ;#     pheapName promote|demote|insert item prio
    ;# depending on whether the item already is in the priority queue and
    ;# whether the new prio is smaller or bigger than before.
    ;# Then prio is returned.
    ;# 
proc pheap::setp {id item {cost {}}} {
    upvar #0 ::pheap::ph$id PH  ::pheap::root$id root  ::pheap::cmp$id cmp
    if {[llength [info level 0]] == 3} { ;# get priority
        if {[info exist PH($item)]} { return [lindex $PH($item) 0] }
        error "*** [set ::pheap::cmdName$id] no such item: $item"
    }
    if {[info exists PH($item)]} {
        set c [{*}$cmp $cost [lindex $PH($item) 0]]
        if {$c < 0} {
            promote $id $item $cost
        } elseif {!$c} {
            lset PH($item) 0 $cost
        } else {
            demote $id $item $cost
        }
    } elseif {$root eq {}} {
        set PH($item) [list $cost {} {} {}]
        set root $item
    } else {
        lassign $PH($root) rcost rchild rprev rnext
        if {[{*}$cmp $cost $rcost] <= 0} { ;# item becomes new root
            lset PH($root) 2 $item
            set PH($item) [list $cost $root {} {}]
            set root $item
        } else {               ;# item becomes first-child of root
            lset PH($root) 1 $item
            set PH($item) [list $cost {} $root $rchild]
            if {$rchild ne {}} { lset PH($rchild) 2 $item }
        }
    }
    set cost
}
# ************************************************************************
    ;# Robust:  $item need not be in pheap.  (contains)
    ;# 
proc pheap::remove {id item {aCost _}} {
    upvar #0 ::pheap::ph$id PH  ::pheap::root$id root
    if {![info exists PH($item)]} { return 0 }  ;# don't touch anything

    if {[llength [info level 0]] == 4} { upvar $aCost cost }
    if {$item eq $root} { return [popmin $id item cost] }

    # _remove $id $item cost
    lassign $PH($item) cost xchild xprev xnext

    if {$xchild eq {}} {  ;# just cut item
        if {$xnext ne {}} { lset PH($xnext) 2 $xprev }
        if {[lindex $PH($xprev) 1] eq $item} {  ;# (prev.child == item)
            lset PH($xprev) 1 $xnext
        } else {                             ;# (prev.next == item)
            lset PH($xprev) 3 $xnext
        }
    } else {  ;# xchild replaces item
        set xchild [_twoPass $id $xchild]  ;# remove siblings
        if {$xnext ne {}} {
            lset PH($xnext) 2 $xchild
            lset PH($xchild) 3 $xnext
        }
        if {[lindex $PH($xprev) 1] eq $item} {  ;# (prev.child == item)
            lset PH($xprev) 1 $xchild
        } else {                             ;# (prev.next == item)
            lset PH($xprev) 3 $xchild
        }
        lset PH($xchild) 2 $xprev
    }

    unset PH($item)
    return 1
}
# ************************************************************************
    ;# Get minimum and its cost and remove it from the heap.
    ;# 
proc pheap::popmin {id {aElem _} {aCost _}} {
    upvar #0 ::pheap::ph$id PH  ::pheap::root$id root
    if {$root eq {}} { return 0 }  ;# don't touch anything

    switch [llength [info level 0]] {
        3 { upvar $aElem x }
        4 { upvar $aElem x  $aCost cost }
    }
    set x $root
    lassign $PH($root) cost rchild rprev rnext
    #assert {[_testMin $id]}

    if {$rchild eq {}} {
        set root {}
    } else {
        set root [_twoPass $id $rchild]
        lset PH($root) 2 {}  ;# .prev
        #assert {[lindex $PH($root) 2] eq {}}; assert {[lindex $PH($root) 3] eq {}}
    }

    unset PH($x)
    return 1
}
# ************************************************************************
    ;# Return 0 if empty, else set item and prio and return 1.
    ;# 
proc pheap::hasmin {id {item _} {prio _}} {
    upvar #0 ::pheap::ph$id PH  ::pheap::root$id root
    if {$root eq {}} { return 0 }  ;# don't touch anything
    
    switch [llength [info level 0]] {
        3 { upvar $item x }
        4 { upvar $item x  $prio cost }
    }
    set x $root
    set cost [lindex $PH($root) 0]
    return 1
}
# ************************************************************************
    ;# Set a new, smaller priority $cost for object $item.
    ;# 'decreaseKey'  := 'decrease cost'
    ;# 
proc pheap::promote {id item cost} {
    upvar #0 ::pheap::ph$id PH  ::pheap::root$id root  ::pheap::cmp$id cmp
    if {$item eq $root} {
        lset PH($item) 0 $cost
    } else {
        # _remove $id $item xcost ;# (redundant with 'remove')
        lassign $PH($item) xcost xchild xprev xnext
    
        if {$xchild eq {}} {  ;# just cut item
            if {$xnext ne {}} { lset PH($xnext) 2 $xprev }
            if {[lindex $PH($xprev) 1] eq $item} {  ;# (prev.child == item)
                lset PH($xprev) 1 $xnext
            } else {                             ;# (prev.next == item)
                lset PH($xprev) 3 $xnext
            }
        } else {  ;# xchild replaces item
            set xchild [_twoPass $id $xchild]  ;# remove siblings
            if {$xnext ne {}} {
                lset PH($xnext) 2 $xchild
                lset PH($xchild) 3 $xnext
            }
            if {[lindex $PH($xprev) 1] eq $item} {  ;# (prev.child == item)
                lset PH($xprev) 1 $xchild
            } else {                             ;# (prev.next == item)
                lset PH($xprev) 3 $xchild
            }
            lset PH($xchild) 2 $xprev
        }

        # _insert $id $item $cost (redundant with 'insert').
        if {[{*}$cmp $cost [lindex $PH($root) 0]] <= 0} { ;# item becomes new root
            lset PH($root) 2 $item
            set PH($item) [list $cost $root {} {}]
            set root $item
        } else {               ;# item becomes first-child of root
            set rchild [lindex $PH($root) 1]
            lset PH($root) 1 $item
            set PH($item) [list $cost {} $root $rchild]
            if {$rchild ne {}} { lset PH($rchild) 2 $item }
        }
    }
    set cost
}
# ************************************************************************
    ;# Set a new, bigger priority $cost for object $item.
    ;# 
    ;# xxx Not tested yet!
    ;# 
proc pheap::demote {id item cost} {
    upvar #0 ::pheap::ph$id PH  ::pheap::root$id root  ::pheap::cmp$id cmp
    lset PH($item) 0 $cost
    lassign $PH($item) mcost mchild mprev mnext

    if {$item eq $root} {
        if {$mchild eq {}} { return $cost }

        set x [_twoPass $id $mchild]  ;# remove siblings
        lassign $PH($x) xcost xchild xprev xnext
        if {[{*}$cmp $cost $xcost] > 0} {
            ;# remove root and insert it with modified cost
            lset PH($root) 1 {}
            set PH($x) [list $xcost $xchild {} $root]
            set root [_compLink $id $x]
            #assert {[lindex $PH($root) 2] eq {}}; assert {[lindex $PH($root) 3] eq {}}
        }
    } else {
        if {$mchild ne {} && [{*}$cmp [lindex $PH($mchild) 0] $cost] < 0} {
            set x [_twoPass $id $mchild]  ;# remove siblings
            lassign $PH($x) xcost xchild xprev xnext
            # remove x (new child of item) and insert it at root
            lset PH($item) 1 {}

            # Put 'x' on top as first-child
            # We know:
            #     (root.cost < x.cost)   &&
            #     (root.child ne {})     &&
            #     (root.child ne mchild) &&
            #     (root.child ne x)      
            lassign $PH($root) rcost rchild rprev rnext

            lset PH($root)   1 $x      ;# .child
            lset PH($x)      2 $root   ;# .prev
            lset PH($rchild) 2 $x      ;# .prev
            lset PH($x)      3 $rchild ;# .next
        }
    }
    set cost
}
# ************************************************************************
proc pheap::insert {id item cost} {
    upvar #0 ::pheap::ph$id PH  ::pheap::root$id root  ::pheap::cmp$id cmp
    if {$root eq {}} {
        set PH($item) [list $cost {} {} {}]
        set root $item
    } else {  ;# _insert $id $item $cost
        if {[{*}$cmp $cost [lindex $PH($root) 0]] <= 0} { ;# item becomes new root
            lset PH($root) 2 $item
            set PH($item) [list $cost $root {} {}]
            set root $item
        } else {               ;# item becomes first-child of root
            set rchild [lindex $PH($root) 1]
            lset PH($root) 1 $item
            set PH($item) [list $cost {} $root $rchild]
            if {$rchild ne {}} { lset PH($rchild) 2 $item }
        }
    }
}
# ************************************************************************
    ;# Reduce siblings of child x to null and return new child.
    ;#     assert {$x ne {}}
    ;#     TODO:  assert {$x ne {} && $xnext ne {}}
    ;# Uses O(log(n)) amortized time!
    ;# The real workhorse of the pairing heap.
    ;# Uses "two-pass merging" of siblings until no siblings are left.
    ;# 
    ;#         |
    ;#         x - c1 - c2 - c3 - c4
    ;#         |   |    |    |    |  
    ;#         A   B1   B2   B3   B4
    ;#     -----------------------------
    ;# pass1:
    ;#         |
    ;#         xc1 - c2c3 - c4 
    ;#         |      |     |   
    ;#         AB1   B2B3   B4 
    ;#     -----------------------------
    ;# pass2:
    ;#         |
    ;#         xc1c2c3c4
    ;#         |
    ;#         AB1B2B3B4
    ;#
proc pheap::_twoPass {id x} {
    upvar #0 ::pheap::ph$id PH
    # list:   0=.cost 1=.child 2=.prev 3=.next
    if {[lindex $PH($x) 3] eq {}} { return $x }  ;# .next  xxx out to caller!

    # pass1:  left-to-right merging pairs of children.
    set n 0
    while {1} {
        incr n
        set y [_compLink $id $x]
        set x [lindex $PH($y) 3]   ;# .next
        if {$x eq {}} { set x $y;  break }
        if {[lindex $PH($x) 3] eq {}} { incr n;  break }  ;# .next
    }

    # pass2:  right-to-left merging with the current result.
    while {[incr n -1]} {
        set x [_compLink $id [lindex $PH($x) 2]]   ;# .prev
    }
    set x
}
# ************************************************************************
    ;#                  x -      y - C
    ;#                  |    +   |
    ;#                  A        B
    ;#   -------------------- -------------------
    ;#          (x<y)               (x>=y)
    ;#
    ;#           x - C                y - C
    ;#           |                    |
    ;#           y - A                x - B
    ;#           |                    |
    ;#           B                    A
    ;#
    ;# Remark:  Experiments show, that using "<" instead of "<=" is slightly
    ;# faster, i.e. it is faster to prefer y on top.
    ;#
proc pheap::_compLink {id x} {
    upvar #0 ::pheap::ph$id PH  ::pheap::cmp$id cmp

    lassign $PH($x) xcost xchild xprev xnext
    set y $xnext ;# implicit para, instead of:  assert (xnext=={})
    lassign $PH($y) ycost ychild yprev ynext
    # Note:  By the 'implicit para' trick 
    #   ($yprev eq $x) and ($xnext eq $y), but $xprev can be anything!
    #   Only ($xnext eq $y) is used! [I.e. yprev may contain nonsense]

    if {[{*}$cmp $xcost $ycost] < 0} {  ;# x stays on top.
        set PH($x) [list $xcost $y      $xprev $ynext]
        set PH($y) [list $ycost $ychild $x     $xchild]

        if {$ynext ne {}}  { lset PH($ynext) 2 $x }  ;# C.prev is now x
        if {$xchild ne {}} { lset PH($xchild) 2 $y } ;# A.prev is now y
        return $x
    }

    # y goes on top.
    set PH($x) [list $xcost $xchild $y     $ychild]
    set PH($y) [list $ycost $x      $xprev $ynext]

    if {$xprev ne {}} {
        if {[lindex $PH($xprev) 1] eq $x} {      ;# xprev.child is now y
            lset PH($xprev) 1 $y
        } else {                                 ;# xprev.next is now y
            # assert {[lindex $PH($xprev) 3] eq $x}
            lset PH($xprev) 3 $y
        }
     }
    if {$ychild ne {}} { lset PH($ychild) 2 $x } ;# B.prev is now x
    set y
}
# ************************************************************************
    ;# Sorts the list.
    ;# Mainly as an example to illustrate pheap and for testing.
    ;# 
proc pheap::sort {alist args} {
    set q [::pheap::pheap {*}$args ::pheap[incr ::pheap::counter]]
    foreach i $alist { $q insert [incr cnt] $i }

    set rval {}
    while {[$q popmin cnt i]} { lappend rval $i }
    $q destroy
    set rval
}
# ************************************************************************

Examples

1. Sort a list using pheap

proc mysort {alist args} {
    set q [::pheap::pheap {*}$args ::mypheap]
    foreach i $alist { $q setp [incr cnt] $i }

    set rval {}
    while {[$q popmin cnt i]} { lappend rval $i }
    $q destroy
    set rval
}

2. Sort -unique

proc mysort_unique {alist args} {
    set q [::pheap::pheap {*}$args ::mypheap]
    foreach i $alist { $q setp $i $i }

    set rval {}
    while {[$q popmin item]} { lappend rval $item }
    $q destroy
    set rval
}

3. Find shortest route in a graph using Dijkstra's algorithm

proc myDijkstra {src sink aRoute aDist} {
    global Successor Dist
    set q [::pheap::pheap]
    set p($src) 0   ;# distance to 'src' known
    set r($src) {}  ;# previous node along shortest route

    $q insert $src 0

    while {[$q popmin node pot]} {
        set p($node) $pot

        if {$node eq $sink} {  ;# a shortest route found
            upvar $aRoute route  $aDist distance
            set distance $pot
            set route {}
            while {$node ne {}} { lappend route $node;  set node $r($node) }
            set route [lreverse $route]
            $q destroy
            return 1
        }

        foreach succ $Successor($node) {
            if {[info exists p($succ)]} continue
            set dist [expr {$pot+$Dist([list $node $succ])}]

            if {[$q contains $succ dist0]} {
                if {$dist < $dist0} {
                    $q promote $succ $dist
                    set r($succ) $node
                }
            } else {
                $q insert $succ $dist
                set r($succ) $node
            }
        }
    }
    $q destroy
    return 0;  # no route from src to sink
}

Remarks

Since this is the first version of this package, some of the functions are still experimental and might change or vanish in a future release. The function destroy might lose its parameter name, once I find out how to find out the command-name that called it (info level 0 and info frame 2 didn't seem to do the trick).

As it is now, pheap relies on a hashtable (array, or dict) as backbone in its implementation, endorsing functions that use an item as index. For C internal purposes one can easily adapt the algorithmic ideas of the implementation without using any hashtable and store all pointers in the items themselves.

Comparison with package struct::prioqueue: Prioqueue lacks the sometimes essential functionality of setp or promote and its implementation seems to be a bubblesort in disguise, which is detrimental to performance if one is dealing with many items. Pheap on the other hand, reflects more closely the intention and performance characteristics of a priority queue and it seems to be more versatile, too. (The interface of get and peek in struct::prioqueue makes me frown, too. Imho the distinction of lists and strings should not be blurred more, but less.)

Functions using count as parameter require sorting at least the first count items, which makes them potentially costly. Therefore these functions are in the experimental section.

While example 1 shows one usage of priority queues, it is a bit uncharacteristic, because usually the items are the important part and not the priorities. More typical are algorithms like Dijkstra's shortest path, or A*, where the items are nodes and the priorities are distances or costs. Those algorithms greatly benefit from pheap, where cost estimates can dynamically be adapted.

Bugs, Ideas, Feedback

pheap 0.2 was intended as slightly performance improved version, but some bugs crept in. pheap 0.3 fixes these bugs.

This document, and the package it describes, might undoubtedly contain bugs and other problems. Please report such problems with title "pheap" to

 [string map {at @ x . ext .com} [append _ Florian x Murr "at" siemens ext]]

Please also report any ideas for enhancements you may have for either package and/or documentation.