diff --git a/src/bootsupport/lib/base64/ascii85.tcl b/src/bootsupport/lib/base64/ascii85.tcl new file mode 100644 index 00000000..e05e3430 --- /dev/null +++ b/src/bootsupport/lib/base64/ascii85.tcl @@ -0,0 +1,271 @@ +# ascii85.tcl -- +# +# Encode/Decode ascii85 for a string +# +# Copyright (c) Emiliano Gavilan +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.4 + +namespace eval ascii85 { + namespace export encode encodefile decode + # default values for encode options + variable options + array set options [list -wrapchar \n -maxlen 76] +} + +# ::ascii85::encode -- +# +# Ascii85 encode a given string. +# +# Arguments: +# args ?-maxlen maxlen? ?-wrapchar wrapchar? string +# +# If maxlen is 0, the output is not wrapped. +# +# Results: +# A Ascii85 encoded version of $string, wrapped at $maxlen characters +# by $wrapchar. + +proc ascii85::encode {args} { + variable options + + set alen [llength $args] + if {$alen != 1 && $alen != 3 && $alen != 5} { + return -code error "wrong # args:\ + should be \"[lindex [info level 0] 0]\ + ?-maxlen maxlen?\ + ?-wrapchar wrapchar? string\"" + } + + set data [lindex $args end] + array set opts [array get options] + array set opts [lrange $args 0 end-1] + foreach key [array names opts] { + if {[lsearch -exact [array names options] $key] == -1} { + return -code error "unknown option \"$key\":\ + must be -maxlen or -wrapchar" + } + } + + if {![string is integer -strict $opts(-maxlen)] + || $opts(-maxlen) < 0} { + return -code error "expected positive integer but got\ + \"$opts(-maxlen)\"" + } + + # perform this check early + if {[string length $data] == 0} { + return "" + } + + # shorten the names + set ml $opts(-maxlen) + set wc $opts(-wrapchar) + + # if maxlen is zero, don't wrap the output + if {$ml == 0} { + set wc "" + } + + set encoded {} + + binary scan $data c* X + set len [llength $X] + set rest [expr {$len % 4}] + set lastidx [expr {$len - $rest - 1}] + + foreach {b1 b2 b3 b4} [lrange $X 0 $lastidx] { + # calculate the 32 bit value + # this is an inlined version of the [encode4bytes] proc + # included here for performance reasons + set val [expr { + ( (($b1 & 0xff) << 24) + |(($b2 & 0xff) << 16) + |(($b3 & 0xff) << 8) + | ($b4 & 0xff) + ) & 0xffffffff }] + + if {$val == 0} { + # four \0 bytes encodes as "z" instead of "!!!!!" + append current "z" + } else { + # no magic numbers here. + # 52200625 -> 85 ** 4 + # 614125 -> 85 ** 3 + # 7225 -> 85 ** 2 + append current [binary format ccccc \ + [expr { ( $val / 52200625) + 33 }] \ + [expr { (($val % 52200625) / 614125) + 33 }] \ + [expr { (($val % 614125) / 7225) + 33 }] \ + [expr { (($val % 7225) / 85) + 33 }] \ + [expr { ( $val % 85) + 33 }]] + } + + if {[string length $current] >= $ml} { + append encoded [string range $current 0 [expr {$ml - 1}]] $wc + set current [string range $current $ml end] + } + } + + if { $rest } { + # there are remaining bytes. + # pad with \0 and encode not using the "z" convention. + # finally, add ($rest + 1) chars. + set val 0 + foreach {b1 b2 b3 b4} [pad [lrange $X [incr lastidx] end] 4 0] break + append current [string range [encode4bytes $b1 $b2 $b3 $b4] 0 $rest] + } + append encoded [regsub -all -- ".{$ml}" $current "&$wc"] + + return $encoded +} + +proc ascii85::encode4bytes {b1 b2 b3 b4} { + set val [expr { + ( (($b1 & 0xff) << 24) + |(($b2 & 0xff) << 16) + |(($b3 & 0xff) << 8) + | ($b4 & 0xff) + ) & 0xffffffff }] + return [binary format ccccc \ + [expr { ( $val / 52200625) + 33 }] \ + [expr { (($val % 52200625) / 614125) + 33 }] \ + [expr { (($val % 614125) / 7225) + 33 }] \ + [expr { (($val % 7225) / 85) + 33 }] \ + [expr { ( $val % 85) + 33 }]] +} + +# ::ascii85::encodefile -- +# +# Ascii85 encode the contents of a file using default values +# for maxlen and wrapchar parameters. +# +# Arguments: +# fname The name of the file to encode. +# +# Results: +# An Ascii85 encoded version of the contents of the file. +# This is a convenience command + +proc ascii85::encodefile {fname} { + set fd [open $fname] + fconfigure $fd -encoding binary -translation binary + return [encode [read $fd]][close $fd] +} + +# ::ascii85::decode -- +# +# Ascii85 decode a given string. +# +# Arguments: +# string The string to decode. +# Leading spaces and tabs are removed, along with trailing newlines +# +# Results: +# The decoded value. + +proc ascii85::decode {data} { + # get rid of leading spaces/tabs and trailing newlines + set data [string map [list \n {} \t {} { } {}] $data] + set len [string length $data] + + # perform this ckeck early + if {! $len} { + return "" + } + + set decoded {} + set count 0 + set group [list] + binary scan $data c* X + + foreach char $X { + # we must check that every char is in the allowed range + if {$char < 33 || $char > 117 } { + # "z" is an exception + if {$char == 122} { + if {$count == 0} { + # if a "z" char appears at the beggining of a group, + # it decodes as four null bytes + append decoded \x00\x00\x00\x00 + continue + } else { + # if not, is an error + return -code error \ + "error decoding data: \"z\" char misplaced" + } + } + # char is not in range and not a "z" at the beggining of a group + return -code error \ + "error decoding data: chars outside the allowed range" + } + + lappend group $char + incr count + if {$count == 5} { + # this is an inlined version of the [decode5chars] proc + # included here for performance reasons + set val [expr { + ([lindex $group 0] - 33) * wide(52200625) + + ([lindex $group 1] - 33) * 614125 + + ([lindex $group 2] - 33) * 7225 + + ([lindex $group 3] - 33) * 85 + + ([lindex $group 4] - 33) }] + if {$val > 0xffffffff} { + return -code error "error decoding data: decoded group overflow" + } else { + append decoded [binary format I $val] + incr count -5 + set group [list] + } + } + } + + set len [llength $group] + switch -- $len { + 0 { + # all input has been consumed + # do nothing + } + 1 { + # a single char is a condition error, there should be at least 2 + return -code error \ + "error decoding data: trailing char" + } + default { + # pad with "u"s, decode and add ($len - 1) bytes + append decoded [string range \ + [decode5chars [pad $group 5 122]] \ + 0 \ + [expr {$len - 2}]] + } + } + + return $decoded +} + +proc ascii85::decode5chars {group} { + set val [expr { + ([lindex $group 0] - 33) * wide(52200625) + + ([lindex $group 1] - 33) * 614125 + + ([lindex $group 2] - 33) * 7225 + + ([lindex $group 3] - 33) * 85 + + ([lindex $group 4] - 33) }] + if {$val > 0xffffffff} { + return -code error "error decoding data: decoded group overflow" + } + + return [binary format I $val] +} + +proc ascii85::pad {chars len padchar} { + while {[llength $chars] < $len} { + lappend chars $padchar + } + + return $chars +} + +package provide ascii85 1.0 diff --git a/src/bootsupport/lib/base64/base64.tcl b/src/bootsupport/lib/base64/base64.tcl new file mode 100644 index 00000000..fa52c1c3 --- /dev/null +++ b/src/bootsupport/lib/base64/base64.tcl @@ -0,0 +1,410 @@ +# base64.tcl -- +# +# Encode/Decode base64 for a string +# Stephen Uhler / Brent Welch (c) 1997 Sun Microsystems +# The decoder was done for exmh by Chris Garrigues +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# Version 1.0 implemented Base64_Encode, Base64_Decode +# Version 2.0 uses the base64 namespace +# Version 2.1 fixes various decode bugs and adds options to encode +# Version 2.2 is much faster, Tcl8.0 compatible +# Version 2.2.1 bugfixes +# Version 2.2.2 bugfixes +# Version 2.3 bugfixes and extended to support Trf +# Version 2.4.x bugfixes + +# @mdgen EXCLUDE: base64c.tcl + +package require Tcl 8.2 +namespace eval ::base64 { + namespace export encode decode +} + +package provide base64 2.5 + +if {[package vsatisfies [package require Tcl] 8.6]} { + proc ::base64::encode {args} { + binary encode base64 -maxlen 76 {*}$args + } + + proc ::base64::decode {string} { + # Tcllib is strict with respect to end of input, yet lax for + # invalid characters outside of that. + regsub -all -- {[^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/]} $string {} string + binary decode base64 -strict $string + } + + return +} + +if {![catch {package require Trf 2.0}]} { + # Trf is available, so implement the functionality provided here + # in terms of calls to Trf for speed. + + # ::base64::encode -- + # + # Base64 encode a given string. + # + # Arguments: + # args ?-maxlen maxlen? ?-wrapchar wrapchar? string + # + # If maxlen is 0, the output is not wrapped. + # + # Results: + # A Base64 encoded version of $string, wrapped at $maxlen characters + # by $wrapchar. + + proc ::base64::encode {args} { + # Set the default wrapchar and maximum line length to match + # the settings for MIME encoding (RFC 3548, RFC 2045). These + # are the settings used by Trf as well. Various RFCs allow for + # different wrapping characters and wraplengths, so these may + # be overridden by command line options. + set wrapchar "\n" + set maxlen 76 + + if { [llength $args] == 0 } { + error "wrong # args: should be \"[lindex [info level 0] 0]\ + ?-maxlen maxlen? ?-wrapchar wrapchar? string\"" + } + + set optionStrings [list "-maxlen" "-wrapchar"] + for {set i 0} {$i < [llength $args] - 1} {incr i} { + set arg [lindex $args $i] + set index [lsearch -glob $optionStrings "${arg}*"] + if { $index == -1 } { + error "unknown option \"$arg\": must be -maxlen or -wrapchar" + } + incr i + if { $i >= [llength $args] - 1 } { + error "value for \"$arg\" missing" + } + set val [lindex $args $i] + + # The name of the variable to assign the value to is extracted + # from the list of known options, all of which have an + # associated variable of the same name as the option without + # a leading "-". The [string range] command is used to strip + # of the leading "-" from the name of the option. + # + # FRINK: nocheck + set [string range [lindex $optionStrings $index] 1 end] $val + } + + # [string is] requires Tcl8.2; this works with 8.0 too + if {[catch {expr {$maxlen % 2}}]} { + return -code error "expected integer but got \"$maxlen\"" + } elseif {$maxlen < 0} { + return -code error "expected positive integer but got \"$maxlen\"" + } + + set string [lindex $args end] + set result [::base64 -mode encode -- $string] + + # Trf's encoder implicitly uses the settings -maxlen 76, + # -wrapchar \n for its output. We may have to reflow this for + # the settings chosen by the user. A second difference is that + # Trf closes the output with the wrap char sequence, + # always. The code here doesn't. Therefore 'trimright' is + # needed in the fast cases. + + if {($maxlen == 76) && [string equal $wrapchar \n]} { + # Both maxlen and wrapchar are identical to Trf's + # settings. This is the super-fast case, because nearly + # nothing has to be done. Only thing to do is strip a + # terminating wrapchar. + set result [string trimright $result] + } elseif {$maxlen == 76} { + # wrapchar has to be different here, length is the + # same. We can use 'string map' to transform the wrap + # information. + set result [string map [list \n $wrapchar] \ + [string trimright $result]] + } elseif {$maxlen == 0} { + # Have to reflow the output to no wrapping. Another fast + # case using only 'string map'. 'trimright' is not needed + # here. + + set result [string map [list \n ""] $result] + } else { + # Have to reflow the output from 76 to the chosen maxlen, + # and possibly change the wrap sequence as well. + + # Note: After getting rid of the old wrap sequence we + # extract the relevant segments from the string without + # modifying the string. Modification, i.e. removal of the + # processed part, means 'shifting down characters in + # memory', making the algorithm O(n^2). By avoiding the + # modification we stay in O(n). + + set result [string map [list \n ""] $result] + set l [expr {[string length $result]-$maxlen}] + for {set off 0} {$off < $l} {incr off $maxlen} { + append res [string range $result $off [expr {$off+$maxlen-1}]] $wrapchar + } + append res [string range $result $off end] + set result $res + } + + return $result + } + + # ::base64::decode -- + # + # Base64 decode a given string. + # + # Arguments: + # string The string to decode. Characters not in the base64 + # alphabet are ignored (e.g., newlines) + # + # Results: + # The decoded value. + + proc ::base64::decode {string} { + regsub -all {\s} $string {} string + ::base64 -mode decode -- $string + } + +} else { + # Without Trf use a pure tcl implementation + + namespace eval base64 { + variable base64 {} + variable base64_en {} + + # We create the auxiliary array base64_tmp, it will be unset later. + variable base64_tmp + variable i + + set i 0 + foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \ + a b c d e f g h i j k l m n o p q r s t u v w x y z \ + 0 1 2 3 4 5 6 7 8 9 + /} { + set base64_tmp($char) $i + lappend base64_en $char + incr i + } + + # + # Create base64 as list: to code for instance C<->3, specify + # that [lindex $base64 67] be 3 (C is 67 in ascii); non-coded + # ascii chars get a {}. we later use the fact that lindex on a + # non-existing index returns {}, and that [expr {} < 0] is true + # + + # the last ascii char is 'z' + variable char + variable len + variable val + + scan z %c len + for {set i 0} {$i <= $len} {incr i} { + set char [format %c $i] + set val {} + if {[info exists base64_tmp($char)]} { + set val $base64_tmp($char) + } else { + set val {} + } + lappend base64 $val + } + + # code the character "=" as -1; used to signal end of message + scan = %c i + set base64 [lreplace $base64 $i $i -1] + + # remove unneeded variables + unset base64_tmp i char len val + + namespace export encode decode + } + + # ::base64::encode -- + # + # Base64 encode a given string. + # + # Arguments: + # args ?-maxlen maxlen? ?-wrapchar wrapchar? string + # + # If maxlen is 0, the output is not wrapped. + # + # Results: + # A Base64 encoded version of $string, wrapped at $maxlen characters + # by $wrapchar. + + proc ::base64::encode {args} { + set base64_en $::base64::base64_en + + # Set the default wrapchar and maximum line length to match + # the settings for MIME encoding (RFC 3548, RFC 2045). These + # are the settings used by Trf as well. Various RFCs allow for + # different wrapping characters and wraplengths, so these may + # be overridden by command line options. + set wrapchar "\n" + set maxlen 76 + + if { [llength $args] == 0 } { + error "wrong # args: should be \"[lindex [info level 0] 0]\ + ?-maxlen maxlen? ?-wrapchar wrapchar? string\"" + } + + set optionStrings [list "-maxlen" "-wrapchar"] + for {set i 0} {$i < [llength $args] - 1} {incr i} { + set arg [lindex $args $i] + set index [lsearch -glob $optionStrings "${arg}*"] + if { $index == -1 } { + error "unknown option \"$arg\": must be -maxlen or -wrapchar" + } + incr i + if { $i >= [llength $args] - 1 } { + error "value for \"$arg\" missing" + } + set val [lindex $args $i] + + # The name of the variable to assign the value to is extracted + # from the list of known options, all of which have an + # associated variable of the same name as the option without + # a leading "-". The [string range] command is used to strip + # of the leading "-" from the name of the option. + # + # FRINK: nocheck + set [string range [lindex $optionStrings $index] 1 end] $val + } + + # [string is] requires Tcl8.2; this works with 8.0 too + if {[catch {expr {$maxlen % 2}}]} { + return -code error "expected integer but got \"$maxlen\"" + } elseif {$maxlen < 0} { + return -code error "expected positive integer but got \"$maxlen\"" + } + + set string [lindex $args end] + + set result {} + set state 0 + set length 0 + + + # Process the input bytes 3-by-3 + + binary scan $string c* X + + foreach {x y z} $X { + ADD [lindex $base64_en [expr {($x >>2) & 0x3F}]] + if {$y != {}} { + ADD [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]] + if {$z != {}} { + ADD [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]] + ADD [lindex $base64_en [expr {($z & 0x3F)}]] + } else { + set state 2 + break + } + } else { + set state 1 + break + } + } + if {$state == 1} { + ADD [lindex $base64_en [expr {(($x << 4) & 0x30)}]] + ADD = + ADD = + } elseif {$state == 2} { + ADD [lindex $base64_en [expr {(($y << 2) & 0x3C)}]] + ADD = + } + return $result + } + + proc ::base64::ADD {x} { + # The line length check is always done before appending so + # that we don't get an extra newline if the output is a + # multiple of $maxlen chars long. + + upvar 1 maxlen maxlen length length result result wrapchar wrapchar + if {$maxlen && $length >= $maxlen} { + append result $wrapchar + set length 0 + } + append result $x + incr length + return + } + + # ::base64::decode -- + # + # Base64 decode a given string. + # + # Arguments: + # string The string to decode. Characters not in the base64 + # alphabet are ignored (e.g., newlines) + # + # Results: + # The decoded value. + + proc ::base64::decode {string} { + if {[string length $string] == 0} {return ""} + + set base64 $::base64::base64 + set output "" ; # Fix for [Bug 821126] + set nums {} + + binary scan $string c* X + lappend X 61 ;# force a terminator + foreach x $X { + set bits [lindex $base64 $x] + if {$bits >= 0} { + if {[llength [lappend nums $bits]] == 4} { + foreach {v w z y} $nums break + set a [expr {($v << 2) | ($w >> 4)}] + set b [expr {(($w & 0xF) << 4) | ($z >> 2)}] + set c [expr {(($z & 0x3) << 6) | $y}] + append output [binary format ccc $a $b $c] + set nums {} + } + } elseif {$bits == -1} { + # = indicates end of data. Output whatever chars are + # left, if any. + if {![llength $nums]} break + # The encoding algorithm dictates that we can only + # have 1 or 2 padding characters. If x=={}, we must + # (*) have 12 bits of input (enough for 1 8-bit + # output). If x!={}, we have 18 bits of input (enough + # for 2 8-bit outputs). + # + # (*) If we don't then the input is broken (bug 2976290). + + foreach {v w z} $nums break + + # Bug 2976290 + if {$w == {}} { + return -code error "Not enough data to process padding" + } + + set a [expr {($v << 2) | (($w & 0x30) >> 4)}] + if {$z == {}} { + append output [binary format c $a ] + } else { + set b [expr {(($w & 0xF) << 4) | (($z & 0x3C) >> 2)}] + append output [binary format cc $a $b] + } + break + } else { + # RFC 2045 says that line breaks and other characters not part + # of the Base64 alphabet must be ignored, and that the decoder + # can optionally emit a warning or reject the message. We opt + # not to do so, but to just ignore the character. + continue + } + } + return $output + } +} + +# # ## ### ##### ######## ############# ##################### +return + diff --git a/src/bootsupport/lib/base64/base64c.tcl b/src/bootsupport/lib/base64/base64c.tcl new file mode 100644 index 00000000..29e501df --- /dev/null +++ b/src/bootsupport/lib/base64/base64c.tcl @@ -0,0 +1,19 @@ +# base64c - Copyright (C) 2003 Pat Thoyts +# +# This package is a place-holder for the critcl enhanced code present in +# the tcllib base64 module. +# +# Normally this code will become part of the tcllibc library. +# + +# @sak notprovided base64c +package require critcl +package provide base64c 0.1.0 + +namespace eval ::base64c { + variable base64c_rcsid {$Id: base64c.tcl,v 1.5 2008/03/25 07:15:35 andreas_kupries Exp $} + + critcl::ccode { + /* no code required in this file */ + } +} diff --git a/src/bootsupport/lib/base64/pkgIndex.tcl b/src/bootsupport/lib/base64/pkgIndex.tcl new file mode 100644 index 00000000..c8528f59 --- /dev/null +++ b/src/bootsupport/lib/base64/pkgIndex.tcl @@ -0,0 +1,5 @@ +if {![package vsatisfies [package provide Tcl] 8.2]} {return} +package ifneeded base64 2.5 [list source [file join $dir base64.tcl]] +package ifneeded uuencode 1.1.5 [list source [file join $dir uuencode.tcl]] +package ifneeded yencode 1.1.3 [list source [file join $dir yencode.tcl]] +package ifneeded ascii85 1.0 [list source [file join $dir ascii85.tcl]] diff --git a/src/bootsupport/lib/base64/uuencode.tcl b/src/bootsupport/lib/base64/uuencode.tcl new file mode 100644 index 00000000..5e26422d --- /dev/null +++ b/src/bootsupport/lib/base64/uuencode.tcl @@ -0,0 +1,335 @@ +# uuencode - Copyright (C) 2002 Pat Thoyts +# +# Provide a Tcl only implementation of uuencode and uudecode. +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- + +package require Tcl 8.2; # tcl minimum version + +# Try and get some compiled helper package. +if {[catch {package require tcllibc}]} { + catch {package require Trf} +} + +namespace eval ::uuencode { + namespace export encode decode uuencode uudecode +} + +proc ::uuencode::Enc {c} { + return [format %c [expr {($c != 0) ? (($c & 0x3f) + 0x20) : 0x60}]] +} + +proc ::uuencode::Encode {s} { + set r {} + binary scan $s c* d + foreach {c1 c2 c3} $d { + if {$c1 == {}} {set c1 0} + if {$c2 == {}} {set c2 0} + if {$c3 == {}} {set c3 0} + append r [Enc [expr {$c1 >> 2}]] + append r [Enc [expr {(($c1 << 4) & 060) | (($c2 >> 4) & 017)}]] + append r [Enc [expr {(($c2 << 2) & 074) | (($c3 >> 6) & 003)}]] + append r [Enc [expr {($c3 & 077)}]] + } + return $r +} + + +proc ::uuencode::Decode {s} { + if {[string length $s] == 0} {return ""} + set r {} + binary scan [pad $s] c* d + + foreach {c0 c1 c2 c3} $d { + append r [format %c [expr {((($c0-0x20)&0x3F) << 2) & 0xFF + | ((($c1-0x20)&0x3F) >> 4) & 0xFF}]] + append r [format %c [expr {((($c1-0x20)&0x3F) << 4) & 0xFF + | ((($c2-0x20)&0x3F) >> 2) & 0xFF}]] + append r [format %c [expr {((($c2-0x20)&0x3F) << 6) & 0xFF + | (($c3-0x20)&0x3F) & 0xFF}]] + } + return $r +} + +# ------------------------------------------------------------------------- +# C coded version of the Encode/Decode functions for base64c package. +# ------------------------------------------------------------------------- +if {[package provide critcl] != {}} { + namespace eval ::uuencode { + critcl::ccode { + #include + static unsigned char Enc(unsigned char c) { + return (c != 0) ? ((c & 0x3f) + 0x20) : 0x60; + } + } + critcl::ccommand CEncode {dummy interp objc objv} { + Tcl_Obj *inputPtr, *resultPtr; + int len, rlen, xtra; + unsigned char *input, *p, *r; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "data"); + return TCL_ERROR; + } + + inputPtr = objv[1]; + input = Tcl_GetByteArrayFromObj(inputPtr, &len); + if ((xtra = (3 - (len % 3))) != 3) { + if (Tcl_IsShared(inputPtr)) + inputPtr = Tcl_DuplicateObj(inputPtr); + input = Tcl_SetByteArrayLength(inputPtr, len + xtra); + memset(input + len, 0, xtra); + len += xtra; + } + + rlen = (len / 3) * 4; + resultPtr = Tcl_NewObj(); + r = Tcl_SetByteArrayLength(resultPtr, rlen); + memset(r, 0, rlen); + + for (p = input; p < input + len; p += 3) { + char a, b, c; + a = *p; b = *(p+1), c = *(p+2); + *r++ = Enc(a >> 2); + *r++ = Enc(((a << 4) & 060) | ((b >> 4) & 017)); + *r++ = Enc(((b << 2) & 074) | ((c >> 6) & 003)); + *r++ = Enc(c & 077); + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + + critcl::ccommand CDecode {dummy interp objc objv} { + Tcl_Obj *inputPtr, *resultPtr; + int len, rlen, xtra; + unsigned char *input, *p, *r; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "data"); + return TCL_ERROR; + } + + /* if input is not mod 4, extend it with nuls */ + inputPtr = objv[1]; + input = Tcl_GetByteArrayFromObj(inputPtr, &len); + if ((xtra = (4 - (len % 4))) != 4) { + if (Tcl_IsShared(inputPtr)) + inputPtr = Tcl_DuplicateObj(inputPtr); + input = Tcl_SetByteArrayLength(inputPtr, len + xtra); + memset(input + len, 0, xtra); + len += xtra; + } + + /* output will be 1/3 smaller than input and a multiple of 3 */ + rlen = (len / 4) * 3; + resultPtr = Tcl_NewObj(); + r = Tcl_SetByteArrayLength(resultPtr, rlen); + memset(r, 0, rlen); + + for (p = input; p < input + len; p += 4) { + char a, b, c, d; + a = *p; b = *(p+1), c = *(p+2), d = *(p+3); + *r++ = (((a - 0x20) & 0x3f) << 2) | (((b - 0x20) & 0x3f) >> 4); + *r++ = (((b - 0x20) & 0x3f) << 4) | (((c - 0x20) & 0x3f) >> 2); + *r++ = (((c - 0x20) & 0x3f) << 6) | (((d - 0x20) & 0x3f) ); + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + } +} + +# ------------------------------------------------------------------------- + +# Description: +# Permit more tolerant decoding of invalid input strings by padding to +# a multiple of 4 bytes with nulls. +# Result: +# Returns the input string - possibly padded with uuencoded null chars. +# +proc ::uuencode::pad {s} { + if {[set mod [expr {[string length $s] % 4}]] != 0} { + append s [string repeat "`" [expr {4 - $mod}]] + } + return $s +} + +# ------------------------------------------------------------------------- + +# If the Trf package is available then we shall use this by default but the +# Tcllib implementations are always visible if needed (ie: for testing) +if {[info commands ::uuencode::CDecode] != {}} { + # tcllib critcl package + interp alias {} ::uuencode::encode {} ::uuencode::CEncode + interp alias {} ::uuencode::decode {} ::uuencode::CDecode +} elseif {[package provide Trf] != {}} { + proc ::uuencode::encode {s} { + return [::uuencode -mode encode -- $s] + } + proc ::uuencode::decode {s} { + return [::uuencode -mode decode -- [pad $s]] + } +} else { + # pure-tcl then + interp alias {} ::uuencode::encode {} ::uuencode::Encode + interp alias {} ::uuencode::decode {} ::uuencode::Decode +} + +# ------------------------------------------------------------------------- + +proc ::uuencode::uuencode {args} { + array set opts {mode 0644 filename {} name {}} + set wrongargs "wrong \# args: should be\ + \"uuencode ?-name string? ?-mode octal?\ + (-file filename | ?--? string)\"" + while {[string match -* [lindex $args 0]]} { + switch -glob -- [lindex $args 0] { + -f* { + if {[llength $args] < 2} { + return -code error $wrongargs + } + set opts(filename) [lindex $args 1] + set args [lreplace $args 0 0] + } + -m* { + if {[llength $args] < 2} { + return -code error $wrongargs + } + set opts(mode) [lindex $args 1] + set args [lreplace $args 0 0] + } + -n* { + if {[llength $args] < 2} { + return -code error $wrongargs + } + set opts(name) [lindex $args 1] + set args [lreplace $args 0 0] + } + -- { + set args [lreplace $args 0 0] + break + } + default { + return -code error "bad option [lindex $args 0]:\ + must be -file, -mode, or -name" + } + } + set args [lreplace $args 0 0] + } + + if {$opts(name) == {}} { + set opts(name) $opts(filename) + } + if {$opts(name) == {}} { + set opts(name) "data.dat" + } + + if {$opts(filename) != {}} { + set f [open $opts(filename) r] + fconfigure $f -translation binary + set data [read $f] + close $f + } else { + if {[llength $args] != 1} { + return -code error $wrongargs + } + set data [lindex $args 0] + } + + set r {} + append r [format "begin %o %s" $opts(mode) $opts(name)] "\n" + for {set n 0} {$n < [string length $data]} {incr n 45} { + set s [string range $data $n [expr {$n + 44}]] + append r [Enc [string length $s]] + append r [encode $s] "\n" + } + append r "`\nend" + return $r +} + +# ------------------------------------------------------------------------- +# Description: +# Perform uudecoding of a file or data. A file may contain more than one +# encoded data section so the result is a list where each element is a +# three element list of the provided filename, the suggested mode and the +# data itself. +# +proc ::uuencode::uudecode {args} { + array set opts {mode 0644 filename {}} + set wrongargs "wrong \# args: should be \"uudecode (-file filename | ?--? string)\"" + while {[string match -* [lindex $args 0]]} { + switch -glob -- [lindex $args 0] { + -f* { + if {[llength $args] < 2} { + return -code error $wrongargs + } + set opts(filename) [lindex $args 1] + set args [lreplace $args 0 0] + } + -- { + set args [lreplace $args 0 0] + break + } + default { + return -code error "bad option [lindex $args 0]:\ + must be -file" + } + } + set args [lreplace $args 0 0] + } + + if {$opts(filename) != {}} { + set f [open $opts(filename) r] + set data [read $f] + close $f + } else { + if {[llength $args] != 1} { + return -code error $wrongargs + } + set data [lindex $args 0] + } + + set state false + set result {} + + foreach {line} [split $data "\n"] { + switch -exact -- $state { + false { + if {[regexp {^begin ([0-7]+) ([^\s]*)} $line \ + -> opts(mode) opts(name)]} { + set state true + set r {} + } + } + + true { + if {[string match "end" $line]} { + set state false + lappend result [list $opts(name) $opts(mode) $r] + } else { + scan $line %c c + set n [expr {($c - 0x21)}] + append r [string range \ + [decode [string range $line 1 end]] 0 $n] + } + } + } + } + + return $result +} + +# ------------------------------------------------------------------------- + +package provide uuencode 1.1.5 + +# ------------------------------------------------------------------------- +# +# Local variables: +# mode: tcl +# indent-tabs-mode: nil +# End: + diff --git a/src/bootsupport/lib/base64/yencode.tcl b/src/bootsupport/lib/base64/yencode.tcl new file mode 100644 index 00000000..0d4554c0 --- /dev/null +++ b/src/bootsupport/lib/base64/yencode.tcl @@ -0,0 +1,307 @@ +# yencode.tcl - Copyright (C) 2002 Pat Thoyts +# +# Provide a Tcl only implementation of yEnc encoding algorithm +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- + +# FUTURE: Rework to allow switching between the tcl/critcl implementations. + +package require Tcl 8.2; # tcl minimum version +catch {package require crc32}; # tcllib 1.1 +catch {package require tcllibc}; # critcl enhancements for tcllib + +namespace eval ::yencode { + namespace export encode decode yencode ydecode +} + +# ------------------------------------------------------------------------- + +proc ::yencode::Encode {s} { + set r {} + binary scan $s c* d + foreach {c} $d { + set v [expr {($c + 42) % 256}] + if {$v == 0x00 || $v == 0x09 || $v == 0x0A + || $v == 0x0D || $v == 0x3D} { + append r "=" + set v [expr {($v + 64) % 256}] + } + append r [format %c $v] + } + return $r +} + +proc ::yencode::Decode {s} { + if {[string length $s] == 0} {return ""} + set r {} + set esc 0 + binary scan $s c* d + foreach c $d { + if {$c == 61 && $esc == 0} { + set esc 1 + continue + } + set v [expr {($c - 42) % 256}] + if {$esc} { + set v [expr {($v - 64) % 256}] + set esc 0 + } + append r [format %c $v] + } + return $r +} + +# ------------------------------------------------------------------------- +# C coded versions for critcl built base64c package +# ------------------------------------------------------------------------- + +if {[package provide critcl] != {}} { + namespace eval ::yencode { + critcl::ccode { + #include + } + critcl::ccommand CEncode {dummy interp objc objv} { + Tcl_Obj *inputPtr, *resultPtr; + int len, rlen, xtra; + unsigned char *input, *p, *r, v; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "data"); + return TCL_ERROR; + } + + /* fetch the input data */ + inputPtr = objv[1]; + input = Tcl_GetByteArrayFromObj(inputPtr, &len); + + /* calculate the length of the encoded result */ + rlen = len; + for (p = input; p < input + len; p++) { + v = (*p + 42) % 256; + if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D) + rlen++; + } + + /* allocate the output buffer */ + resultPtr = Tcl_NewObj(); + r = Tcl_SetByteArrayLength(resultPtr, rlen); + + /* encode the input */ + for (p = input; p < input + len; p++) { + v = (*p + 42) % 256; + if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D) { + *r++ = '='; + v = (v + 64) % 256; + } + *r++ = v; + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + + critcl::ccommand CDecode {dummy interp objc objv} { + Tcl_Obj *inputPtr, *resultPtr; + int len, rlen, esc; + unsigned char *input, *p, *r, v; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "data"); + return TCL_ERROR; + } + + /* fetch the input data */ + inputPtr = objv[1]; + input = Tcl_GetByteArrayFromObj(inputPtr, &len); + + /* allocate the output buffer */ + resultPtr = Tcl_NewObj(); + r = Tcl_SetByteArrayLength(resultPtr, len); + + /* encode the input */ + for (p = input, esc = 0, rlen = 0; p < input + len; p++) { + if (*p == 61 && esc == 0) { + esc = 1; + continue; + } + v = (*p - 42) % 256; + if (esc) { + v = (v - 64) % 256; + esc = 0; + } + *r++ = v; + rlen++; + } + Tcl_SetByteArrayLength(resultPtr, rlen); + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + } +} + +if {[info commands ::yencode::CEncode] != {}} { + interp alias {} ::yencode::encode {} ::yencode::CEncode + interp alias {} ::yencode::decode {} ::yencode::CDecode +} else { + interp alias {} ::yencode::encode {} ::yencode::Encode + interp alias {} ::yencode::decode {} ::yencode::Decode +} + +# ------------------------------------------------------------------------- +# Description: +# Pop the nth element off a list. Used in options processing. +# +proc ::yencode::Pop {varname {nth 0}} { + upvar $varname args + set r [lindex $args $nth] + set args [lreplace $args $nth $nth] + return $r +} + +# ------------------------------------------------------------------------- + +proc ::yencode::yencode {args} { + array set opts {mode 0644 filename {} name {} line 128 crc32 1} + while {[string match -* [lindex $args 0]]} { + switch -glob -- [lindex $args 0] { + -f* { set opts(filename) [Pop args 1] } + -m* { set opts(mode) [Pop args 1] } + -n* { set opts(name) [Pop args 1] } + -l* { set opts(line) [Pop args 1] } + -c* { set opts(crc32) [Pop args 1] } + -- { Pop args ; break } + default { + set options [join [lsort [array names opts]] ", -"] + return -code error "bad option [lindex $args 0]:\ + must be -$options" + } + } + Pop args + } + + if {$opts(name) == {}} { + set opts(name) $opts(filename) + } + if {$opts(name) == {}} { + set opts(name) "data.dat" + } + if {! [string is boolean $opts(crc32)]} { + return -code error "bad option -crc32: argument must be true or false" + } + + if {$opts(filename) != {}} { + set f [open $opts(filename) r] + fconfigure $f -translation binary + set data [read $f] + close $f + } else { + if {[llength $args] != 1} { + return -code error "wrong \# args: should be\ + \"yencode ?options? -file name | data\"" + } + set data [lindex $args 0] + } + + set opts(size) [string length $data] + + set r {} + append r [format "=ybegin line=%d size=%d name=%s" \ + $opts(line) $opts(size) $opts(name)] "\n" + + set ndx 0 + while {$ndx < $opts(size)} { + set pln [string range $data $ndx [expr {$ndx + $opts(line) - 1}]] + set enc [encode $pln] + incr ndx [string length $pln] + append r $enc "\r\n" + } + + append r [format "=yend size=%d" $ndx] + if {$opts(crc32)} { + append r " crc32=" [crc::crc32 -format %x $data] + } + return $r +} + +# ------------------------------------------------------------------------- +# Description: +# Perform ydecoding of a file or data. A file may contain more than one +# encoded data section so the result is a list where each element is a +# three element list of the provided filename, the file size and the +# data itself. +# +proc ::yencode::ydecode {args} { + array set opts {mode 0644 filename {} name default.bin} + while {[string match -* [lindex $args 0]]} { + switch -glob -- [lindex $args 0] { + -f* { set opts(filename) [Pop args 1] } + -- { Pop args ; break; } + default { + set options [join [lsort [array names opts]] ", -"] + return -code error "bad option [lindex $args 0]:\ + must be -$opts" + } + } + Pop args + } + + if {$opts(filename) != {}} { + set f [open $opts(filename) r] + set data [read $f] + close $f + } else { + if {[llength $args] != 1} { + return -code error "wrong \# args: should be\ + \"ydecode ?options? -file name | data\"" + } + set data [lindex $args 0] + } + + set state false + set result {} + + foreach {line} [split $data "\n"] { + set line [string trimright $line "\r\n"] + switch -exact -- $state { + false { + if {[string match "=ybegin*" $line]} { + regexp {line=(\d+)} $line -> opts(line) + regexp {size=(\d+)} $line -> opts(size) + regexp {name=(\d+)} $line -> opts(name) + + if {$opts(name) == {}} { + set opts(name) default.bin + } + + set state true + set r {} + } + } + + true { + if {[string match "=yend*" $line]} { + set state false + lappend result [list $opts(name) $opts(size) $r] + } else { + append r [decode $line] + } + } + } + } + + return $result +} + +# ------------------------------------------------------------------------- + +package provide yencode 1.1.3 + +# ------------------------------------------------------------------------- +# +# Local variables: +# mode: tcl +# indent-tabs-mode: nil +# End: + diff --git a/src/bootsupport/lib/control/ascaller.tcl b/src/bootsupport/lib/control/ascaller.tcl new file mode 100644 index 00000000..6c864bb5 --- /dev/null +++ b/src/bootsupport/lib/control/ascaller.tcl @@ -0,0 +1,72 @@ +# ascaller.tcl - +# +# A few utility procs that manage the evaluation of a command +# or a script in the context of a caller, taking care of all +# the ugly details of proper return codes, errorcodes, and +# a good stack trace in ::errorInfo as appropriate. +# ------------------------------------------------------------------------- +# +# RCS: @(#) $Id: ascaller.tcl,v 1.3 2004/01/15 06:36:12 andreas_kupries Exp $ + +namespace eval ::control { + + proc CommandAsCaller {cmdVar resultVar {where {}} {codeVar code}} { + set x [expr {[string equal "" $where] + ? {} : [subst -nobackslashes {\n ($where)}]}] + set script [subst -nobackslashes -nocommands { + set $codeVar [catch {uplevel 1 $$cmdVar} $resultVar] + if {$$codeVar > 1} { + return -code $$codeVar $$resultVar + } + if {$$codeVar == 1} { + if {[string equal {"uplevel 1 $$cmdVar"} \ + [lindex [split [set ::errorInfo] \n] end]]} { + set $codeVar [join \ + [lrange [split [set ::errorInfo] \n] 0 \ + end-[expr {4+[llength [split $$cmdVar \n]]}]] \n] + } else { + set $codeVar [join \ + [lrange [split [set ::errorInfo] \n] 0 end-1] \n] + } + return -code error -errorcode [set ::errorCode] \ + -errorinfo "$$codeVar$x" $$resultVar + } + }] + return $script + } + + proc BodyAsCaller {bodyVar resultVar codeVar {where {}}} { + set x [expr {[string equal "" $where] + ? {} : [subst -nobackslashes -nocommands \ + {\n ($where[string map {{ ("uplevel"} {}} \ + [lindex [split [set ::errorInfo] \n] end]]}]}] + set script [subst -nobackslashes -nocommands { + set $codeVar [catch {uplevel 1 $$bodyVar} $resultVar] + if {$$codeVar == 1} { + if {[string equal {"uplevel 1 $$bodyVar"} \ + [lindex [split [set ::errorInfo] \n] end]]} { + set ::errorInfo [join \ + [lrange [split [set ::errorInfo] \n] 0 end-2] \n] + } + set $codeVar [join \ + [lrange [split [set ::errorInfo] \n] 0 end-1] \n] + return -code error -errorcode [set ::errorCode] \ + -errorinfo "$$codeVar$x" $$resultVar + } + }] + return $script + } + + proc ErrorInfoAsCaller {find replace} { + set info $::errorInfo + set i [string last "\n (\"$find" $info] + if {$i == -1} {return $info} + set result [string range $info 0 [incr i 6]] ;# keep "\n (\"" + append result $replace ;# $find -> $replace + incr i [string length $find] + set j [string first ) $info [incr i]] ;# keep rest of parenthetical + append result [string range $info $i $j] + return $result + } + +} diff --git a/src/bootsupport/lib/control/assert.tcl b/src/bootsupport/lib/control/assert.tcl new file mode 100644 index 00000000..8aac408d --- /dev/null +++ b/src/bootsupport/lib/control/assert.tcl @@ -0,0 +1,91 @@ +# assert.tcl -- +# +# The [assert] command of the package "control". +# +# RCS: @(#) $Id: assert.tcl,v 1.3 2004/01/15 06:36:12 andreas_kupries Exp $ + +namespace eval ::control { + + namespace eval assert { + namespace export EnabledAssert DisabledAssert + variable CallbackCmd [list return -code error] + + namespace import [namespace parent]::no-op + rename no-op DisabledAssert + + proc EnabledAssert {expr args} { + variable CallbackCmd + + set code [catch {uplevel 1 [list expr $expr]} res] + if {$code} { + return -code $code $res + } + if {![string is boolean -strict $res]} { + return -code error "invalid boolean expression: $expr" + } + if {$res} {return} + if {[llength $args]} { + set msg [join $args] + } else { + set msg "assertion failed: $expr" + } + # Might want to catch this + namespace eval :: $CallbackCmd [list $msg] + } + + proc enabled {args} { + set n [llength $args] + if {$n > 1} { + return -code error "wrong # args: should be\ + \"[lindex [info level 0] 0] ?boolean?\"" + } + if {$n} { + set val [lindex $args 0] + if {![string is boolean -strict $val]} { + return -code error "invalid boolean value: $val" + } + if {$val} { + [namespace parent]::AssertSwitch Disabled Enabled + } else { + [namespace parent]::AssertSwitch Enabled Disabled + } + } else { + return [string equal [namespace origin EnabledAssert] \ + [namespace origin [namespace parent]::assert]] + } + return "" + } + + proc callback {args} { + set n [llength $args] + if {$n > 1} { + return -code error "wrong # args: should be\ + \"[lindex [info level 0] 0] ?command?\"" + } + if {$n} { + return [variable CallbackCmd [lindex $args 0]] + } + variable CallbackCmd + return $CallbackCmd + } + + } + + proc AssertSwitch {old new} { + if {[string equal [namespace origin assert] \ + [namespace origin assert::${new}Assert]]} {return} + rename assert ${old}Assert + rename ${new}Assert assert + } + + namespace import assert::DisabledAssert assert::EnabledAssert + + # For indexer + proc assert args # + rename assert {} + + # Initial default: disabled asserts + rename DisabledAssert assert + +} + diff --git a/src/bootsupport/lib/control/control.tcl b/src/bootsupport/lib/control/control.tcl new file mode 100644 index 00000000..6cdf08a0 --- /dev/null +++ b/src/bootsupport/lib/control/control.tcl @@ -0,0 +1,24 @@ +# control.tcl -- +# +# This is the main package provide script for the package +# "control". It provides commands that govern the flow of +# control of a program. + +package require Tcl 8.2 + +namespace eval ::control { + namespace export assert control do no-op rswitch + + proc control {command args} { + # Need to add error handling here + namespace eval [list $command] $args + } + + # Set up for auto-loading the commands + variable home [file join [pwd] [file dirname [info script]]] + if {[lsearch -exact $::auto_path $home] == -1} { + lappend ::auto_path $home + } + + package provide [namespace tail [namespace current]] 0.1.3 +} diff --git a/src/bootsupport/lib/control/do.tcl b/src/bootsupport/lib/control/do.tcl new file mode 100644 index 00000000..aa5c1af5 --- /dev/null +++ b/src/bootsupport/lib/control/do.tcl @@ -0,0 +1,81 @@ +# do.tcl -- +# +# Tcl implementation of a "do ... while|until" loop. +# +# Originally written for the "Texas Tcl Shootout" programming contest +# at the 2000 Tcl Conference in Austin/Texas. +# +# Copyright (c) 2001 by Reinhard Max +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: do.tcl,v 1.6 2004/01/15 06:36:12 andreas_kupries Exp $ +# +namespace eval ::control { + + proc do {body args} { + + # + # Implements a "do body while|until test" loop + # + # It is almost as fast as builtin "while" command for loops with + # more than just a few iterations. + # + + set len [llength $args] + if {$len !=2 && $len != 0} { + set proc [namespace current]::[lindex [info level 0] 0] + return -code error "wrong # args: should be \"$proc body\" or \"$proc body \[until|while\] test\"" + } + set test 0 + foreach {whileOrUntil test} $args { + switch -exact -- $whileOrUntil { + "while" {} + "until" { set test !($test) } + default { + return -code error \ + "bad option \"$whileOrUntil\": must be until, or while" + } + } + break + } + + # the first invocation of the body + set code [catch { uplevel 1 $body } result] + + # decide what to do upon the return code: + # + # 0 - the body executed successfully + # 1 - the body raised an error + # 2 - the body invoked [return] + # 3 - the body invoked [break] + # 4 - the body invoked [continue] + # everything else - return and pass on the results + # + switch -exact -- $code { + 0 {} + 1 { + return -errorinfo [ErrorInfoAsCaller uplevel do] \ + -errorcode $::errorCode -code error $result + } + 3 { + # FRINK: nocheck + return + } + 4 {} + default { + return -code $code $result + } + } + # the rest of the loop + set code [catch {uplevel 1 [list while $test $body]} result] + if {$code == 1} { + return -errorinfo [ErrorInfoAsCaller while do] \ + -errorcode $::errorCode -code error $result + } + return -code $code $result + + } + +} diff --git a/src/bootsupport/lib/control/no-op.tcl b/src/bootsupport/lib/control/no-op.tcl new file mode 100644 index 00000000..2400303f --- /dev/null +++ b/src/bootsupport/lib/control/no-op.tcl @@ -0,0 +1,14 @@ +# no-op.tcl -- +# +# The [no-op] command of the package "control". +# It accepts any number of arguments and does nothing. +# It returns an empty string. +# +# RCS: @(#) $Id: no-op.tcl,v 1.2 2004/01/15 06:36:12 andreas_kupries Exp $ + +namespace eval ::control { + + proc no-op args {} + +} + diff --git a/src/bootsupport/lib/control/pkgIndex.tcl b/src/bootsupport/lib/control/pkgIndex.tcl new file mode 100644 index 00000000..3b432db7 --- /dev/null +++ b/src/bootsupport/lib/control/pkgIndex.tcl @@ -0,0 +1,2 @@ +if {![package vsatisfies [package provide Tcl] 8.2]} {return} +package ifneeded control 0.1.3 [list source [file join $dir control.tcl]] diff --git a/src/bootsupport/lib/control/tclIndex b/src/bootsupport/lib/control/tclIndex new file mode 100644 index 00000000..614d932f --- /dev/null +++ b/src/bootsupport/lib/control/tclIndex @@ -0,0 +1,18 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(::control::CommandAsCaller) [list source [file join $dir ascaller.tcl]] +set auto_index(::control::BodyAsCaller) [list source [file join $dir ascaller.tcl]] +set auto_index(::control::ErrorInfoAsCaller) [list source [file join $dir ascaller.tcl]] +set auto_index(::control::assert::EnabledAssert) [list source [file join $dir assert.tcl]] +set auto_index(::control::assert::enabled) [list source [file join $dir assert.tcl]] +set auto_index(::control::assert::callback) [list source [file join $dir assert.tcl]] +set auto_index(::control::AssertSwitch) [list source [file join $dir assert.tcl]] +set auto_index(::control::assert) [list source [file join $dir assert.tcl]] +set auto_index(::control::do) [list source [file join $dir do.tcl]] +set auto_index(::control::no-op) [list source [file join $dir no-op.tcl]] diff --git a/src/bootsupport/lib/debug/caller.tcl b/src/bootsupport/lib/debug/caller.tcl new file mode 100644 index 00000000..e85a9f08 --- /dev/null +++ b/src/bootsupport/lib/debug/caller.tcl @@ -0,0 +1,97 @@ +## -*- tcl -*- +# ### ### ### ######### ######### ######### + +## Utility command for use as debug prefix command to un-mangle snit +## and TclOO method calls. + +# ### ### ### ######### ######### ######### +## Requisites + +package require Tcl 8.5 +package require debug + +namespace eval ::debug { + namespace export caller + namespace ensemble create +} + +# ### ### ### ######### ######### ######### +## API & Implementation + +proc ::debug::caller {args} { + # For snit (type)methods, rework the command line to be more + # legible and in line with what the user would expect. To this end + # we pull the primary command out of the arguments, be it type or + # object, massage the command to match the original (type)method + # name, then resort and expand the words to match the call before + # the snit got its claws into it. + + set a [lassign [info level -1] m] + regsub {.*Snit_} $m {} m + + if {[string match ::oo::Obj*::my $m]} { + # TclOO call. + set m [uplevel 1 self] + return [list $m {*}[Filter $a $args]] + } + if {$m eq "my"} { + # TclOO call. + set m [uplevel 1 self] + return [list $m {*}[Filter $a $args]] + } + + switch -glob -- $m { + htypemethod* { + # primary = type, a = type + set a [lassign $a primary] + set m [string map {_ { }} [string range $m 11 end]] + } + typemethod* { + # primary = type, a = type + set a [lassign $a primary] + set m [string range $m 10 end] + } + hmethod* { + # primary = self, a = type selfns self win ... + set a [lassign $a _ _ primary _] + set m [string map {_ { }} [string range $m 7 end]] + } + method* { + # primary = self, a = type selfns self win ... + set a [lassign $a _ _ primary _] + set m [string range $m 6 end] + } + destructor - + constructor { + # primary = self, a = type selfns self win ... + set a [lassign $a _ _ primary _] + } + typeconstructor { + return [list {*}$a $m] + } + default { + # Unknown + return [list $m {*}[Filter $a $args]] + } + } + return [list $primary {*}$m {*}[Filter $a $args]] +} + +proc ::debug::Filter {args droplist} { + if {[llength $droplist]} { + # Replace unwanted arguments with '*'. This is usually done + # for arguments which can be large Tcl values. These would + # screw up formatting and, to add insult to this injury, also + # repeat for each debug output in the same proc, method, etc. + foreach i [lsort -integer $droplist] { + set args [lreplace $args $i $i *] + } + } + return $args +} + +# ### ######### ########################### +## Ready for use + +package provide debug::caller 1.1 +return diff --git a/src/bootsupport/lib/debug/debug.tcl b/src/bootsupport/lib/debug/debug.tcl new file mode 100644 index 00000000..4ce60808 --- /dev/null +++ b/src/bootsupport/lib/debug/debug.tcl @@ -0,0 +1,306 @@ +# Debug - a debug narrative logger. +# -- Colin McCormack / originally Wub server utilities +# +# Debugging areas of interest are represented by 'tokens' which have +# independantly settable levels of interest (an integer, higher is more detailed) +# +# Debug narrative is provided as a tcl script whose value is [subst]ed in the +# caller's scope if and only if the current level of interest matches or exceeds +# the Debug call's level of detail. This is useful, as one can place arbitrarily +# complex narrative in code without unnecessarily evaluating it. +# +# TODO: potentially different streams for different areas of interest. +# (currently only stderr is used. there is some complexity in efficient +# cross-threaded streams.) + +# # ## ### ##### ######## ############# ##################### +## Requisites + +package require Tcl 8.5 + +namespace eval ::debug { + namespace export -clear \ + define on off prefix suffix header trailer \ + names 2array level setting parray pdict \ + nl tab hexl + namespace ensemble create -subcommands {} +} + +# # ## ### ##### ######## ############# ##################### +## API & Implementation + +proc ::debug::noop {args} {} + +proc ::debug::debug {tag message {level 1}} { + variable detail + if {$detail($tag) < $level} { + #puts stderr "$tag @@@ $detail($tag) >= $level" + return + } + + variable prefix + variable suffix + variable header + variable trailer + variable fds + + if {[info exists fds($tag)]} { + set fd $fds($tag) + } else { + set fd stderr + } + + # Assemble the shown text from the user message and the various + # prefixes and suffices (global + per-tag). + + set themessage "" + if {[info exists prefix(::)]} { append themessage $prefix(::) } + if {[info exists prefix($tag)]} { append themessage $prefix($tag) } + append themessage $message + if {[info exists suffix($tag)]} { append themessage $suffix($tag) } + if {[info exists suffix(::)]} { append themessage $suffix(::) } + + # Resolve variables references and command invokations embedded + # into the message with plain text. + set code [catch { + set smessage [uplevel 1 [list ::subst -nobackslashes $themessage]] + set sheader [uplevel 1 [list ::subst -nobackslashes $header]] + set strailer [uplevel 1 [list ::subst -nobackslashes $trailer]] + } __ eo] + + # And dump an internal error if that resolution failed. + if {$code} { + if {[catch { + set caller [info level -1] + }]} { set caller GLOBAL } + if {[string length $caller] >= 1000} { + set caller "[string range $caller 0 200]...[string range $caller end-200 end]" + } + foreach line [split $caller \n] { + puts -nonewline $fd "@@(DebugError from $tag ($eo): $line)" + } + return + } + + # From here we have a good message to show. We only shorten it a + # bit if its a bit excessive in size. + + if {[string length $smessage] > 4096} { + set head [string range $smessage 0 2048] + set tail [string range $smessage end-2048 end] + set smessage "${head}...(truncated)...$tail" + } + + foreach line [split $smessage \n] { + puts $fd "$sheader$tag | $line$strailer" + } + return +} + +# names - return names of debug tags +proc ::debug::names {} { + variable detail + return [lsort [array names detail]] +} + +proc ::debug::2array {} { + variable detail + set result {} + foreach n [lsort [array names detail]] { + if {[interp alias {} debug.$n] ne "::debug::noop"} { + lappend result $n $detail($n) + } else { + lappend result $n -$detail($n) + } + } + return $result +} + +# level - set level and fd for tag +proc ::debug::level {tag {level ""} {fd {}}} { + variable detail + # TODO: Force level >=0. + if {$level ne ""} { + set detail($tag) $level + } + + if {![info exists detail($tag)]} { + set detail($tag) 1 + } + + variable fds + if {$fd ne {}} { + set fds($tag) $fd + } + + return $detail($tag) +} + +proc ::debug::header {text} { variable header $text } +proc ::debug::trailer {text} { variable trailer $text } + +proc ::debug::define {tag} { + if {[interp alias {} debug.$tag] ne {}} return + off $tag + return +} + +# Set a prefix/suffix to use for tag. +# The global (tag-independent) prefix/suffix is adressed through tag '::'. +# This works because colon (:) is an illegal character for user-specified tags. + +proc ::debug::prefix {tag {theprefix {}}} { + variable prefix + set prefix($tag) $theprefix + + if {[interp alias {} debug.$tag] ne {}} return + off $tag + return +} + +proc ::debug::suffix {tag {theprefix {}}} { + variable suffix + set suffix($tag) $theprefix + + if {[interp alias {} debug.$tag] ne {}} return + off $tag + return +} + +# turn on debugging for tag +proc ::debug::on {tag {level ""} {fd {}}} { + variable active + set active($tag) 1 + level $tag $level $fd + interp alias {} debug.$tag {} ::debug::debug $tag + return +} + +# turn off debugging for tag +proc ::debug::off {tag {level ""} {fd {}}} { + variable active + set active($tag) 1 + level $tag $level $fd + interp alias {} debug.$tag {} ::debug::noop + return +} + +proc ::debug::setting {args} { + if {[llength $args] == 1} { + set args [lindex $args 0] + } + set fd stderr + if {[llength $args] % 2} { + set fd [lindex $args end] + set args [lrange $args 0 end-1] + } + foreach {tag level} $args { + if {$level > 0} { + level $tag $level $fd + interp alias {} debug.$tag {} ::debug::debug $tag + } else { + level $tag [expr {-$level}] $fd + interp alias {} debug.$tag {} ::debug::noop + } + } + return +} + +# # ## ### ##### ######## ############# ##################### +## Convenience commands. +# Format arrays and dicts as multi-line message. +# Insert newlines and tabs. + +proc ::debug::nl {} { return \n } +proc ::debug::tab {} { return \t } + +proc ::debug::parray {a {pattern *}} { + upvar 1 $a array + if {![array exists array]} { + error "\"$a\" isn't an array" + } + pdict [array get array] $pattern +} + +proc ::debug::pdict {dict {pattern *}} { + set maxl 0 + set names [lsort -dict [dict keys $dict $pattern]] + foreach name $names { + if {[string length $name] > $maxl} { + set maxl [string length $name] + } + } + set maxl [expr {$maxl + 2}] + set lines {} + foreach name $names { + set nameString [format (%s) $name] + lappend lines [format "%-*s = %s" \ + $maxl $nameString \ + [dict get $dict $name]] + } + return [join $lines \n] +} + +proc ::debug::hexl {data {prefix {}}} { + set r {} + + # Convert the data to hex and to characters. + binary scan $data H*@0a* hexa asciia + + # Replace non-printing characters in the data with dots. + regsub -all -- {[^[:graph:] ]} $asciia {.} asciia + + # Pad with spaces to a full multiple of 32/16. + set n [expr {[string length $hexa] % 32}] + if {$n < 32} { append hexa [string repeat { } [expr {32-$n}]] } + #puts "pad H [expr {32-$n}]" + + set n [expr {[string length $asciia] % 32}] + if {$n < 16} { append asciia [string repeat { } [expr {16-$n}]] } + #puts "pad A [expr {32-$n}]" + + # Reassemble formatted, in groups of 16 bytes/characters. + # The hex part is handled in groups of 32 nibbles. + set addr 0 + while {[string length $hexa]} { + # Get front group of 16 bytes each. + set hex [string range $hexa 0 31] + set ascii [string range $asciia 0 15] + # Prep for next iteration + set hexa [string range $hexa 32 end] + set asciia [string range $asciia 16 end] + + # Convert the hex to pairs of hex digits + regsub -all -- {..} $hex {& } hex + + # Add the hex and latin-1 data to the result buffer + append r $prefix [format %04x $addr] { | } $hex { |} $ascii |\n + incr addr 16 + } + + # And done + return $r +} + +# # ## ### ##### ######## ############# ##################### + +namespace eval debug { + variable detail ; # map: TAG -> level of interest + variable prefix ; # map: TAG -> message prefix to use + variable suffix ; # map: TAG -> message suffix to use + variable fds ; # map: TAG -> handle of open channel to log to. + variable header {} ; # per-line heading, subst'ed + variable trailer {} ; # per-line ending, subst'ed + + # Notes: + # - The tag '::' is reserved. "prefix" and "suffix" use it to store + # the global message prefix / suffix. + # - prefix and suffix are applied per message. + # - header and trailer are per line. And should not generate multiple lines! +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide debug 1.0.6 +return diff --git a/src/bootsupport/lib/debug/heartbeat.tcl b/src/bootsupport/lib/debug/heartbeat.tcl new file mode 100644 index 00000000..a00ecd94 --- /dev/null +++ b/src/bootsupport/lib/debug/heartbeat.tcl @@ -0,0 +1,68 @@ +# -*- tcl -* +# Debug -- Heartbeat. Track operation of Tcl's eventloop. +# -- Colin McCormack / originally Wub server utilities + +# # ## ### ##### ######## ############# ##################### +## Requisites + +package require Tcl 8.5 +package require debug + +namespace eval ::debug { + namespace export heartbeat + namespace ensemble create +} + +# # ## ### ##### ######## ############# ##################### +## API & Implementation + +proc ::debug::heartbeat {{delta 500}} { + variable duration $delta + variable timer + + if {$duration > 0} { + # stop a previous heartbeat before starting the next + catch { after cancel $timer } + on heartbeat + ::debug::every $duration { + debug.heartbeat {[::debug::pulse]} + } + } else { + catch { after cancel $timer } + off heartbeat + } +} + +proc ::debug::every {ms body} { + eval $body + variable timer [after $ms [info level 0]] + return +} + +proc ::debug::pulse {} { + variable duration + variable hbtimer + variable heartbeat + + set now [::tcl::clock::milliseconds] + set diff [expr {$now - $hbtimer - $duration}] + + set hbtimer $now + + return [list [incr heartbeat] $diff] +} + +# # ## ### ##### ######## ############# ##################### + +namespace eval ::debug { + variable duration 0 ; # milliseconds between heart-beats + variable heartbeat 0 ; # beat counter + variable hbtimer [::tcl::clock::milliseconds] + variable timer +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide debug::heartbeat 1.0.1 +return diff --git a/src/bootsupport/lib/debug/pkgIndex.tcl b/src/bootsupport/lib/debug/pkgIndex.tcl new file mode 100644 index 00000000..065cc9e7 --- /dev/null +++ b/src/bootsupport/lib/debug/pkgIndex.tcl @@ -0,0 +1,5 @@ +if {![package vsatisfies [package require Tcl] 8.5]} return +package ifneeded debug 1.0.6 [list source [file join $dir debug.tcl]] +package ifneeded debug::heartbeat 1.0.1 [list source [file join $dir heartbeat.tcl]] +package ifneeded debug::timestamp 1 [list source [file join $dir timestamp.tcl]] +package ifneeded debug::caller 1.1 [list source [file join $dir caller.tcl]] diff --git a/src/bootsupport/lib/debug/timestamp.tcl b/src/bootsupport/lib/debug/timestamp.tcl new file mode 100644 index 00000000..5fec019e --- /dev/null +++ b/src/bootsupport/lib/debug/timestamp.tcl @@ -0,0 +1,47 @@ +# -*- tcl -* +# Debug -- Timestamps. +# -- Colin McCormack / originally Wub server utilities +# +# Generate timestamps for debug messages. +# The provided commands are for use in prefixes and headers. + +# # ## ### ##### ######## ############# ##################### +## Requisites + +package require Tcl 8.5 +package require debug + +namespace eval ::debug { + namespace export timestamp + namespace ensemble create +} + +# # ## ### ##### ######## ############# ##################### +## API & Implementation + +proc ::debug::timestamp {} { + variable timestamp::delta + variable timestamp::baseline + + set now [::tcl::clock::milliseconds] + if {$delta} { + set time "${now}-[expr {$now - $delta}]mS " + } else { + set time "${now}mS " + } + set delta $now + return $time +} + +# # ## ### ##### ######## ############# ##################### + +namespace eval ::debug::timestamp { + variable delta 0 + variable baseline [::tcl::clock::milliseconds] +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide debug::timestamp 1 +return diff --git a/src/bootsupport/lib/struct/disjointset.tcl b/src/bootsupport/lib/struct/disjointset.tcl new file mode 100644 index 00000000..84a59a21 --- /dev/null +++ b/src/bootsupport/lib/struct/disjointset.tcl @@ -0,0 +1,385 @@ +# disjointset.tcl -- +# +# Implementation of a Disjoint Set for Tcl. +# +# Copyright (c) Google Summer of Code 2008 Alejandro Eduardo Cruz Paz +# Copyright (c) 2008 Andreas Kupries (API redesign and simplification) +# Copyright (c) 2018 by Kevin B. Kenny - reworked to a proper disjoint-sets +# data structure, added 'add-element', 'exemplars' and 'find-exemplar'. + +# References +# +# - General overview +# - https://en.wikipedia.org/wiki/Disjoint-set_data_structure +# +# - Time/Complexity proofs +# - https://dl.acm.org/citation.cfm?doid=62.2160 +# - https://dl.acm.org/citation.cfm?doid=364099.364331 +# + +package require Tcl 8.6 + +# Initialize the disjointset structure namespace. Note that any +# missing parent namespace (::struct) will be automatically created as +# well. +namespace eval ::struct::disjointset { + + # Only export one command, the one used to instantiate a new + # disjoint set + namespace export disjointset +} + +# class struct::disjointset::_disjointset -- +# +# Implementation of a disjoint-sets data structure + +oo::class create struct::disjointset::_disjointset { + + # elements - Dictionary whose keys are all the elements in the structure, + # and whose values are element numbers. + # tree - List indexed by element number whose members are + # ordered triples consisting of the element's name, + # the element number of the element's parent (or the element's + # own index if the element is a root), and the rank of + # the element. + # nParts - Number of partitions in the structure. Maintained only + # so that num_partitions will work. + + variable elements tree nParts + + constructor {} { + set elements {} + set tree {} + set nParts 0 + } + + # add-element -- + # + # Adds an element to the structure + # + # Parameters: + # item - Name of the element to add + # + # Results: + # None. + # + # Side effects: + # Element is added + + method add-element {item} { + if {[dict exists $elements $item]} { + return -code error \ + -errorcode [list STRUCT DISJOINTSET DUPLICATE $item [self]] \ + "The element \"$item\" is already known to the disjoint\ + set [self]" + } + set n [llength $tree] + dict set elements $item $n + lappend tree [list $item $n 0] + incr nParts + return + } + + # add-partition -- + # + # Adds a collection of new elements to a disjoint-sets structure and + # makes them all one partition. + # + # Parameters: + # items - List of elements to add. + # + # Results: + # None. + # + # Side effects: + # Adds all the elements, and groups them into a single partition. + + method add-partition {items} { + + # Integrity check - make sure that none of the elements have yet + # been added + + foreach name $items { + if {[dict exists $elements $name]} { + return -code error \ + -errorcode [list STRUCT DISJOINTSET DUPLICATE \ + $name [self]] \ + "The element \"$name\" is already known to the disjoint\ + set [self]" + } + } + + # Add all the elements in one go, and establish parent links for all + # but the first + + set first -1 + foreach n $items { + set idx [llength $tree] + dict set elements $n $idx + if {$first < 0} { + set first $idx + set rank 1 + } else { + set rank 0 + } + lappend tree [list $n $first $rank] + } + incr nParts + return + } + + # equal -- + # + # Test if two elements belong to the same partition in a disjoint-sets + # data structure. + # + # Parameters: + # a - Name of the first element + # b - Name of the second element + # + # Results: + # Returns 1 if the elements are in the same partition, and 0 otherwise. + + method equal {a b} { + expr {[my FindNum $a] == [my FindNum $b]} + } + + # exemplars -- + # + # Find one representative element for each partition in a disjoint-sets + # data structure. + # + # Results: + # Returns a list of element names + + method exemplars {} { + set result {} + set n -1 + foreach row $tree { + if {[lindex $row 1] == [incr n]} { + lappend result [lindex $row 0] + } + } + return $result + } + + # find -- + # + # Find the partition to which a given element belongs. + # + # Parameters: + # item - Item to find + # + # Results: + # Returns a list of the partition's members + # + # Notes: + # This operation takes time proportional to the total number of elements + # in the disjoint-sets structure. If a simple name of the partition + # is all that is required, use "find-exemplar" instead, which runs + # in amortized time proportional to the inverse Ackermann function of + # the size of the partition. + + method find {item} { + set result {} + # No error on a nonexistent item + if {![dict exists $elements $item]} { + return {} + } + set pnum [my FindNum $item] + set n -1 + foreach row $tree { + if {[my FindByNum [incr n]] eq $pnum} { + lappend result [lindex $row 0] + } + } + return $result + } + + # find-exemplar -- + # + # Find a representative element of the partition that contains a given + # element. + # + # parameters: + # item - Item to examine + # + # Results: + # Returns the exemplar + # + # Notes: + # Takes O(alpha(|P|)) amortized time, where |P| is the size of the + # partition, and alpha is the inverse Ackermann function + + method find-exemplar {item} { + return [lindex $tree [my FindNum $item] 0] + } + + # merge -- + # + # Merges the partitions that two elements are in. + # + # Results: + # None. + + method merge {a b} { + my MergeByNum [my FindNum $a] [my FindNum $b] + } + + # num-partitions -- + # + # Counts the partitions of a disjoint-sets data structure + # + # Results: + # Returns the partition count. + + method num-partitions {} { + return $nParts + } + + # partitions -- + # + # Enumerates the partitions of a disjoint-sets data structure + # + # Results: + # Returns a list of lists. Each list is one of the partitions + # in the disjoint set, and each member of the sublist is one + # of the elements added to the structure. + + method partitions {} { + + # Find the partition number for each element, and accumulate a + # list per partition + set parts {} + dict for {element eltNo} $elements { + set partNo [my FindByNum $eltNo] + dict lappend parts $partNo $element + } + return [dict values $parts] + } + + # FindNum -- + # + # Finds the partition number for an element. + # + # Parameters: + # item - Item to look up + # + # Results: + # Returns the partition number + + method FindNum {item} { + if {![dict exists $elements $item]} { + return -code error \ + -errorcode [list STRUCT DISJOINTSET NOTFOUND $item [self]] \ + "The element \"$item\" is not known to the disjoint\ + set [self]" + } + return [my FindByNum [dict get $elements $item]] + } + + # FindByNum -- + # + # Finds the partition number for an element, given the element's + # index + # + # Parameters: + # idx - Index of the item to look up + # + # Results: + # Returns the partition number + # + # Side effects: + # Performs path splitting + + method FindByNum {idx} { + while {1} { + set parent [lindex $tree $idx 1] + if {$parent == $idx} { + return $idx + } + set prev $idx + set idx $parent + lset tree $prev 1 [lindex $tree $idx 1] + } + } + + # MergeByNum -- + # + # Merges two partitions in a disjoint-sets data structure + # + # Parameters: + # x - Index of an element in the first partition + # y - Index of an element in the second partition + # + # Results: + # None + # + # Side effects: + # Merges the partition of the lower rank into the one of the + # higher rank. + + method MergeByNum {x y} { + set xroot [my FindByNum $x] + set yroot [my FindByNum $y] + + if {$xroot == $yroot} { + # The elements are already in the same partition + return + } + + incr nParts -1 + + # Make xroot the taller tree + if {[lindex $tree $xroot 2] < [lindex $tree $yroot 2]} { + set t $xroot; set xroot $yroot; set yroot $t + } + + # Merge yroot into xroot + set xrank [lindex $tree $xroot 2] + set yrank [lindex $tree $yroot 2] + lset tree $yroot 1 $xroot + if {$xrank == $yrank} { + lset tree $xroot 2 [expr {$xrank + 1}] + } + } +} + +# ::struct::disjointset::disjointset -- +# +# Create a new disjoint set with a given name; if no name is +# given, use disjointsetX, where X is a number. +# +# Arguments: +# name Optional name of the disjoint set; if not specified, generate one. +# +# Results: +# name Name of the disjoint set created + +proc ::struct::disjointset::disjointset {args} { + + switch -exact -- [llength $args] { + 0 { + return [_disjointset new] + } + 1 { + # Name supplied by user + return [uplevel 1 [list [namespace which _disjointset] \ + create [lindex $args 0]]] + } + default { + # Too many args + return -code error \ + -errorcode {TCL WRONGARGS} \ + "wrong # args: should be \"[lindex [info level 0] 0] ?name?\"" + } + } +} + +namespace eval ::struct { + namespace import disjointset::disjointset + namespace export disjointset +} + +package provide struct::disjointset 1.1 +return diff --git a/src/bootsupport/lib/struct/graph.tcl b/src/bootsupport/lib/struct/graph.tcl new file mode 100644 index 00000000..19663fd3 --- /dev/null +++ b/src/bootsupport/lib/struct/graph.tcl @@ -0,0 +1,178 @@ +# graph.tcl -- +# +# Implementation of a graph data structure for Tcl. +# +# Copyright (c) 2000-2005,2019 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# @mdgen EXCLUDE: graph_c.tcl + +package require Tcl 8.4 + +namespace eval ::struct::graph {} + +# ### ### ### ######### ######### ######### +## Management of graph implementations. + +# ::struct::graph::LoadAccelerator -- +# +# Loads a named implementation, if possible. +# +# Arguments: +# key Name of the implementation to load. +# +# Results: +# A boolean flag. True if the implementation +# was successfully loaded; and False otherwise. + +proc ::struct::graph::LoadAccelerator {key} { + variable accel + set r 0 + switch -exact -- $key { + critcl { + # Critcl implementation of graph requires Tcl 8.4. + if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} + if {[catch {package require tcllibc}]} {return 0} + set r [llength [info commands ::struct::graph_critcl]] + } + tcl { + variable selfdir + source [file join $selfdir graph_tcl.tcl] + set r 1 + } + default { + return -code error "invalid accelerator/impl. package $key:\ + must be one of [join [KnownImplementations] {, }]" + } + } + set accel($key) $r + return $r +} + +# ::struct::graph::SwitchTo -- +# +# Activates a loaded named implementation. +# +# Arguments: +# key Name of the implementation to activate. +# +# Results: +# None. + +proc ::struct::graph::SwitchTo {key} { + variable accel + variable loaded + + if {[string equal $key $loaded]} { + # No change, nothing to do. + return + } elseif {![string equal $key ""]} { + # Validate the target implementation of the switch. + + if {![info exists accel($key)]} { + return -code error "Unable to activate unknown implementation \"$key\"" + } elseif {![info exists accel($key)] || !$accel($key)} { + return -code error "Unable to activate missing implementation \"$key\"" + } + } + + # Deactivate the previous implementation, if there was any. + + if {![string equal $loaded ""]} { + rename ::struct::graph ::struct::graph_$loaded + } + + # Activate the new implementation, if there is any. + + if {![string equal $key ""]} { + rename ::struct::graph_$key ::struct::graph + } + + # Remember the active implementation, for deactivation by future + # switches. + + set loaded $key + return +} + +# ::struct::graph::Implementations -- +# +# Determines which implementations are +# present, i.e. loaded. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. + +proc ::struct::graph::Implementations {} { + variable accel + set res {} + foreach n [array names accel] { + if {!$accel($n)} continue + lappend res $n + } + return $res +} + +# ::struct::graph::KnownImplementations -- +# +# Determines which implementations are known +# as possible implementations. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. In the order +# of preference, most prefered first. + +proc ::struct::graph::KnownImplementations {} { + return {critcl tcl} +} + +proc ::struct::graph::Names {} { + return { + critcl {tcllibc based} + tcl {pure Tcl} + } +} + +# ### ### ### ######### ######### ######### +## Initialization: Data structures. + +namespace eval ::struct::graph { + variable selfdir [file dirname [info script]] + variable accel + array set accel {tcl 0 critcl 0} + variable loaded {} +} + +# ### ### ### ######### ######### ######### +## Initialization: Choose an implementation, +## most prefered first. Loads only one of the +## possible implementations. And activates it. + +namespace eval ::struct::graph { + variable e + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Export the constructor command. + namespace export graph +} + +package provide struct::graph 2.4.3 diff --git a/src/bootsupport/lib/struct/graph1.tcl b/src/bootsupport/lib/struct/graph1.tcl new file mode 100644 index 00000000..80c24592 --- /dev/null +++ b/src/bootsupport/lib/struct/graph1.tcl @@ -0,0 +1,2154 @@ +# graph.tcl -- +# +# Implementation of a graph data structure for Tcl. +# +# Copyright (c) 2000 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: graph1.tcl,v 1.5 2008/08/13 20:30:58 mic42 Exp $ + +# Create the namespace before determining cgraph vs. tcl +# Otherwise the loading 'struct.tcl' may get into trouble +# when trying to import commands from them + +namespace eval ::struct {} +namespace eval ::struct::graph {} + +# Try to load the cgraph package + +if {![catch {package require cgraph 0.6}]} { + # the cgraph package takes over, so we can return + return +} + +namespace eval ::struct {} +namespace eval ::struct::graph { + # Data storage in the graph module + # ------------------------------- + # + # There's a lot of bits to keep track of for each graph: + # nodes + # node values + # node relationships (arcs) + # arc values + # + # It would quickly become unwieldy to try to keep these in arrays or lists + # within the graph namespace itself. Instead, each graph structure will + # get its own namespace. Each namespace contains: + # node:$node array mapping keys to values for the node $node + # arc:$arc array mapping keys to values for the arc $arc + # inArcs array mapping nodes to the list of incoming arcs + # outArcs array mapping nodes to the list of outgoing arcs + # arcNodes array mapping arcs to the two nodes (start & end) + + # counter is used to give a unique name for unnamed graph + variable counter 0 + + # commands is the list of subcommands recognized by the graph + variable commands [list \ + "arc" \ + "arcs" \ + "destroy" \ + "get" \ + "getall" \ + "keys" \ + "keyexists" \ + "node" \ + "nodes" \ + "set" \ + "swap" \ + "unset" \ + "walk" \ + ] + + variable arcCommands [list \ + "append" \ + "delete" \ + "exists" \ + "get" \ + "getall" \ + "insert" \ + "keys" \ + "keyexists" \ + "lappend" \ + "set" \ + "source" \ + "target" \ + "unset" \ + ] + + variable nodeCommands [list \ + "append" \ + "degree" \ + "delete" \ + "exists" \ + "get" \ + "getall" \ + "insert" \ + "keys" \ + "keyexists" \ + "lappend" \ + "opposite" \ + "set" \ + "unset" \ + ] + + # Only export one command, the one used to instantiate a new graph + namespace export graph +} + +# ::struct::graph::graph -- +# +# Create a new graph with a given name; if no name is given, use +# graphX, where X is a number. +# +# Arguments: +# name name of the graph; if null, generate one. +# +# Results: +# name name of the graph created + +proc ::struct::graph::graph {{name ""}} { + variable counter + + if { [llength [info level 0]] == 1 } { + incr counter + set name "graph${counter}" + } + + if { ![string equal [info commands ::$name] ""] } { + error "command \"$name\" already exists, unable to create graph" + } + + # Set up the namespace + namespace eval ::struct::graph::graph$name { + + # Set up the map for values associated with the graph itself + variable graphData + array set graphData {data ""} + + # Set up the map from nodes to the arcs coming to them + variable inArcs + array set inArcs {} + + # Set up the map from nodes to the arcs going out from them + variable outArcs + array set outArcs {} + + # Set up the map from arcs to the nodes they touch. + variable arcNodes + array set arcNodes {} + + # Set up a value for use in creating unique node names + variable nextUnusedNode + set nextUnusedNode 1 + + # Set up a value for use in creating unique arc names + variable nextUnusedArc + set nextUnusedArc 1 + } + + # Create the command to manipulate the graph + interp alias {} ::$name {} ::struct::graph::GraphProc $name + + return $name +} + +########################## +# Private functions follow + +# ::struct::graph::GraphProc -- +# +# Command that processes all graph object commands. +# +# Arguments: +# name name of the graph object to manipulate. +# args command name and args for the command +# +# Results: +# Varies based on command to perform + +proc ::struct::graph::GraphProc {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 { [llength [info commands ::struct::graph::_$cmd]] == 0 } { + variable commands + set optlist [join $commands ", "] + set optlist [linsert $optlist "end-1" "or"] + error "bad option \"$cmd\": must be $optlist" + } + eval [list ::struct::graph::_$cmd $name] $args +} + +# ::struct::graph::_arc -- +# +# Dispatches the invocation of arc methods to the proper handler +# procedure. +# +# Arguments: +# name name of the graph. +# cmd arc command to invoke +# args arguments to propagate to the handler for the arc command +# +# Results: +# As of the invoked handler. + +proc ::struct::graph::_arc {name cmd args} { + + # Split the args into command and args components + if { [llength [info commands ::struct::graph::__arc_$cmd]] == 0 } { + variable arcCommands + set optlist [join $arcCommands ", "] + set optlist [linsert $optlist "end-1" "or"] + error "bad option \"$cmd\": must be $optlist" + } + + eval [list ::struct::graph::__arc_$cmd $name] $args +} + +# ::struct::graph::__arc_delete -- +# +# Remove an arc from a graph, including all of its values. +# +# Arguments: +# name name of the graph. +# args list of arcs to delete. +# +# Results: +# None. + +proc ::struct::graph::__arc_delete {name args} { + + foreach arc $args { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + } + + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::outArcs outArcs + upvar ::struct::graph::graph${name}::arcNodes arcNodes + + foreach arc $args { + foreach {source target} $arcNodes($arc) break ; # lassign + + unset arcNodes($arc) + # FRINK: nocheck + unset ::struct::graph::graph${name}::arc$arc + + # Remove arc from the arc lists of source and target nodes. + + set index [lsearch -exact $outArcs($source) $arc] + set outArcs($source) [lreplace $outArcs($source) $index $index] + + set index [lsearch -exact $inArcs($target) $arc] + set inArcs($target) [lreplace $inArcs($target) $index $index] + } + + return +} + +# ::struct::graph::__arc_exists -- +# +# Test for existance of a given arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to look for. +# +# Results: +# 1 if the arc exists, 0 else. + +proc ::struct::graph::__arc_exists {name arc} { + return [info exists ::struct::graph::graph${name}::arcNodes($arc)] +} + +# ::struct::graph::__arc_get -- +# +# Get a keyed value from an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# flag -key; anything else is an error +# key key to lookup; defaults to data +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__arc_get {name arc {flag -key} {key data}} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::arc${arc} data + + if { ![info exists data($key)] } { + error "invalid key \"$key\" for arc \"$arc\"" + } + + return $data($key) +} + +# ::struct::graph::__arc_getall -- +# +# Get a serialized array of key/value pairs from an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# +# Results: +# value serialized array of key/value pairs. + +proc ::struct::graph::__arc_getall {name arc args} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + if { [llength $args] } { + error "wrong # args: should be none" + } + + upvar ::struct::graph::graph${name}::arc${arc} data + + return [array get data] +} + +# ::struct::graph::__arc_keys -- +# +# Get a list of keys for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__arc_keys {name arc args} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + if { [llength $args] } { + error "wrong # args: should be none" + } + + upvar ::struct::graph::graph${name}::arc${arc} data + + return [array names data] +} + +# ::struct::graph::__arc_keyexists -- +# +# Test for existance of a given key for a given arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# flag -key; anything else is an error +# key key to lookup; defaults to data +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::graph::__arc_keyexists {name arc {flag -key} {key data}} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + if { ![string equal $flag "-key"] } { + error "invalid option \"$flag\": should be -key" + } + + upvar ::struct::graph::graph${name}::arc${arc} data + + return [info exists data($key)] +} + +# ::struct::graph::__arc_insert -- +# +# Add an arc to a graph. +# +# Arguments: +# name name of the graph. +# source source node of the new arc +# target target node of the new arc +# args arc to insert; must be unique. If none is given, +# the routine will generate a unique node name. +# +# Results: +# arc The name of the new arc. + +proc ::struct::graph::__arc_insert {name source target args} { + + if { [llength $args] == 0 } { + # No arc name was given; generate a unique one + set arc [__generateUniqueArcName $name] + } else { + set arc [lindex $args 0] + } + + if { [__arc_exists $name $arc] } { + error "arc \"$arc\" already exists in graph \"$name\"" + } + + if { ![__node_exists $name $source] } { + error "source node \"$source\" does not exist in graph \"$name\"" + } + + if { ![__node_exists $name $target] } { + error "target node \"$target\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::outArcs outArcs + upvar ::struct::graph::graph${name}::arcNodes arcNodes + upvar ::struct::graph::graph${name}::arc${arc} data + + # Set up the new arc + set data(data) "" + set arcNodes($arc) [list $source $target] + + # Add this arc to the arc lists of its source resp. target nodes. + lappend outArcs($source) $arc + lappend inArcs($target) $arc + + return $arc +} + +# ::struct::graph::__arc_set -- +# +# Set or get a value for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to modify or query. +# args ?-key key? ?value? +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::__arc_set {name arc args} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::arc$arc data + + if { [llength $args] > 3 } { + error "wrong # args: should be \"$name arc set $arc ?-key key?\ + ?value?\"" + } + + set key "data" + set haveValue 0 + if { [llength $args] > 1 } { + foreach {flag key} $args break + if { ![string match "${flag}*" "-key"] } { + error "invalid option \"$flag\": should be key" + } + if { [llength $args] == 3 } { + set haveValue 1 + set value [lindex $args end] + } + } elseif { [llength $args] == 1 } { + set haveValue 1 + set value [lindex $args end] + } + + if { $haveValue } { + # Setting a value + return [set data($key) $value] + } else { + # Getting a value + if { ![info exists data($key)] } { + error "invalid key \"$key\" for arc \"$arc\"" + } + return $data($key) + } +} + +# ::struct::graph::__arc_append -- +# +# Append a value for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to modify or query. +# args ?-key key? value +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::__arc_append {name arc args} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::arc$arc data + + if { [llength $args] != 1 && [llength $args] != 3 } { + error "wrong # args: should be \"$name arc append $arc ?-key key?\ + value\"" + } + + if { [llength $args] == 3 } { + foreach {flag key} $args break + if { ![string equal $flag "-key"] } { + error "invalid option \"$flag\": should be -key" + } + } else { + set key "data" + } + + set value [lindex $args end] + + return [append data($key) $value] +} + +# ::struct::graph::__arc_lappend -- +# +# lappend a value for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to modify or query. +# args ?-key key? value +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::__arc_lappend {name arc args} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::arc$arc data + + if { [llength $args] != 1 && [llength $args] != 3 } { + error "wrong # args: should be \"$name arc lappend $arc ?-key key?\ + value\"" + } + + if { [llength $args] == 3 } { + foreach {flag key} $args break + if { ![string equal $flag "-key"] } { + error "invalid option \"$flag\": should be -key" + } + } else { + set key "data" + } + + set value [lindex $args end] + + return [lappend data($key) $value] +} + +# ::struct::graph::__arc_source -- +# +# Return the node at the beginning of the specified arc. +# +# Arguments: +# name name of the graph object. +# arc arc to look up. +# +# Results: +# node name of the node. + +proc ::struct::graph::__arc_source {name arc} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::arcNodes arcNodes + return [lindex $arcNodes($arc) 0] +} + +# ::struct::graph::__arc_target -- +# +# Return the node at the end of the specified arc. +# +# Arguments: +# name name of the graph object. +# arc arc to look up. +# +# Results: +# node name of the node. + +proc ::struct::graph::__arc_target {name arc} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::arcNodes arcNodes + return [lindex $arcNodes($arc) 1] +} + +# ::struct::graph::__arc_unset -- +# +# Remove a keyed value from a arc. +# +# Arguments: +# name name of the graph. +# arc arc to modify. +# args additional args: ?-key key? +# +# Results: +# None. + +proc ::struct::graph::__arc_unset {name arc {flag -key} {key data}} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + if { ![string match "${flag}*" "-key"] } { + error "invalid option \"$flag\": should be \"$name arc unset\ + $arc ?-key key?\"" + } + + upvar ::struct::graph::graph${name}::arc${arc} data + if { [info exists data($key)] } { + unset data($key) + } + return +} + +# ::struct::graph::_arcs -- +# +# Return a list of all arcs in a graph satisfying some +# node based restriction. +# +# Arguments: +# name name of the graph. +# +# Results: +# arcs list of arcs + +proc ::struct::graph::_arcs {name args} { + + # Discriminate between conditions and nodes + + set haveCond 0 + set haveKey 0 + set haveValue 0 + set cond "none" + set condNodes [list] + + for {set i 0} {$i < [llength $args]} {incr i} { + set arg [lindex $args $i] + switch -glob -- $arg { + -in - + -out - + -adj - + -inner - + -embedding { + if {$haveCond} { + return -code error "invalid restriction:\ + illegal multiple use of\ + \"-in\"|\"-out\"|\"-adj\"|\"-inner\"|\"-embedding\"" + } + + set haveCond 1 + set cond [string range $arg 1 end] + } + -key { + if {$haveKey} { + return -code error {invalid restriction: illegal multiple use of "-key"} + } + + incr i + set key [lindex $args $i] + set haveKey 1 + } + -value { + if {$haveValue} { + return -code error {invalid restriction: illegal multiple use of "-value"} + } + + incr i + set value [lindex $args $i] + set haveValue 1 + } + -* { + error "invalid restriction \"$arg\": should be -in, -out,\ + -adj, -inner, -embedding, -key or -value" + } + default { + lappend condNodes $arg + } + } + } + + # Validate that there are nodes to use in the restriction. + # otherwise what's the point? + if {$haveCond} { + if {[llength $condNodes] == 0} { + set usage "$name arcs ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?" + error "no nodes specified: should be \"$usage\"" + } + + # Make sure that the specified nodes exist! + foreach node $condNodes { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + } + } + + # Now we are able to go to work + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::outArcs outArcs + upvar ::struct::graph::graph${name}::arcNodes arcNodes + + set arcs [list] + + switch -exact -- $cond { + in { + # Result is all arcs going to at least one node + # in the list of arguments. + + foreach node $condNodes { + foreach e $inArcs($node) { + # As an arc has only one destination, i.e. is the + # in-arc of exactly one node it is impossible to + # count an arc twice. IOW the [info exists] below + # is never true. Found through coverage analysis + # and then trying to think up a testcase invoking + # the continue. + # if {[info exists coll($e)]} {continue} + lappend arcs $e + #set coll($e) . + } + } + } + out { + # Result is all arcs coming from at least one node + # in the list of arguments. + + foreach node $condNodes { + foreach e $outArcs($node) { + # See above 'in', same reasoning, one source per arc. + # if {[info exists coll($e)]} {continue} + lappend arcs $e + #set coll($e) . + } + } + } + adj { + # Result is all arcs coming from or going to at + # least one node in the list of arguments. + + array set coll {} + # Here we do need 'coll' as each might be an in- and + # out-arc for one or two nodes in the list of arguments. + + foreach node $condNodes { + foreach e $inArcs($node) { + if {[info exists coll($e)]} {continue} + lappend arcs $e + set coll($e) . + } + foreach e $outArcs($node) { + if {[info exists coll($e)]} {continue} + lappend arcs $e + set coll($e) . + } + } + } + inner { + # Result is all arcs running between nodes in the list. + + array set coll {} + # Here we do need 'coll' as each might be an in- and + # out-arc for one or two nodes in the list of arguments. + + array set group {} + foreach node $condNodes { + set group($node) . + } + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {![info exists group($n)]} {continue} + if { [info exists coll($e)]} {continue} + lappend arcs $e + set coll($e) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {![info exists group($n)]} {continue} + if { [info exists coll($e)]} {continue} + lappend arcs $e + set coll($e) . + } + } + } + embedding { + # Result is all arcs from -adj minus the arcs from -inner. + # IOW all arcs going from a node in the list to a node + # which is *not* in the list + + # This also means that no arc can be counted twice as it + # is either going to a node, or coming from a node in the + # list, but it can't do both, because then it is part of + # -inner, which was excluded! + + array set group {} + foreach node $condNodes { + set group($node) . + } + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists group($n)]} {continue} + # if {[info exists coll($e)]} {continue} + lappend arcs $e + # set coll($e) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists group($n)]} {continue} + # if {[info exists coll($e)]} {continue} + lappend arcs $e + # set coll($e) . + } + } + } + none { + set arcs [array names arcNodes] + } + default {error "Can't happen, panic"} + } + + # + # We have a list of arcs that match the relation to the nodes. + # Now filter according to -key and -value. + # + + set filteredArcs [list] + + if {$haveKey} { + foreach arc $arcs { + catch { + set aval [__arc_get $name $arc -key $key] + if {$haveValue} { + if {$aval == $value} { + lappend filteredArcs $arc + } + } else { + lappend filteredArcs $arc + } + } + } + } else { + set filteredArcs $arcs + } + + return $filteredArcs +} + +# ::struct::graph::_destroy -- +# +# Destroy a graph, including its associated command and data storage. +# +# Arguments: +# name name of the graph. +# +# Results: +# None. + +proc ::struct::graph::_destroy {name} { + namespace delete ::struct::graph::graph$name + interp alias {} ::$name {} +} + +# ::struct::graph::__generateUniqueArcName -- +# +# Generate a unique arc name for the given graph. +# +# Arguments: +# name name of the graph. +# +# Results: +# arc name of a arc guaranteed to not exist in the graph. + +proc ::struct::graph::__generateUniqueArcName {name} { + upvar ::struct::graph::graph${name}::nextUnusedArc nextUnusedArc + while {[__arc_exists $name "arc${nextUnusedArc}"]} { + incr nextUnusedArc + } + return "arc${nextUnusedArc}" +} + +# ::struct::graph::__generateUniqueNodeName -- +# +# Generate a unique node name for the given graph. +# +# Arguments: +# name name of the graph. +# +# Results: +# node name of a node guaranteed to not exist in the graph. + +proc ::struct::graph::__generateUniqueNodeName {name} { + upvar ::struct::graph::graph${name}::nextUnusedNode nextUnusedNode + while {[__node_exists $name "node${nextUnusedNode}"]} { + incr nextUnusedNode + } + return "node${nextUnusedNode}" +} + +# ::struct::graph::_get -- +# +# Get a keyed value from the graph itself +# +# Arguments: +# name name of the graph. +# flag -key; anything else is an error +# key key to lookup; defaults to data +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::_get {name {flag -key} {key data}} { + upvar ::struct::graph::graph${name}::graphData data + + if { ![info exists data($key)] } { + error "invalid key \"$key\" for graph \"$name\"" + } + + return $data($key) +} + +# ::struct::graph::_getall -- +# +# Get a serialized list of key/value pairs from a graph. +# +# Arguments: +# name name of the graph. +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::_getall {name args} { + if { [llength $args] } { + error "wrong # args: should be none" + } + + upvar ::struct::graph::graph${name}::graphData data + return [array get data] +} + +# ::struct::graph::_keys -- +# +# Get a list of keys from a graph. +# +# Arguments: +# name name of the graph. +# +# Results: +# value list of known keys + +proc ::struct::graph::_keys {name args} { + if { [llength $args] } { + error "wrong # args: should be none" + } + + upvar ::struct::graph::graph${name}::graphData data + return [array names data] +} + +# ::struct::graph::_keyexists -- +# +# Test for existance of a given key in a graph. +# +# Arguments: +# name name of the graph. +# flag -key; anything else is an error +# key key to lookup; defaults to data +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::graph::_keyexists {name {flag -key} {key data}} { + if { ![string equal $flag "-key"] } { + error "invalid option \"$flag\": should be -key" + } + + upvar ::struct::graph::graph${name}::graphData data + return [info exists data($key)] +} + +# ::struct::graph::_node -- +# +# Dispatches the invocation of node methods to the proper handler +# procedure. +# +# Arguments: +# name name of the graph. +# cmd node command to invoke +# args arguments to propagate to the handler for the node command +# +# Results: +# As of the the invoked handler. + +proc ::struct::graph::_node {name cmd args} { + + # Split the args into command and args components + if { [llength [info commands ::struct::graph::__node_$cmd]] == 0 } { + variable nodeCommands + set optlist [join $nodeCommands ", "] + set optlist [linsert $optlist "end-1" "or"] + error "bad option \"$cmd\": must be $optlist" + } + + eval [list ::struct::graph::__node_$cmd $name] $args +} + +# ::struct::graph::__node_degree -- +# +# Return the number of arcs adjacent to the specified node. +# If one of the restrictions -in or -out is given only +# incoming resp. outgoing arcs are counted. +# +# Arguments: +# name name of the graph. +# args option, followed by the node. +# +# Results: +# None. + +proc ::struct::graph::__node_degree {name args} { + + if {([llength $args] < 1) || ([llength $args] > 2)} { + error "wrong # args: should be \"$name node degree ?-in|-out? node\"" + } + + switch -exact -- [llength $args] { + 1 { + set opt {} + set node [lindex $args 0] + } + 2 { + set opt [lindex $args 0] + set node [lindex $args 1] + } + default {error "Can't happen, panic"} + } + + # Validate the option. + + switch -exact -- $opt { + {} - + -in - + -out {} + default { + error "invalid option \"$opt\": should be -in or -out" + } + } + + # Validate the node + + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::outArcs outArcs + + switch -exact -- $opt { + -in { + set result [llength $inArcs($node)] + } + -out { + set result [llength $outArcs($node)] + } + {} { + set result [expr {[llength $inArcs($node)] \ + + [llength $outArcs($node)]}] + + # loops count twice, don't do arithmetics, i.e. no union! + if {0} { + array set coll {} + set result [llength $inArcs($node)] + + foreach e $inArcs($node) { + set coll($e) . + } + foreach e $outArcs($node) { + if {[info exists coll($e)]} {continue} + incr result + set coll($e) . + } + } + } + default {error "Can't happen, panic"} + } + + return $result +} + +# ::struct::graph::__node_delete -- +# +# Remove a node from a graph, including all of its values. +# Additionally removes the arcs connected to this node. +# +# Arguments: +# name name of the graph. +# args list of the nodes to delete. +# +# Results: +# None. + +proc ::struct::graph::__node_delete {name args} { + + foreach node $args { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + } + + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::outArcs outArcs + + foreach node $args { + # Remove all the arcs connected to this node + foreach e $inArcs($node) { + __arc_delete $name $e + } + foreach e $outArcs($node) { + # Check existence to avoid problems with + # loops (they are in and out arcs! at + # the same time and thus already deleted) + if { [__arc_exists $name $e] } { + __arc_delete $name $e + } + } + + unset inArcs($node) + unset outArcs($node) + # FRINK: nocheck + unset ::struct::graph::graph${name}::node$node + } + + return +} + +# ::struct::graph::__node_exists -- +# +# Test for existance of a given node in a graph. +# +# Arguments: +# name name of the graph. +# node node to look for. +# +# Results: +# 1 if the node exists, 0 else. + +proc ::struct::graph::__node_exists {name node} { + return [info exists ::struct::graph::graph${name}::inArcs($node)] +} + +# ::struct::graph::__node_get -- +# +# Get a keyed value from a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# flag -key; anything else is an error +# key key to lookup; defaults to data +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__node_get {name node {flag -key} {key data}} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::node${node} data + + if { ![info exists data($key)] } { + error "invalid key \"$key\" for node \"$node\"" + } + + return $data($key) +} + +# ::struct::graph::__node_getall -- +# +# Get a serialized list of key/value pairs from a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__node_getall {name node args} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + if { [llength $args] } { + error "wrong # args: should be none" + } + + upvar ::struct::graph::graph${name}::node${node} data + + return [array get data] +} + +# ::struct::graph::__node_keys -- +# +# Get a list of keys from a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__node_keys {name node args} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + if { [llength $args] } { + error "wrong # args: should be none" + } + + upvar ::struct::graph::graph${name}::node${node} data + + return [array names data] +} + +# ::struct::graph::__node_keyexists -- +# +# Test for existance of a given key for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# flag -key; anything else is an error +# key key to lookup; defaults to data +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::graph::__node_keyexists {name node {flag -key} {key data}} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + if { ![string equal $flag "-key"] } { + error "invalid option \"$flag\": should be -key" + } + + upvar ::struct::graph::graph${name}::node${node} data + + return [info exists data($key)] +} + +# ::struct::graph::__node_insert -- +# +# Add a node to a graph. +# +# Arguments: +# name name of the graph. +# args node to insert; must be unique. If none is given, +# the routine will generate a unique node name. +# +# Results: +# node The namee of the new node. + +proc ::struct::graph::__node_insert {name args} { + + if { [llength $args] == 0 } { + # No node name was given; generate a unique one + set node [__generateUniqueNodeName $name] + } else { + set node [lindex $args 0] + } + + if { [__node_exists $name $node] } { + error "node \"$node\" already exists in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::outArcs outArcs + upvar ::struct::graph::graph${name}::node${node} data + + # Set up the new node + set inArcs($node) [list] + set outArcs($node) [list] + set data(data) "" + + return $node +} + +# ::struct::graph::__node_opposite -- +# +# Retrieve node opposite to the specified one, along the arc. +# +# Arguments: +# name name of the graph. +# node node to look up. +# arc arc to look up. +# +# Results: +# nodex Node opposite to + +proc ::struct::graph::__node_opposite {name node arc} { + if {![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + if {![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::arcNodes arcNodes + + # Node must be connected to at least one end of the arc. + + if {[string equal $node [lindex $arcNodes($arc) 0]]} { + set result [lindex $arcNodes($arc) 1] + } elseif {[string equal $node [lindex $arcNodes($arc) 1]]} { + set result [lindex $arcNodes($arc) 0] + } else { + error "node \"$node\" and arc \"$arc\" are not connected\ + in graph \"$name\"" + } + + return $result +} + +# ::struct::graph::__node_set -- +# +# Set or get a value for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to modify or query. +# args ?-key key? ?value? +# +# Results: +# val value associated with the given key of the given node + +proc ::struct::graph::__node_set {name node args} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + upvar ::struct::graph::graph${name}::node$node data + + if { [llength $args] > 3 } { + error "wrong # args: should be \"$name node set $node ?-key key?\ + ?value?\"" + } + + set key "data" + set haveValue 0 + if { [llength $args] > 1 } { + foreach {flag key} $args break + if { ![string match "${flag}*" "-key"] } { + error "invalid option \"$flag\": should be key" + } + if { [llength $args] == 3 } { + set haveValue 1 + set value [lindex $args end] + } + } elseif { [llength $args] == 1 } { + set haveValue 1 + set value [lindex $args end] + } + + if { $haveValue } { + # Setting a value + return [set data($key) $value] + } else { + # Getting a value + if { ![info exists data($key)] } { + error "invalid key \"$key\" for node \"$node\"" + } + return $data($key) + } +} + +# ::struct::graph::__node_append -- +# +# Append a value for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to modify or query. +# args ?-key key? value +# +# Results: +# val value associated with the given key of the given node + +proc ::struct::graph::__node_append {name node args} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + upvar ::struct::graph::graph${name}::node$node data + + if { [llength $args] != 1 && [llength $args] != 3 } { + error "wrong # args: should be \"$name node append $node ?-key key?\ + value\"" + } + + if { [llength $args] == 3 } { + foreach {flag key} $args break + if { ![string equal $flag "-key"] } { + error "invalid option \"$flag\": should be -key" + } + } else { + set key "data" + } + + set value [lindex $args end] + + return [append data($key) $value] +} + +# ::struct::graph::__node_lappend -- +# +# lappend a value for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to modify or query. +# args ?-key key? value +# +# Results: +# val value associated with the given key of the given node + +proc ::struct::graph::__node_lappend {name node args} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + upvar ::struct::graph::graph${name}::node$node data + + if { [llength $args] != 1 && [llength $args] != 3 } { + error "wrong # args: should be \"$name node lappend $node ?-key key?\ + value\"" + } + + if { [llength $args] == 3 } { + foreach {flag key} $args break + if { ![string equal $flag "-key"] } { + error "invalid option \"$flag\": should be -key" + } + } else { + set key "data" + } + + set value [lindex $args end] + + return [lappend data($key) $value] +} + +# ::struct::graph::__node_unset -- +# +# Remove a keyed value from a node. +# +# Arguments: +# name name of the graph. +# node node to modify. +# args additional args: ?-key key? +# +# Results: +# None. + +proc ::struct::graph::__node_unset {name node {flag -key} {key data}} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + if { ![string match "${flag}*" "-key"] } { + error "invalid option \"$flag\": should be \"$name node unset\ + $node ?-key key?\"" + } + + upvar ::struct::graph::graph${name}::node${node} data + if { [info exists data($key)] } { + unset data($key) + } + return +} + +# ::struct::graph::_nodes -- +# +# Return a list of all nodes in a graph satisfying some restriction. +# +# Arguments: +# name name of the graph. +# args list of options and nodes specifying the restriction. +# +# Results: +# nodes list of nodes + +proc ::struct::graph::_nodes {name args} { + + # Discriminate between conditions and nodes + + set haveCond 0 + set haveKey 0 + set haveValue 0 + set cond "none" + set condNodes [list] + + for {set i 0} {$i < [llength $args]} {incr i} { + set arg [lindex $args $i] + switch -glob -- $arg { + -in - + -out - + -adj - + -inner - + -embedding { + if {$haveCond} { + return -code error "invalid restriction:\ + illegal multiple use of\ + \"-in\"|\"-out\"|\"-adj\"|\"-inner\"|\"-embedding\"" + } + + set haveCond 1 + set cond [string range $arg 1 end] + } + -key { + if {$haveKey} { + return -code error {invalid restriction: illegal multiple use of "-key"} + } + + incr i + set key [lindex $args $i] + set haveKey 1 + } + -value { + if {$haveValue} { + return -code error {invalid restriction: illegal multiple use of "-value"} + } + + incr i + set value [lindex $args $i] + set haveValue 1 + } + -* { + error "invalid restriction \"$arg\": should be -in, -out,\ + -adj, -inner, -embedding, -key or -value" + } + default { + lappend condNodes $arg + } + } + } + + # Validate that there are nodes to use in the restriction. + # otherwise what's the point? + if {$haveCond} { + if {[llength $condNodes] == 0} { + set usage "$name nodes ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?" + error "no nodes specified: should be \"$usage\"" + } + + # Make sure that the specified nodes exist! + foreach node $condNodes { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + } + } + + # Now we are able to go to work + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::outArcs outArcs + upvar ::struct::graph::graph${name}::arcNodes arcNodes + + set nodes [list] + array set coll {} + + switch -exact -- $cond { + in { + # Result is all nodes with at least one arc going to + # at least one node in the list of arguments. + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } + out { + # Result is all nodes with at least one arc coming from + # at least one node in the list of arguments. + + foreach node $condNodes { + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } + adj { + # Result is all nodes with at least one arc coming from + # or going to at least one node in the list of arguments. + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } + inner { + # Result is all nodes from the list! with at least one arc + # coming from or going to at least one node in the list of + # arguments. + + array set group {} + foreach node $condNodes { + set group($node) . + } + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {![info exists group($n)]} {continue} + if { [info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {![info exists group($n)]} {continue} + if { [info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } + embedding { + # Result is all nodes with at least one arc coming from + # or going to at least one node in the list of arguments, + # but not in the list itself! + + array set group {} + foreach node $condNodes { + set group($node) . + } + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists group($n)]} {continue} + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists group($n)]} {continue} + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } + none { + set nodes [array names inArcs] + } + default {error "Can't happen, panic"} + } + + # + # We have a list of nodes that match the relation to the nodes. + # Now filter according to -key and -value. + # + + set filteredNodes [list] + + if {$haveKey} { + foreach node $nodes { + catch { + set nval [__node_get $name $node -key $key] + if {$haveValue} { + if {$nval == $value} { + lappend filteredNodes $node + } + } else { + lappend filteredNodes $node + } + } + } + } else { + set filteredNodes $nodes + } + + return $filteredNodes +} + +# ::struct::graph::_set -- +# +# Set or get a keyed value from the graph itself +# +# Arguments: +# name name of the graph. +# flag -key; anything else is an error +# args ?-key key? ?value? +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::_set {name args} { + upvar ::struct::graph::graph${name}::graphData data + + if { [llength $args] > 3 } { + error "wrong # args: should be \"$name set ?-key key?\ + ?value?\"" + } + + set key "data" + set haveValue 0 + if { [llength $args] > 1 } { + foreach {flag key} $args break + if { ![string match "${flag}*" "-key"] } { + error "invalid option \"$flag\": should be key" + } + if { [llength $args] == 3 } { + set haveValue 1 + set value [lindex $args end] + } + } elseif { [llength $args] == 1 } { + set haveValue 1 + set value [lindex $args end] + } + + if { $haveValue } { + # Setting a value + return [set data($key) $value] + } else { + # Getting a value + if { ![info exists data($key)] } { + error "invalid key \"$key\" for graph \"$name\"" + } + return $data($key) + } +} + +# ::struct::graph::_swap -- +# +# Swap two nodes in a graph. +# +# Arguments: +# name name of the graph. +# node1 first node to swap. +# node2 second node to swap. +# +# Results: +# None. + +proc ::struct::graph::_swap {name node1 node2} { + # Can only swap two real nodes + if { ![__node_exists $name $node1] } { + error "node \"$node1\" does not exist in graph \"$name\"" + } + if { ![__node_exists $name $node2] } { + error "node \"$node2\" does not exist in graph \"$name\"" + } + + # Can't swap a node with itself + if { [string equal $node1 $node2] } { + error "cannot swap node \"$node1\" with itself" + } + + # Swapping nodes means swapping their labels, values and arcs + upvar ::struct::graph::graph${name}::outArcs outArcs + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::arcNodes arcNodes + upvar ::struct::graph::graph${name}::node${node1} node1Vals + upvar ::struct::graph::graph${name}::node${node2} node2Vals + + # Redirect arcs to the new nodes. + + foreach e $inArcs($node1) { + set arcNodes($e) [lreplace $arcNodes($e) end end $node2] + } + foreach e $inArcs($node2) { + set arcNodes($e) [lreplace $arcNodes($e) end end $node1] + } + foreach e $outArcs($node1) { + set arcNodes($e) [lreplace $arcNodes($e) 0 0 $node2] + } + foreach e $outArcs($node2) { + set arcNodes($e) [lreplace $arcNodes($e) 0 0 $node1] + } + + # Swap arc lists + + set tmp $inArcs($node1) + set inArcs($node1) $inArcs($node2) + set inArcs($node2) $tmp + + set tmp $outArcs($node1) + set outArcs($node1) $outArcs($node2) + set outArcs($node2) $tmp + + # Swap the values + set value1 [array get node1Vals] + unset node1Vals + array set node1Vals [array get node2Vals] + unset node2Vals + array set node2Vals $value1 + + return +} + +# ::struct::graph::_unset -- +# +# Remove a keyed value from the graph itself +# +# Arguments: +# name name of the graph. +# flag -key; anything else is an error +# args additional args: ?-key key? +# +# Results: +# None. + +proc ::struct::graph::_unset {name {flag -key} {key data}} { + upvar ::struct::graph::graph${name}::graphData data + + if { ![string match "${flag}*" "-key"] } { + error "invalid option \"$flag\": should be \"$name unset\ + ?-key key?\"" + } + + if { [info exists data($key)] } { + unset data($key) + } + + return +} + +# ::struct::graph::_walk -- +# +# Walk a graph using a pre-order depth or breadth first +# search. Pre-order DFS is the default. At each node that is visited, +# a command will be called with the name of the graph and the node. +# +# Arguments: +# name name of the graph. +# node node at which to start. +# args additional args: ?-order pre|post|both? ?-type {bfs|dfs}? +# -command cmd +# +# Results: +# None. + +proc ::struct::graph::_walk {name node args} { + set usage "$name walk $node ?-dir forward|backward?\ + ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd" + + if {[llength $args] > 8 || [llength $args] < 2} { + error "wrong # args: should be \"$usage\"" + } + + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + # Set defaults + set type dfs + set order pre + set cmd "" + set dir forward + + # Process specified options + for {set i 0} {$i < [llength $args]} {incr i} { + set flag [lindex $args $i] + incr i + if { $i >= [llength $args] } { + error "value for \"$flag\" missing: should be \"$usage\"" + } + switch -glob -- $flag { + "-type" { + set type [string tolower [lindex $args $i]] + } + "-order" { + set order [string tolower [lindex $args $i]] + } + "-command" { + set cmd [lindex $args $i] + } + "-dir" { + set dir [string tolower [lindex $args $i]] + } + default { + error "unknown option \"$flag\": should be \"$usage\"" + } + } + } + + # Make sure we have a command to run, otherwise what's the point? + if { [string equal $cmd ""] } { + error "no command specified: should be \"$usage\"" + } + + # Validate that the given type is good + switch -glob -- $type { + "dfs" { + set type "dfs" + } + "bfs" { + set type "bfs" + } + default { + error "invalid search type \"$type\": should be dfs, or bfs" + } + } + + # Validate that the given order is good + switch -glob -- $order { + "both" { + set order both + } + "pre" { + set order pre + } + "post" { + set order post + } + default { + error "invalid search order \"$order\": should be both,\ + pre or post" + } + } + + # Validate that the given direction is good + switch -glob -- $dir { + "forward" { + set dir -out + } + "backward" { + set dir -in + } + default { + error "invalid search direction \"$dir\": should be\ + forward or backward" + } + } + + # Do the walk + + set st [list ] + lappend st $node + array set visited {} + + if { [string equal $type "dfs"] } { + if { [string equal $order "pre"] } { + # Pre-order Depth-first search + + while { [llength $st] > 0 } { + set node [lindex $st end] + set st [lreplace $st end end] + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy enter $name $node + uplevel 2 $cmdcpy + + set visited($node) . + + # Add this node's neighbours (according to direction) + # Have to add them in reverse order + # so that they will be popped left-to-right + + set next [_nodes $name $dir $node] + set len [llength $next] + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + set nextnode [lindex $next $i] + if {[info exists visited($nextnode)]} { + # Skip nodes already visited + continue + } + lappend st $nextnode + } + } + } elseif { [string equal $order "post"] } { + # Post-order Depth-first search + + while { [llength $st] > 0 } { + set node [lindex $st end] + + if {[info exists visited($node)]} { + # Second time we are here, pop it, + # then evaluate the command. + + set st [lreplace $st end end] + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy leave $name $node + uplevel 2 $cmdcpy + } else { + # First visit. Remember it. + set visited($node) . + + # Add this node's neighbours. + set next [_nodes $name $dir $node] + set len [llength $next] + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + set nextnode [lindex $next $i] + if {[info exists visited($nextnode)]} { + # Skip nodes already visited + continue + } + lappend st $nextnode + } + } + } + } else { + # Both-order Depth-first search + + while { [llength $st] > 0 } { + set node [lindex $st end] + + if {[info exists visited($node)]} { + # Second time we are here, pop it, + # then evaluate the command. + + set st [lreplace $st end end] + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy leave $name $node + uplevel 2 $cmdcpy + } else { + # First visit. Remember it. + set visited($node) . + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy enter $name $node + uplevel 2 $cmdcpy + + # Add this node's neighbours. + set next [_nodes $name $dir $node] + set len [llength $next] + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + set nextnode [lindex $next $i] + if {[info exists visited($nextnode)]} { + # Skip nodes already visited + continue + } + lappend st $nextnode + } + } + } + } + + } else { + if { [string equal $order "pre"] } { + # Pre-order Breadth first search + while { [llength $st] > 0 } { + set node [lindex $st 0] + set st [lreplace $st 0 0] + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy enter $name $node + uplevel 2 $cmdcpy + + set visited($node) . + + # Add this node's neighbours. + foreach child [_nodes $name $dir $node] { + if {[info exists visited($child)]} { + # Skip nodes already visited + continue + } + lappend st $child + } + } + } else { + # Post-order Breadth first search + # Both-order Breadth first search + # Haven't found anything in Knuth + # and unable to define something + # consistent for myself. Leave it + # out. + + error "unable to do a ${order}-order breadth first walk" + } + } + return +} + +# ::struct::graph::Union -- +# +# Return a list which is the union of the elements +# in the specified lists. +# +# Arguments: +# args list of lists representing sets. +# +# Results: +# set list representing the union of the argument lists. + +proc ::struct::graph::Union {args} { + switch -- [llength $args] { + 0 { + return {} + } + 1 { + return [lindex $args 0] + } + default { + foreach set $args { + foreach e $set { + set tmp($e) . + } + } + return [array names tmp] + } + } +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'graph::graph' into the general structure namespace. + namespace import -force graph::graph + namespace export graph +} +package provide struct::graph 1.2.1 diff --git a/src/bootsupport/lib/struct/graph_c.tcl b/src/bootsupport/lib/struct/graph_c.tcl new file mode 100644 index 00000000..56493b32 --- /dev/null +++ b/src/bootsupport/lib/struct/graph_c.tcl @@ -0,0 +1,158 @@ +# graphc.tcl -- +# +# Implementation of a graph data structure for Tcl. +# This code based on critcl, API compatible to the PTI [x]. +# [x] Pure Tcl Implementation. +# +# Copyright (c) 2006,2019 Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require critcl +# @sak notprovided struct_graphc +package provide struct_graphc 2.4.3 +package require Tcl 8.2 + +namespace eval ::struct { + # Supporting code for the main command. + + catch { + #critcl::cheaders -g + #critcl::debug memory symbols + } + + critcl::cheaders graph/*.h + critcl::csources graph/*.c + + critcl::ccode { + /* -*- c -*- */ + + #include + #include + #include + + #define USAGE "?name ?=|:=|as|deserialize source??" + + static void gg_delete (ClientData clientData) + { + /* Release the whole graph. */ + g_delete ((G*) clientData); + } + } + + # Main command, graph creation. + + critcl::ccommand graph_critcl {dummy interp objc objv} { + /* Syntax */ + /* - epsilon |1 */ + /* - name |2 */ + /* - name =|:=|as|deserialize source |4 */ + + CONST char* name; + G* g; + Tcl_Obj* fqn; + Tcl_CmdInfo ci; + + if ((objc != 4) && (objc != 2) && (objc != 1)) { + Tcl_WrongNumArgs (interp, 1, objv, USAGE); + return TCL_ERROR; + } + + if (objc < 2) { + name = gg_new (interp); + } else { + name = Tcl_GetString (objv [1]); + } + + if (!Tcl_StringMatch (name, "::*")) { + /* Relative name. Prefix with current namespace */ + + Tcl_Eval (interp, "namespace current"); + fqn = Tcl_GetObjResult (interp); + fqn = Tcl_DuplicateObj (fqn); + Tcl_IncrRefCount (fqn); + + if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { + Tcl_AppendToObj (fqn, "::", -1); + } + Tcl_AppendToObj (fqn, name, -1); + } else { + fqn = Tcl_NewStringObj (name, -1); + Tcl_IncrRefCount (fqn); + } + + Tcl_ResetResult (interp); + + if (Tcl_GetCommandInfo (interp, Tcl_GetString (fqn), &ci)) { + Tcl_Obj* err; + + err = Tcl_NewObj (); + Tcl_AppendToObj (err, "command \"", -1); + Tcl_AppendObjToObj (err, fqn); + Tcl_AppendToObj (err, "\" already exists, unable to create graph", -1); + + Tcl_DecrRefCount (fqn); + Tcl_SetObjResult (interp, err); + return TCL_ERROR; + } + + if (objc == 4) { + /* Construction with immediate initialization */ + /* through deserialization */ + + Tcl_Obj* type = objv[2]; + Tcl_Obj* src = objv[3]; + int srctype; + + static CONST char* types [] = { + ":=", "=", "as", "deserialize", NULL + }; + enum types { + G_ASSIGN, G_IS, G_AS, G_DESER + }; + + if (Tcl_GetIndexFromObj (interp, type, types, "type", 0, &srctype) != TCL_OK) { + Tcl_DecrRefCount (fqn); + Tcl_ResetResult (interp); + Tcl_WrongNumArgs (interp, 1, objv, USAGE); + return TCL_ERROR; + } + + g = g_new (); + + switch (srctype) { + case G_ASSIGN: + case G_AS: + case G_IS: + if (g_ms_assign (interp, g, src) != TCL_OK) { + g_delete (g); + Tcl_DecrRefCount (fqn); + return TCL_ERROR; + } + break; + + case G_DESER: + if (g_deserialize (g, interp, src) != TCL_OK) { + g_delete (g); + Tcl_DecrRefCount (fqn); + return TCL_ERROR; + } + break; + } + } else { + g = g_new (); + } + + g->cmd = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn), + g_objcmd, (ClientData) g, + gg_delete); + + Tcl_SetObjResult (interp, fqn); + Tcl_DecrRefCount (fqn); + return TCL_OK; + } +} + +# ### ### ### ######### ######### ######### +## Ready diff --git a/src/bootsupport/lib/struct/graph_tcl.tcl b/src/bootsupport/lib/struct/graph_tcl.tcl new file mode 100644 index 00000000..a63fd548 --- /dev/null +++ b/src/bootsupport/lib/struct/graph_tcl.tcl @@ -0,0 +1,3279 @@ +# graph_tcl.tcl -- +# +# Implementation of a graph data structure for Tcl. +# +# Copyright (c) 2000-2009,2019 by Andreas Kupries +# Copyright (c) 2008 by Alejandro Paz +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.4 +package require struct::list +package require struct::set + +namespace eval ::struct::graph { + # Data storage in the graph module + # ------------------------------- + # + # There's a lot of bits to keep track of for each graph: + # nodes + # node values + # node relationships (arcs) + # arc values + # + # It would quickly become unwieldy to try to keep these in arrays or lists + # within the graph namespace itself. Instead, each graph structure will + # get its own namespace. Each namespace contains: + # node:$node array mapping keys to values for the node $node + # arc:$arc array mapping keys to values for the arc $arc + # inArcs array mapping nodes to the list of incoming arcs + # outArcs array mapping nodes to the list of outgoing arcs + # arcNodes array mapping arcs to the two nodes (start & end) + + # counter is used to give a unique name for unnamed graph + variable counter 0 + + # Only export one command, the one used to instantiate a new graph + namespace export graph_tcl +} + +# ::struct::graph::graph_tcl -- +# +# Create a new graph with a given name; if no name is given, use +# graphX, where X is a number. +# +# Arguments: +# name name of the graph; if null, generate one. +# +# Results: +# name name of the graph created + +proc ::struct::graph::graph_tcl {args} { + variable counter + + set src {} + set srctype {} + + switch -exact -- [llength [info level 0]] { + 1 { + # Missing name, generate one. + incr counter + set name "graph${counter}" + } + 2 { + # Standard call. New empty graph. + set name [lindex $args 0] + } + 4 { + # Copy construction. + foreach {name as src} $args break + switch -exact -- $as { + = - := - as { + set srctype graph + } + deserialize { + set srctype serial + } + default { + return -code error \ + "wrong # args: should be \"struct::graph ?name ?=|:=|as|deserialize source??\"" + } + } + } + default { + # Error. + return -code error \ + "wrong # args: should be \"struct::graph ?name ?=|:=|as|deserialize source??\"" + } + } + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + + set name "$ns$name" + } + if {[llength [info commands $name]]} { + return -code error "command \"$name\" already exists, unable to create graph" + } + + # Set up the namespace + namespace eval $name { + + # Set up the map for values associated with the graph itself + variable graphAttr + array set graphAttr {} + + # Set up the node attribute mapping + variable nodeAttr + array set nodeAttr {} + + # Set up the arc attribute mapping + variable arcAttr + array set arcAttr {} + + # Set up the map from nodes to the arcs coming to them + variable inArcs + array set inArcs {} + + # Set up the map from nodes to the arcs going out from them + variable outArcs + array set outArcs {} + + # Set up the map from arcs to the nodes they touch. + variable arcNodes + array set arcNodes {} + + # Set up a value for use in creating unique node names + variable nextUnusedNode + set nextUnusedNode 1 + + # Set up a value for use in creating unique arc names + variable nextUnusedArc + set nextUnusedArc 1 + + # Set up a counter for use in creating attribute arrays. + variable nextAttr + set nextAttr 0 + + # Set up a map from arcs to their weights. Note: Only arcs + # which actually have a weight are recorded in the map, to + # keep memory usage down. + variable arcWeight + array set arcWeight {} + } + + # Create the command to manipulate the graph + interp alias {} $name {} ::struct::graph::GraphProc $name + + # Automatic execution of assignment if a source + # is present. + if {$src != {}} { + switch -exact -- $srctype { + graph {_= $name $src} + serial {_deserialize $name $src} + default { + return -code error \ + "Internal error, illegal srctype \"$srctype\"" + } + } + } + + return $name +} + +########################## +# Private functions follow + +# ::struct::graph::GraphProc -- +# +# Command that processes all graph object commands. +# +# Arguments: +# name name of the graph object to manipulate. +# args command name and args for the command +# +# Results: +# Varies based on command to perform + +proc ::struct::graph::GraphProc {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub _$cmd + if { [llength [info commands ::struct::graph::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::graph::_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + if {[string match __* $p]} {continue} + lappend xlist [string range $p 1 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::graph::$sub $name] +} + +# ::struct::graph::_= -- +# +# Assignment operator. Copies the source graph into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the graph object we are copying into. +# source Name of the graph object providing us with the +# data to copy. +# +# Results: +# Nothing. + +proc ::struct::graph::_= {name source} { + _deserialize $name [$source serialize] + return +} + +# ::struct::graph::_--> -- +# +# Reverse assignment operator. Copies this graph into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the graph object to copy +# dest Name of the graph object we are copying to. +# +# Results: +# Nothing. + +proc ::struct::graph::_--> {name dest} { + $dest deserialize [_serialize $name] + return +} + +# ::struct::graph::_append -- +# +# Append a value for an attribute in a graph. +# +# Arguments: +# name name of the graph. +# args key value +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::_append {name key value} { + variable ${name}::graphAttr + return [append graphAttr($key) $value] +} + +# ::struct::graph::_lappend -- +# +# lappend a value for an attribute in a graph. +# +# Arguments: +# name name of the graph. +# args key value +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::_lappend {name key value} { + variable ${name}::graphAttr + return [lappend graphAttr($key) $value] +} + +# ::struct::graph::_arc -- +# +# Dispatches the invocation of arc methods to the proper handler +# procedure. +# +# Arguments: +# name name of the graph. +# cmd arc command to invoke +# args arguments to propagate to the handler for the arc command +# +# Results: +# As of the invoked handler. + +proc ::struct::graph::_arc {name cmd args} { + # Split the args into command and args components + + set sub __arc_$cmd + if { [llength [info commands ::struct::graph::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::graph::__arc_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 6 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::graph::$sub $name] +} + +# ::struct::graph::__arc_delete -- +# +# Remove an arc from a graph, including all of its values. +# +# Arguments: +# name name of the graph. +# args list of arcs to delete. +# +# Results: +# None. + +proc ::struct::graph::__arc_delete {name args} { + if {![llength $args]} { + return {wrong # args: should be "::struct::graph::__arc_delete name arc arc..."} + } + + # seen is used to catch duplicate arcs in the args + array set seen {} + foreach arc $args { + if {[info exists seen($arc)]} { + return -code error "arc \"$arc\" does not exist in graph \"$name\"" + } + CheckMissingArc $name $arc + set seen($arc) . + } + + variable ${name}::inArcs + variable ${name}::outArcs + variable ${name}::arcNodes + variable ${name}::arcAttr + variable ${name}::arcWeight + + foreach arc $args { + foreach {source target} $arcNodes($arc) break ; # lassign + + unset arcNodes($arc) + + if {[info exists arcAttr($arc)]} { + unset ${name}::$arcAttr($arc) ;# Note the double indirection here + unset arcAttr($arc) + } + if {[info exists arcWeight($arc)]} { + unset arcWeight($arc) + } + + # Remove arc from the arc lists of source and target nodes. + + set index [lsearch -exact $outArcs($source) $arc] + ldelete outArcs($source) $index + + set index [lsearch -exact $inArcs($target) $arc] + ldelete inArcs($target) $index + } + + return +} + +# ::struct::graph::__arc_exists -- +# +# Test for existence of a given arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to look for. +# +# Results: +# 1 if the arc exists, 0 else. + +proc ::struct::graph::__arc_exists {name arc} { + return [info exists ${name}::arcNodes($arc)] +} + +# ::struct::graph::__arc_flip -- +# +# Exchanges origin and destination node of the specified arc. +# +# Arguments: +# name name of the graph object. +# arc arc to change. +# +# Results: +# None + +proc ::struct::graph::__arc_flip {name arc} { + CheckMissingArc $name $arc + + variable ${name}::arcNodes + variable ${name}::outArcs + variable ${name}::inArcs + + set oldsource [lindex $arcNodes($arc) 0] + set oldtarget [lindex $arcNodes($arc) 1] + + if {[string equal $oldsource $oldtarget]} return + + set newtarget $oldsource + set newsource $oldtarget + + set arcNodes($arc) [lreplace $arcNodes($arc) 0 0 $newsource] + lappend outArcs($newsource) $arc + ldelete outArcs($oldsource) [lsearch -exact $outArcs($oldsource) $arc] + + set arcNodes($arc) [lreplace $arcNodes($arc) 1 1 $newtarget] + lappend inArcs($newtarget) $arc + ldelete inArcs($oldtarget) [lsearch -exact $inArcs($oldtarget) $arc] + return +} + +# ::struct::graph::__arc_get -- +# +# Get a keyed value from an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# key key to lookup +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__arc_get {name arc key} { + CheckMissingArc $name $arc + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attribute data for this arc, key has to be invalid. + return -code error "invalid key \"$key\" for arc \"$arc\"" + } + + upvar ${name}::$arcAttr($arc) data + if { ![info exists data($key)] } { + return -code error "invalid key \"$key\" for arc \"$arc\"" + } + return $data($key) +} + +# ::struct::graph::__arc_getall -- +# +# Get a serialized array of key/value pairs from an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# pattern optional glob pattern to restrict retrieval +# +# Results: +# value serialized array of key/value pairs. + +proc ::struct::graph::__arc_getall {name arc {pattern *}} { + CheckMissingArc $name $arc + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attributes ... + return {} + } + + upvar ${name}::$arcAttr($arc) data + return [array get data $pattern] +} + +# ::struct::graph::__arc_keys -- +# +# Get a list of keys for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# pattern optional glob pattern to restrict retrieval +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__arc_keys {name arc {pattern *}} { + CheckMissingArc $name $arc + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attributes ... + return {} + } + + upvar ${name}::$arcAttr($arc) data + return [array names data $pattern] +} + +# ::struct::graph::__arc_keyexists -- +# +# Test for existence of a given key for a given arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# key key to lookup +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::graph::__arc_keyexists {name arc key} { + CheckMissingArc $name $arc + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attribute data for this arc, key cannot exist. + return 0 + } + + upvar ${name}::$arcAttr($arc) data + return [info exists data($key)] +} + +# ::struct::graph::__arc_insert -- +# +# Add an arc to a graph. +# +# Arguments: +# name name of the graph. +# source source node of the new arc +# target target node of the new arc +# args arc to insert; must be unique. If none is given, +# the routine will generate a unique node name. +# +# Results: +# arc The name of the new arc. + +proc ::struct::graph::__arc_insert {name source target args} { + + if { [llength $args] == 0 } { + # No arc name was given; generate a unique one + set arc [__generateUniqueArcName $name] + } elseif { [llength $args] > 1 } { + return {wrong # args: should be "::struct::graph::__arc_insert name source target ?arc?"} + } else { + set arc [lindex $args 0] + } + + CheckDuplicateArc $name $arc + CheckMissingNode $name $source {source } + CheckMissingNode $name $target {target } + + variable ${name}::inArcs + variable ${name}::outArcs + variable ${name}::arcNodes + + # Set up the new arc + set arcNodes($arc) [list $source $target] + + # Add this arc to the arc lists of its source resp. target nodes. + lappend outArcs($source) $arc + lappend inArcs($target) $arc + + return $arc +} + +# ::struct::graph::__arc_rename -- +# +# Rename a arc in place. +# +# Arguments: +# name name of the graph. +# arc Name of the arc to rename +# newname The new name of the arc. +# +# Results: +# The new name of the arc. + +proc ::struct::graph::__arc_rename {name arc newname} { + CheckMissingArc $name $arc + CheckDuplicateArc $name $newname + + set oldname $arc + + # Perform the rename in the internal + # data structures. + + # - graphAttr - not required, arc independent. + # - nodeAttr - not required, arc independent. + # - counters - not required + + variable ${name}::arcAttr + variable ${name}::inArcs + variable ${name}::outArcs + variable ${name}::arcNodes + variable ${name}::arcWeight + + # Arc relocation + + set arcNodes($newname) [set nodes $arcNodes($oldname)] + unset arcNodes($oldname) + + # Update the two nodes ... + foreach {start end} $nodes break + + set pos [lsearch -exact $inArcs($end) $oldname] + lset inArcs($end) $pos $newname + + set pos [lsearch -exact $outArcs($start) $oldname] + lset outArcs($start) $pos $newname + + if {[info exists arcAttr($oldname)]} { + set arcAttr($newname) $arcAttr($oldname) + unset arcAttr($oldname) + } + + if {[info exists arcWeight($oldname)]} { + set arcWeight($newname) $arcWeight($oldname) + unset arcWeight($oldname) + } + + return $newname +} + +# ::struct::graph::__arc_set -- +# +# Set or get a value for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to modify or query. +# key attribute to modify or query +# args ?value? +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::__arc_set {name arc key args} { + if { [llength $args] > 1 } { + return -code error "wrong # args: should be \"$name arc set arc key ?value?\"" + } + CheckMissingArc $name $arc + + if { [llength $args] > 0 } { + # Setting the value. This may have to create + # the attribute array for this particular + # node + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attribute data for this node, + # so create it as we need it now. + GenAttributeStorage $name arc $arc + } + + upvar ${name}::$arcAttr($arc) data + return [set data($key) [lindex $args end]] + } else { + # Getting a value + return [__arc_get $name $arc $key] + } +} + +# ::struct::graph::__arc_append -- +# +# Append a value for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to modify or query. +# args key value +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::__arc_append {name arc key value} { + CheckMissingArc $name $arc + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attribute data for this arc, + # so create it as we need it. + GenAttributeStorage $name arc $arc + } + + upvar ${name}::$arcAttr($arc) data + return [append data($key) $value] +} + +# ::struct::graph::__arc_attr -- +# +# Return attribute data for one key and multiple arcs, possibly all. +# +# Arguments: +# name Name of the graph object. +# key Name of the attribute to retrieve. +# +# Results: +# children Dictionary mapping arcs to attribute data. + +proc ::struct::graph::__arc_attr {name key args} { + # Syntax: + # + # t attr key + # t attr key -arcs {arclist} + # t attr key -glob arcpattern + # t attr key -regexp arcpattern + + variable ${name}::arcAttr + + set usage "wrong # args: should be \"[list $name] arc attr key ?-arcs list|-glob pattern|-regexp pattern?\"" + if {([llength $args] != 0) && ([llength $args] != 2)} { + return -code error $usage + } elseif {[llength $args] == 0} { + # This automatically restricts the list + # to arcs which can have the attribute + # in question. + + set arcs [array names arcAttr] + } else { + # Determine a list of arcs to look at + # based on the chosen restriction. + + foreach {mode value} $args break + switch -exact -- $mode { + -arcs { + # This is the only branch where we have to + # perform an explicit restriction to the + # arcs which have attributes. + set arcs {} + foreach n $value { + if {![info exists arcAttr($n)]} continue + lappend arcs $n + } + } + -glob { + set arcs [array names arcAttr $value] + } + -regexp { + set arcs {} + foreach n [array names arcAttr] { + if {![regexp -- $value $n]} continue + lappend arcs $n + } + } + default { + return -code error "bad type \"$mode\": must be -arcs, -glob, or -regexp" + } + } + } + + # Without possibly matching arcs + # the result has to be empty. + + if {![llength $arcs]} { + return {} + } + + # Now locate matching keys and their values. + + set result {} + foreach n $arcs { + upvar ${name}::$arcAttr($n) data + if {[info exists data($key)]} { + lappend result $n $data($key) + } + } + + return $result +} + +# ::struct::graph::__arc_lappend -- +# +# lappend a value for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to modify or query. +# args key value +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::__arc_lappend {name arc key value} { + CheckMissingArc $name $arc + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attribute data for this arc, + # so create it as we need it. + GenAttributeStorage $name arc $arc + } + + upvar ${name}::$arcAttr($arc) data + return [lappend data($key) $value] +} + +# ::struct::graph::__arc_source -- +# +# Return the node at the beginning of the specified arc. +# +# Arguments: +# name name of the graph object. +# arc arc to look up. +# +# Results: +# node name of the node. + +proc ::struct::graph::__arc_source {name arc} { + CheckMissingArc $name $arc + + variable ${name}::arcNodes + return [lindex $arcNodes($arc) 0] +} + +# ::struct::graph::__arc_target -- +# +# Return the node at the end of the specified arc. +# +# Arguments: +# name name of the graph object. +# arc arc to look up. +# +# Results: +# node name of the node. + +proc ::struct::graph::__arc_target {name arc} { + CheckMissingArc $name $arc + + variable ${name}::arcNodes + return [lindex $arcNodes($arc) 1] +} + +# ::struct::graph::__arc_nodes -- +# +# Return a list containing both source and target nodes of the arc. +# +# Arguments: +# name name of the graph object. +# arc arc to look up. +# +# Results: +# nodes list containing the names of the connected nodes node. +# None + +proc ::struct::graph::__arc_nodes {name arc} { + CheckMissingArc $name $arc + + variable ${name}::arcNodes + return $arcNodes($arc) +} + +# ::struct::graph::__arc_move-target -- +# +# Change the destination node of the specified arc. +# The arc is rotated around its origin to a different +# node. +# +# Arguments: +# name name of the graph object. +# arc arc to change. +# newtarget new destination/target of the arc. +# +# Results: +# None + +proc ::struct::graph::__arc_move-target {name arc newtarget} { + CheckMissingArc $name $arc + CheckMissingNode $name $newtarget + + variable ${name}::arcNodes + variable ${name}::inArcs + + set oldtarget [lindex $arcNodes($arc) 1] + if {[string equal $oldtarget $newtarget]} return + + set arcNodes($arc) [lreplace $arcNodes($arc) 1 1 $newtarget] + + lappend inArcs($newtarget) $arc + ldelete inArcs($oldtarget) [lsearch -exact $inArcs($oldtarget) $arc] + return +} + +# ::struct::graph::__arc_move-source -- +# +# Change the origin node of the specified arc. +# The arc is rotated around its destination to a different +# node. +# +# Arguments: +# name name of the graph object. +# arc arc to change. +# newsource new origin/source of the arc. +# +# Results: +# None + +proc ::struct::graph::__arc_move-source {name arc newsource} { + CheckMissingArc $name $arc + CheckMissingNode $name $newsource + + variable ${name}::arcNodes + variable ${name}::outArcs + + set oldsource [lindex $arcNodes($arc) 0] + if {[string equal $oldsource $newsource]} return + + set arcNodes($arc) [lreplace $arcNodes($arc) 0 0 $newsource] + + lappend outArcs($newsource) $arc + ldelete outArcs($oldsource) [lsearch -exact $outArcs($oldsource) $arc] + return +} + +# ::struct::graph::__arc_move -- +# +# Changes both origin and destination node of the specified arc. +# +# Arguments: +# name name of the graph object. +# arc arc to change. +# newsource new origin/source of the arc. +# newtarget new destination/target of the arc. +# +# Results: +# None + +proc ::struct::graph::__arc_move {name arc newsource newtarget} { + CheckMissingArc $name $arc + CheckMissingNode $name $newsource + CheckMissingNode $name $newtarget + + variable ${name}::arcNodes + variable ${name}::outArcs + variable ${name}::inArcs + + set oldsource [lindex $arcNodes($arc) 0] + if {![string equal $oldsource $newsource]} { + set arcNodes($arc) [lreplace $arcNodes($arc) 0 0 $newsource] + lappend outArcs($newsource) $arc + ldelete outArcs($oldsource) [lsearch -exact $outArcs($oldsource) $arc] + } + + set oldtarget [lindex $arcNodes($arc) 1] + if {![string equal $oldtarget $newtarget]} { + set arcNodes($arc) [lreplace $arcNodes($arc) 1 1 $newtarget] + lappend inArcs($newtarget) $arc + ldelete inArcs($oldtarget) [lsearch -exact $inArcs($oldtarget) $arc] + } + return +} + +# ::struct::graph::__arc_unset -- +# +# Remove a keyed value from a arc. +# +# Arguments: +# name name of the graph. +# arc arc to modify. +# key attribute to remove +# +# Results: +# None. + +proc ::struct::graph::__arc_unset {name arc key} { + CheckMissingArc $name $arc + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attribute data for this arc, + # nothing to do. + return + } + + upvar ${name}::$arcAttr($arc) data + catch {unset data($key)} + + if {[array size data] == 0} { + # No attributes stored for this arc, squash the whole array. + unset arcAttr($arc) + unset data + } + return +} + +# ::struct::graph::__arc_getunweighted -- +# +# Return the arcs which have no weight defined. +# +# Arguments: +# name name of the graph. +# +# Results: +# arcs list of arcs without weights. + +proc ::struct::graph::__arc_getunweighted {name} { + variable ${name}::arcNodes + variable ${name}::arcWeight + return [struct::set difference \ + [array names arcNodes] \ + [array names arcWeight]] +} + +# ::struct::graph::__arc_getweight -- +# +# Get the weight given to an arc in a graph. +# Throws an error if the arc has no weight defined for it. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# +# Results: +# weight The weight defined for the arc. + +proc ::struct::graph::__arc_getweight {name arc} { + CheckMissingArc $name $arc + + variable ${name}::arcWeight + if {![info exists arcWeight($arc)]} { + return -code error "arc \"$arc\" has no weight" + } + return $arcWeight($arc) +} + +# ::struct::graph::__arc_setunweighted -- +# +# Define a weight for all arcs which have no weight defined. +# After this call no arc will be unweighted. +# +# Arguments: +# name name of the graph. +# defval weight to give to all unweighted arcs +# +# Results: +# None + +proc ::struct::graph::__arc_setunweighted {name {weight 0}} { + variable ${name}::arcWeight + foreach arc [__arc_getunweighted $name] { + set arcWeight($arc) $weight + } + return +} + +# ::struct::graph::__arc_setweight -- +# +# Define a weight for an arc. +# +# Arguments: +# name name of the graph. +# arc arc to modify +# weight the weight to set for the arc +# +# Results: +# weight The new weight + +proc ::struct::graph::__arc_setweight {name arc weight} { + CheckMissingArc $name $arc + + variable ${name}::arcWeight + set arcWeight($arc) $weight + return $weight +} + +# ::struct::graph::__arc_unsetweight -- +# +# Remove the weight for an arc. +# +# Arguments: +# name name of the graph. +# arc arc to modify +# +# Results: +# None. + +proc ::struct::graph::__arc_unsetweight {name arc} { + CheckMissingArc $name $arc + + variable ${name}::arcWeight + if {[info exists arcWeight($arc)]} { + unset arcWeight($arc) + } + return +} + +# ::struct::graph::__arc_hasweight -- +# +# Remove the weight for an arc. +# +# Arguments: +# name name of the graph. +# arc arc to modify +# +# Results: +# None. + +proc ::struct::graph::__arc_hasweight {name arc} { + CheckMissingArc $name $arc + + variable ${name}::arcWeight + return [info exists arcWeight($arc)] +} + +# ::struct::graph::__arc_weights -- +# +# Return the arcs and weights for all arcs which have such. +# +# Arguments: +# name name of the graph. +# +# Results: +# aw dictionary mapping arcs to their weights. + +proc ::struct::graph::__arc_weights {name} { + variable ${name}::arcWeight + return [array get arcWeight] +} + +# ::struct::graph::_arcs -- +# +# Return a list of all arcs in a graph satisfying some +# node based restriction. +# +# Arguments: +# name name of the graph. +# +# Results: +# arcs list of arcs + +proc ::struct::graph::_arcs {name args} { + + CheckE $name arcs $args + + switch -exact -- $cond { + none {set arcs [ArcsNONE $name]} + in {set arcs [ArcsIN $name $condNodes]} + out {set arcs [ArcsOUT $name $condNodes]} + adj {set arcs [ArcsADJ $name $condNodes]} + inner {set arcs [ArcsINN $name $condNodes]} + embedding {set arcs [ArcsEMB $name $condNodes]} + default {return -code error "Can't happen, panic"} + } + + # + # We have a list of arcs that match the relation to the nodes. + # Now filter according to -key and -value. + # + + if {$haveKey && $haveValue} { + set arcs [ArcsKV $name $key $value $arcs] + } elseif {$haveKey} { + set arcs [ArcsK $name $key $arcs] + } + + # + # Apply the general filter command, if specified. + # + + if {$haveFilter} { + lappend fcmd $name + set arcs [uplevel 1 [list ::struct::list filter $arcs $fcmd]] + } + + return $arcs +} + +proc ::struct::graph::ArcsIN {name cn} { + # arcs -in. "Arcs going into the node set" + # + # ARC/in (NS) := { a | target(a) in NS } + + # The result is all arcs going to at least one node in the set + # 'cn' of nodes. + + # As an arc has only one destination, i.e. is the + # in-arc of exactly one node it is impossible to + # count an arc twice. Therefore there is no need + # to keep track of arcs to avoid duplicates. + + variable ${name}::inArcs + + set arcs {} + foreach node $cn { + foreach e $inArcs($node) { + lappend arcs $e + } + } + + return $arcs +} + +proc ::struct::graph::ArcsOUT {name cn} { + # arcs -out. "Arcs coming from the node set" + # + # ARC/out (NS) := { a | source(a) in NS } + + # The result is all arcs coming from at least one node in the list + # of arguments. + + variable ${name}::outArcs + + set arcs {} + foreach node $cn { + foreach e $outArcs($node) { + lappend arcs $e + } + } + + return $arcs +} + +proc ::struct::graph::ArcsADJ {name cn} { + # arcs -adj. "Arcs adjacent to the node set" + # + # ARC/adj (NS) := ARC/in (NS) + ARC/out (NS) + + # Result is all arcs coming from or going to at + # least one node in the list of arguments. + + return [struct::set union \ + [ArcsIN $name $cn] \ + [ArcsOUT $name $cn]] + if 0 { + # Alternate implementation using arrays, + # implementing the set union directly, + # intertwined with the data retrieval. + + array set coll {} + foreach node $condNodes { + foreach e $inArcs($node) { + if {[info exists coll($e)]} {continue} + lappend arcs $e + set coll($e) . + } + foreach e $outArcs($node) { + if {[info exists coll($e)]} {continue} + lappend arcs $e + set coll($e) . + } + } + } +} + +proc ::struct::graph::ArcsINN {name cn} { + # arcs -adj. "Arcs inside the node set" + # + # ARC/inner (NS) := ARC/in (NS) * ARC/out (NS) + + # Result is all arcs running between nodes + # in the list. + + return [struct::set intersect \ + [ArcsIN $name $cn] \ + [ArcsOUT $name $cn]] + if 0 { + # Alternate implementation using arrays, + # implementing the set intersection + # directly, intertwined with the data + # retrieval. + + array set coll {} + # Here we do need 'coll' as each might be an in- and + # out-arc for one or two nodes in the list of arguments. + + array set group {} + foreach node $condNodes { + set group($node) . + } + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {![info exists group($n)]} {continue} + if { [info exists coll($e)]} {continue} + lappend arcs $e + set coll($e) . + } + # Second iteration over outgoing arcs not + # required. Any arc found above would be found here as + # well, and arcs not recognized above can't be + # recognized by the out loop either. + } + } +} + +proc ::struct::graph::ArcsEMB {name cn} { + # arcs -adj. "Arcs bordering the node set" + # + # ARC/emb (NS) := ARC/inner (NS) - ARC/adj (NS) + # <=> (ARC/in + ARC/out) - (ARC/in * ARC/out) + # <=> (ARC/in - ARC/out) + (ARC/out - ARC/in) + # <=> symmetric difference (ARC/in, ARC/out) + + # Result is all arcs from -adj minus the arcs from -inner. + # IOW all arcs going from a node in the list to a node + # which is *not* in the list + + return [struct::set symdiff \ + [ArcsIN $name $cn] \ + [ArcsOUT $name $cn]] + if 0 { + # Alternate implementation using arrays, + # implementing the set intersection + # directly, intertwined with the data + # retrieval. + + # This also means that no arc can be counted twice as it + # is either going to a node, or coming from a node in the + # list, but it can't do both, because then it is part of + # -inner, which was excluded! + + array set group {} + foreach node $condNodes { + set group($node) . + } + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists group($n)]} {continue} + # if {[info exists coll($e)]} {continue} + lappend arcs $e + # set coll($e) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists group($n)]} {continue} + # if {[info exists coll($e)]} {continue} + lappend arcs $e + # set coll($e) . + } + } + } +} + +proc ::struct::graph::ArcsNONE {name} { + variable ${name}::arcNodes + return [array names arcNodes] +} + +proc ::struct::graph::ArcsKV {name key value arcs} { + set filteredArcs {} + foreach arc $arcs { + catch { + set aval [__arc_get $name $arc $key] + if {$aval == $value} { + lappend filteredArcs $arc + } + } + } + return $filteredArcs +} + +proc ::struct::graph::ArcsK {name key arcs} { + set filteredArcs {} + foreach arc $arcs { + catch { + __arc_get $name $arc $key + lappend filteredArcs $arc + } + } + return $filteredArcs +} + +# ::struct::graph::_deserialize -- +# +# Assignment operator. Copies a serialization into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the graph object we are copying into. +# serial Serialized graph to copy from. +# +# Results: +# Nothing. + +proc ::struct::graph::_deserialize {name serial} { + # As we destroy the original graph as part of + # the copying process we don't have to deal + # with issues like node names from the new graph + # interfering with the old ... + + # I. Get the serialization of the source graph + # and check it for validity. + + CheckSerialization $serial \ + gattr nattr aattr ina outa arcn arcw + + # Get all the relevant data into the scope + + variable ${name}::graphAttr + variable ${name}::nodeAttr + variable ${name}::arcAttr + variable ${name}::inArcs + variable ${name}::outArcs + variable ${name}::arcNodes + variable ${name}::nextAttr + variable ${name}::arcWeight + + # Kill the existing information and insert the new + # data in their place. + + array unset inArcs * + array unset outArcs * + array set inArcs [array get ina] + array set outArcs [array get outa] + unset ina outa + + array unset arcNodes * + array set arcNodes [array get arcn] + unset arcn + + array unset arcWeight * + array set arcWeight [array get arcw] + unset arcw + + set nextAttr 0 + foreach a [array names nodeAttr] { + unset ${name}::$nodeAttr($a) + } + foreach a [array names arcAttr] { + unset ${name}::$arcAttr($a) + } + foreach n [array names nattr] { + GenAttributeStorage $name node $n + array set ${name}::$nodeAttr($n) $nattr($n) + } + foreach a [array names aattr] { + GenAttributeStorage $name arc $a + array set ${name}::$arcAttr($a) $aattr($a) + } + + array unset graphAttr * + array set graphAttr $gattr + + ## Debug ## Dump internals ... + if {0} { + puts "___________________________________ $name" + parray inArcs + parray outArcs + parray arcNodes + parray nodeAttr + parray arcAttr + parray graphAttr + parray arcWeight + puts ___________________________________ + } + return +} + +# ::struct::graph::_destroy -- +# +# Destroy a graph, including its associated command and data storage. +# +# Arguments: +# name name of the graph. +# +# Results: +# None. + +proc ::struct::graph::_destroy {name} { + namespace delete $name + interp alias {} $name {} +} + +# ::struct::graph::__generateUniqueArcName -- +# +# Generate a unique arc name for the given graph. +# +# Arguments: +# name name of the graph. +# +# Results: +# arc name of a arc guaranteed to not exist in the graph. + +proc ::struct::graph::__generateUniqueArcName {name} { + variable ${name}::nextUnusedArc + while {[__arc_exists $name "arc${nextUnusedArc}"]} { + incr nextUnusedArc + } + return "arc${nextUnusedArc}" +} + +# ::struct::graph::__generateUniqueNodeName -- +# +# Generate a unique node name for the given graph. +# +# Arguments: +# name name of the graph. +# +# Results: +# node name of a node guaranteed to not exist in the graph. + +proc ::struct::graph::__generateUniqueNodeName {name} { + variable ${name}::nextUnusedNode + while {[__node_exists $name "node${nextUnusedNode}"]} { + incr nextUnusedNode + } + return "node${nextUnusedNode}" +} + +# ::struct::graph::_get -- +# +# Get a keyed value from the graph itself +# +# Arguments: +# name name of the graph. +# key key to lookup +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::_get {name key} { + variable ${name}::graphAttr + if { ![info exists graphAttr($key)] } { + return -code error "invalid key \"$key\" for graph \"$name\"" + } + return $graphAttr($key) +} + +# ::struct::graph::_getall -- +# +# Get an attribute dictionary from a graph. +# +# Arguments: +# name name of the graph. +# pattern optional, glob pattern +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::_getall {name {pattern *}} { + variable ${name}::graphAttr + return [array get graphAttr $pattern] +} + +# ::struct::graph::_keys -- +# +# Get a list of keys from a graph. +# +# Arguments: +# name name of the graph. +# pattern optional, glob pattern +# +# Results: +# value list of known keys + +proc ::struct::graph::_keys {name {pattern *}} { + variable ${name}::graphAttr + return [array names graphAttr $pattern] +} + +# ::struct::graph::_keyexists -- +# +# Test for existence of a given key in a graph. +# +# Arguments: +# name name of the graph. +# key key to lookup +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::graph::_keyexists {name key} { + variable ${name}::graphAttr + return [info exists graphAttr($key)] +} + +# ::struct::graph::_node -- +# +# Dispatches the invocation of node methods to the proper handler +# procedure. +# +# Arguments: +# name name of the graph. +# cmd node command to invoke +# args arguments to propagate to the handler for the node command +# +# Results: +# As of the the invoked handler. + +proc ::struct::graph::_node {name cmd args} { + # Split the args into command and args components + set sub __node_$cmd + if { [llength [info commands ::struct::graph::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::graph::__node_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 7 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::graph::$sub $name] +} + +# ::struct::graph::__node_degree -- +# +# Return the number of arcs adjacent to the specified node. +# If one of the restrictions -in or -out is given only +# incoming resp. outgoing arcs are counted. +# +# Arguments: +# name name of the graph. +# args option, followed by the node. +# +# Results: +# None. + +proc ::struct::graph::__node_degree {name args} { + + if {([llength $args] < 1) || ([llength $args] > 2)} { + return -code error "wrong # args: should be \"$name node degree ?-in|-out? node\"" + } + + switch -exact -- [llength $args] { + 1 { + set opt {} + set node [lindex $args 0] + } + 2 { + set opt [lindex $args 0] + set node [lindex $args 1] + } + default {return -code error "Can't happen, panic"} + } + + # Validate the option. + + switch -exact -- $opt { + {} - + -in - + -out {} + default { + return -code error "bad option \"$opt\": must be -in or -out" + } + } + + # Validate the node + + CheckMissingNode $name $node + + variable ${name}::inArcs + variable ${name}::outArcs + + switch -exact -- $opt { + -in { + set result [llength $inArcs($node)] + } + -out { + set result [llength $outArcs($node)] + } + {} { + set result [expr {[llength $inArcs($node)] \ + + [llength $outArcs($node)]}] + + # loops count twice, don't do arithmetics, i.e. no union! + if {0} { + array set coll {} + set result [llength $inArcs($node)] + + foreach e $inArcs($node) { + set coll($e) . + } + foreach e $outArcs($node) { + if {[info exists coll($e)]} {continue} + incr result + set coll($e) . + } + } + } + default {return -code error "Can't happen, panic"} + } + + return $result +} + +# ::struct::graph::__node_delete -- +# +# Remove a node from a graph, including all of its values. +# Additionally removes the arcs connected to this node. +# +# Arguments: +# name name of the graph. +# args list of the nodes to delete. +# +# Results: +# None. + +proc ::struct::graph::__node_delete {name args} { + if {![llength $args]} { + return {wrong # args: should be "::struct::graph::__node_delete name node node..."} + } + # seen is used to catch duplicate nodes in the args + array set seen {} + foreach node $args { + if {[info exists seen($node)]} { + return -code error "node \"$node\" does not exist in graph \"$name\"" + } + CheckMissingNode $name $node + set seen($node) . + } + + variable ${name}::inArcs + variable ${name}::outArcs + variable ${name}::nodeAttr + + foreach node $args { + # Remove all the arcs connected to this node + foreach e $inArcs($node) { + __arc_delete $name $e + } + foreach e $outArcs($node) { + # Check existence to avoid problems with + # loops (they are in and out arcs! at + # the same time and thus already deleted) + if { [__arc_exists $name $e] } { + __arc_delete $name $e + } + } + + unset inArcs($node) + unset outArcs($node) + + if {[info exists nodeAttr($node)]} { + unset ${name}::$nodeAttr($node) + unset nodeAttr($node) + } + } + + return +} + +# ::struct::graph::__node_exists -- +# +# Test for existence of a given node in a graph. +# +# Arguments: +# name name of the graph. +# node node to look for. +# +# Results: +# 1 if the node exists, 0 else. + +proc ::struct::graph::__node_exists {name node} { + return [info exists ${name}::inArcs($node)] +} + +# ::struct::graph::__node_get -- +# +# Get a keyed value from a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# key key to lookup +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__node_get {name node key} { + CheckMissingNode $name $node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attribute data for this node, key has to be invalid. + return -code error "invalid key \"$key\" for node \"$node\"" + } + + upvar ${name}::$nodeAttr($node) data + if { ![info exists data($key)] } { + return -code error "invalid key \"$key\" for node \"$node\"" + } + return $data($key) +} + +# ::struct::graph::__node_getall -- +# +# Get a serialized list of key/value pairs from a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# pattern optional glob pattern to restrict retrieval +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__node_getall {name node {pattern *}} { + CheckMissingNode $name $node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attributes ... + return {} + } + + upvar ${name}::$nodeAttr($node) data + return [array get data $pattern] +} + +# ::struct::graph::__node_keys -- +# +# Get a list of keys from a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# pattern optional glob pattern to restrict retrieval +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__node_keys {name node {pattern *}} { + CheckMissingNode $name $node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attributes ... + return {} + } + + upvar ${name}::$nodeAttr($node) data + return [array names data $pattern] +} + +# ::struct::graph::__node_keyexists -- +# +# Test for existence of a given key for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# key key to lookup +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::graph::__node_keyexists {name node key} { + CheckMissingNode $name $node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attribute data for this node, key cannot exist. + return 0 + } + + upvar ${name}::$nodeAttr($node) data + return [info exists data($key)] +} + +# ::struct::graph::__node_insert -- +# +# Add a node to a graph. +# +# Arguments: +# name name of the graph. +# args node to insert; must be unique. If none is given, +# the routine will generate a unique node name. +# +# Results: +# node The name of the new node. + +proc ::struct::graph::__node_insert {name args} { + if {[llength $args] == 0} { + # No node name was given; generate a unique one + set args [list [__generateUniqueNodeName $name]] + } else { + # seen is used to catch duplicate nodes in the args + array set seen {} + foreach node $args { + if {[info exists seen($node)]} { + return -code error "node \"$node\" already exists in graph \"$name\"" + } + CheckDuplicateNode $name $node + set seen($node) . + } + } + + variable ${name}::inArcs + variable ${name}::outArcs + + foreach node $args { + # Set up the new node + set inArcs($node) {} + set outArcs($node) {} + } + + return $args +} + +# ::struct::graph::__node_opposite -- +# +# Retrieve node opposite to the specified one, along the arc. +# +# Arguments: +# name name of the graph. +# node node to look up. +# arc arc to look up. +# +# Results: +# nodex Node opposite to + +proc ::struct::graph::__node_opposite {name node arc} { + CheckMissingNode $name $node + CheckMissingArc $name $arc + + variable ${name}::arcNodes + + # Node must be connected to at least one end of the arc. + + if {[string equal $node [lindex $arcNodes($arc) 0]]} { + set result [lindex $arcNodes($arc) 1] + } elseif {[string equal $node [lindex $arcNodes($arc) 1]]} { + set result [lindex $arcNodes($arc) 0] + } else { + return -code error "node \"$node\" and arc \"$arc\" are not connected\ + in graph \"$name\"" + } + + return $result +} + +# ::struct::graph::__node_set -- +# +# Set or get a value for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to modify or query. +# key attribute to modify or query +# args ?value? +# +# Results: +# val value associated with the given key of the given node + +proc ::struct::graph::__node_set {name node key args} { + if { [llength $args] > 1 } { + return -code error "wrong # args: should be \"$name node set node key ?value?\"" + } + CheckMissingNode $name $node + + if { [llength $args] > 0 } { + # Setting the value. This may have to create + # the attribute array for this particular + # node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attribute data for this node, + # so create it as we need it now. + GenAttributeStorage $name node $node + } + upvar ${name}::$nodeAttr($node) data + + return [set data($key) [lindex $args end]] + } else { + # Getting a value + return [__node_get $name $node $key] + } +} + +# ::struct::graph::__node_append -- +# +# Append a value for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to modify or query. +# args key value +# +# Results: +# val value associated with the given key of the given node + +proc ::struct::graph::__node_append {name node key value} { + CheckMissingNode $name $node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attribute data for this node, + # so create it as we need it. + GenAttributeStorage $name node $node + } + + upvar ${name}::$nodeAttr($node) data + return [append data($key) $value] +} + +# ::struct::graph::__node_attr -- +# +# Return attribute data for one key and multiple nodes, possibly all. +# +# Arguments: +# name Name of the graph object. +# key Name of the attribute to retrieve. +# +# Results: +# children Dictionary mapping nodes to attribute data. + +proc ::struct::graph::__node_attr {name key args} { + # Syntax: + # + # t attr key + # t attr key -nodes {nodelist} + # t attr key -glob nodepattern + # t attr key -regexp nodepattern + + variable ${name}::nodeAttr + + set usage "wrong # args: should be \"[list $name] node attr key ?-nodes list|-glob pattern|-regexp pattern?\"" + if {([llength $args] != 0) && ([llength $args] != 2)} { + return -code error $usage + } elseif {[llength $args] == 0} { + # This automatically restricts the list + # to nodes which can have the attribute + # in question. + + set nodes [array names nodeAttr] + } else { + # Determine a list of nodes to look at + # based on the chosen restriction. + + foreach {mode value} $args break + switch -exact -- $mode { + -nodes { + # This is the only branch where we have to + # perform an explicit restriction to the + # nodes which have attributes. + set nodes {} + foreach n $value { + if {![info exists nodeAttr($n)]} continue + lappend nodes $n + } + } + -glob { + set nodes [array names nodeAttr $value] + } + -regexp { + set nodes {} + foreach n [array names nodeAttr] { + if {![regexp -- $value $n]} continue + lappend nodes $n + } + } + default { + return -code error "bad type \"$mode\": must be -glob, -nodes, or -regexp" + } + } + } + + # Without possibly matching nodes + # the result has to be empty. + + if {![llength $nodes]} { + return {} + } + + # Now locate matching keys and their values. + + set result {} + foreach n $nodes { + upvar ${name}::$nodeAttr($n) data + if {[info exists data($key)]} { + lappend result $n $data($key) + } + } + + return $result +} + +# ::struct::graph::__node_lappend -- +# +# lappend a value for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to modify or query. +# args key value +# +# Results: +# val value associated with the given key of the given node + +proc ::struct::graph::__node_lappend {name node key value} { + CheckMissingNode $name $node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attribute data for this node, + # so create it as we need it. + GenAttributeStorage $name node $node + } + + upvar ${name}::$nodeAttr($node) data + return [lappend data($key) $value] +} + +# ::struct::graph::__node_unset -- +# +# Remove a keyed value from a node. +# +# Arguments: +# name name of the graph. +# node node to modify. +# key attribute to remove +# +# Results: +# None. + +proc ::struct::graph::__node_unset {name node key} { + CheckMissingNode $name $node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attribute data for this node, + # nothing to do. + return + } + + upvar ${name}::$nodeAttr($node) data + catch {unset data($key)} + + if {[array size data] == 0} { + # No attributes stored for this node, squash the whole array. + unset nodeAttr($node) + unset data + } + return +} + +# ::struct::graph::_nodes -- +# +# Return a list of all nodes in a graph satisfying some restriction. +# +# Arguments: +# name name of the graph. +# args list of options and nodes specifying the restriction. +# +# Results: +# nodes list of nodes + +proc ::struct::graph::_nodes {name args} { + + CheckE $name nodes $args + + switch -exact -- $cond { + none {set nodes [NodesNONE $name]} + in {set nodes [NodesIN $name $condNodes]} + out {set nodes [NodesOUT $name $condNodes]} + adj {set nodes [NodesADJ $name $condNodes]} + inner {set nodes [NodesINN $name $condNodes]} + embedding {set nodes [NodesEMB $name $condNodes]} + default {return -code error "Can't happen, panic"} + } + + # + # We have a list of nodes that match the relation to the nodes. + # Now filter according to -key and -value. + # + + if {$haveKey && $haveValue} { + set nodes [NodesKV $name $key $value $nodes] + } elseif {$haveKey} { + set nodes [NodesK $name $key $nodes] + } + + # + # Apply the general filter command, if specified. + # + + if {$haveFilter} { + lappend fcmd $name + set nodes [uplevel 1 [list ::struct::list filter $nodes $fcmd]] + } + + return $nodes +} + +proc ::struct::graph::NodesIN {name cn} { + # nodes -in. + # "Neighbours with arcs going into the node set" + # + # NODES/in (NS) := { source(a) | a in ARC/in (NS) } + + # Result is all nodes with at least one arc going to + # at least one node in the list of arguments. + + variable ${name}::inArcs + variable ${name}::arcNodes + + set nodes {} + array set coll {} + + foreach node $cn { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + return $nodes +} + +proc ::struct::graph::NodesOUT {name cn} { + # nodes -out. + # "Neighbours with arcs coming from the node set" + # + # NODES/out (NS) := { target(a) | a in ARC/out (NS) } + + # Result is all nodes with at least one arc coming from + # at least one node in the list of arguments. + + variable ${name}::outArcs + variable ${name}::arcNodes + + set nodes {} + array set coll {} + + foreach node $cn { + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + return $nodes +} + +proc ::struct::graph::NodesADJ {name cn} { + # nodes -adj. + # "Neighbours of the node set" + # + # NODES/adj (NS) := NODES/in (NS) + NODES/out (NS) + + # Result is all nodes with at least one arc coming from + # or going to at least one node in the list of arguments. + + return [struct::set union \ + [NodesIN $name $cn] \ + [NodesOUT $name $cn]] + if 0 { + # Alternate implementation using arrays, + # implementing the set union directly, + # intertwined with the data retrieval. + + foreach node $cn { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } +} + +proc ::struct::graph::NodesINN {name cn} { + # nodes -adj. + # "Inner node of the node set" + # + # NODES/inner (NS) := NODES/adj (NS) * NS + + # Result is all nodes from the set with at least one arc coming + # from or going to at least one node in the set. + # + # I.e the adjacent nodes also in the set. + + return [struct::set intersect \ + [NodesADJ $name $cn] $cn] + + if 0 { + # Alternate implementation using arrays, + # implementing the set intersect/union + # directly, intertwined with the data retrieval. + + array set group {} + foreach node $cn { + set group($node) . + } + + foreach node $cn { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {![info exists group($n)]} {continue} + if { [info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {![info exists group($n)]} {continue} + if { [info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } +} + +proc ::struct::graph::NodesEMB {name cn} { + # nodes -embedding. + # "Embedding nodes for the node set" + # + # NODES/emb (NS) := NODES/adj (NS) - NS + + # Result is all nodes with at least one arc coming from or going + # to at least one node in the set, but not in the set itself + # + # I.e the adjacent nodes not in the set. + + # Result is all nodes from the set with at least one arc coming + # from or going to at least one node in the set. + # I.e the adjacent nodes still in the set. + + return [struct::set difference \ + [NodesADJ $name $cn] $cn] + + if 0 { + # Alternate implementation using arrays, + # implementing the set diff/union directly, + # intertwined with the data retrieval. + + array set group {} + foreach node $cn { + set group($node) . + } + + foreach node $cn { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists group($n)]} {continue} + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists group($n)]} {continue} + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } +} + +proc ::struct::graph::NodesNONE {name} { + variable ${name}::inArcs + return [array names inArcs] +} + +proc ::struct::graph::NodesKV {name key value nodes} { + set filteredNodes {} + foreach node $nodes { + catch { + set nval [__node_get $name $node $key] + if {$nval == $value} { + lappend filteredNodes $node + } + } + } + return $filteredNodes +} + +proc ::struct::graph::NodesK {name key nodes} { + set filteredNodes {} + foreach node $nodes { + catch { + __node_get $name $node $key + lappend filteredNodes $node + } + } + return $filteredNodes +} + +# ::struct::graph::__node_rename -- +# +# Rename a node in place. +# +# Arguments: +# name name of the graph. +# node Name of the node to rename +# newname The new name of the node. +# +# Results: +# The new name of the node. + +proc ::struct::graph::__node_rename {name node newname} { + CheckMissingNode $name $node + CheckDuplicateNode $name $newname + + set oldname $node + + # Perform the rename in the internal + # data structures. + + # - graphAttr - not required, node independent. + # - arcAttr - not required, node independent. + # - counters - not required + + variable ${name}::nodeAttr + variable ${name}::inArcs + variable ${name}::outArcs + variable ${name}::arcNodes + + # Node relocation + + set inArcs($newname) [set in $inArcs($oldname)] + unset inArcs($oldname) + set outArcs($newname) [set out $outArcs($oldname)] + unset outArcs($oldname) + + if {[info exists nodeAttr($oldname)]} { + set nodeAttr($newname) $nodeAttr($oldname) + unset nodeAttr($oldname) + } + + # Update all relevant arcs. + # 8.4: lset ... + + foreach a $in { + set arcNodes($a) [list [lindex $arcNodes($a) 0] $newname] + } + foreach a $out { + set arcNodes($a) [list $newname [lindex $arcNodes($a) 1]] + } + + return $newname +} + +# ::struct::graph::_serialize -- +# +# Serialize a graph object (partially) into a transportable value. +# If only a subset of nodes is serialized the result will be a sub- +# graph in the mathematical sense of the word: These nodes and all +# arcs which are only between these nodes. No arcs to modes outside +# of the listed set. +# +# Arguments: +# name Name of the graph. +# args list of nodes to place into the serialized graph +# +# Results: +# A list structure describing the part of the graph which was serialized. + +proc ::struct::graph::_serialize {name args} { + + # all - boolean flag - set if and only if the all nodes of the + # graph are chosen for serialization. Because if that is true we + # can skip the step finding the relevant arcs and simply take all + # arcs. + + variable ${name}::arcNodes + variable ${name}::arcWeight + variable ${name}::inArcs + + set all 0 + if {[llength $args] > 0} { + set nodes [luniq $args] + foreach n $nodes {CheckMissingNode $name $n} + if {[llength $nodes] == [array size inArcs]} { + set all 1 + } + } else { + set nodes [array names inArcs] + set all 1 + } + + if {$all} { + set arcs [array names arcNodes] + } else { + set arcs [eval [linsert $nodes 0 _arcs $name -inner]] + } + + variable ${name}::nodeAttr + variable ${name}::arcAttr + variable ${name}::graphAttr + + set na {} + set aa {} + array set np {} + + # node indices, attribute data ... + set i 0 + foreach n $nodes { + set np($n) [list $i] + incr i 3 + + if {[info exists nodeAttr($n)]} { + upvar ${name}::$nodeAttr($n) data + lappend np($n) [array get data] + } else { + lappend np($n) {} + } + } + + # arc dictionary + set arcdata {} + foreach a $arcs { + foreach {src dst} $arcNodes($a) break + # Arc information + + set arc [list $a] + lappend arc [lindex $np($dst) 0] + if {[info exists arcAttr($a)]} { + upvar ${name}::$arcAttr($a) data + lappend arc [array get data] + } else { + lappend arc {} + } + + # Add weight information, if there is any. + + if {[info exists arcWeight($a)]} { + lappend arc $arcWeight($a) + } + + # Add the information to the node + # indices ... + + lappend np($src) $arc + } + + # Combine the transient data into one result. + + set result [list] + foreach n $nodes { + lappend result $n + lappend result [lindex $np($n) 1] + lappend result [lrange $np($n) 2 end] + } + lappend result [array get graphAttr] + + return $result +} + +# ::struct::graph::_set -- +# +# Set or get a keyed value from the graph itself +# +# Arguments: +# name name of the graph. +# key attribute to modify or query +# args ?value? +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::_set {name key args} { + if { [llength $args] > 1 } { + return -code error "wrong # args: should be \"$name set key ?value?\"" + } + if { [llength $args] > 0 } { + variable ${name}::graphAttr + return [set graphAttr($key) [lindex $args end]] + } else { + # Getting a value + return [_get $name $key] + } +} + +# ::struct::graph::_swap -- +# +# Swap two nodes in a graph. +# +# Arguments: +# name name of the graph. +# node1 first node to swap. +# node2 second node to swap. +# +# Results: +# None. + +proc ::struct::graph::_swap {name node1 node2} { + # Can only swap two real nodes + CheckMissingNode $name $node1 + CheckMissingNode $name $node2 + + # Can't swap a node with itself + if { [string equal $node1 $node2] } { + return -code error "cannot swap node \"$node1\" with itself" + } + + # Swapping nodes means swapping their labels, values and arcs + variable ${name}::outArcs + variable ${name}::inArcs + variable ${name}::arcNodes + variable ${name}::nodeAttr + + # Redirect arcs to the new nodes. + + foreach e $inArcs($node1) {lset arcNodes($e) end $node2} + foreach e $inArcs($node2) {lset arcNodes($e) end $node1} + foreach e $outArcs($node1) {lset arcNodes($e) 0 $node2} + foreach e $outArcs($node2) {lset arcNodes($e) 0 $node1} + + # Swap arc lists + + set tmp $inArcs($node1) + set inArcs($node1) $inArcs($node2) + set inArcs($node2) $tmp + + set tmp $outArcs($node1) + set outArcs($node1) $outArcs($node2) + set outArcs($node2) $tmp + + # Swap the values + # More complicated now with the possibility that nodes do not have + # attribute storage associated with them. But also + # simpler as we just have to swap/move the array + # reference + + if { + [set ia [info exists nodeAttr($node1)]] || + [set ib [info exists nodeAttr($node2)]] + } { + # At least one of the nodes has attribute data. We simply swap + # the references to the arrays containing them. No need to + # copy the actual data around. + + if {$ia && $ib} { + set tmp $nodeAttr($node1) + set nodeAttr($node1) $nodeAttr($node2) + set nodeAttr($node2) $tmp + } elseif {$ia} { + set nodeAttr($node2) $nodeAttr($node1) + unset nodeAttr($node1) + } elseif {$ib} { + set nodeAttr($node1) $nodeAttr($node2) + unset nodeAttr($node2) + } else { + return -code error "Impossible condition." + } + } ; # else: No attribute storage => Nothing to do {} + + return +} + +# ::struct::graph::_unset -- +# +# Remove a keyed value from the graph itself +# +# Arguments: +# name name of the graph. +# key attribute to remove +# +# Results: +# None. + +proc ::struct::graph::_unset {name key} { + variable ${name}::graphAttr + if {[info exists graphAttr($key)]} { + unset graphAttr($key) + } + return +} + +# ::struct::graph::_walk -- +# +# Walk a graph using a pre-order depth or breadth first +# search. Pre-order DFS is the default. At each node that is visited, +# a command will be called with the name of the graph and the node. +# +# Arguments: +# name name of the graph. +# node node at which to start. +# args additional args: ?-order pre|post|both? ?-type {bfs|dfs}? +# -command cmd +# +# Results: +# None. + +proc ::struct::graph::_walk {name node args} { + set usage "$name walk node ?-dir forward|backward?\ + ?-order pre|post|both? ?-type bfs|dfs? -command cmd" + + if {[llength $args] < 2} { + return -code error "wrong # args: should be \"$usage\"" + } + + CheckMissingNode $name $node + + # Set defaults + set type dfs + set order pre + set cmd "" + set dir forward + + # Process specified options + for {set i 0} {$i < [llength $args]} {incr i} { + set flag [lindex $args $i] + switch -glob -- $flag { + "-type" { + incr i + if { $i >= [llength $args] } { + return -code error "value for \"$flag\" missing: should be \"$usage\"" + } + set type [string tolower [lindex $args $i]] + } + "-order" { + incr i + if { $i >= [llength $args] } { + return -code error "value for \"$flag\" missing: should be \"$usage\"" + } + set order [string tolower [lindex $args $i]] + } + "-command" { + incr i + if { $i >= [llength $args] } { + return -code error "value for \"$flag\" missing: should be \"$usage\"" + } + set cmd [lindex $args $i] + } + "-dir" { + incr i + if { $i >= [llength $args] } { + return -code error "value for \"$flag\" missing: should be \"$usage\"" + } + set dir [string tolower [lindex $args $i]] + } + default { + return -code error "unknown option \"$flag\": should be \"$usage\"" + } + } + } + + # Make sure we have a command to run, otherwise what's the point? + if { [string equal $cmd ""] } { + return -code error "no command specified: should be \"$usage\"" + } + + # Validate that the given type is good + switch -glob -- $type { + "dfs" { + set type "dfs" + } + "bfs" { + set type "bfs" + } + default { + return -code error "bad search type \"$type\": must be bfs or dfs" + } + } + + # Validate that the given order is good + switch -glob -- $order { + "both" { + set order both + } + "pre" { + set order pre + } + "post" { + set order post + } + default { + return -code error "bad search order \"$order\": must be both,\ + pre, or post" + } + } + + # Validate that the given direction is good + switch -glob -- $dir { + "forward" { + set dir -out + } + "backward" { + set dir -in + } + default { + return -code error "bad search direction \"$dir\": must be\ + backward or forward" + } + } + + # Do the walk + + set st [list ] + lappend st $node + array set visited {} + + if { [string equal $type "dfs"] } { + if { [string equal $order "pre"] } { + # Pre-order Depth-first search + + while { [llength $st] > 0 } { + set node [lindex $st end] + ldelete st end + + # Skip all nodes already visited via some other path + # through the graph. + if {[info exists visited($node)]} continue + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy enter $name $node + uplevel 1 $cmdcpy + + set visited($node) . + + # Add this node's neighbours (according to direction) + # Have to add them in reverse order + # so that they will be popped left-to-right + + set next [_nodes $name $dir $node] + set len [llength $next] + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + set nextnode [lindex $next $i] + if {[info exists visited($nextnode)]} { + # Skip nodes already visited + continue + } + lappend st $nextnode + } + } + } elseif { [string equal $order "post"] } { + # Post-order Depth-first search + + while { [llength $st] > 0 } { + set node [lindex $st end] + + if {[info exists visited($node)]} { + # Second time we are here, pop it, + # then evaluate the command. + + ldelete st end + # Bug 2420330. Note: The visited node may be + # multiple times on the stack (neighbour of more + # than one node). Remove all occurences. + while {[set index [lsearch -exact $st $node]] != -1} { + set st [lreplace $st $index $index] + } + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy leave $name $node + uplevel 1 $cmdcpy + } else { + # First visit. Remember it. + set visited($node) . + + # Add this node's neighbours. + set next [_nodes $name $dir $node] + set len [llength $next] + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + set nextnode [lindex $next $i] + if {[info exists visited($nextnode)]} { + # Skip nodes already visited + continue + } + lappend st $nextnode + } + } + } + } else { + # Both-order Depth-first search + + while { [llength $st] > 0 } { + set node [lindex $st end] + + if {[info exists visited($node)]} { + # Second time we are here, pop it, + # then evaluate the command. + + ldelete st end + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy leave $name $node + uplevel 1 $cmdcpy + } else { + # First visit. Remember it. + set visited($node) . + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy enter $name $node + uplevel 1 $cmdcpy + + # Add this node's neighbours. + set next [_nodes $name $dir $node] + set len [llength $next] + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + set nextnode [lindex $next $i] + if {[info exists visited($nextnode)]} { + # Skip nodes already visited + continue + } + lappend st $nextnode + } + } + } + } + + } else { + if { [string equal $order "pre"] } { + # Pre-order Breadth first search + while { [llength $st] > 0 } { + set node [lindex $st 0] + ldelete st 0 + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy enter $name $node + uplevel 1 $cmdcpy + + set visited($node) . + + # Add this node's neighbours. + foreach child [_nodes $name $dir $node] { + if {[info exists visited($child)]} { + # Skip nodes already visited + continue + } + lappend st $child + } + } + } else { + # Post-order Breadth first search + # Both-order Breadth first search + # Haven't found anything in Knuth + # and unable to define something + # consistent for myself. Leave it + # out. + + return -code error "unable to do a ${order}-order breadth first walk" + } + } + return +} + +# ::struct::graph::Union -- +# +# Return a list which is the union of the elements +# in the specified lists. +# +# Arguments: +# args list of lists representing sets. +# +# Results: +# set list representing the union of the argument lists. + +proc ::struct::graph::Union {args} { + switch -- [llength $args] { + 0 { + return {} + } + 1 { + return [lindex $args 0] + } + default { + foreach set $args { + foreach e $set { + set tmp($e) . + } + } + return [array names tmp] + } + } +} + +# ::struct::graph::GenAttributeStorage -- +# +# Create an array to store the attributes of a node in. +# +# Arguments: +# name Name of the graph containing the node +# type Type of object for the attribute +# obj Name of the node or arc which got attributes. +# +# Results: +# none + +proc ::struct::graph::GenAttributeStorage {name type obj} { + variable ${name}::nextAttr + upvar ${name}::${type}Attr attribute + + set attr "a[incr nextAttr]" + set attribute($obj) $attr + return +} + +proc ::struct::graph::CheckMissingArc {name arc} { + if {![__arc_exists $name $arc]} { + return -code error "arc \"$arc\" does not exist in graph \"$name\"" + } +} + +proc ::struct::graph::CheckMissingNode {name node {prefix {}}} { + if {![__node_exists $name $node]} { + return -code error "${prefix}node \"$node\" does not exist in graph \"$name\"" + } +} + +proc ::struct::graph::CheckDuplicateArc {name arc} { + if {[__arc_exists $name $arc]} { + return -code error "arc \"$arc\" already exists in graph \"$name\"" + } +} + +proc ::struct::graph::CheckDuplicateNode {name node} { + if {[__node_exists $name $node]} { + return -code error "node \"$node\" already exists in graph \"$name\"" + } +} + +proc ::struct::graph::CheckE {name what arguments} { + + # Discriminate between conditions and nodes + + upvar 1 haveCond haveCond ; set haveCond 0 + upvar 1 haveKey haveKey ; set haveKey 0 + upvar 1 key key ; set key {} + upvar 1 haveValue haveValue ; set haveValue 0 + upvar 1 value value ; set value {} + upvar 1 haveFilter haveFilter ; set haveFilter 0 + upvar 1 fcmd fcmd ; set fcmd {} + upvar 1 cond cond ; set cond "none" + upvar 1 condNodes condNodes ; set condNodes {} + + set wa_usage "wrong # args: should be \"$name $what ?-key key? ?-value value? ?-filter cmd? ?-in|-out|-adj|-inner|-embedding node node...?\"" + set seenodes 0 + + for {set i 0} {$i < [llength $arguments]} {incr i} { + set arg [lindex $arguments $i] + switch -glob -- $arg { + -in - + -out - + -adj - + -inner - + -embedding { + if {$haveCond} { + return -code error "invalid restriction:\ + illegal multiple use of\ + \"-in\"|\"-out\"|\"-adj\"|\"-inner\"|\"-embedding\"" + } + + set haveCond 1 + set cond [string range $arg 1 end] + set seenodes 1 + } + -key { + if {($i + 1) == [llength $arguments]} { + return -code error $wa_usage + } + if {$haveKey} { + return -code error {invalid restriction: illegal multiple use of "-key"} + } + + incr i + set key [lindex $arguments $i] + set haveKey 1 + set seenodes 0 + } + -value { + if {($i + 1) == [llength $arguments]} { + return -code error $wa_usage + } + if {$haveValue} { + return -code error {invalid restriction: illegal multiple use of "-value"} + } + + incr i + set value [lindex $arguments $i] + set haveValue 1 + set seenodes 0 + } + -filter { + if {($i + 1) == [llength $arguments]} { + return -code error $wa_usage + } + if {$haveFilter} { + return -code error {invalid restriction: illegal multiple use of "-filter"} + } + + incr i + set fcmd [lindex $arguments $i] + set haveFilter 1 + set seenodes 0 + } + -* { + if {$seenodes} { + lappend condNodes $arg + } else { + return -code error "bad restriction \"$arg\": must be -adj, -embedding,\ + -filter, -in, -inner, -key, -out, or -value" + } + } + default { + lappend condNodes $arg + } + } + } + + # Validate that there are nodes to use in the restriction. + # otherwise what's the point? + if {$haveCond} { + if {[llength $condNodes] == 0} { + return -code error $wa_usage + } + + # Remove duplicates. Note: lsort -unique is not present in Tcl + # 8.2, thus not usable here. + + array set nx {} + foreach c $condNodes {set nx($c) .} + set condNodes [array names nx] + unset nx + + # Make sure that the specified nodes exist! + foreach node $condNodes {CheckMissingNode $name $node} + } + + if {$haveValue && !$haveKey} { + return -code error {invalid restriction: use of "-value" without "-key"} + } + + return +} + +proc ::struct::graph::CheckSerialization {ser gavar navar aavar inavar outavar arcnvar arcwvar} { + upvar 1 \ + $gavar graphAttr \ + $navar nodeAttr \ + $aavar arcAttr \ + $inavar inArcs \ + $outavar outArcs \ + $arcnvar arcNodes \ + $arcwvar arcWeight + + array set nodeAttr {} + array set arcAttr {} + array set inArcs {} + array set outArcs {} + array set arcNodes {} + array set arcWeight {} + + # Overall length ok ? + if {[llength $ser] % 3 != 1} { + return -code error \ + "error in serialization: list length not 1 mod 3." + } + + # Attribute length ok ? Dictionary! + set graphAttr [lindex $ser end] + if {[llength $graphAttr] % 2} { + return -code error \ + "error in serialization: malformed graph attribute dictionary." + } + + # Basic decoder pass + + foreach {node attr narcs} [lrange $ser 0 end-1] { + if {![info exists inArcs($node)]} { + set inArcs($node) [list] + } + set outArcs($node) [list] + + # Attribute length ok ? Dictionary! + if {[llength $attr] % 2} { + return -code error \ + "error in serialization: malformed node attribute dictionary." + } + # Remember attribute data only for non-empty nodes + if {[llength $attr]} { + set nodeAttr($node) $attr + } + + foreach arcd $narcs { + if { + ([llength $arcd] != 3) && + ([llength $arcd] != 4) + } { + return -code error \ + "error in serialization: arc information length not 3 or 4." + } + + foreach {arc dst aattr} $arcd break + + if {[info exists arcNodes($arc)]} { + return -code error \ + "error in serialization: duplicate definition of arc \"$arc\"." + } + + # Attribute length ok ? Dictionary! + if {[llength $aattr] % 2} { + return -code error \ + "error in serialization: malformed arc attribute dictionary." + } + # Remember attribute data only for non-empty nodes + if {[llength $aattr]} { + set arcAttr($arc) $aattr + } + + # Remember weight data if it was specified. + if {[llength $arcd] == 4} { + set arcWeight($arc) [lindex $arcd 3] + } + + # Destination reference ok ? + if { + ![string is integer -strict $dst] || + ($dst % 3) || + ($dst < 0) || + ($dst >= [llength $ser]) + } { + return -code error \ + "error in serialization: bad arc destination reference \"$dst\"." + } + + # Get destination and reconstruct the + # various relationships. + + set dstnode [lindex $ser $dst] + + set arcNodes($arc) [list $node $dstnode] + lappend inArcs($dstnode) $arc + lappend outArcs($node) $arc + } + } + + # Duplicate node names ? + + if {[array size outArcs] < ([llength $ser] / 3)} { + return -code error \ + "error in serialization: duplicate node names." + } + + # Ok. The data is now ready for the caller. + return +} + +########################## +# Private functions follow +# +# Do a compatibility version of [lset] for pre-8.4 versions of Tcl. +# This version does not do multi-arg [lset]! + +proc ::struct::graph::K { x y } { set x } + +if { [package vcompare [package provide Tcl] 8.4] < 0 } { + proc ::struct::graph::lset { var index arg } { + upvar 1 $var list + set list [::lreplace [K $list [set list {}]] $index $index $arg] + } +} + +proc ::struct::graph::ldelete {var index {end {}}} { + upvar 1 $var list + if {$end == {}} {set end $index} + set list [lreplace [K $list [set list {}]] $index $end] + return +} + +proc ::struct::graph::luniq {list} { + array set _ {} + set result [list] + foreach e $list { + if {[info exists _($e)]} {continue} + lappend result $e + set _($e) . + } + return $result +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Put 'graph::graph' into the general structure namespace + # for pickup by the main management. + + namespace import -force graph::graph_tcl +} + diff --git a/src/bootsupport/lib/struct/graphops.tcl b/src/bootsupport/lib/struct/graphops.tcl new file mode 100644 index 00000000..91ec450d --- /dev/null +++ b/src/bootsupport/lib/struct/graphops.tcl @@ -0,0 +1,3787 @@ +# graphops.tcl -- +# +# Operations on and algorithms for graph data structures. +# +# Copyright (c) 2008 Alejandro Paz , algorithm implementation +# Copyright (c) 2008 Andreas Kupries, integration with Tcllib's struct::graph +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: graphops.tcl,v 1.19 2009/09/24 19:30:10 andreas_kupries Exp $ + +# ### ### ### ######### ######### ######### +## Requisites + +package require Tcl 8.6 + +package require struct::disjointset ; # Used by kruskal -- 8.6 required +package require struct::prioqueue ; # Used by kruskal, prim +package require struct::queue ; # Used by isBipartite?, connectedComponent(Of) +package require struct::stack ; # Used by tarjan +package require struct::graph ; # isBridge, isCutVertex +package require struct::tree ; # Used by BFS + +# ### ### ### ######### ######### ######### +## + +namespace eval ::struct::graph::op {} + +# ### ### ### ######### ######### ######### +## + +# This command constructs an adjacency matrix representation of the +# graph argument. + +# Reference: http://en.wikipedia.org/wiki/Adjacency_matrix +# +# Note: The reference defines the matrix in such a way that some of +# the limitations of the code here are not present. I.e. the +# definition at wikipedia deals properly with arc directionality +# and parallelism. +# +# TODO: Rework the code so that the result is in line with the reference. +# Add features to handle weights as well. + +proc ::struct::graph::op::toAdjacencyMatrix {g} { + set nodeList [lsort -dict [$g nodes]] + # Note the lsort. This is used to impose some order on the matrix, + # for comparability of results. Otherwise different versions of + # Tcl and struct::graph (critcl) may generate different, yet + # equivalent matrices, dependent on things like the order a hash + # search is done, or nodes have been added to the graph, or ... + + # Fill an array for index tracking later. Note how we start from + # index 1. This allows us avoid multiple expr+1 later on when + # iterating over the nodes and converting the names to matrix + # indices. See (*). + + set i 1 + foreach n $nodeList { + set nodeDict($n) $i + incr i + } + + set matrix {} + lappend matrix [linsert $nodeList 0 {}] + + # Setting up a template row with all of it's elements set to zero. + + set baseRow 0 + foreach n $nodeList { + lappend baseRow 0 + } + + foreach node $nodeList { + + # The first element in every row is the name of its + # corresponding node. Using lreplace to overwrite the initial + # data in the template we get a copy apart from the template, + # which we can then modify further. + + set currentRow [lreplace $baseRow 0 0 $node] + + # Iterate over the neighbours, also known as 'adjacent' + # rows. The exact set of neighbours depends on the mode. + + foreach neighbour [$g nodes -adj $node] { + # Set value for neighbour on this node list + set at $nodeDict($neighbour) + + # (*) Here we avoid +1 due to starting from index 1 in the + # initialization of nodeDict. + set currentRow [lreplace $currentRow $at $at 1] + } + lappend matrix $currentRow + } + + # The resulting matrix is a list of lists, size (n+1)^2 where n = + # number of nodes. First row and column (index 0) are node + # names. The other entries are boolean flags. True when an arc is + # present, False otherwise. The matrix represents an + # un-directional form of the graph with parallel arcs collapsed. + + return $matrix +} + +#Adjacency List +#------------------------------------------------------------------------------------- +#Procedure creates for graph G, it's representation as Adjacency List. +# +#In comparison to Adjacency Matrix it doesn't force using array with quite big +#size - V^2, where V is a number of vertices ( instead, memory we need is about O(E) ). +#It's especially important when concerning rare graphs ( graphs with amount of vertices +#far bigger than amount of edges ). In practise, it turns out that generally, +#Adjacency List is more effective. Moreover, going through the set of edges take +#less time ( O(E) instead of O(E^2) ) and adding new edges is rapid. +#On the other hand, checking if particular edge exists in graph G takes longer +#( checking if edge {v1,v2} belongs to E(G) in proportion to min{deg(v1,v2)} ). +#Deleting an edge is also longer - in proportion to max{ deg(v1), deg(v2) }. +# +#Input: +# graph G ( directed or undirected ). Default is undirected. +# +#Output: +# Adjacency List for graph G, represented by dictionary containing lists of adjacent nodes +#for each node in G (key). +# +#Options: +# -weights - adds to returning dictionary arc weights for each connection between nodes, so +#each node returned by list as adjacent has additional parameter - weight of arc between him and +#current node. +# -directed - sets graph G to be interpreted as directed graph. +# +#Reference: +#http://en.wikipedia.org/wiki/Adjacency_list +# + +proc ::struct::graph::op::toAdjacencyList {G args} { + + set arcTraversal "undirected" + set weightsOn 0 + + #options for procedure + foreach option $args { + switch -exact -- $option { + -directed { + set arcTraversal "directed" + } + -weights { + #checking if all edges have their weights set + VerifyWeightsAreOk $G + set weightsOn 1 + } + default { + return -code error "Bad option \"$option\". Expected -directed or -weights" + } + } + } + + set V [lsort -dict [$G nodes]] + + #mainloop + switch -exact -- $arcTraversal { + undirected { + #setting up the Adjacency List with nodes + foreach v [lsort -dict [$G nodes]] { + dict set AdjacencyList $v {} + } + #appending the edges adjacent to nodes + foreach e [$G arcs] { + + set v [$G arc source $e] + set u [$G arc target $e] + + if { !$weightsOn } { + dict lappend AdjacencyList $v $u + dict lappend AdjacencyList $u $v + } else { + dict lappend AdjacencyList $v [list $u [$G arc getweight $e]] + dict lappend AdjacencyList $u [list $v [$G arc getweight $e]] + } + } + #deleting duplicated edges + foreach x [dict keys $AdjacencyList] { + dict set AdjacencyList $x [lsort -unique [dict get $AdjacencyList $x]] + } + } + directed { + foreach v $V { + set E [$G arcs -out $v] + set adjNodes {} + foreach e $E { + if { !$weightsOn } { + lappend adjNodes [$G arc target $e] + } else { + lappend adjNodes [list [$G arc target $e] [$G arc getweight $e]] + } + } + dict set AdjacencyList $v $adjNodes + } + } + default { + return -code error "Error while executing procedure" + } + } + + return $AdjacencyList +} + +#Bellman's Ford Algorithm +#------------------------------------------------------------------------------------- +#Searching for shortest paths between chosen node and +#all other nodes in graph G. Based on relaxation method. In comparison to Dijkstra +#it doesn't assume that all weights on edges are positive. However, this generality +#costs us time complexity - O(V*E), where V is number of vertices and E is number +#of edges. +# +#Input: +#Directed graph G, weighted on edges and not containing +#any cycles with negative sum of weights ( the presence of such cycles means +#there is no shortest path, since the total weight becomes lower each time the +#cycle is traversed ). Possible negative weights on edges. +# +#Output: +#dictionary d[u] - distances from start node to each other node in graph G. +# +#Reference: http://en.wikipedia.org/wiki/Bellman-Ford_algorithm +# + +proc ::struct::graph::op::BellmanFord { G startnode } { + + #checking if all edges have their weights set + VerifyWeightsAreOk $G + + #checking if the startnode exists in given graph G + if {![$G node exists $startnode]} { + return -code error "node \"$startnode\" does not exist in graph \"$G\"" + } + + #sets of nodes and edges for graph G + set V [$G nodes] + set E [$G arcs] + + #initialization + foreach i $V { + dict set distances $i Inf + } + + dict set distances $startnode 0 + + #main loop (relaxation) + for { set i 1 } { $i <= ([dict size $distances]-1) } { incr i } { + + foreach j $E { + set u [$G arc source $j] ;# start node of edge j + set v [$G arc target $j] ;# end node of edge j + + if { [ dict get $distances $v ] > [ dict get $distances $u ] + [ $G arc getweight $j ]} { + dict set distances $v [ expr {[dict get $distances $u] + [$G arc getweight $j]} ] + } + } + } + + #checking if there exists cycle with negative sum of weights + foreach i $E { + set u [$G arc source $i] ;# start node of edge i + set v [$G arc target $i] ;# end node of edge i + + if { [dict get $distances $v] > [ dict get $distances $u ] + [$G arc getweight $i] } { + return -code error "Error. Given graph \"$G\" contains cycle with negative sum of weights." + } + } + + return $distances + +} + + +#Johnson's Algorithm +#------------------------------------------------------------------------------------- +#Searching paths between all pairs of vertices in graph. For rare graphs +#asymptotically quicker than Floyd-Warshall's algorithm. Johnson's algorithm +#uses Bellman-Ford's and Dijkstra procedures. +# +#Input: +#Directed graph G, weighted on edges and not containing +#any cycles with negative sum of weights ( the presence of such cycles means +#there is no shortest path, since the total weight becomes lower each time the +#cycle is traversed ). Possible negative weights on edges. +#Possible options: +# -filter ( returns only existing distances, cuts all Inf values for +# non-existing connections between pairs of nodes ) +# +#Output: +# Dictionary containing distances between all pairs of vertices +# +#Reference: http://en.wikipedia.org/wiki/Johnson_algorithm +# + +proc ::struct::graph::op::Johnsons { G args } { + + #options for procedure + set displaymode 0 + foreach option $args { + switch -exact -- $option { + -filter { + set displaymode 1 + } + default { + return -code error "Bad option \"$option\". Expected -filter" + } + } + } + + #checking if all edges have their weights set + VerifyWeightsAreOk $G + + #Transformation of graph G - adding one more node connected with + #each existing node with an edge, which weight is 0 + set V [$G nodes] + set s [$G node insert] + + foreach i $V { + if { $i ne $s } { + $G arc insert $s $i + } + } + + $G arc setunweighted + + #set potential values with Bellman-Ford's + set h [BellmanFord $G $s] + + #transformed graph no needed longer - deleting added node and edges + $G node delete $s + + #setting new weights for edges in graph G + foreach i [$G arcs] { + set u [$G arc source $i] + set v [$G arc target $i] + + lappend weights [$G arc getweight $i] + $G arc setweight $i [ expr { [$G arc getweight $i] + [dict get $h $u] - [dict get $h $v] } ] + } + + #finding distances between all pair of nodes with Dijkstra started from each node + foreach i [$G nodes] { + set dijkstra [dijkstra $G $i -arcmode directed -outputformat distances] + + foreach j [$G nodes] { + if { $i ne $j } { + if { $displaymode eq 1 } { + if { [dict get $dijkstra $j] ne "Inf" } { + dict set values [list $i $j] [ expr {[ dict get $dijkstra $j] - [dict get $h $i] + [dict get $h $j]} ] + } + } else { + dict set values [list $i $j] [ expr {[ dict get $dijkstra $j] - [dict get $h $i] + [dict get $h $j]} ] + } + } + } + } + + #setting back edge weights for graph G + set k 0 + foreach i [$G arcs] { + $G arc setweight $i [ lindex $weights $k ] + incr k + } + + return $values +} + + +#Floyd-Warshall's Algorithm +#------------------------------------------------------------------------------------- +#Searching shortest paths between all pairs of edges in weighted graphs. +#Time complexity: O(V^3) - where V is number of vertices. +#Memory complexity: O(V^2) +#Input: directed weighted graph G +#Output: dictionary containing shortest distances to each node from each node +# +#Algorithm finds solutions dynamically. It compares all possible paths through the graph +#between each pair of vertices. Graph shouldn't possess any cycle with negative +#sum of weights ( the presence of such cycles means there is no shortest path, +#since the total weight becomes lower each time the cycle is traversed ). +#On the other hand algorithm can be used to find those cycles - if any shortest distance +#found by algorithm for any nodes v and u (when v is the same node as u) is negative, +#that node surely belong to at least one negative cycle. +# +#Reference: http://en.wikipedia.org/wiki/Floyd-Warshall_algorithm +# + +proc ::struct::graph::op::FloydWarshall { G } { + + VerifyWeightsAreOk $G + + foreach v1 [$G nodes] { + foreach v2 [$G nodes] { + dict set values [list $v1 $v2] Inf + } + dict set values [list $v1 $v1] 0 + } + + foreach e [$G arcs] { + set v1 [$G arc source $e] + set v2 [$G arc target $e] + dict set values [list $v1 $v2] [$G arc getweight $e] + } + + foreach u [$G nodes] { + foreach v1 [$G nodes] { + foreach v2 [$G nodes] { + + set x [dict get $values [list $v1 $u]] + set y [dict get $values [list $u $v2]] + set d [ expr {$x + $y}] + + if { [dict get $values [list $v1 $v2]] > $d } { + dict set values [list $v1 $v2] $d + } + } + } + } + #finding negative cycles + foreach v [$G nodes] { + if { [dict get $values [list $v $v]] < 0 } { + return -code error "Error. Given graph \"$G\" contains cycle with negative sum of weights." + } + } + + return $values +} + +#Metric Travelling Salesman Problem (TSP) - 2 approximation algorithm +#------------------------------------------------------------------------------------- +#Travelling salesman problem is a very popular problem in graph theory, where +#we are trying to find minimal Hamilton cycle in weighted complete graph. In other words: +#given a list of cities (nodes) and their pairwise distances (edges), the task is to find +#a shortest possible tour that visits each city exactly once. +#TSP problem is NP-Complete, so there is no efficient algorithm to solve it. Greedy methods +#are getting extremely slow, with the increase in the set of nodes. +# +#For this algorithm we consider a case when for given graph G, the triangle inequality is +#satisfied. So for example, for any three nodes A, B and C the distance between A and C must +#be at most the distance from A to B plus the distance from B to C. What's important +#most of the considered cases in TSP problem will satisfy this condition. +# +#Input: undirected, weighted graph G +#Output: approximated solution of minimum Hamilton Cycle - closed path visiting all nodes, +#each exactly one time. +# +#Reference: http://en.wikipedia.org/wiki/Travelling_salesman_problem +# + +proc ::struct::graph::op::MetricTravellingSalesman { G } { + + #checking if graph is connected + if { ![isConnected? $G] } { + return -code error "Error. Given graph \"$G\" is not a connected graph." + } + #checking if all weights are set + VerifyWeightsAreOk $G + + # Extend graph to make it complete. + # NOTE: The graph is modified in place. + createCompleteGraph $G originalEdges + + #create minimum spanning tree for graph G + set T [prim $G] + + #TGraph - spanning tree of graph G + #filling TGraph with edges and nodes + set TGraph [createTGraph $G $T 0] + + #finding Hamilton cycle + set result [findHamiltonCycle $TGraph $originalEdges $G] + + $TGraph destroy + + # Note: Fleury, which is the algorithm used to find our the cycle + # (inside of isEulerian?) is inherently directionless, i.e. it + # doesn't care about arc direction. This does not matter if our + # input is a symmetric graph, i.e. u->v and v->u have the same + # weight for all nodes u, v in G, u != v. But for an asymmetric + # graph as our input we really have to check the two possible + # directions of the returned tour for the one with the smaller + # weight. See test case MetricTravellingSalesman-1.1 for an + # exmaple. + + set w {} + foreach a [$G arcs] { + set u [$G arc source $a] + set v [$G arc target $a] + set uv [list $u $v] + # uv = <$G arc nodes $arc> + dict set w $uv [$G arc getweight $a] + } + foreach k [dict keys $w] { + lassign $k u v + set vu [list $v $u] + if {[dict exists $w $vu]} continue + dict set w $vu [dict get $w $k] + } + + set reversed [lreverse $result] + + if {[TourWeight $w $result] > [TourWeight $w $reversed]} { + return $reversed + } + return $result +} + +proc ::struct::graph::op::TourWeight {w tour} { + set total 0 + foreach \ + u [lrange $tour 0 end-1] \ + v [lrange $tour 1 end] { + set uv [list $u $v] + set total [expr { + $total + + [dict get $w $uv] + }] + } + return $total +} + +#Christofides Algorithm - for Metric Travelling Salesman Problem (TSP) +#------------------------------------------------------------------------------------- +#Travelling salesman problem is a very popular problem in graph theory, where +#we are trying to find minimal Hamilton cycle in weighted complete graph. In other words: +#given a list of cities (nodes) and their pairwise distances (edges), the task is to find +#a shortest possible tour that visits each city exactly once. +#TSP problem is NP-Complete, so there is no efficient algorithm to solve it. Greedy methods +#are getting extremely slow, with the increase in the set of nodes. +# +#For this algorithm we consider a case when for given graph G, the triangle inequality is +#satisfied. So for example, for any three nodes A, B and C the distance between A and C must +#be at most the distance from A to B plus the distance from B to C. What's important +#most of the considered cases in TSP problem will satisfy this condition. +# +#Christofides is a 3/2 approximation algorithm. For a graph given at input, it returns +#found Hamilton cycle (list of nodes). +# +#Reference: http://en.wikipedia.org/wiki/Christofides_algorithm +# + +proc ::struct::graph::op::Christofides { G } { + + #checking if graph is connected + if { ![isConnected? $G] } { + return -code error "Error. Given graph \"$G\" is not a connected graph." + } + #checking if all weights are set + VerifyWeightsAreOk $G + + createCompleteGraph $G originalEdges + + #create minimum spanning tree for graph G + set T [prim $G] + + #setting graph algorithm is working on - spanning tree of graph G + set TGraph [createTGraph $G $T 1] + + set oddTGraph [struct::graph] + + foreach v [$TGraph nodes] { + if { [$TGraph node degree $v] % 2 == 1 } { + $oddTGraph node insert $v + } + } + + #create complete graph + foreach v [$oddTGraph nodes] { + foreach u [$oddTGraph nodes] { + if { ($u ne $v) && ![$oddTGraph arc exists [list $u $v]] } { + $oddTGraph arc insert $v $u [list $v $u] + $oddTGraph arc setweight [list $v $u] [distance $G $v $u] + } + + } + } + + #### + # MAX MATCHING HERE!!! + #### + set M [GreedyMaxMatching $oddTGraph] + + foreach e [$oddTGraph arcs] { + if { ![struct::set contains $M $e] } { + $oddTGraph arc delete $e + } + } + + #operation: M + T + foreach e [$oddTGraph arcs] { + set u [$oddTGraph arc source $e] + set v [$oddTGraph arc target $e] + set uv [list $u $v] + + # Check if the arc in max-matching is parallel or not, to make + # sure that we always insert an anti-parallel arc. + + if {[$TGraph arc exists $uv]} { + set vu [list $v $u] + $TGraph arc insert $v $u $vu + $TGraph arc setweight $vu [$oddTGraph arc getweight $e] + } else { + $TGraph arc insert $u $v $uv + $TGraph arc setweight $uv [$oddTGraph arc getweight $e] + } + } + + #finding Hamilton Cycle + set result [findHamiltonCycle $TGraph $originalEdges $G] + $oddTGraph destroy + $TGraph destroy + return $result +} + +#Greedy Max Matching procedure, which finds maximal ( not maximum ) matching +#for given graph G. It adds edges to solution, beginning from edges with the +#lowest cost. + +proc ::struct::graph::op::GreedyMaxMatching {G} { + + set maxMatch {} + + foreach e [sortEdges $G] { + set v [$G arc source $e] + set u [$G arc target $e] + set neighbours [$G arcs -adj $v $u] + set noAdjacentArcs 1 + + lremove neighbours $e + + foreach a $neighbours { + if { $a in $maxMatch } { + set noAdjacentArcs 0 + break + } + } + if { $noAdjacentArcs } { + lappend maxMatch $e + } + } + + return $maxMatch +} + +#Subprocedure which for given graph G, returns the set of edges +#sorted with their costs. +proc ::struct::graph::op::sortEdges {G} { + set weights [$G arc weights] + + # NOTE: Look at possible rewrite, simplification. + + set sortedEdges {} + + foreach val [lsort [dict values $weights]] { + foreach x [dict keys $weights] { + if { [dict get $weights $x] == $val } { + set weights [dict remove $weights $x] + lappend sortedEdges $x ;#[list $val $x] + } + } + } + + return $sortedEdges +} + +#Subprocedure, which for given graph G, returns the dictionary +#containing edges sorted by weights (sortMode -> weights) or +#nodes sorted by degree (sortMode -> degrees). + +proc ::struct::graph::op::sortGraph {G sortMode} { + + switch -exact -- $sortMode { + weights { + set weights [$G arc weights] + foreach val [lsort [dict values $weights]] { + foreach x [dict keys $weights] { + if { [dict get $weights $x] == $val } { + set weights [dict remove $weights $x] + dict set sortedVals $x $val + } + } + } + } + degrees { + foreach v [$G nodes] { + dict set degrees $v [$G node degree $v] + } + foreach x [lsort -integer -decreasing [dict values $degrees]] { + foreach y [dict keys $degrees] { + if { [dict get $degrees $y] == $x } { + set degrees [dict remove $degrees $y] + dict set sortedVals $y $x + } + } + } + } + default { + return -code error "Unknown sort mode \"$sortMode\", expected weights, or degrees" + } + } + + return $sortedVals +} + +#Finds Hamilton cycle in given graph G +#Procedure used by Metric TSP Algorithms: +#Christofides and Metric TSP 2-approximation algorithm + +proc ::struct::graph::op::findHamiltonCycle {G originalEdges originalGraph} { + + isEulerian? $G tourvar tourstart + + # Note: The start node is not necessarily the source node of the + # first arc in the tour. The Fleury in isEulerian? may have walked + # the arcs against! their direction. See also the note in our + # caller (MetricTravellingSalesman). + + # Instead of reconstructing the start node by intersecting the + # node-set for first and last arc, we are taking the easy and get + # it directly from isEulerian?, as that command knows which node + # it had chosen for this. + + lappend result $tourstart + lappend tourvar [lindex $tourvar 0] + + set v $tourstart + foreach i $tourvar { + set u [$G node opposite $v $i] + + if { $u ni $result } { + set va [lindex $result end] + set vb $u + + if { ([list $va $vb] in $originalEdges) || ([list $vb $va] in $originalEdges) } { + lappend result $u + } else { + + set path [dict get [dijkstra $G $va] $vb] + + #reversing the path + set path [lreverse $path] + #cutting the start element + set path [lrange $path 1 end] + + #adding the path and the target element + lappend result {*}$path + lappend result $vb + } + } + set v $u + } + + set path [dict get [dijkstra $originalGraph [lindex $result 0]] [lindex $result end]] + set path [lreverse $path] + + set path [lrange $path 1 end] + + if { [llength $path] } { + lappend result {*}$path + } + + lappend result $tourstart + return $result +} + +#Subprocedure for TSP problems. +# +#Creating graph from sets of given nodes and edges. +#In option doubledArcs we decide, if we want edges to be +#duplicated or not: +#0 - duplicated (Metric TSP 2-approximation algorithm) +#1 - single (Christofides Algorithm) +# +#Note that it assumes that graph's edges are properly weighted. That +#condition is checked before in procedures that use createTGraph, but for +#other uses it should be taken into consideration. +# + +proc ::struct::graph::op::createTGraph {G Edges doubledArcs} { + #checking if given set of edges is proper (all edges are in graph G) + foreach e $Edges { + if { ![$G arc exists $e] } { + return -code error "Edge \"$e\" doesn't exist in graph \"$G\". Set the proper set of edges." + } + } + + set TGraph [struct::graph] + + #fill TGraph with nodes + foreach v [$G nodes] { + $TGraph node insert + } + + #fill TGraph with arcs + foreach e $Edges { + set v [$G arc source $e] + set u [$G arc target $e] + if { ![$TGraph arc exists [list $u $v]] } { + $TGraph arc insert $u $v [list $u $v] + $TGraph arc setweight [list $u $v] [$G arc getweight $e] + } + if { !$doubledArcs } { + if { ![$TGraph arc exists [list $v $u]] } { + $TGraph arc insert $v $u [list $v $u] + $TGraph arc setweight [list $v $u] [$G arc getweight $e] + } + } + } + + return $TGraph +} + +#Subprocedure for some algorithms, e.g. TSP algorithms. +# +#It returns graph filled with arcs missing to say that graph is complete. +#Also it sets variable originalEdges with edges, which existed in given +#graph G at beginning, before extending the set of edges. +# + +proc ::struct::graph::op::createCompleteGraph {G originalEdges} { + + upvar $originalEdges st + set st {} + foreach e [$G arcs] { + set v [$G arc source $e] + set u [$G arc target $e] + + lappend st [list $v $u] + } + + foreach v [$G nodes] { + foreach u [$G nodes] { + if { ($u != $v) && ([list $v $u] ni $st) && ([list $u $v] ni $st) && ![$G arc exists [list $u $v]] } { + $G arc insert $v $u [list $v $u] + $G arc setweight [list $v $u] Inf + } + } + } + return $G +} + + +#Maximum Cut - 2 approximation algorithm +#------------------------------------------------------------------------------------- +#Maximum cut problem is a problem finding a cut not smaller than any other cut. In +#other words, we divide set of nodes for graph G into such 2 sets of nodes U and V, +#that the amount of edges connecting U and V is as high as possible. +# +#Algorithm is a 2-approximation, so for ALG ( solution returned by Algorithm) and +#OPT ( optimal solution), such inequality is true: OPT <= 2 * ALG. +# +#Input: +#Graph G +#U - variable storing first set of nodes (cut) given by solution +#V - variable storing second set of nodes (cut) given by solution +# +#Output: +#Algorithm returns number of edges between found two sets of nodes. +# +#Reference: http://en.wikipedia.org/wiki/Maxcut +# + +proc ::struct::graph::op::MaxCut {G U V} { + + upvar $U _U + upvar $V _V + + set _U {} + set _V {} + set counter 0 + + foreach {u v} [lsort -dict [$G nodes]] { + lappend _U $u + if {$v eq ""} continue + lappend _V $v + } + + set val 1 + set ALG [countEdges $G $_U $_V] + while {$val>0} { + set val [cut $G _U _V $ALG] + if { $val > $ALG } { + set ALG $val + } + } + return $ALG +} + +#procedure replaces nodes between sets and checks if that change is profitable +proc ::struct::graph::op::cut {G Uvar Vvar param} { + + upvar $Uvar U + upvar $Vvar V + set _V {} + set _U {} + set value 0 + + set maxValue $param + set _U $U + set _V $V + + foreach v [$G nodes] { + + if { $v ni $_U } { + lappend _U $v + lremove _V $v + set value [countEdges $G $_U $_V] + } else { + lappend _V $v + lremove _U $v + set value [countEdges $G $_U $_V] + } + + if { $value > $maxValue } { + set U $_U + set V $_V + set maxValue $value + } else { + set _V $V + set _U $U + } + } + + set value $maxValue + + if { $value > $param } { + return $value + } else { + return 0 + } +} + +#Removing element from the list - auxiliary procedure +proc ::struct::graph::op::lremove {listVariable value} { + upvar 1 $listVariable var + set idx [lsearch -exact $var $value] + set var [lreplace $var $idx $idx] +} + +#procedure counts edges that link two sets of nodes +proc ::struct::graph::op::countEdges {G U V} { + + set value 0 + + foreach u $U { + foreach e [$G arcs -out $u] { + set v [$G arc target $e] + if {$v ni $V} continue + incr value + } + } + foreach v $V { + foreach e [$G arcs -out $v] { + set u [$G arc target $e] + if {$u ni $U} continue + incr value + } + } + + return $value +} + +#K-Center Problem - 2 approximation algorithm +#------------------------------------------------------------------------------------- +#Input: +#Undirected complete graph G, which satisfies triangle inequality. +#k - positive integer +# +#Definition: +#For any set S ( which is subset of V ) and node v, let the connect(v,S) be the +#cost of cheapest edge connecting v with any node in S. The goal is to find +#such S, that |S| = k and max_v{connect(v,S)} is possibly small. +# +#In other words, we can use it i.e. for finding best locations in the city ( nodes +#of input graph ) for placing k buildings, such that those buildings will be as close +#as possible to all other locations in town. +# +#Output: +#set of nodes - k center for graph G +# + +proc ::struct::graph::op::UnweightedKCenter {G k} { + + #checking if all weights for edges in graph G are set well + VerifyWeightsAreOk $G + + #checking if proper value of k is given at input + if { $k <= 0 } { + return -code error "The \"k\" value must be an positive integer." + } + + set j [ expr {$k+1} ] + + #variable for holding the graph G(i) in each iteration + set Gi [struct::graph] + #two squared graph G + set GiSQ [struct::graph] + #sorted set of edges for graph G + set arcs [sortEdges $G] + + #initializing both graph variables + foreach v [$G nodes] { + $Gi node insert $v + $GiSQ node insert $v + } + + #index i for each iteration + + #we seek for final solution, as long as the max independent + #set Mi (found in particular iterations), such that |Mi| <= k, is found. + for {set index 0} {$j > $k} {incr index} { + #source node of an edge we add in current iteration + set u [$G arc source [lindex $arcs $index]] + #target node of an edge we add in current iteration + set v [$G arc target [lindex $arcs $index]] + + #adding edge Ei to graph G(i) + $Gi arc insert $u $v [list $u $v] + #extending G(i-1)**2 to G(i)**2 using G(i) + set GiSQ [extendTwoSquaredGraph $GiSQ $Gi $u $v] + + #finding maximal independent set for G(i)**2 + set Mi [GreedyMaxIndependentSet $GiSQ] + + #number of nodes in maximal independent set that was found + set j [llength $Mi] + } + + $Gi destroy + $GiSQ destroy + return $Mi +} + +#Weighted K-Center - 3 approximation algorithm +#------------------------------------------------------------------------------------- +# +#The variation of unweighted k-center problem. Besides the fact graph is edge-weighted, +#there are also weights on vertices of input graph G. We've got also restriction +#W. The goal is to choose such set of nodes S ( which is a subset of V ), that it's +#total weight is not greater than W and also function: max_v { min_u { cost(u,v) }} +#has the smallest possible worth ( v is a node in V and u is a node in S ). +# +#Note: +#For more information about K-Center problem check Unweighted K-Center algorithm +#description. + +proc ::struct::graph::op::WeightedKCenter {G nodeWeights W} { + + #checking if all weights for edges in graph G are set well + VerifyWeightsAreOk $G + + #checking if proper value of k is given at input + if { $W <= 0 } { + return -code error "The \"W\" value must be an positive integer." + } + #initilization + set j [ expr {$W+1} ] + + #graphs G(i) and G(i)**2 + set Gi [struct::graph] + set GiSQ [struct::graph] + #the set of arcs for graph G sorted with their weights (increasing) + set arcs [sortEdges $G] + + #initialization of graphs G(i) and G(i)**2 + foreach v [$G nodes] { + $Gi node insert $v + $GiSQ node insert $v + } + + #the main loop - iteration over all G(i)'s and G(i)**2's, + #extended with each iteration till the solution is found + + foreach arc $arcs { + #initilization of the set of nodes, which are cheapest neighbours + #for particular nodes in maximal independent set + set Si {} + + set u [$G arc source $arc] + set v [$G arc target $arc] + + #extending graph G(i) + $Gi arc insert $u $v [list $u $v] + + #extending graph G(i)**2 from G(i-1)**2 using G(i) + set GiSQ [extendTwoSquaredGraph $GiSQ $Gi $u $v] + + #finding maximal independent set (Mi) for graph G(i)**2 found in the + #previous step. Mi is found using greedy algorithm that also considers + #weights on vertices. + set Mi [GreedyWeightedMaxIndependentSet $GiSQ $nodeWeights] + + #for each node u in Maximal Independent set found in previous step, + #we search for its cheapest ( considering costs at vertices ) neighbour. + #Note that node u is considered as it is a neighbour for itself. + foreach u $Mi { + + set minWeightOfSi Inf + + #the neighbours of u + set neighbours [$Gi nodes -adj $u] + set smallestNeighbour 0 + #u is a neighbour for itself + lappend neighbours $u + + #finding neighbour with minimal cost + foreach w [lsort -index 1 $nodeWeights] { + lassign $w node weight + if {[struct::set contains $neighbours $node]} { + set minWeightOfSi $weight + set smallestNeighbour $node + break + } + } + + lappend Si [list $smallestNeighbour $minWeightOfSi] + } + + set totalSiWeight 0 + set possibleSolution {} + + foreach s $Si { + #counting the total weight of the set of nodes - Si + set totalSiWeight [ expr { $totalSiWeight + [lindex $s 1] } ] + + #it's final solution, if weight found in previous step is + #not greater than W + lappend possibleSolution [lindex $s 0] + } + + #checking if final solution is found + if { $totalSiWeight <= $W } { + $Gi destroy + $GiSQ destroy + return $possibleSolution + } + } + + $Gi destroy + $GiSQ destroy + + #no solution found - error returned + return -code error "No k-center found for restriction W = $W" + +} + +#Maximal Independent Set - 2 approximation greedy algorithm +#------------------------------------------------------------------------------------- +# +#A maximal independent set is an independent set such that adding any other node +#to the set forces the set to contain an edge. +# +#Note: +#Don't confuse it with maximum independent set, which is a largest independent set +#for a given graph G. +# +#Reference: http://en.wikipedia.org/wiki/Maximal_independent_set + +proc ::struct::graph::op::GreedyMaxIndependentSet {G} { + + set result {} + set nodes [$G nodes] + + foreach v $nodes { + if { [struct::set contains $nodes $v] } { + lappend result $v + + foreach neighbour [$G nodes -adj $v] { + struct::set exclude nodes $neighbour + } + } + } + + return $result +} + +#Weighted Maximal Independent Set - 2 approximation greedy algorithm +#------------------------------------------------------------------------------------- +# +#Weighted variation of Maximal Independent Set. It takes as an input argument +#not only graph G but also set of weights for all vertices in graph G. +# +#Note: +#Read also Maximal Independent Set description for more info. +# +#Reference: http://en.wikipedia.org/wiki/Maximal_independent_set + +proc ::struct::graph::op::GreedyWeightedMaxIndependentSet {G nodeWeights} { + + set result {} + set nodes {} + foreach v [lsort -index 1 $nodeWeights] { + lappend nodes [lindex $v 0] + } + + foreach v $nodes { + if { [struct::set contains $nodes $v] } { + lappend result $v + + set neighbours [$G nodes -adj $v] + + foreach neighbour [$G nodes -adj $v] { + struct::set exclude nodes $neighbour + } + } + } + + return $result +} + +#subprocedure creating from graph G two squared graph +#G^2 - graph in which edge between nodes u and v exists, +#if and only if, when distance (in edges, not weights) +#between those nodes is not greater than 2 and u != v. + +proc ::struct::graph::op::createSquaredGraph {G} { + + set H [struct::graph] + foreach v [$G nodes] { + $H node insert $v + } + + foreach v [$G nodes] { + foreach u [$G nodes -adj $v] { + if { ($v != $u) && ![$H arc exists [list $v $u]] && ![$H arc exists [list $u $v]] } { + $H arc insert $u $v [list $u $v] + } + foreach z [$G nodes -adj $u] { + if { ($v != $z) && ![$H arc exists [list $v $z]] && ![$H arc exists [list $z $v]] } { + $H arc insert $v $z [list $v $z] + } + } + } + } + + return $H +} + +#subprocedure for Metric K-Center problem +# +#Input: +#previousGsq - graph G(i-1)**2 +#currentGi - graph G(i) +#u and v - source and target of an edge added in this iteration +# +#Output: +#Graph G(i)**2 used by next steps of K-Center algorithm + +proc ::struct::graph::op::extendTwoSquaredGraph {previousGsq currentGi u v} { + + #adding new edge + if { ![$previousGsq arc exists [list $v $u]] && ![$previousGsq arc exists [list $u $v]]} { + $previousGsq arc insert $u $v [list $u $v] + } + + #adding new edges to solution graph: + #here edges, where source is a $u node and targets are neighbours of node $u except for $v + foreach x [$currentGi nodes -adj $u] { + if { ( $x != $v) && ![$previousGsq arc exists [list $v $x]] && ![$previousGsq arc exists [list $x $v]] } { + $previousGsq arc insert $v $x [list $v $x] + } + } + #here edges, where source is a $v node and targets are neighbours of node $v except for $u + foreach x [$currentGi nodes -adj $v] { + if { ( $x != $u ) && ![$previousGsq arc exists [list $u $x]] && ![$previousGsq arc exists [list $x $u]] } { + $previousGsq arc insert $u $x [list $u $x] + } + } + + return $previousGsq +} + +#Vertices Cover - 2 approximation algorithm +#------------------------------------------------------------------------------------- +#Vertices cover is a set o vertices such that each edge of the graph is incident to +#at least one vertex of the set. This 2-approximation algorithm searches for minimum +#vertices cover, which is a classical optimization problem in computer science and +#is a typical example of an NP-hard optimization problem that has an approximation +#algorithm. +# +#Reference: http://en.wikipedia.org/wiki/Vertex_cover_problem +# + +proc ::struct::graph::op::VerticesCover {G} { + #variable containing final solution + set vc {} + #variable containing sorted (with degree) set of arcs for graph G + set arcs {} + + #setting the dictionary with degrees for each node + foreach v [$G nodes] { + dict set degrees $v [$G node degree $v] + } + + #creating a list containing the sum of degrees for source and + #target nodes for each edge in graph G + foreach e [$G arcs] { + set v [$G arc source $e] + set u [$G arc target $e] + + lappend values [list [expr {[dict get $degrees $v]+[dict get $degrees $u]}] $e] + } + #sorting the list of source and target degrees + set values [lsort -integer -decreasing -index 0 $values] + + #setting the set of edges in a right sequence + foreach e $values { + lappend arcs [lindex $e 1] + } + + #for each node in graph G, we add it to the final solution and + #erase all arcs adjacent to it, so they cannot be + #added to solution in next iterations + foreach e $arcs { + + if { [struct::set contains $arcs $e] } { + set v [$G arc source $e] + set u [$G arc target $e] + lappend vc $v $u + + foreach n [$G arcs -adj $v $u] { + struct::set exclude arcs $n + } + } + } + + return $vc +} + + +#Ford's Fulkerson algorithm - computing maximum flow in a flow network +#------------------------------------------------------------------------------------- +# +#The general idea of algorithm is finding augumenting paths in graph G, as long +#as they exist, and for each path updating the edge's weights along that path, +#with maximum possible throughput. The final (maximum) flow is found +#when there is no other augumenting path from source to sink. +# +#Input: +#graph G - weighted and directed graph. Weights at edges are considered as +#maximum throughputs that can be carried by that link (edge). +#s - the node that is a source for graph G +#t - the node that is a sink for graph G +# +#Output: +#Procedure returns the dictionary contaning throughputs for all edges. For +#each key ( the edge between nodes u and v in the for of list u v ) there is +#a value that is a throughput for that key. Edges where throughput values +#are equal to 0 are not returned ( it is like there was no link in the flow network +#between nodes connected by such edge). +# +#Reference: http://en.wikipedia.org/wiki/Ford-Fulkerson_algorithm + +proc ::struct::graph::op::FordFulkerson {G s t} { + + #checking if nodes s and t are in graph G + if { !([$G node exists $s] && [$G node exists $t]) } { + return -code error "Nodes \"$s\" and \"$t\" should be contained in graph's G set of nodes" + } + + #checking if all attributes for input network are set well ( costs and throughputs ) + foreach e [$G arcs] { + if { ![$G arc keyexists $e throughput] } { + return -code error "The input network doesn't have all attributes set correctly... Please, check again attributes: \"throughput\" for input graph." + } + } + + #initilization + foreach e [$G arcs] { + set u [$G arc source $e] + set v [$G arc target $e] + dict set f [list $u $v] 0 + dict set f [list $v $u] 0 + } + + #setting the residual graph for the first iteration + set residualG [createResidualGraph $G $f] + + #deleting the arcs that are 0-weighted + foreach e [$residualG arcs] { + if { [$residualG arc set $e throughput] == 0 } { + $residualG arc delete $e + } + } + + #the main loop - works till the path between source and the sink can be found + while {1} { + set paths [ShortestsPathsByBFS $residualG $s paths] + + if { ($paths == {}) || (![dict exists $paths $t]) } break + + set path [dict get $paths $t] + #setting the path from source to sink + + #adding sink to path + lappend path $t + + #finding the throughput of path p - the smallest value of c(f) among + #edges that are contained in the path + set maxThroughput Inf + + foreach u [lrange $path 0 end-1] v [lrange $path 1 end] { + set pathEdgeFlow [$residualG arc set [list $u $v] throughput] + if { $maxThroughput > $pathEdgeFlow } { + set maxThroughput $pathEdgeFlow + } + } + + #increase of throughput using the path p, with value equal to maxThroughput + foreach u [lrange $path 0 end-1] v [lrange $path 1 end] { + + #if maximum throughput that was found for the path p (maxThroughput) is bigger than current throughput + #at the edge not contained in the path p (for current pair of nodes u and v), then we add to the edge + #which is contained into path p the maxThroughput value decreased by the value of throughput at + #the second edge (not contained in path). That second edge's throughtput value is set to 0. + + set f_uv [dict get $f [list $u $v]] + set f_vu [dict get $f [list $v $u]] + if { $maxThroughput >= $f_vu } { + dict set f [list $u $v] [ expr { $f_uv + $maxThroughput - $f_vu } ] + dict set f [list $v $u] 0 + } else { + + #if maxThroughput is not greater than current throughput at the edge not contained in path p (here - v->u), + #we add a difference between those values to edge contained in the path p (here u->v) and substract that + #difference from edge not contained in the path p. + set difference [ expr { $f_vu - $maxThroughput } ] + dict set f [list $u $v] [ expr { $f_uv + $difference } ] + dict set f [list $v $u] $maxThroughput + } + } + + #when the current throughput for the graph is updated, we generate new residual graph + #for new values of throughput + $residualG destroy + set residualG [createResidualGraph $G $f] + + foreach e [$residualG arcs] { + if { [$residualG arc set $e throughput] == 0 } { + $residualG arc delete $e + } + } + } + + $residualG destroy + + #removing 0-weighted edges from solution + foreach e [dict keys $f] { + if { [dict get $f $e] == 0 } { + set f [dict remove $f $e] + } + } + + return $f +} + +#subprocedure for FordFulkerson's algorithm, which creates +#for input graph G and given throughput f residual graph +#for further operations to find maximum flow in flow network + +proc ::struct::graph::op::createResidualGraph {G f} { + + #initialization + set residualG [struct::graph] + + foreach v [$G nodes] { + $residualG node insert $v + } + + foreach e [$G arcs] { + set u [$G arc source $e] + set v [$G arc target $e] + dict set GF [list $u $v] [$G arc set $e throughput] + } + + foreach e [dict keys $GF] { + + lassign $e u v + + set c_uv [dict get $GF $e] + set flow_uv [dict get $f $e] + set flow_vu [dict get $f [list $v $u]] + + if { ![$residualG arc exists $e] } { + $residualG arc insert $u $v $e + } + + if { ![$residualG arc exists [list $v $u]] } { + $residualG arc insert $v $u [list $v $u] + } + + #new value of c_f(u,v) for residual Graph is a max flow value for this edge + #minus current flow on that edge + if { ![$residualG arc keyexists $e throughput] } { + if { [dict exists $GF [list $v $u]] } { + $residualG arc set [list $u $v] throughput [ expr { $c_uv - $flow_uv + $flow_vu } ] + } else { + $residualG arc set $e throughput [ expr { $c_uv - $flow_uv } ] + } + } + + if { [dict exists $GF [list $v $u]] } { + #when double arcs in graph G (u->v , v->u) + #so, x/y i w/z y-x+w + set c_vu [dict get $GF [list $v $u]] + if { ![$residualG arc keyexists [list $v $u] throughput] } { + $residualG arc set [list $v $u] throughput [ expr { $c_vu - $flow_vu + $flow_uv} ] + } + } else { + $residualG arc set [list $v $u] throughput $flow_uv + } + } + + #setting all weights at edges to 1 for proper usage of shortest paths finding procedures + $residualG arc setunweighted 1 + + return $residualG +} + +#Subprocedure for Busacker Gowen algorithm +# +#Input: +#graph G - flow network. Graph G has two attributes for each edge: +#cost and throughput. Each arc must have it's attribute value assigned. +#dictionary f - some flow for network G. Keys represent edges and values +#are flows at those edges +#path - set of nodes for which we transform the network +# +#Subprocedure checks 6 vital conditions and for them updates the network +#(let values with * be updates values for network). So, let edge (u,v) be +#the non-zero flow for network G, c(u,v) throughput of edge (u,v) and +#d(u,v) non-negative cost of edge (u,v): +#1. c*(v,u) = f(u,v) --- adding apparent arc +#2. d*(v,u) = -d(u,v) +#3. c*(u,v) = c(u,v) - f(u,v) --- if f(v,u) = 0 and c(u,v) > f(u,v) +#4. d*(u,v) = d(u,v) --- if f(v,u) = 0 and c(u,v) > f(u,v) +#5. c*(u,v) = 0 --- if f(v,u) = 0 and c(u,v) = f(u,v) +#6. d*(u,v) = Inf --- if f(v,u) = 0 and c(u,v) = f(u,v) + +proc ::struct::graph::op::createAugmentingNetwork {G f path} { + + set Gf [struct::graph] + + #setting the Gf graph + foreach v [$G nodes] { + $Gf node insert $v + } + + foreach e [$G arcs] { + set u [$G arc source $e] + set v [$G arc target $e] + + $Gf arc insert $u $v [list $u $v] + + $Gf arc set [list $u $v] throughput [$G arc set $e throughput] + $Gf arc set [list $u $v] cost [$G arc set $e cost] + } + + #we set new values for each edge contained in the path from input + foreach u [lrange $path 0 end-1] v [lrange $path 1 end] { + + set f_uv [dict get $f [list $u $v]] + set f_vu [dict get $f [list $v $u]] + set c_uv [$G arc get [list $u $v] throughput] + set d_uv [$G arc get [list $u $v] cost] + + #adding apparent arcs + if { ![$Gf arc exists [list $v $u]] } { + $Gf arc insert $v $u [list $v $u] + #1. + $Gf arc set [list $v $u] throughput $f_uv + #2. + $Gf arc set [list $v $u] cost [ expr { -1 * $d_uv } ] + } else { + #1. + $Gf arc set [list $v $u] throughput $f_uv + #2. + $Gf arc set [list $v $u] cost [ expr { -1 * $d_uv } ] + $Gf arc set [list $u $v] cost Inf + $Gf arc set [list $u $v] throughput 0 + } + + if { ($f_vu == 0 ) && ( $c_uv > $f_uv ) } { + #3. + $Gf arc set [list $u $v] throughput [ expr { $c_uv - $f_uv } ] + #4. + $Gf arc set [list $u $v] cost $d_uv + } + + if { ($f_vu == 0 ) && ( $c_uv == $f_uv) } { + #5. + $Gf arc set [list $u $v] throughput 0 + #6. + $Gf arc set [list $u $v] cost Inf + } + } + + return $Gf +} + +#Busacker Gowen's algorithm - computing minimum cost maximum flow in a flow network +#------------------------------------------------------------------------------------- +# +#The goal is to find a flow, whose max value can be d, from source node to +#sink node in given flow network. That network except throughputs at edges has +#also defined a non-negative cost on each edge - cost of using that edge when +#directing flow with that edge ( it can illustrate e.g. fuel usage, time or +#any other measure dependent on usages ). +# +#Input: +#graph G - flow network, weights at edges are costs of using particular edge +#desiredFlow - max value of the flow for that network +#dictionary c - throughputs for all edges +#node s - the source node for graph G +#node t - the sink node for graph G +# +#Output: +#f - dictionary containing values of used throughputs for each edge ( key ) +#found by algorithm. +# +#Reference: http://en.wikipedia.org/wiki/Minimum_cost_flow_problem +# + +proc ::struct::graph::op::BusackerGowen {G desiredFlow s t} { + + #checking if nodes s and t are in graph G + if { !([$G node exists $s] && [$G node exists $t]) } { + return -code error "Nodes \"$s\" and \"$t\" should be contained in graph's G set of nodes" + } + + if { $desiredFlow <= 0 } { + return -code error "The \"desiredFlow\" value must be an positive integer." + } + + #checking if all attributes for input network are set well ( costs and throughputs ) + foreach e [$G arcs] { + if { !([$G arc keyexists $e throughput] && [$G arc keyexists $e cost]) } { + return -code error "The input network doesn't have all attributes set correctly... Please, check again attributes: \"throughput\" and \"cost\" for input graph." + } + } + + set Gf [struct::graph] + + #initialization of Augmenting Network + foreach v [$G nodes] { + $Gf node insert $v + } + + foreach e [$G arcs] { + set u [$G arc source $e] + set v [$G arc target $e] + $Gf arc insert $u $v [list $u $v] + + $Gf arc set [list $u $v] throughput [$G arc set $e throughput] + $Gf arc set [list $u $v] cost [$G arc set $e cost] + } + + #initialization of f + foreach e [$G arcs] { + set u [$G arc source $e] + set v [$G arc target $e] + dict set f [list $u $v] 0 + dict set f [list $v $u] 0 + } + + set currentFlow 0 + + #main loop - it ends when we reach desired flow value or there is no path in Gf + #leading from source node s to sink t + + while { $currentFlow < $desiredFlow } { + + #preparing correct values for pathfinding + foreach edge [$Gf arcs] { + $Gf arc setweight $edge [$Gf arc get $edge cost] + } + + #setting the path 'p' from 's' to 't' + set paths [ShortestsPathsByBFS $Gf $s paths] + + #if there are no more paths, the search has ended + if { ($paths == {}) || (![dict exists $paths $t]) } break + + set path [dict get $paths $t] + lappend path $t + + #counting max throughput that is availiable to send + #using path 'p' + set maxThroughput Inf + foreach u [lrange $path 0 end-1] v [lrange $path 1 end] { + set uv_throughput [$Gf arc set [list $u $v] throughput] + if { $maxThroughput > $uv_throughput } { + set maxThroughput $uv_throughput + } + } + + #if max throughput that was found will cause exceeding the desired + #flow, send as much as it's possible + if { ( $currentFlow + $maxThroughput ) <= $desiredFlow } { + set fAdd $maxThroughput + set currentFlow [ expr { $currentFlow + $fAdd } ] + } else { + set fAdd [ expr { $desiredFlow - $currentFlow } ] + set currentFlow $desiredFlow + } + + #update the throuputs on edges + foreach v [lrange $path 0 end-1] u [lrange $path 1 end] { + if { [dict get $f [list $u $v]] >= $fAdd } { + dict set f [list $u $v] [ expr { [dict get $f [list $u $v]] - $fAdd } ] + } + + if { ( [dict get $f [list $u $v]] < $fAdd ) && ( [dict get $f [list $u $v]] > 0 ) } { + dict set f [list $v $u] [ expr { $fAdd - [dict get $f [list $u $v]] } ] + dict set f [list $u $v] 0 + } + + if { [dict get $f [list $u $v]] == 0 } { + dict set f [list $v $u] [ expr { [dict get $f [list $v $u]] + $fAdd } ] + } + } + + #create new Augemnting Network + + set Gfnew [createAugmentingNetwork $Gf $f $path] + $Gf destroy + set Gf $Gfnew + } + + set f [dict filter $f script {flow flowvalue} {expr {$flowvalue != 0}}] + + $Gf destroy + return $f +} + +# +proc ::struct::graph::op::ShortestsPathsByBFS {G s outputFormat} { + + switch -exact -- $outputFormat { + distances { + set outputMode distances + } + paths { + set outputMode paths + } + default { + return -code error "Unknown output format \"$outputFormat\", expected distances, or paths." + } + } + + set queue [list $s] + set result {} + + #initialization of marked nodes, distances and predecessors + foreach v [$G nodes] { + dict set marked $v 0 + dict set distances $v Inf + dict set pred $v -1 + } + + #the s node is initially marked and has 0 distance to itself + dict set marked $s 1 + dict set distances $s 0 + + #the main loop + while { [llength $queue] != 0 } { + + #removing top element from the queue + set v [lindex $queue 0] + lremove queue $v + + #for each arc that begins in v + foreach arc [$G arcs -out $v] { + + set u [$G arc target $arc] + set newlabel [ expr { [dict get $distances $v] + [$G arc getweight $arc] } ] + + if { $newlabel < [dict get $distances $u] } { + + dict set distances $u $newlabel + dict set pred $u $v + + #case when current node wasn't placed in a queue yet - + #we set u at the end of the queue + if { [dict get $marked $u] == 0 } { + lappend queue $u + dict set marked $u 1 + } else { + + #case when current node u was in queue before but it is not in it now - + #we set u at the beginning of the queue + if { [lsearch $queue $u] < 0 } { + set queue [linsert $queue 0 $u] + } + } + } + } + } + + #if the outputformat is paths, we travel back to find shorests paths + #to return sets of nodes for each node, which are their paths between + #s and particular node + dict set paths nopaths 1 + if { $outputMode eq "paths" } { + foreach node [$G nodes] { + + set path {} + set lastNode $node + + while { $lastNode != -1 } { + set currentNode [dict get $pred $lastNode] + if { $currentNode != -1 } { + lappend path $currentNode + } + set lastNode $currentNode + } + + set path [lreverse $path] + + if { [llength $path] != 0 } { + dict set paths $node $path + dict unset paths nopaths + } + } + + if { ![dict exists $paths nopaths] } { + return $paths + } else { + return {} + } + + #returning dictionary containing distance from start node to each other node (key) + } else { + return $distances + } + +} + +# +proc ::struct::graph::op::BFS {G s outputFormat} { + + set queue [list $s] + + switch -exact -- $outputFormat { + graph { + set outputMode graph + } + tree { + set outputMode tree + } + default { + return -code error "Unknown output format \"$outputFormat\", expected graph, or tree." + } + } + + if { $outputMode eq "graph" } { + #graph initializing + set BFSGraph [struct::graph] + foreach v [$G nodes] { + $BFSGraph node insert $v + } + } else { + #tree initializing + set BFSTree [struct::tree] + $BFSTree set root name $s + $BFSTree rename root $s + } + + #initilization of marked nodes + foreach v [$G nodes] { + dict set marked $v 0 + } + + #start node is marked from the beginning + dict set marked $s 1 + + #the main loop + while { [llength $queue] != 0 } { + #removing top element from the queue + + set v [lindex $queue 0] + lremove queue $v + + foreach x [$G nodes -adj $v] { + if { ![dict get $marked $x] } { + dict set marked $x 1 + lappend queue $x + + if { $outputMode eq "graph" } { + $BFSGraph arc insert $v $x [list $v $x] + } else { + $BFSTree insert $v end $x + } + } + } + } + + if { $outputMode eq "graph" } { + return $BFSGraph + } else { + return $BFSTree + } +} + +#Minimum Diameter Spanning Tree - MDST +#------------------------------------------------------------------------------------- +# +#The goal is to find for input graph G, the spanning tree that +#has the minimum diameter worth. +# +#General idea of algorithm is to run BFS over all vertices in graph +#G. If the diameter "d" of the tree is odd, then we are sure that tree +#given by BFS is minimum (considering diameter value). When, diameter "d" +#is even, then optimal tree can have minimum diameter equal to "d" or +#"d-1". +# +#In that case, what algorithm does is rebuilding the tree given by BFS, by +#adding a vertice between root node and root's child node (nodes), such that +#subtree created with child node as root node is the greatest one (has the +#greatests height). In the next step for such rebuilded tree, we run again BFS +#with new node as root node. If the height of the tree didn't changed, we have found +#a better solution. + +proc ::struct::graph::op::MinimumDiameterSpanningTree {G} { + + set min_diameter Inf + set best_Tree [struct::graph] + + foreach v [$G nodes] { + + #BFS Tree + set T [BFS $G $v tree] + #BFS Graph + set TGraph [BFS $G $v graph] + + #Setting all arcs to 1 for diameter procedure + $TGraph arc setunweighted 1 + + #setting values for current Tree + set diam [diameter $TGraph] + set subtreeHeight [ expr { $diam / 2 - 1} ] + + ############################################## + #case when diameter found for tree found by BFS is even: + #it's possible to decrease the diameter by one. + if { ( $diam % 2 ) == 0 } { + + #for each child u that current root node v has, we search + #for the greatest subtree(subtrees) with the root in child u. + # + foreach u [$TGraph nodes -adj $v] { + set u_depth 1 ;#[$T depth $u] + set d_depth 0 + + set descendants [$T descendants $u] + + foreach d $descendants { + if { $d_depth < [$T depth $d] } { + set d_depth [$T depth $d] + } + } + + #depth of the current subtree + set depth [ expr { $d_depth - $u_depth } ] + + #proceed if found subtree is the greatest one + if { $depth >= $subtreeHeight } { + + #temporary Graph for holding potential better values + set tempGraph [struct::graph] + + foreach node [$TGraph nodes] { + $tempGraph node insert $node + } + + #zmienic nazwy zmiennych zeby sie nie mylily + foreach arc [$TGraph arcs] { + set _u [$TGraph arc source $arc] + set _v [$TGraph arc target $arc] + $tempGraph arc insert $_u $_v [list $_u $_v] + } + + if { [$tempGraph arc exists [list $u $v]] } { + $tempGraph arc delete [list $u $v] + } else { + $tempGraph arc delete [list $v $u] + } + + #for nodes u and v, we add a node between them + #to again start BFS with root in new node to check + #if it's possible to decrease the diameter in solution + set node [$tempGraph node insert] + $tempGraph arc insert $node $v [list $node $v] + $tempGraph arc insert $node $u [list $node $u] + + set newtempGraph [BFS $tempGraph $node graph] + $tempGraph destroy + set tempGraph $newtempGraph + + $tempGraph node delete $node + $tempGraph arc insert $u $v [list $u $v] + $tempGraph arc setunweighted 1 + + set tempDiam [diameter $tempGraph] + + #if better tree is found (that any that were already found) + #replace it + if { $min_diameter > $tempDiam } { + set $min_diameter [diameter $tempGraph ] + $best_Tree destroy + set best_Tree $tempGraph + } else { + $tempGraph destroy + } + } + + } + } + ################################################################ + + set currentTreeDiameter $diam + + if { $min_diameter > $currentTreeDiameter } { + set min_diameter $currentTreeDiameter + $best_Tree destroy + set best_Tree $TGraph + } else { + $TGraph destroy + } + + $T destroy + } + + return $best_Tree +} + +#Minimum Degree Spanning Tree +#------------------------------------------------------------------------------------- +# +#In graph theory, minimum degree spanning tree (or degree-constrained spanning tree) +#is a spanning tree where the maximum vertex degree is as small as possible (or is +#limited to a certain constant k). The minimum degree spanning tree problem is to +#determine whether a particular graph has such a spanning tree for a particular k. +# +#Algorithm for input undirected graph G finds its spanning tree with the smallest +#possible degree. Algorithm is a 2-approximation, so it doesn't assure that optimal +#solution will be found. +# +#Reference: http://en.wikipedia.org/wiki/Degree-constrained_spanning_tree + +proc ::struct::graph::op::MinimumDegreeSpanningTree {G} { + + #initialization of spanning tree for G + set MST [struct::graph] + + foreach v [$G nodes] { + $MST node insert $v + } + + #forcing all arcs to be 1-weighted + foreach e [$G arcs] { + $G arc setweight $e 1 + } + + foreach e [kruskal $G] { + set u [$G arc source $e] + set v [$G arc target $e] + + $MST arc insert $u $v [list $u $v] + } + + #main loop + foreach e [$G arcs] { + + set u [$G arc source $e] + set v [$G arc target $e] + + #if nodes u and v are neighbours, proceed to next iteration + if { ![$MST arc exists [list $u $v]] && ![$MST arc exists [list $v $u]] } { + + $MST arc setunweighted 1 + + #setting the path between nodes u and v in Spanning Tree MST + set path [dict get [dijkstra $MST $u] $v] + lappend path $v + + #search for the node in the path, such that its degree is greater than degree of any of nodes + #u or v increased by one + foreach node $path { + if { [$MST node degree $node] > ([Max [$MST node degree $u] [$MST node degree $v]] + 1) } { + + #if such node is found add the arc between nodes u and v + $MST arc insert $u $v [list $u $v] + + #then to hold MST being a spanning tree, delete any arc that is in the path + #that is adjacent to found node + foreach n [$MST nodes -adj $node] { + if { $n in $path } { + if { [$MST arc exists [list $node $n]] } { + $MST arc delete [list $node $n] + } else { + $MST arc delete [list $n $node] + } + break + } + } + + # Node found, stop processing the path + break + } + } + } + } + + return $MST +} + +#Dinic algorithm for finding maximum flow in flow network +#------------------------------------------------------------------------------------- +# +#Reference: http://en.wikipedia.org/wiki/Dinic's_algorithm +# +proc ::struct::graph::op::MaximumFlowByDinic {G s t blockingFlowAlg} { + + if { !($blockingFlowAlg eq "dinic" || $blockingFlowAlg eq "mkm") } { + return -code error "Uncorrect name of blocking flow algorithm. Choose \"mkm\" for Malhotra, Kumar and Maheshwari algorithm and \"dinic\" for Dinic algorithm." + } + + foreach arc [$G arcs] { + set u [$G arc source $arc] + set v [$G arc target $arc] + + dict set f [list $u $v] 0 + dict set f [list $v $u] 0 + } + + while {1} { + set residualG [createResidualGraph $G $f] + if { $blockingFlowAlg == "mkm" } { + set blockingFlow [BlockingFlowByMKM $residualG $s $t] + } else { + set blockingFlow [BlockingFlowByDinic $residualG $s $t] + } + $residualG destroy + + if { $blockingFlow == {} } break + + foreach key [dict keys $blockingFlow] { + dict set f $key [ expr { [dict get $f $key] + [dict get $blockingFlow $key] } ] + } + } + + set f [dict filter $f script {flow flowvalue} {expr {$flowvalue != 0}}] + + return $f +} + +#Dinic algorithm for finding blocking flow +#------------------------------------------------------------------------------------- +# +#Algorithm for given network G with source s and sink t, finds a blocking +#flow, which can be used to obtain a maximum flow for that network G. +# +#Some steps that algorithm takes: +#1. constructing the level graph from network G +#2. until there are edges in level graph: +# 3. find the path between s and t nodes in level graph +# 4. for each edge in path update current throughputs at those edges and... +# 5. ...deleting nodes from which there are no residual edges +#6. return the dictionary containing the blocking flow + +proc ::struct::graph::op::BlockingFlowByDinic {G s t} { + + #initializing blocking flow dictionary + foreach edge [$G arcs] { + set u [$G arc source $edge] + set v [$G arc target $edge] + + dict set b [list $u $v] 0 + } + + #1. + set LevelGraph [createLevelGraph $G $s] + + #2. the main loop + while { [llength [$LevelGraph arcs]] > 0 } { + + if { ![$LevelGraph node exists $s] || ![$LevelGraph node exists $t] } break + + #3. + set paths [ShortestsPathsByBFS $LevelGraph $s paths] + + if { $paths == {} } break + if { ![dict exists $paths $t] } break + + set path [dict get $paths $t] + lappend path $t + + #setting the max throughput to go with the path found one step before + set maxThroughput Inf + foreach u [lrange $path 0 end-1] v [lrange $path 1 end] { + + set uv_throughput [$LevelGraph arc get [list $u $v] throughput] + + if { $maxThroughput > $uv_throughput } { + set maxThroughput $uv_throughput + } + } + + #4. updating throughputs and blocking flow + foreach u [lrange $path 0 end-1] v [lrange $path 1 end] { + + set uv_throughput [$LevelGraph arc get [list $u $v] throughput] + #decreasing the throughputs contained in the path by max flow value + $LevelGraph arc set [list $u $v] throughput [ expr { $uv_throughput - $maxThroughput } ] + + #updating blocking flows + dict set b [list $u $v] [ expr { [dict get $b [list $u $v]] + $maxThroughput } ] + #dict set b [list $v $u] [ expr { -1 * [dict get $b [list $u $v]] } ] + + #5. deleting the arcs, whose throughput is completely used + if { [$LevelGraph arc get [list $u $v] throughput] == 0 } { + $LevelGraph arc delete [list $u $v] + } + + #deleting the node, if it hasn't any outgoing arcs + if { ($u != $s) && ( ![llength [$LevelGraph nodes -out $u]] || ![llength [$LevelGraph nodes -in $u]] ) } { + $LevelGraph node delete $u + } + } + + } + + set b [dict filter $b script {flow flowvalue} {expr {$flowvalue != 0}}] + + $LevelGraph destroy + + #6. + return $b +} + +#Malhotra, Kumar and Maheshwari Algorithm for finding blocking flow +#------------------------------------------------------------------------------------- +# +#Algorithm for given network G with source s and sink t, finds a blocking +#flow, which can be used to obtain a maximum flow for that network G. +# +#For given node v, Let c(v) be the min{ a, b }, where a is the sum of all incoming +#throughputs and b is the sum of all outcoming throughputs from the node v. +# +#Some steps that algorithm takes: +#1. constructing the level graph from network G +#2. until there are edges in level graph: +# 3. finding the node with the minimum c(v) +# 4. sending c(v) units of throughput by incoming arcs of v +# 5. sending c(v) units of throughput by outcoming arcs of v +# 6. 4 and 5 steps can cause excess or deficiency of throughputs at nodes, so we +# send exceeds forward choosing arcs greedily and... +# 7. ...the same with deficiencies but we send those backward. +# 8. delete the v node from level graph +# 9. upgrade the c values for all nodes +# +#10. if no other edges left in level graph, return b - found blocking flow +# + +proc ::struct::graph::op::BlockingFlowByMKM {G s t} { + + #initializing blocking flow dictionary + foreach edge [$G arcs] { + set u [$G arc source $edge] + set v [$G arc target $edge] + + dict set b [list $u $v] 0 + } + + #1. setting the level graph + set LevelGraph [createLevelGraph $G $s] + + #setting the in/out throughputs for each node + set c [countThroughputsAtNodes $LevelGraph $s $t] + + #2. the main loop + while { [llength [$LevelGraph nodes]] > 2 } { + + #if there is no path between s and t nodes, end the procedure and + #return current blocking flow + set distances [ShortestsPathsByBFS $LevelGraph $s distances] + if { [dict get $distances $t] == "Inf" } { + $LevelGraph destroy + set b [dict filter $b script {flow flowvalue} {expr {$flowvalue != 0}}] + return $b + } + + #3. finding the node with minimum value of c(v) + set min_cv Inf + + dict for {node cv} $c { + if { $min_cv > $cv } { + set min_cv $cv + set minCv_node $node + } + } + + #4. sending c(v) by all incoming arcs of node with minimum c(v) + set _min_cv $min_cv + foreach arc [$LevelGraph arcs -in $minCv_node] { + + set t_arc [$LevelGraph arc get $arc throughput] + set u [$LevelGraph arc source $arc] + set v [$LevelGraph arc target $arc] + set b_uv [dict get $b [list $u $v]] + + if { $t_arc >= $min_cv } { + $LevelGraph arc set $arc throughput [ expr { $t_arc - $min_cv } ] + dict set b [list $u $v] [ expr { $b_uv + $min_cv } ] + break + } else { + set difference [ expr { $min_cv - $t_arc } ] + set min_cv $difference + dict set b [list $u $v] [ expr { $b_uv + $difference } ] + $LevelGraph arc set $arc throughput 0 + } + } + + #5. sending c(v) by all outcoming arcs of node with minimum c(v) + foreach arc [$LevelGraph arcs -out $minCv_node] { + + set t_arc [$LevelGraph arc get $arc throughput] + set u [$LevelGraph arc source $arc] + set v [$LevelGraph arc target $arc] + set b_uv [dict get $b [list $u $v]] + + if { $t_arc >= $min_cv } { + $LevelGraph arc set $arc throughput [ expr { $t_arc - $_min_cv } ] + dict set b [list $u $v] [ expr { $b_uv + $_min_cv } ] + break + } else { + set difference [ expr { $_min_cv - $t_arc } ] + set _min_cv $difference + dict set b [list $u $v] [ expr { $b_uv + $difference } ] + $LevelGraph arc set $arc throughput 0 + } + } + + #find exceeds and if any, send them forward or backwards + set distances [ShortestsPathsByBFS $LevelGraph $s distances] + + #6. + for {set i [ expr {[dict get $distances $minCv_node] + 1}] } { $i < [llength [$G nodes]] } { incr i } { + foreach w [$LevelGraph nodes] { + if { [dict get $distances $w] == $i } { + set excess [findExcess $LevelGraph $w $b] + if { $excess > 0 } { + set b [sendForward $LevelGraph $w $b $excess] + } + } + } + } + + #7. + for { set i [ expr { [dict get $distances $minCv_node] - 1} ] } { $i > 0 } { incr i -1 } { + foreach w [$LevelGraph nodes] { + if { [dict get $distances $w] == $i } { + set excess [findExcess $LevelGraph $w $b] + if { $excess < 0 } { + set b [sendBack $LevelGraph $w $b [ expr { (-1) * $excess } ]] + } + } + } + } + + #8. delete current node from the network + $LevelGraph node delete $minCv_node + + #9. correctingg the in/out throughputs for each node after + #deleting one of the nodes in network + set c [countThroughputsAtNodes $LevelGraph $s $t] + + #if node has no availiable outcoming or incoming throughput + #delete that node from the graph + dict for {key val} $c { + if { $val == 0 } { + $LevelGraph node delete $key + dict unset c $key + } + } + } + + set b [dict filter $b script {flow flowvalue} {expr {$flowvalue != 0}}] + + $LevelGraph destroy + #10. + return $b +} + +#Subprocedure for algorithms that find blocking-flows. +#It's creating a level graph from the residual network. +proc ::struct::graph::op::createLevelGraph {Gf s} { + + set LevelGraph [struct::graph] + + $Gf arc setunweighted 1 + + #deleting arcs with 0 throughputs for proper pathfinding + foreach arc [$Gf arcs] { + if { [$Gf arc get $arc throughput] == 0 } { + $Gf arc delete $arc + } + } + + set distances [ShortestsPathsByBFS $Gf $s distances] + + foreach v [$Gf nodes] { + $LevelGraph node insert $v + $LevelGraph node set $v distance [dict get $distances $v] + } + + foreach e [$Gf arcs] { + set u [$Gf arc source $e] + set v [$Gf arc target $e] + + if { ([$LevelGraph node get $u distance] + 1) == [$LevelGraph node get $v distance]} { + $LevelGraph arc insert $u $v [list $u $v] + $LevelGraph arc set [list $u $v] throughput [$Gf arc get $e throughput] + } + } + + $LevelGraph arc setunweighted 1 + return $LevelGraph +} + +#Subprocedure for blocking flow finding by MKM algorithm +# +#It computes for graph G and each of his nodes the throughput value - +#for node v: from the sum of availiable throughputs from incoming arcs and +#the sum of availiable throughputs from outcoming arcs chooses lesser and sets +#as the throughput of the node. +# +#Throughputs of nodes are returned in the dictionary. +# +proc ::struct::graph::op::countThroughputsAtNodes {G s t} { + + set c {} + foreach v [$G nodes] { + + if { ($v eq $t) || ($v eq $s) } continue + + set outcoming [$G arcs -out $v] + set incoming [$G arcs -in $v] + + set outsum 0 + set insum 0 + + foreach o $outcoming i $incoming { + + if { [llength $o] > 0 } { + set outsum [ expr { $outsum + [$G arc get $o throughput] } ] + } + + if { [llength $i] > 0 } { + set insum [ expr { $insum + [$G arc get $i throughput] } ] + } + + set value [Min $outsum $insum] + } + + dict set c $v $value + } + + return $c +} + +#Subprocedure for blocking-flow finding algorithm by MKM +# +#If for a given input node, outcoming flow is bigger than incoming, then that deficiency +#has to be send back by that subprocedure. +proc ::struct::graph::op::sendBack {G node b value} { + + foreach arc [$G arcs -in $node] { + set u [$G arc source $arc] + set v [$G arc target $arc] + + if { $value > [$G arc get $arc throughput] } { + set value [ expr { $value - [$G arc get $arc throughput] } ] + dict set b [list $u $v] [ expr { [dict get $b [list $u $v]] + [$G arc get $arc throughput] } ] + $G arc set $arc throughput 0 + } else { + $G arc set $arc throughput [ expr { [$G arc get $arc throughput] - $value } ] + dict set b [list $u $v] [ expr { [dict get $b [list $u $v]] + $value } ] + set value 0 + break + } + } + + return $b +} + +#Subprocedure for blocking-flow finding algorithm by MKM +# +#If for a given input node, incoming flow is bigger than outcoming, then that exceed +#has to be send forward by that sub procedure. +proc ::struct::graph::op::sendForward {G node b value} { + + foreach arc [$G arcs -out $node] { + + set u [$G arc source $arc] + set v [$G arc target $arc] + + if { $value > [$G arc get $arc throughput] } { + set value [ expr { $value - [$G arc get $arc throughput] } ] + dict set b [list $u $v] [ expr { [dict get $b [list $u $v]] + [$G arc get $arc throughput] } ] + $G arc set $arc throughput 0 + } else { + $G arc set $arc throughput [ expr { [$G arc get $arc throughput] - $value } ] + dict set b [list $u $v] [ expr { [dict get $b [list $u $v]] + $value } ] + + set value 0 + break + } + } + + return $b +} + +#Subprocedure for blocking-flow finding algorithm by MKM +# +#It checks for graph G if node given at input has a exceed +#or deficiency of throughput. +# +#For exceed the positive value of exceed is returned, for deficiency +#procedure returns negative value. If the incoming throughput +#is the same as outcoming, procedure returns 0. +# +proc ::struct::graph::op::findExcess {G node b} { + + set incoming 0 + set outcoming 0 + + foreach key [dict keys $b] { + + lassign $key u v + if { $u eq $node } { + set outcoming [ expr { $outcoming + [dict get $b $key] } ] + } + if { $v eq $node } { + set incoming [ expr { $incoming + [dict get $b $key] } ] + } + } + + return [ expr { $incoming - $outcoming } ] +} + +#Travelling Salesman Problem - Heuristic of local searching +#2 - approximation Algorithm +#------------------------------------------------------------------------------------- +# + +proc ::struct::graph::op::TSPLocalSearching {G C} { + + foreach arc $C { + if { ![$G arc exists $arc] } { + return -code error "Given cycle has arcs not included in graph G." + } + } + + #initialization + set CGraph [struct::graph] + set GCopy [struct::graph] + set w 0 + + foreach node [$G nodes] { + $CGraph node insert $node + $GCopy node insert $node + } + + foreach arc [$G arcs] { + set u [$G arc source $arc] + set v [$G arc target $arc] + $GCopy arc insert $u $v [list $u $v] + $GCopy arc set [list $u $v] weight [$G arc get $arc weight] + } + + foreach arc $C { + + set u [$G arc source $arc] + set v [$G arc target $arc] + set arcWeight [$G arc get $arc weight] + + $CGraph arc insert $u $v [list $u $v] + $CGraph arc set [list $u $v] weight $arcWeight + + set w [ expr { $w + $arcWeight } ] + } + + set reductionDone 1 + + while { $reductionDone } { + + set queue {} + set reductionDone 0 + + #double foreach loop goes through all pairs of arcs + foreach i [$CGraph arcs] { + + #source and target nodes of first arc + set iu [$CGraph arc source $i] + set iv [$CGraph arc target $i] + + #second arc + foreach j [$CGraph arcs] { + + #if pair of arcs already was considered, continue with next pair of arcs + if { [list $j $i] ni $queue } { + + #add current arc to queue to mark that it was used + lappend queue [list $i $j] + + set ju [$CGraph arc source $j] + set jv [$CGraph arc target $j] + + #we consider only arcs that are not adjacent + if { !($iu eq $ju) && !($iu eq $jv) && !($iv eq $ju) && !($iv eq $jv) } { + + #set the current cycle + set CPrim [copyGraph $CGraph] + + #transform the current cycle: + #1. + $CPrim arc delete $i + $CPrim arc delete $j + + + set param 0 + + #adding new edges instead of erased ones + if { !([$CPrim arc exists [list $iu $ju]] || [$CPrim arc exists [list $iv $jv]] || [$CPrim arc exists [list $ju $iu]] || [$CPrim arc exists [list $jv $iv]] ) } { + + $CPrim arc insert $iu $ju [list $iu $ju] + $CPrim arc insert $iv $jv [list $iv $jv] + + if { [$GCopy arc exists [list $iu $ju]] } { + $CPrim arc set [list $iu $ju] weight [$GCopy arc get [list $iu $ju] weight] + } else { + $CPrim arc set [list $iu $ju] weight [$GCopy arc get [list $ju $iu] weight] + } + + if { [$GCopy arc exists [list $iv $jv]] } { + $CPrim arc set [list $iv $jv] weight [$GCopy arc get [list $iv $jv] weight] + } else { + $CPrim arc set [list $iv $jv] weight [$GCopy arc get [list $jv $iv] weight] + } + } else { + set param 1 + } + + $CPrim arc setunweighted 1 + + #check if it's still a cycle or if any arcs were added instead those erased + if { !([struct::graph::op::distance $CPrim $iu $ju] > 0 ) || $param } { + + #deleting new edges if they were added before in current iteration + if { !$param } { + $CPrim arc delete [list $iu $ju] + } + + if { !$param } { + $CPrim arc delete [list $iv $jv] + } + + #adding new ones that will assure the graph is still a cycle + $CPrim arc insert $iu $jv [list $iu $jv] + $CPrim arc insert $iv $ju [list $iv $ju] + + if { [$GCopy arc exists [list $iu $jv]] } { + $CPrim arc set [list $iu $jv] weight [$GCopy arc get [list $iu $jv] weight] + } else { + $CPrim arc set [list $iu $jv] weight [$GCopy arc get [list $jv $iu] weight] + } + + if { [$GCopy arc exists [list $iv $ju]] } { + $CPrim arc set [list $iv $ju] weight [$GCopy arc get [list $iv $ju] weight] + } else { + $CPrim arc set [list $iv $ju] weight [$GCopy arc get [list $ju $iv] weight] + } + } + + #count current value of cycle + set cycleWeight [countCycleWeight $CPrim] + + #if we found cycle with lesser sum of weights, we set is as a result and + #marked that reduction was successful + if { $w > $cycleWeight } { + set w $cycleWeight + set reductionDone 1 + set C [$CPrim arcs] + } + + $CPrim destroy + } + } + } + } + + #setting the new current cycle if the reduction was successful + if { $reductionDone } { + foreach arc [$CGraph arcs] { + $CGraph arc delete $arc + } + for {set i 0} { $i < [llength $C] } { incr i } { + lset C $i [lsort [lindex $C $i]] + } + + foreach arc [$GCopy arcs] { + if { [lsort $arc] in $C } { + set u [$GCopy arc source $arc] + set v [$GCopy arc target $arc] + $CGraph arc insert $u $v [list $u $v] + $CGraph arc set $arc weight [$GCopy arc get $arc weight] + } + } + } + } + + $GCopy destroy + $CGraph destroy + + return $C +} + +proc ::struct::graph::op::copyGraph {G} { + + set newGraph [struct::graph] + + foreach node [$G nodes] { + $newGraph node insert $node + } + foreach arc [$G arcs] { + set u [$G arc source $arc] + set v [$G arc target $arc] + $newGraph arc insert $u $v $arc + $newGraph arc set $arc weight [$G arc get $arc weight] + } + + return $newGraph +} + +proc ::struct::graph::op::countCycleWeight {G} { + + set result 0 + + foreach arc [$G arcs] { + set result [ expr { $result + [$G arc get $arc weight] } ] + } + + return $result +} + +# ### ### ### ######### ######### ######### +## + +# This command finds a minimum spanning tree/forest (MST) of the graph +# argument, using the algorithm developed by Joseph Kruskal. The +# result is a set (as list) containing the names of the arcs in the +# MST. The set of nodes of the MST is implied by set of arcs, and thus +# not given explicitly. The algorithm does not consider arc +# directions. Note that unconnected nodes are left out of the result. + +# Reference: http://en.wikipedia.org/wiki/Kruskal%27s_algorithm + +proc ::struct::graph::op::kruskal {g} { + # Check graph argument for proper configuration. + + VerifyWeightsAreOk $g + + # Transient helper data structures. A priority queue for the arcs + # under consideration, using their weights as priority, and a + # disjoint-set to keep track of the forest of partial minimum + # spanning trees we are working with. + + set consider [::struct::prioqueue -dictionary consider] + set forest [::struct::disjointset forest] + + # Start with all nodes in the graph each in their partition. + + foreach n [$g nodes] { + $forest add-partition $n + } + + # Then fill the queue with all arcs, using their weight to + # prioritize. The weight is the cost of the arc. The lesser the + # better. + + foreach {arc weight} [$g arc weights] { + $consider put $arc $weight + } + + # And now we can construct the tree. This is done greedily. In + # each round we add the arc with the smallest weight to the + # minimum spanning tree, except if doing so would violate the tree + # condition. + + set result {} + + while {[$consider size]} { + set minarc [$consider get] + set origin [$g arc source $minarc] + set destin [$g arc target $minarc] + + # Ignore the arc if both ends are in the same partition. Using + # it would add a cycle to the result, i.e. it would not be a + # tree anymore. + + if {[$forest equal $origin $destin]} continue + + # Take the arc for the result, and merge the trees both ends + # are in into a single tree. + + lappend result $minarc + $forest merge $origin $destin + } + + # We are done. Get rid of the transient helper structures and + # return our result. + + $forest destroy + $consider destroy + + return $result +} + +# ### ### ### ######### ######### ######### +## + +# This command finds a minimum spanning tree/forest (MST) of the graph +# argument, using the algorithm developed by Prim. The result is a +# set (as list) containing the names of the arcs in the MST. The set +# of nodes of the MST is implied by set of arcs, and thus not given +# explicitly. The algorithm does not consider arc directions. + +# Reference: http://en.wikipedia.org/wiki/Prim%27s_algorithm + +proc ::struct::graph::op::prim {g} { + VerifyWeightsAreOk $g + + # Fill an array with all nodes, to track which nodes have been + # visited at least once. When the inner loop runs out of nodes and + # we still have some left over we restart using one of the + # leftover as new starting point. In this manner we get the MST of + # the whole graph minus unconnected nodes, instead of only the MST + # for the component the initial starting node is in. + + array set unvisited {} + foreach n [$g nodes] { set unvisited($n) . } + + # Transient helper data structure. A priority queue for the nodes + # and arcs under consideration for inclusion into the MST. Each + # element of the queue is a list containing node name, a flag bit, + # and arc name, in this order. The associated priority is the + # weight of the arc. The flag bit is set for the initial queue + # entry only, containing a fake (empty) arc, to trigger special + # handling. + + set consider [::struct::prioqueue -dictionary consider] + + # More data structures, the result arrays. + array set weightmap {} ; # maps nodes to min arc weight seen so + # far. This is the threshold other arcs + # on this node will have to beat to be + # added to the MST. + array set arcmap {} ; # maps arcs to nothing, these are the + # arcs in the MST. + + while {[array size unvisited]} { + # Choose a 'random' node as the starting point for the inner + # loop, prim's algorithm, and put it on the queue for + # consideration. Then we iterate until we have considered all + # nodes in the its component. + + set startnode [lindex [array names unvisited] 0] + $consider put [list $startnode 1 {}] 0 + + while {[$consider size] > 0} { + # Pull the next minimum weight to look for. This is the + # priority of the next item we can get from the queue. And the + # associated node/decision/arc data. + + set arcweight [$consider peekpriority 1] + + foreach {v arcundefined arc} [$consider get] break + #8.5: lassign [$consider get] v arcundefined arc + + # Two cases to consider: The node v is already part of the + # MST, or not. If yes we check if the new arcweight is better + # than what we have stored already, and update accordingly. + + if {[info exists weightmap($v)]} { + set currentweight $weightmap($v) + if {$arcweight < $currentweight} { + # The new weight is better, update to use it as + # the new threshold. Note that this fill not touch + # any other arcs found for this node, as these are + # still minimal. + + set weightmap($v) $arcweight + set arcmap($arc) . + } + } else { + # Node not yet present. Save weight and arc. The + # latter if and only the arc is actually defined. For + # the first, initial queue entry, it is not. Then we + # add all the arcs adjacent to the current node to the + # queue to consider them in the next rounds. + + set weightmap($v) $arcweight + if {!$arcundefined} { + set arcmap($arc) . + } + foreach adjacentarc [$g arcs -adj $v] { + set weight [$g arc getweight $adjacentarc] + set neighbour [$g node opposite $v $adjacentarc] + $consider put [list $neighbour 0 $adjacentarc] $weight + } + } + + # Mark the node as visited, belonging to the current + # component. Future iterations will ignore it. + unset -nocomplain unvisited($v) + } + } + + # We are done. Get rid of the transient helper structure and + # return our result. + + $consider destroy + + return [array names arcmap] +} + +# ### ### ### ######### ######### ######### +## + +# This command checks whether the graph argument is bi-partite or not, +# and returns the result as a boolean value, true for a bi-partite +# graph, and false otherwise. A variable can be provided to store the +# bi-partition into. +# +# Reference: http://en.wikipedia.org/wiki/Bipartite_graph + +proc ::struct::graph::op::isBipartite? {g {bipartitionvar {}}} { + + # Handle the special cases of empty graphs, or one without arcs + # quickly. Both are bi-partite. + + if {$bipartitionvar ne ""} { + upvar 1 $bipartitionvar bipartitions + } + if {![llength [$g nodes]]} { + set bipartitions {{} {}} + return 1 + } elseif {![llength [$g arcs]]} { + if {$bipartitionvar ne ""} { + set bipartitions [list [$g nodes] {}] + } + return 1 + } + + # Transient helper data structure, a queue of the nodes waiting + # for processing. + + set pending [struct::queue pending] + set nodes [$g nodes] + + # Another structure, a map from node names to their 'color', + # indicating which of the two partitions a node belngs to. All + # nodes start out as undefined (0). Traversing the arcs we + # set and flip them as needed (1,2). + + array set color {} + foreach node $nodes { + set color($node) 0 + } + + # Iterating over all nodes we use their connections to traverse + # the components and assign colors. We abort when encountering + # paradox, as that means that the graph is not bi-partite. + + foreach node $nodes { + # Ignore nodes already in the second partition. + if {$color($node)} continue + + # Flip the color, then travel the component and check for + # conflicts with the neighbours. + + set color($node) 1 + + $pending put $node + while {[$pending size]} { + set current [$pending get] + foreach neighbour [$g nodes -adj $current] { + if {!$color($neighbour)} { + # Exchange the color between current and previous + # nodes, and remember the neighbour for further + # processing. + set color($neighbour) [expr {3 - $color($current)}] + $pending put $neighbour + } elseif {$color($neighbour) == $color($current)} { + # Color conflict between adjacent nodes, should be + # different. This graph is not bi-partite. Kill + # the data structure and abort. + + $pending destroy + return 0 + } + } + } + } + + # The graph is bi-partite. Kill the transient data structure, and + # move the partitions into the provided variable, if there is any. + + $pending destroy + + if {$bipartitionvar ne ""} { + # Build bipartition, then set the data into the variable + # passed as argument to this command. + + set X {} + set Y {} + + foreach {node partition} [array get color] { + if {$partition == 1} { + lappend X $node + } else { + lappend Y $node + } + } + set bipartitions [list $X $Y] + } + + return 1 +} + +# ### ### ### ######### ######### ######### +## + +# This command computes a maximal matching, if it exists, for the +# graph argument G and its bi-partition as specified through the node +# sets X and Y. As is implied, this method requires that the graph is +# bi-partite. Use the command 'isBipartite?' to check for this +# property, and to obtain the bi-partition. +if 0 { + proc ::struct::graph::op::maxMatching {g X Y} { + return -code error "not implemented yet" + }} + +# ### ### ### ######### ######### ######### +## + +# This command computes the strongly connected components (SCCs) of +# the graph argument G. The result is a list of node-sets, each set +# containing the nodes of one SCC of G. In any SCC there is a directed +# path between any two nodes U, V from U to V. If all SCCs contain +# only a single node the graph is acyclic. + +proc ::struct::graph::op::tarjan {g} { + set all [$g nodes] + + # Quick bailout for simple special cases, i.e. graphs without + # nodes or arcs. + if {![llength $all]} { + # No nodes => no SCCs + return {} + } elseif {![llength [$g arcs]]} { + # Have nodes, but no arcs => each node is its own SCC. + set r {} ; foreach a $all { lappend r [list $a] } + return $r + } + + # Transient data structures. Stack of nodes to consider, the + # result, and various state arrays. TarjanSub upvar's all them + # into its scope. + + set pending [::struct::stack pending] + set result {} + + array set index {} + array set lowlink {} + array set instack {} + + # Invoke the main search system while we have unvisited + # nodes. TarjanSub will remove all visited nodes from 'all', + # ensuring termination. + + while {[llength $all]} { + TarjanSub [lindex $all 0] 0 + } + + # Release the transient structures and return result. + $pending destroy + return $result +} + +proc ::struct::graph::op::TarjanSub {start counter} { + # Import the tracer state from our caller. + upvar 1 g g index index lowlink lowlink instack instack result result pending pending all all + + struct::set subtract all $start + + set component {} + set index($start) $counter + set lowlink($start) $counter + incr counter + + $pending push $start + set instack($start) 1 + + foreach outarc [$g arcs -out $start] { + set neighbour [$g arc target $outarc] + + if {![info exists index($neighbour)]} { + # depth-first-search of reachable nodes from the neighbour + # node. Original from the chosen startnode. + TarjanSub $neighbour $counter + set lowlink($start) [Min $lowlink($start) $lowlink($neighbour)] + + } elseif {[info exists instack($neighbour)]} { + set lowlink($start) [Min $lowlink($start) $lowlink($neighbour)] + } + } + + # Check if the 'start' node on this recursion level is the root + # node of a SCC, and collect the component if yes. + + if {$lowlink($start) == $index($start)} { + while {1} { + set v [$pending pop] + unset instack($v) + lappend component $v + if {$v eq $start} break + } + lappend result $component + } + + return +} + +# ### ### ### ######### ######### ######### +## + +# This command computes the connected components (CCs) of the graph +# argument G. The result is a list of node-sets, each set containing +# the nodes of one CC of G. In any CC there is UN-directed path +# between any two nodes U, V. + +proc ::struct::graph::op::connectedComponents {g} { + set all [$g nodes] + + # Quick bailout for simple special cases, i.e. graphs without + # nodes or arcs. + if {![llength $all]} { + # No nodes => no CCs + return {} + } elseif {![llength [$g arcs]]} { + # Have nodes, but no arcs => each node is its own CC. + set r {} ; foreach a $all { lappend r [list $a] } + return $r + } + + # Invoke the main search system while we have unvisited + # nodes. + + set result {} + while {[llength $all]} { + set component [ComponentOf $g [lindex $all 0]] + lappend result $component + # all = all - component + struct::set subtract all $component + } + return $result +} + +# A derivative command which computes the connected component (CC) of +# the graph argument G containing the node N. The result is a node-set +# containing the nodes of the CC of N in G. + +proc ::struct::graph::op::connectedComponentOf {g n} { + # Quick bailout for simple special cases + if {![$g node exists $n]} { + return -code error "node \"$n\" does not exist in graph \"$g\"" + } elseif {![llength [$g arcs -adj $n]]} { + # The chosen node has no neighbours, so is its own CC. + return [list $n] + } + + # Invoke the main search system for the chosen node. + + return [ComponentOf $g $n] +} + +# Internal helper for finding connected components. + +proc ::struct::graph::op::ComponentOf {g start} { + set pending [::struct::queue pending] + $pending put $start + + array set visited {} + set visited($start) . + + while {[$pending size]} { + set current [$pending get 1] + foreach neighbour [$g nodes -adj $current] { + if {[info exists visited($neighbour)]} continue + $pending put $neighbour + set visited($neighbour) 1 + } + } + $pending destroy + return [array names visited] +} + +# ### ### ### ######### ######### ######### +## + +# This command determines if the specified arc A in the graph G is a +# bridge, i.e. if its removal will split the connected component its +# end nodes belong to, into two. The result is a boolean value. Uses +# the 'ComponentOf' helper command. + +proc ::struct::graph::op::isBridge? {g arc} { + if {![$g arc exists $arc]} { + return -code error "arc \"$arc\" does not exist in graph \"$g\"" + } + + # Note: We could avoid the need for a copy of the graph if we were + # willing to modify G (*). As we are not willing using a copy is + # the easiest way to allow us a trivial modification. For the + # future consider the creation of a graph class which represents + # virtual graphs over a source, generated by deleting nodes and/or + # arcs. without actually modifying the source. + # + # (Ad *): Create a new unnamed helper node X. Move the arc + # destination to X. Recompute the component and ignore + # X. Then move the arc target back to its original node + # and remove X again. + + set src [$g arc source $arc] + set compBefore [ComponentOf $g $src] + if {[llength $compBefore] == 1} { + # Special case, the arc is a loop on an otherwise unconnected + # node. The component will not split, this is not a bridge. + return 0 + } + + set copy [struct::graph BridgeCopy = $g] + $copy arc delete $arc + set compAfter [ComponentOf $copy $src] + $copy destroy + + return [expr {[llength $compBefore] != [llength $compAfter]}] +} + +# This command determines if the specified node N in the graph G is a +# cut vertex, i.e. if its removal will split the connected component +# it belongs to into two. The result is a boolean value. Uses the +# 'ComponentOf' helper command. + +proc ::struct::graph::op::isCutVertex? {g n} { + if {![$g node exists $n]} { + return -code error "node \"$n\" does not exist in graph \"$g\"" + } + + # Note: We could avoid the need for a copy of the graph if we were + # willing to modify G (*). As we are not willing using a copy is + # the easiest way to allow us a trivial modification. For the + # future consider the creation of a graph class which represents + # virtual graphs over a source, generated by deleting nodes and/or + # arcs. without actually modifying the source. + # + # (Ad *): Create two new unnamed helper nodes X and Y. Move the + # icoming and outgoing arcs to these helpers. Recompute + # the component and ignore the helpers. Then move the arcs + # back to their original nodes and remove the helpers + # again. + + set compBefore [ComponentOf $g $n] + + if {[llength $compBefore] == 1} { + # Special case. The node is unconnected. Its removal will + # cause no changes. Therefore not a cutvertex. + return 0 + } + + # We remove the node from the original component, so that we can + # select a new start node without fear of hitting on the + # cut-vertex candidate. Also makes the comparison later easier + # (straight ==). + struct::set subtract compBefore $n + + set copy [struct::graph CutVertexCopy = $g] + $copy node delete $n + set compAfter [ComponentOf $copy [lindex $compBefore 0]] + $copy destroy + + return [expr {[llength $compBefore] != [llength $compAfter]}] +} + +# This command determines if the graph G is connected. + +proc ::struct::graph::op::isConnected? {g} { + return [expr { [llength [connectedComponents $g]] == 1 }] +} + +# ### ### ### ######### ######### ######### +## + +# This command determines if the specified graph G has an eulerian +# cycle (aka euler tour, <=> g is eulerian) or not. If yes, it can +# return the cycle through the named variable, as a list of arcs +# traversed. +# +# Note that for a graph to be eulerian all nodes have to have an even +# degree, and the graph has to be connected. And if more than two +# nodes have an odd degree the graph is not even semi-eulerian (cannot +# even have an euler path). + +proc ::struct::graph::op::isEulerian? {g {eulervar {}} {tourstart {}}} { + set nodes [$g nodes] + if {![llength $nodes] || ![llength [$g arcs]]} { + # Quick bailout for special cases. No nodes, or no arcs imply + # that no euler cycle is present. + return 0 + } + + # Check the condition regarding even degree nodes, then + # connected-ness. + + foreach n $nodes { + if {([$g node degree $n] % 2) == 0} continue + # Odd degree node found, not eulerian. + return 0 + } + + if {![isConnected? $g]} { + return 0 + } + + # At this point the graph is connected, with all nodes of even + # degree. As per Carl Hierholzer the graph has to have an euler + # tour. If the user doesn't request it we do not waste the time to + # actually compute one. + + if {$tourstart ne ""} { + upvar 1 $tourstart start + } + + # We start the tour at an arbitrary node. + set start [lindex $nodes 0] + + if {$eulervar eq ""} { + return 1 + } + + upvar 1 $eulervar tour + Fleury $g $start tour + return 1 +} + +# This command determines if the specified graph G has an eulerian +# path (<=> g is semi-eulerian) or not. If yes, it can return the +# path through the named variable, as a list of arcs traversed. +# +# (*) Aka euler tour. +# +# Note that for a graph to be semi-eulerian at most two nodes are +# allowed to have an odd degree, all others have to be of even degree, +# and the graph has to be connected. + +proc ::struct::graph::op::isSemiEulerian? {g {eulervar {}}} { + set nodes [$g nodes] + if {![llength $nodes] || ![llength [$g arcs]]} { + # Quick bailout for special cases. No nodes, or no arcs imply + # that no euler path is present. + return 0 + } + + # Check the condition regarding oddd/even degree nodes, then + # connected-ness. + + set odd 0 + foreach n $nodes { + if {([$g node degree $n] % 2) == 0} continue + incr odd + set lastodd $n + } + if {($odd > 2) || ![isConnected? $g]} { + return 0 + } + + # At this point the graph is connected, with the node degrees + # supporting existence of an euler path. If the user doesn't + # request it we do not waste the time to actually compute one. + + if {$eulervar eq ""} { + return 1 + } + + upvar 1 $eulervar path + + # We start at either an odd-degree node, or any node, if there are + # no odd-degree ones. In the last case we are actually + # constructing an euler tour, i.e. a closed path. + + if {$odd} { + set start $lastodd + } else { + set start [lindex $nodes 0] + } + + Fleury $g $start path + return 1 +} + +proc ::struct::graph::op::Fleury {g start eulervar} { + upvar 1 $eulervar path + + # We start at the chosen node. + + set copy [struct::graph FleuryCopy = $g] + set path {} + + # Edges are chosen per Fleury's algorithm. That is easy, + # especially as we already have a command to determine whether an + # arc is a bridge or not. + + set arcs [$copy arcs] + while {![struct::set empty $arcs]} { + set adjacent [$copy arcs -adj $start] + + if {[llength $adjacent] == 1} { + # No choice in what arc to traverse. + set arc [lindex $adjacent 0] + } else { + # Choose first non-bridge arcs. The euler conditions force + # that at least two such are present. + + set has 0 + foreach arc $adjacent { + if {[isBridge? $copy $arc]} { + continue + } + set has 1 + break + } + if {!$has} { + $copy destroy + return -code error {Internal error} + } + } + + set start [$copy node opposite $start $arc] + $copy arc delete $arc + struct::set exclude arcs $arc + lappend path $arc + } + + $copy destroy + return +} + +# ### ### ### ######### ######### ######### +## + +# This command uses dijkstra's algorithm to find all shortest paths in +# the graph G starting at node N. The operation can be configured to +# traverse arcs directed and undirected, and the format of the result. + +proc ::struct::graph::op::dijkstra {g node args} { + # Default traversal is undirected. + # Default output format is tree. + + set arcTraversal undirected + set resultFormat tree + + # Process options to override the defaults, if any. + foreach {option param} $args { + switch -exact -- $option { + -arcmode { + switch -exact -- $param { + directed - + undirected { + set arcTraversal $param + } + default { + return -code error "Bad value for -arcmode, expected one of \"directed\" or \"undirected\"" + } + } + } + -outputformat { + switch -exact -- $param { + tree - + distances { + set resultFormat $param + } + default { + return -code error "Bad value for -outputformat, expected one of \"distances\" or \"tree\"" + } + } + } + default { + return -code error "Bad option \"$option\", expected one of \"-arcmode\" or \"-outputformat\"" + } + } + } + + # We expect that all arcs of g are given a weight. + VerifyWeightsAreOk $g + + # And the start node has to belong to the graph too, of course. + if {![$g node exists $node]} { + return -code error "node \"$node\" does not exist in graph \"$g\"" + } + + # TODO: Quick bailout for special cases (no arcs). + + # Transient and other data structures for the core algorithm. + set pending [::struct::prioqueue -dictionary DijkstraQueue] + array set distance {} ; # array: node -> distance to 'n' + array set previous {} ; # array: node -> parent in shortest path to 'n'. + array set visited {} ; # array: node -> bool, true when node processed + + # Initialize the data structures. + foreach n [$g nodes] { + set distance($n) Inf + set previous($n) undefined + set visited($n) 0 + } + + # Compute the distances ... + $pending put $node 0 + set distance($node) 0 + set previous($node) none + + while {[$pending size]} { + set current [$pending get] + set visited($current) 1 + + # Traversal to neighbours according to the chosen mode. + if {$arcTraversal eq "undirected"} { + set arcNeighbours [$g arcs -adj $current] + } else { + set arcNeighbours [$g arcs -out $current] + } + + # Compute distances, record newly discovered nodes, minimize + # distances for nodes reachable through multiple paths. + foreach arcNeighbour $arcNeighbours { + set cost [$g arc getweight $arcNeighbour] + set neighbour [$g node opposite $current $arcNeighbour] + set delta [expr {$distance($current) + $cost}] + + if { + ($distance($neighbour) eq "Inf") || + ($delta < $distance($neighbour)) + } { + # First path, or better path to the node folund, + # update our records. + + set distance($neighbour) $delta + set previous($neighbour) $current + if {!$visited($neighbour)} { + $pending put $neighbour $delta + } + } + } + } + + $pending destroy + + # Now generate the result based on the chosen format. + if {$resultFormat eq "distances"} { + return [array get distance] + } else { + array set listofprevious {} + foreach n [$g nodes] { + set current $n + while {1} { + if {$current eq "undefined"} break + if {$current eq $node} { + lappend listofprevious($n) $current + break + } + if {$current ne $n} { + lappend listofprevious($n) $current + } + set current $previous($current) + } + } + return [array get listofprevious] + } +} + +# This convenience command is a wrapper around dijkstra's algorithm to +# find the (un)directed distance between two nodes in the graph G. + +proc ::struct::graph::op::distance {g origin destination args} { + if {![$g node exists $origin]} { + return -code error "node \"$origin\" does not exist in graph \"$g\"" + } + if {![$g node exists $destination]} { + return -code error "node \"$destination\" does not exist in graph \"$g\"" + } + + set arcTraversal undirected + + # Process options to override the defaults, if any. + foreach {option param} $args { + switch -exact -- $option { + -arcmode { + switch -exact -- $param { + directed - + undirected { + set arcTraversal $param + } + default { + return -code error "Bad value for -arcmode, expected one of \"directed\" or \"undirected\"" + } + } + } + default { + return -code error "Bad option \"$option\", expected \"-arcmode\"" + } + } + } + + # Quick bailout for special case: the distance from a node to + # itself is zero + + if {$origin eq $destination} { + return 0 + } + + # Compute all distances, then pick and return the one we are + # interested in. + array set distance [dijkstra $g $origin -outputformat distances -arcmode $arcTraversal] + return $distance($destination) +} + +# This convenience command is a wrapper around dijkstra's algorithm to +# find the (un)directed eccentricity of the node N in the graph G. The +# eccentricity is the maximal distance to any other node in the graph. + +proc ::struct::graph::op::eccentricity {g node args} { + if {![$g node exists $node]} { + return -code error "node \"$node\" does not exist in graph \"$g\"" + } + + set arcTraversal undirected + + # Process options to override the defaults, if any. + foreach {option param} $args { + switch -exact -- $option { + -arcmode { + switch -exact -- $param { + directed - + undirected { + set arcTraversal $param + } + default { + return -code error "Bad value for -arcmode, expected one of \"directed\" or \"undirected\"" + } + } + } + default { + return -code error "Bad option \"$option\", expected \"-arcmode\"" + } + } + } + + # Compute all distances, then pick out the max + + set ecc 0 + foreach {n distance} [dijkstra $g $node -outputformat distances -arcmode $arcTraversal] { + if {$distance eq "Inf"} { return Inf } + if {$distance > $ecc} { set ecc $distance } + } + + return $ecc +} + +# This convenience command is a wrapper around eccentricity to find +# the (un)directed radius of the graph G. The radius is the minimal +# eccentricity over all nodes in the graph. + +proc ::struct::graph::op::radius {g args} { + return [lindex [RD $g $args] 0] +} + +# This convenience command is a wrapper around eccentricity to find +# the (un)directed diameter of the graph G. The diameter is the +# maximal eccentricity over all nodes in the graph. + +proc ::struct::graph::op::diameter {g args} { + return [lindex [RD $g $args] 1] +} + +proc ::struct::graph::op::RD {g options} { + set arcTraversal undirected + + # Process options to override the defaults, if any. + foreach {option param} $options { + switch -exact -- $option { + -arcmode { + switch -exact -- $param { + directed - + undirected { + set arcTraversal $param + } + default { + return -code error "Bad value for -arcmode, expected one of \"directed\" or \"undirected\"" + } + } + } + default { + return -code error "Bad option \"$option\", expected \"-arcmode\"" + } + } + } + + set radius Inf + set diameter 0 + foreach n [$g nodes] { + set e [eccentricity $g $n -arcmode $arcTraversal] + #puts "$n ==> ($e)" + if {($e eq "Inf") || ($e > $diameter)} { + set diameter $e + } + if {($radius eq "Inf") || ($e < $radius)} { + set radius $e + } + } + + return [list $radius $diameter] +} + +# +## place holder for operations to come +# + +# ### ### ### ######### ######### ######### +## Internal helpers + +proc ::struct::graph::op::Min {first second} { + if {$first > $second} { + return $second + } else { + return $first + } +} + +proc ::struct::graph::op::Max {first second} { + if {$first < $second} { + return $second + } else { + return $first + } +} + +# This method verifies that every arc on the graph has a weight +# assigned to it. This is required for some algorithms. +proc ::struct::graph::op::VerifyWeightsAreOk {g} { + if {![llength [$g arc getunweighted]]} return + return -code error "Operation invalid for graph with unweighted arcs." +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct::graph::op { + #namespace export ... +} + +package provide struct::graph::op 0.11.3 diff --git a/src/bootsupport/lib/struct/list.tcl b/src/bootsupport/lib/struct/list.tcl new file mode 100644 index 00000000..e0f738db --- /dev/null +++ b/src/bootsupport/lib/struct/list.tcl @@ -0,0 +1,1834 @@ +#---------------------------------------------------------------------- +# +# list.tcl -- +# +# Definitions for extended processing of Tcl lists. +# +# Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: list.tcl,v 1.27 2011/09/17 14:35:36 mic42 Exp $ +# +#---------------------------------------------------------------------- + +package require Tcl 8.4 +package require cmdline + +namespace eval ::struct { namespace eval list {} } + +namespace eval ::struct::list { + namespace export list + + if {0} { + # Possibly in the future. + namespace export Lassign + namespace export LdbJoin + namespace export LdbJoinOuter + namespace export Ldelete + namespace export Lequal + namespace export Lfilter + namespace export Lfilterfor + namespace export Lfirstperm + namespace export Lflatten + namespace export Lfold + namespace export Lforeachperm + namespace export Liota + namespace export LlcsInvert + namespace export LlcsInvert2 + namespace export LlcsInvertMerge + namespace export LlcsInvertMerge2 + namespace export LlongestCommonSubsequence + namespace export LlongestCommonSubsequence2 + namespace export Lmap + namespace export Lmapfor + namespace export Lnextperm + namespace export Lpermutations + namespace export Lrepeat + namespace export Lrepeatn + namespace export Lreverse + namespace export Lshift + namespace export Lswap + namespace export Lshuffle + } +} + +########################## +# Public functions + +# ::struct::list::list -- +# +# Command that access all list commands. +# +# Arguments: +# cmd Name of the subcommand to dispatch to. +# args Arguments for the subcommand. +# +# Results: +# Whatever the result of the subcommand is. + +proc ::struct::list::list {cmd args} { + # Do minimal args checks here + if { [llength [info level 0]] == 1 } { + return -code error "wrong # args: should be \"$cmd ?arg arg ...?\"" + } + set sub L$cmd + if { [llength [info commands ::struct::list::$sub]] == 0 } { + set optlist [info commands ::struct::list::L*] + set xlist {} + foreach p $optlist { + lappend xlist [string range $p 1 end] + } + return -code error \ + "bad option \"$cmd\": must be [linsert [join $xlist ", "] "end-1" "or"]" + } + return [uplevel 1 [linsert $args 0 ::struct::list::$sub]] +} + +########################## +# Private functions follow + +proc ::struct::list::K { x y } { set x } + +########################## +# Implementations of the functionality. +# + +# ::struct::list::LlongestCommonSubsequence -- +# +# Computes the longest common subsequence of two lists. +# +# Parameters: +# sequence1, sequence2 -- Two lists to compare. +# maxOccurs -- If provided, causes the procedure to ignore +# lines that appear more than $maxOccurs times +# in the second sequence. See below for a discussion. +# Results: +# Returns a list of two lists of equal length. +# The first sublist is of indices into sequence1, and the +# second sublist is of indices into sequence2. Each corresponding +# pair of indices corresponds to equal elements in the sequences; +# the sequence returned is the longest possible. +# +# Side effects: +# None. +# +# Notes: +# +# While this procedure is quite rapid for many tasks of file +# comparison, its performance degrades severely if the second list +# contains many equal elements (as, for instance, when using this +# procedure to compare two files, a quarter of whose lines are blank. +# This drawback is intrinsic to the algorithm used (see the References +# for details). One approach to dealing with this problem that is +# sometimes effective in practice is arbitrarily to exclude elements +# that appear more than a certain number of times. This number is +# provided as the 'maxOccurs' parameter. If frequent lines are +# excluded in this manner, they will not appear in the common subsequence +# that is computed; the result will be the longest common subsequence +# of infrequent elements. +# +# The procedure struct::list::LongestCommonSubsequence2 +# functions as a wrapper around this procedure; it computes the longest +# common subsequence of infrequent elements, and then subdivides the +# subsequences that lie between the matches to approximate the true +# longest common subsequence. +# +# References: +# J. W. Hunt and M. D. McIlroy, "An algorithm for differential +# file comparison," Comp. Sci. Tech. Rep. #41, Bell Telephone +# Laboratories (1976). Available on the Web at the second +# author's personal site: http://www.cs.dartmouth.edu/~doug/ + +proc ::struct::list::LlongestCommonSubsequence { + sequence1 + sequence2 + {maxOccurs 0x7fffffff} +} { + # Construct a set of equivalence classes of lines in file 2 + + set index 0 + foreach string $sequence2 { + lappend eqv($string) $index + incr index + } + + # K holds descriptions of the common subsequences. + # Initially, there is one common subsequence of length 0, + # with a fence saying that it includes line -1 of both files. + # The maximum subsequence length is 0; position 0 of + # K holds a fence carrying the line following the end + # of both files. + + lappend K [::list -1 -1 {}] + lappend K [::list [llength $sequence1] [llength $sequence2] {}] + set k 0 + + # Walk through the first file, letting i be the index of the line and + # string be the line itself. + + set i 0 + foreach string $sequence1 { + # Consider each possible corresponding index j in the second file. + + if { [info exists eqv($string)] + && [llength $eqv($string)] <= $maxOccurs } { + + # c is the candidate match most recently found, and r is the + # length of the corresponding subsequence. + + set r 0 + set c [lindex $K 0] + + foreach j $eqv($string) { + # Perform a binary search to find a candidate common + # subsequence to which may be appended this match. + + set max $k + set min $r + set s [expr { $k + 1 }] + while { $max >= $min } { + set mid [expr { ( $max + $min ) / 2 }] + set bmid [lindex [lindex $K $mid] 1] + if { $j == $bmid } { + break + } elseif { $j < $bmid } { + set max [expr {$mid - 1}] + } else { + set s $mid + set min [expr { $mid + 1 }] + } + } + + # Go to the next match point if there is no suitable + # candidate. + + if { $j == [lindex [lindex $K $mid] 1] || $s > $k} { + continue + } + + # s is the sequence length of the longest sequence + # to which this match point may be appended. Make + # a new candidate match and store the old one in K + # Set r to the length of the new candidate match. + + set newc [::list $i $j [lindex $K $s]] + if { $r >= 0 } { + lset K $r $c + } + set c $newc + set r [expr { $s + 1 }] + + # If we've extended the length of the longest match, + # we're done; move the fence. + + if { $s >= $k } { + lappend K [lindex $K end] + incr k + break + } + } + + # Put the last candidate into the array + + lset K $r $c + } + + incr i + } + + # Package the common subsequence in a convenient form + + set seta {} + set setb {} + set q [lindex $K $k] + + for { set i 0 } { $i < $k } {incr i } { + lappend seta {} + lappend setb {} + } + while { [lindex $q 0] >= 0 } { + incr k -1 + lset seta $k [lindex $q 0] + lset setb $k [lindex $q 1] + set q [lindex $q 2] + } + + return [::list $seta $setb] +} + +# ::struct::list::LlongestCommonSubsequence2 -- +# +# Derives an approximation to the longest common subsequence +# of two lists. +# +# Parameters: +# sequence1, sequence2 - Lists to be compared +# maxOccurs - Parameter for imprecise matching - see below. +# +# Results: +# Returns a list of two lists of equal length. +# The first sublist is of indices into sequence1, and the +# second sublist is of indices into sequence2. Each corresponding +# pair of indices corresponds to equal elements in the sequences; +# the sequence returned is an approximation to the longest possible. +# +# Side effects: +# None. +# +# Notes: +# This procedure acts as a wrapper around the companion procedure +# struct::list::LongestCommonSubsequence and accepts the same +# parameters. It first computes the longest common subsequence of +# elements that occur no more than $maxOccurs times in the +# second list. Using that subsequence to align the two lists, +# it then tries to augment the subsequence by computing the true +# longest common subsequences of the sublists between matched pairs. + +proc ::struct::list::LlongestCommonSubsequence2 { + sequence1 + sequence2 + {maxOccurs 0x7fffffff} +} { + # Derive the longest common subsequence of elements that occur at + # most $maxOccurs times + + foreach { l1 l2 } \ + [LlongestCommonSubsequence $sequence1 $sequence2 $maxOccurs] { + break + } + + # Walk through the match points in the sequence just derived. + + set result1 {} + set result2 {} + set n1 0 + set n2 0 + foreach i1 $l1 i2 $l2 { + if { $i1 != $n1 && $i2 != $n2 } { + # The match points indicate that there are unmatched + # elements lying between them in both input sequences. + # Extract the unmatched elements and perform precise + # longest-common-subsequence analysis on them. + + set subl1 [lrange $sequence1 $n1 [expr { $i1 - 1 }]] + set subl2 [lrange $sequence2 $n2 [expr { $i2 - 1 }]] + foreach { m1 m2 } [LlongestCommonSubsequence $subl1 $subl2] break + foreach j1 $m1 j2 $m2 { + lappend result1 [expr { $j1 + $n1 }] + lappend result2 [expr { $j2 + $n2 }] + } + } + + # Add the current match point to the result + + lappend result1 $i1 + lappend result2 $i2 + set n1 [expr { $i1 + 1 }] + set n2 [expr { $i2 + 1 }] + } + + # If there are unmatched elements after the last match in both files, + # perform precise longest-common-subsequence matching on them and + # add the result to our return. + + if { $n1 < [llength $sequence1] && $n2 < [llength $sequence2] } { + set subl1 [lrange $sequence1 $n1 end] + set subl2 [lrange $sequence2 $n2 end] + foreach { m1 m2 } [LlongestCommonSubsequence $subl1 $subl2] break + foreach j1 $m1 j2 $m2 { + lappend result1 [expr { $j1 + $n1 }] + lappend result2 [expr { $j2 + $n2 }] + } + } + + return [::list $result1 $result2] +} + +# ::struct::list::LlcsInvert -- +# +# Takes the data describing a longest common subsequence of two +# lists and inverts the information in the sense that the result +# of this command will describe the differences between the two +# sequences instead of the identical parts. +# +# Parameters: +# lcsData longest common subsequence of two lists as +# returned by longestCommonSubsequence(2). +# Results: +# Returns a single list whose elements describe the differences +# between the original two sequences. Each element describes +# one difference through three pieces, the type of the change, +# a pair of indices in the first sequence and a pair of indices +# into the second sequence, in this order. +# +# Side effects: +# None. + +proc ::struct::list::LlcsInvert {lcsData len1 len2} { + return [LlcsInvert2 [::lindex $lcsData 0] [::lindex $lcsData 1] $len1 $len2] +} + +proc ::struct::list::LlcsInvert2 {idx1 idx2 len1 len2} { + set result {} + set last1 -1 + set last2 -1 + + foreach a $idx1 b $idx2 { + # Four possible cases. + # a) last1 ... a and last2 ... b are not empty. + # This is a 'change'. + # b) last1 ... a is empty, last2 ... b is not. + # This is an 'addition'. + # c) last1 ... a is not empty, last2 ... b is empty. + # This is a deletion. + # d) If both ranges are empty we can ignore the + # two current indices. + + set empty1 [expr {($a - $last1) <= 1}] + set empty2 [expr {($b - $last2) <= 1}] + + if {$empty1 && $empty2} { + # Case (d), ignore the indices + } elseif {$empty1} { + # Case (b), 'addition'. + incr last2 ; incr b -1 + lappend result [::list added [::list $last1 $a] [::list $last2 $b]] + incr b + } elseif {$empty2} { + # Case (c), 'deletion' + incr last1 ; incr a -1 + lappend result [::list deleted [::list $last1 $a] [::list $last2 $b]] + incr a + } else { + # Case (q), 'change'. + incr last1 ; incr a -1 + incr last2 ; incr b -1 + lappend result [::list changed [::list $last1 $a] [::list $last2 $b]] + incr a + incr b + } + + set last1 $a + set last2 $b + } + + # Handle the last chunk, using the information about the length of + # the original sequences. + + set empty1 [expr {($len1 - $last1) <= 1}] + set empty2 [expr {($len2 - $last2) <= 1}] + + if {$empty1 && $empty2} { + # Case (d), ignore the indices + } elseif {$empty1} { + # Case (b), 'addition'. + incr last2 ; incr len2 -1 + lappend result [::list added [::list $last1 $len1] [::list $last2 $len2]] + } elseif {$empty2} { + # Case (c), 'deletion' + incr last1 ; incr len1 -1 + lappend result [::list deleted [::list $last1 $len1] [::list $last2 $len2]] + } else { + # Case (q), 'change'. + incr last1 ; incr len1 -1 + incr last2 ; incr len2 -1 + lappend result [::list changed [::list $last1 $len1] [::list $last2 $len2]] + } + + return $result +} + +proc ::struct::list::LlcsInvertMerge {lcsData len1 len2} { + return [LlcsInvertMerge2 [::lindex $lcsData 0] [::lindex $lcsData 1] $len1 $len2] +} + +proc ::struct::list::LlcsInvertMerge2 {idx1 idx2 len1 len2} { + set result {} + set last1 -1 + set last2 -1 + + foreach a $idx1 b $idx2 { + # Four possible cases. + # a) last1 ... a and last2 ... b are not empty. + # This is a 'change'. + # b) last1 ... a is empty, last2 ... b is not. + # This is an 'addition'. + # c) last1 ... a is not empty, last2 ... b is empty. + # This is a deletion. + # d) If both ranges are empty we can ignore the + # two current indices. For merging we simply + # take the information from the input. + + set empty1 [expr {($a - $last1) <= 1}] + set empty2 [expr {($b - $last2) <= 1}] + + if {$empty1 && $empty2} { + # Case (d), add 'unchanged' chunk. + set type -- + foreach {type left right} [lindex $result end] break + if {[string match unchanged $type]} { + # There is an existing result to extend + lset left end $a + lset right end $b + lset result end [::list unchanged $left $right] + } else { + # There is an unchanged result at the start of the list; + # it may be extended. + lappend result [::list unchanged [::list $a $a] [::list $b $b]] + } + } else { + if {$empty1} { + # Case (b), 'addition'. + incr last2 ; incr b -1 + lappend result [::list added [::list $last1 $a] [::list $last2 $b]] + incr b + } elseif {$empty2} { + # Case (c), 'deletion' + incr last1 ; incr a -1 + lappend result [::list deleted [::list $last1 $a] [::list $last2 $b]] + incr a + } else { + # Case (a), 'change'. + incr last1 ; incr a -1 + incr last2 ; incr b -1 + lappend result [::list changed [::list $last1 $a] [::list $last2 $b]] + incr a + incr b + } + # Finally, the two matching lines are a new unchanged region + lappend result [::list unchanged [::list $a $a] [::list $b $b]] + } + set last1 $a + set last2 $b + } + + # Handle the last chunk, using the information about the length of + # the original sequences. + + set empty1 [expr {($len1 - $last1) <= 1}] + set empty2 [expr {($len2 - $last2) <= 1}] + + if {$empty1 && $empty2} { + # Case (d), ignore the indices + } elseif {$empty1} { + # Case (b), 'addition'. + incr last2 ; incr len2 -1 + lappend result [::list added [::list $last1 $len1] [::list $last2 $len2]] + } elseif {$empty2} { + # Case (c), 'deletion' + incr last1 ; incr len1 -1 + lappend result [::list deleted [::list $last1 $len1] [::list $last2 $len2]] + } else { + # Case (q), 'change'. + incr last1 ; incr len1 -1 + incr last2 ; incr len2 -1 + lappend result [::list changed [::list $last1 $len1] [::list $last2 $len2]] + } + + return $result +} + +# ::struct::list::Lreverse -- +# +# Reverses the contents of the list and returns the reversed +# list as the result of the command. +# +# Parameters: +# sequence List to be reversed. +# +# Results: +# The sequence in reverse. +# +# Side effects: +# None. + +proc ::struct::list::Lreverse {sequence} { + set l [::llength $sequence] + + # Shortcut for lists where reversing yields the list itself + if {$l < 2} {return $sequence} + + # Perform true reversal + set res [::list] + while {$l} { + ::lappend res [::lindex $sequence [incr l -1]] + } + return $res +} + + +# ::struct::list::Lassign -- +# +# Assign list elements to variables. +# +# Parameters: +# sequence List to assign +# args Names of the variables to assign to. +# +# Results: +# The unassigned part of the sequence. Can be empty. +# +# Side effects: +# None. + +# Do a compatibility version of [assign] for pre-8.5 versions of Tcl. + +if { [package vcompare [package provide Tcl] 8.5] < 0 } { + # 8.4 + proc ::struct::list::Lassign {sequence v args} { + set args [linsert $args 0 $v] + set a [::llength $args] + + # Nothing to assign. + #if {$a == 0} {return $sequence} + + # Perform assignments + set i 0 + foreach v $args { + upvar 1 $v var + set var [::lindex $sequence $i] + incr i + } + + # Return remainder, if there is any. + return [::lrange $sequence $a end] +} + +} else { + # For 8.5+ simply redirect the method to the core command. + + interp alias {} ::struct::list::Lassign {} lassign +} + + +# ::struct::list::Lshift -- +# +# Shift a list in a variable one element down, and return first element +# +# Parameters: +# listvar Name of variable containing the list to shift. +# +# Results: +# The first element of the list. +# +# Side effects: +# After the call the list variable will contain +# the second to last elements of the list. + +proc ::struct::list::Lshift {listvar} { + upvar 1 $listvar list + set list [Lassign [K $list [set list {}]] v] + return $v +} + + +# ::struct::list::Lflatten -- +# +# Remove nesting from the input +# +# Parameters: +# sequence List to flatten +# +# Results: +# The input list with one or all levels of nesting removed. +# +# Side effects: +# None. + +proc ::struct::list::Lflatten {args} { + if {[::llength $args] < 1} { + return -code error \ + "wrong#args: should be \"::struct::list::Lflatten ?-full? ?--? sequence\"" + } + + set full 0 + while {[string match -* [set opt [::lindex $args 0]]]} { + switch -glob -- $opt { + -full {set full 1} + -- { + set args [::lrange $args 1 end] + break ; # fix ticket 6e778502b8 -- break exits while loop + } + default { + return -code error "Unknown option \"$opt\", should be either -full, or --" + } + } + set args [::lrange $args 1 end] + } + + if {[::llength $args] != 1} { + return -code error \ + "wrong#args: should be \"::struct::list::Lflatten ?-full? ?--? sequence\"" + } + + set sequence [::lindex $args 0] + set cont 1 + while {$cont} { + set cont 0 + set result [::list] + foreach item $sequence { + # catch/llength detects if the item is following the list + # syntax. + + if {[catch {llength $item} len]} { + # Element is not a list in itself, no flatten, add it + # as is. + lappend result $item + } else { + # Element is parseable as list, add all sub-elements + # to the result. + foreach e $item { + lappend result $e + } + } + } + if {$full && [string compare $sequence $result]} {set cont 1} + set sequence $result + } + return $result +} + + +# ::struct::list::Lmap -- +# +# Apply command to each element of a list and return concatenated results. +# +# Parameters: +# sequence List to operate on +# cmdprefix Operation to perform on the elements. +# +# Results: +# List containing the result of applying cmdprefix to the elements of the +# sequence. +# +# Side effects: +# None of its own, but the command prefix can perform arbitry actions. + +proc ::struct::list::Lmap {sequence cmdprefix} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return $sequence} + + set res [::list] + foreach item $sequence { + lappend res [uplevel 1 [linsert $cmdprefix end $item]] + } + return $res +} + +# ::struct::list::Lmapfor -- +# +# Apply a script to each element of a list and return concatenated results. +# +# Parameters: +# sequence List to operate on +# script The script to run on the elements. +# +# Results: +# List containing the result of running script on the elements of the +# sequence. +# +# Side effects: +# None of its own, but the script can perform arbitry actions. + +proc ::struct::list::Lmapfor {var sequence script} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return $sequence} + upvar 1 $var item + + set res [::list] + foreach item $sequence { + lappend res [uplevel 1 $script] + } + return $res +} + +# ::struct::list::Lfilter -- +# +# Apply command to each element of a list and return elements passing the test. +# +# Parameters: +# sequence List to operate on +# cmdprefix Test to perform on the elements. +# +# Results: +# List containing the elements of the input passing the test command. +# +# Side effects: +# None of its own, but the command prefix can perform arbitrary actions. + +proc ::struct::list::Lfilter {sequence cmdprefix} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return $sequence} + return [uplevel 1 [::list ::struct::list::Lfold $sequence {} [::list ::struct::list::FTest $cmdprefix]]] +} + +proc ::struct::list::FTest {cmdprefix result item} { + set pass [uplevel 1 [::linsert $cmdprefix end $item]] + if {$pass} {::lappend result $item} + return $result +} + +# ::struct::list::Lfilterfor -- +# +# Apply expr condition to each element of a list and return elements passing the test. +# +# Parameters: +# sequence List to operate on +# expr Test to perform on the elements. +# +# Results: +# List containing the elements of the input passing the test expression. +# +# Side effects: +# None of its own, but the command prefix can perform arbitrary actions. + +proc ::struct::list::Lfilterfor {var sequence expr} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return $sequence} + + upvar 1 $var item + set result {} + foreach item $sequence { + if {[uplevel 1 [::list ::expr $expr]]} { + lappend result $item + } + } + return $result +} + +# ::struct::list::Lsplit -- +# +# Apply command to each element of a list and return elements passing +# and failing the test. Basic idea by Salvatore Sanfilippo +# (http://wiki.tcl.tk/lsplit). The implementation here is mine (AK), +# and the interface is slightly different (Command prefix with the +# list element given to it as argument vs. variable + script). +# +# Parameters: +# sequence List to operate on +# cmdprefix Test to perform on the elements. +# args = empty | (varPass varFail) +# +# Results: +# If the variables are specified then a list containing the +# numbers of passing and failing elements, in this +# order. Otherwise a list having two elements, the lists of +# passing and failing elements, in this order. +# +# Side effects: +# None of its own, but the command prefix can perform arbitrary actions. + +proc ::struct::list::Lsplit {sequence cmdprefix args} { + set largs [::llength $args] + if {$largs == 0} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return {{} {}}} + return [uplevel 1 [::list [namespace which Lfold] $sequence {} [ + ::list ::struct::list::PFTest $cmdprefix]]] + } elseif {$largs == 2} { + # Shortcut when nothing is to be done. + foreach {pv fv} $args break + upvar 1 $pv pass $fv fail + if {[::llength $sequence] == 0} { + set pass {} + set fail {} + return {0 0} + } + foreach {pass fail} [uplevel 1 [ + ::list ::struct::list::Lfold $sequence {} [ + ::list ::struct::list::PFTest $cmdprefix]]] break + return [::list [llength $pass] [llength $fail]] + } else { + return -code error \ + "wrong#args: should be \"::struct::list::Lsplit sequence cmdprefix ?passVar failVar?" + } +} + +proc ::struct::list::PFTest {cmdprefix result item} { + set passing [uplevel 1 [::linsert $cmdprefix end $item]] + set pass {} ; set fail {} + foreach {pass fail} $result break + if {$passing} { + ::lappend pass $item + } else { + ::lappend fail $item + } + return [::list $pass $fail] +} + +# ::struct::list::Lfold -- +# +# Fold list into one value. +# +# Parameters: +# sequence List to operate on +# cmdprefix Operation to perform on the elements. +# +# Results: +# Result of applying cmdprefix to the elements of the +# sequence. +# +# Side effects: +# None of its own, but the command prefix can perform arbitry actions. + +proc ::struct::list::Lfold {sequence initialvalue cmdprefix} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return $initialvalue} + + set res $initialvalue + foreach item $sequence { + set res [uplevel 1 [linsert $cmdprefix end $res $item]] + } + return $res +} + +# ::struct::list::Liota -- +# +# Return a list containing the integer numbers 0 ... n-1 +# +# Parameters: +# n First number not in the generated list. +# +# Results: +# A list containing integer numbers. +# +# Side effects: +# None + +proc ::struct::list::Liota {n} { + set retval [::list] + for {set i 0} {$i < $n} {incr i} { + ::lappend retval $i + } + return $retval +} + +# ::struct::list::Ldelete -- +# +# Delete an element from a list by name. +# Similar to 'struct::set exclude', however +# this here preserves order and list intrep. +# +# Parameters: +# a First list to compare. +# b Second list to compare. +# +# Results: +# A boolean. True if the lists are delete. +# +# Side effects: +# None + +proc ::struct::list::Ldelete {var item} { + upvar 1 $var list + set pos [lsearch -exact $list $item] + if {$pos < 0} return + set list [lreplace [K $list [set list {}]] $pos $pos] + return +} + +# ::struct::list::Lequal -- +# +# Compares two lists for equality +# (Same length, Same elements in same order). +# +# Parameters: +# a First list to compare. +# b Second list to compare. +# +# Results: +# A boolean. True if the lists are equal. +# +# Side effects: +# None + +proc ::struct::list::Lequal {a b} { + # Author of this command is "Richard Suchenwirth" + + if {[::llength $a] != [::llength $b]} {return 0} + if {[::lindex $a 0] == $a && [::lindex $b 0] == $b} {return [string equal $a $b]} + foreach i $a j $b {if {![Lequal $i $j]} {return 0}} + return 1 +} + +# ::struct::list::Lrepeatn -- +# +# Create a list repeating the same value over again. +# +# Parameters: +# value value to use in the created list. +# args Dimension(s) of the (nested) list to create. +# +# Results: +# A list +# +# Side effects: +# None + +proc ::struct::list::Lrepeatn {value args} { + if {[::llength $args] == 1} {set args [::lindex $args 0]} + set buf {} + foreach number $args { + incr number 0 ;# force integer (1) + set buf {} + for {set i 0} {$i<$number} {incr i} { + ::lappend buf $value + } + set value $buf + } + return $buf + # (1): See 'Stress testing' (wiki) for why this makes the code safer. +} + +# ::struct::list::Lrepeat -- +# +# Create a list repeating the same value over again. +# [Identical to the Tcl 8.5 lrepeat command] +# +# Parameters: +# n Number of replications. +# args values to use in the created list. +# +# Results: +# A list +# +# Side effects: +# None + +# Do a compatibility version of [repeat] for pre-8.5 versions of Tcl. + +if { [package vcompare [package provide Tcl] 8.5] < 0 } { + + proc ::struct::list::Lrepeat {positiveCount value args} { + if {![string is integer -strict $positiveCount]} { + return -code error "expected integer but got \"$positiveCount\"" + } elseif {$positiveCount < 1} { + return -code error {must have a count of at least 1} + } + + set args [linsert $args 0 $value] + + if {$positiveCount == 1} { + # Tcl itself has already listified the incoming parameters + # via 'args'. + return $args + } + + set result [::list] + while {$positiveCount > 0} { + if {($positiveCount % 2) == 0} { + set args [concat $args $args] + set positiveCount [expr {$positiveCount/2}] + } else { + set result [concat $result $args] + incr positiveCount -1 + } + } + return $result + } + +} else { + # For 8.5 simply redirect the method to the core command. + + interp alias {} ::struct::list::Lrepeat {} lrepeat +} + +# ::struct::list::LdbJoin(Keyed) -- +# +# Relational table joins. +# +# Parameters: +# args key specs and tables to join +# +# Results: +# A table/matrix as nested list. See +# struct/matrix set/get rect for structure. +# +# Side effects: +# None + +proc ::struct::list::LdbJoin {args} { + # -------------------------------- + # Process options ... + + set mode inner + set keyvar {} + + while {[llength $args]} { + set err [::cmdline::getopt args {inner left right full keys.arg} opt arg] + if {$err == 1} { + if {[string equal $opt keys]} { + set keyvar $arg + } else { + set mode $opt + } + } elseif {$err < 0} { + return -code error "wrong#args: dbJoin ?-inner|-left|-right|-full? ?-keys varname? \{key table\}..." + } else { + # Non-option argument found, stop processing. + break + } + } + + set inner [string equal $mode inner] + set innerorleft [expr {$inner || [string equal $mode left]}] + + # -------------------------------- + # Process tables ... + + if {([llength $args] % 2) != 0} { + return -code error "wrong#args: dbJoin ?-inner|-left|-right|-full? \{key table\}..." + } + + # One table only, join is identity + if {[llength $args] == 2} {return [lindex $args 1]} + + # Use first table for setup. + + foreach {key table} $args break + + # Check for possible early abort + if {$innerorleft && ([llength $table] == 0)} {return {}} + + set width 0 + array set state {} + + set keylist [InitMap state width $key $table] + + # Extend state with the remaining tables. + + foreach {key table} [lrange $args 2 end] { + # Check for possible early abort + if {$inner && ([llength $table] == 0)} {return {}} + + switch -exact -- $mode { + inner {set keylist [MapExtendInner state $key $table]} + left {set keylist [MapExtendLeftOuter state width $key $table]} + right {set keylist [MapExtendRightOuter state width $key $table]} + full {set keylist [MapExtendFullOuter state width $key $table]} + } + + # Check for possible early abort + if {$inner && ([llength $keylist] == 0)} {return {}} + } + + if {[string length $keyvar]} { + upvar 1 $keyvar keys + set keys $keylist + } + + return [MapToTable state $keylist] +} + +proc ::struct::list::LdbJoinKeyed {args} { + # -------------------------------- + # Process options ... + + set mode inner + set keyvar {} + + while {[llength $args]} { + set err [::cmdline::getopt args {inner left right full keys.arg} opt arg] + if {$err == 1} { + if {[string equal $opt keys]} { + set keyvar $arg + } else { + set mode $opt + } + } elseif {$err < 0} { + return -code error "wrong#args: dbJoin ?-inner|-left|-right|-full? table..." + } else { + # Non-option argument found, stop processing. + break + } + } + + set inner [string equal $mode inner] + set innerorleft [expr {$inner || [string equal $mode left]}] + + # -------------------------------- + # Process tables ... + + # One table only, join is identity + if {[llength $args] == 1} { + return [Dekey [lindex $args 0]] + } + + # Use first table for setup. + + set table [lindex $args 0] + + # Check for possible early abort + if {$innerorleft && ([llength $table] == 0)} {return {}} + + set width 0 + array set state {} + + set keylist [InitKeyedMap state width $table] + + # Extend state with the remaining tables. + + foreach table [lrange $args 1 end] { + # Check for possible early abort + if {$inner && ([llength $table] == 0)} {return {}} + + switch -exact -- $mode { + inner {set keylist [MapKeyedExtendInner state $table]} + left {set keylist [MapKeyedExtendLeftOuter state width $table]} + right {set keylist [MapKeyedExtendRightOuter state width $table]} + full {set keylist [MapKeyedExtendFullOuter state width $table]} + } + + # Check for possible early abort + if {$inner && ([llength $keylist] == 0)} {return {}} + } + + if {[string length $keyvar]} { + upvar 1 $keyvar keys + set keys $keylist + } + + return [MapToTable state $keylist] +} + +## Helpers for the relational joins. +## Map is an array mapping from keys to a list +## of rows with that key + +proc ::struct::list::Cartesian {leftmap rightmap key} { + upvar $leftmap left $rightmap right + set joined [::list] + foreach lrow $left($key) { + foreach row $right($key) { + lappend joined [concat $lrow $row] + } + } + set left($key) $joined + return +} + +proc ::struct::list::SingleRightCartesian {mapvar key rightrow} { + upvar $mapvar map + set joined [::list] + foreach lrow $map($key) { + lappend joined [concat $lrow $rightrow] + } + set map($key) $joined + return +} + +proc ::struct::list::MapToTable {mapvar keys} { + # Note: keys must not appear multiple times in the list. + + upvar $mapvar map + set table [::list] + foreach k $keys { + foreach row $map($k) {lappend table $row} + } + return $table +} + +## More helpers, core join operations: Init, Extend. + +proc ::struct::list::InitMap {mapvar wvar key table} { + upvar $mapvar map $wvar width + set width [llength [lindex $table 0]] + foreach row $table { + set keyval [lindex $row $key] + if {[info exists map($keyval)]} { + lappend map($keyval) $row + } else { + set map($keyval) [::list $row] + } + } + return [array names map] +} + +proc ::struct::list::MapExtendInner {mapvar key table} { + upvar $mapvar map + array set used {} + + # Phase I - Find all keys in the second table matching keys in the + # first. Remember all their rows. + foreach row $table { + set keyval [lindex $row $key] + if {[info exists map($keyval)]} { + if {[info exists used($keyval)]} { + lappend used($keyval) $row + } else { + set used($keyval) [::list $row] + } + } ; # else: Nothing to do for missing keys. + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map, and eliminate all entries which have no keys in + # the second table. + foreach k [array names map] { + if {[info exists used($k)]} { + Cartesian map used $k + } else { + unset map($k) + } + } + return [array names map] +} + +proc ::struct::list::MapExtendRightOuter {mapvar wvar key table} { + upvar $mapvar map $wvar width + array set used {} + + # Phase I - We keep all keys of the right table, even if they are + # missing in the left one <=> Definition of right outer join. + + set w [llength [lindex $table 0]] + foreach row $table { + set keyval [lindex $row $key] + if {[info exists used($keyval)]} { + lappend used($keyval) $row + } else { + set used($keyval) [::list $row] + } + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map, and eliminate all entries which have no keys in + # the second table. If there is nothing in the left table we + # create an appropriate empty row for the cartesian => definition + # of right outer join. + + # We go through used, because map can be empty for outer + + foreach k [array names map] { + if {![info exists used($k)]} { + unset map($k) + } + } + foreach k [array names used] { + if {![info exists map($k)]} { + set map($k) [::list [Lrepeatn {} $width]] + } + Cartesian map used $k + } + + incr width $w + return [array names map] +} + +proc ::struct::list::MapExtendLeftOuter {mapvar wvar key table} { + upvar $mapvar map $wvar width + array set used {} + + ## Keys: All in inner join + additional left keys + ## == All left keys = array names map after + ## all is said and done with it. + + # Phase I - Find all keys in the second table matching keys in the + # first. Remember all their rows. + set w [llength [lindex $table 0]] + foreach row $table { + set keyval [lindex $row $key] + if {[info exists map($keyval)]} { + if {[info exists used($keyval)]} { + lappend used($keyval) $row + } else { + set used($keyval) [::list $row] + } + } ; # else: Nothing to do for missing keys. + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map. We keep entries which have no keys in the second + # table, we actually extend them <=> Left outer join. + + foreach k [array names map] { + if {[info exists used($k)]} { + Cartesian map used $k + } else { + SingleRightCartesian map $k [Lrepeatn {} $w] + } + } + incr width $w + return [array names map] +} + +proc ::struct::list::MapExtendFullOuter {mapvar wvar key table} { + upvar $mapvar map $wvar width + array set used {} + + # Phase I - We keep all keys of the right table, even if they are + # missing in the left one <=> Definition of right outer join. + + set w [llength [lindex $table 0]] + foreach row $table { + set keyval [lindex $row $key] + if {[info exists used($keyval)]} { + lappend used($keyval) $row + } else { + lappend keylist $keyval + set used($keyval) [::list $row] + } + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map. We keep entries which have no keys in the second + # table, we actually extend them <=> Left outer join. + # If there is nothing in the left table we create an appropriate + # empty row for the cartesian => definition of right outer join. + + # We go through used, because map can be empty for outer + + foreach k [array names map] { + if {![info exists used($k)]} { + SingleRightCartesian map $k [Lrepeatn {} $w] + } + } + foreach k [array names used] { + if {![info exists map($k)]} { + set map($k) [::list [Lrepeatn {} $width]] + } + Cartesian map used $k + } + + incr width $w + return [array names map] +} + +## Keyed helpers + +proc ::struct::list::InitKeyedMap {mapvar wvar table} { + upvar $mapvar map $wvar width + set width [llength [lindex [lindex $table 0] 1]] + foreach row $table { + foreach {keyval rowdata} $row break + if {[info exists map($keyval)]} { + lappend map($keyval) $rowdata + } else { + set map($keyval) [::list $rowdata] + } + } + return [array names map] +} + +proc ::struct::list::MapKeyedExtendInner {mapvar table} { + upvar $mapvar map + array set used {} + + # Phase I - Find all keys in the second table matching keys in the + # first. Remember all their rows. + foreach row $table { + foreach {keyval rowdata} $row break + if {[info exists map($keyval)]} { + if {[info exists used($keyval)]} { + lappend used($keyval) $rowdata + } else { + set used($keyval) [::list $rowdata] + } + } ; # else: Nothing to do for missing keys. + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map, and eliminate all entries which have no keys in + # the second table. + foreach k [array names map] { + if {[info exists used($k)]} { + Cartesian map used $k + } else { + unset map($k) + } + } + + return [array names map] +} + +proc ::struct::list::MapKeyedExtendRightOuter {mapvar wvar table} { + upvar $mapvar map $wvar width + array set used {} + + # Phase I - We keep all keys of the right table, even if they are + # missing in the left one <=> Definition of right outer join. + + set w [llength [lindex $table 0]] + foreach row $table { + foreach {keyval rowdata} $row break + if {[info exists used($keyval)]} { + lappend used($keyval) $rowdata + } else { + set used($keyval) [::list $rowdata] + } + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map, and eliminate all entries which have no keys in + # the second table. If there is nothing in the left table we + # create an appropriate empty row for the cartesian => definition + # of right outer join. + + # We go through used, because map can be empty for outer + + foreach k [array names map] { + if {![info exists used($k)]} { + unset map($k) + } + } + foreach k [array names used] { + if {![info exists map($k)]} { + set map($k) [::list [Lrepeatn {} $width]] + } + Cartesian map used $k + } + + incr width $w + return [array names map] +} + +proc ::struct::list::MapKeyedExtendLeftOuter {mapvar wvar table} { + upvar $mapvar map $wvar width + array set used {} + + ## Keys: All in inner join + additional left keys + ## == All left keys = array names map after + ## all is said and done with it. + + # Phase I - Find all keys in the second table matching keys in the + # first. Remember all their rows. + set w [llength [lindex $table 0]] + foreach row $table { + foreach {keyval rowdata} $row break + if {[info exists map($keyval)]} { + if {[info exists used($keyval)]} { + lappend used($keyval) $rowdata + } else { + set used($keyval) [::list $rowdata] + } + } ; # else: Nothing to do for missing keys. + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map. We keep entries which have no keys in the second + # table, we actually extend them <=> Left outer join. + + foreach k [array names map] { + if {[info exists used($k)]} { + Cartesian map used $k + } else { + SingleRightCartesian map $k [Lrepeatn {} $w] + } + } + incr width $w + return [array names map] +} + +proc ::struct::list::MapKeyedExtendFullOuter {mapvar wvar table} { + upvar $mapvar map $wvar width + array set used {} + + # Phase I - We keep all keys of the right table, even if they are + # missing in the left one <=> Definition of right outer join. + + set w [llength [lindex $table 0]] + foreach row $table { + foreach {keyval rowdata} $row break + if {[info exists used($keyval)]} { + lappend used($keyval) $rowdata + } else { + lappend keylist $keyval + set used($keyval) [::list $rowdata] + } + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map. We keep entries which have no keys in the second + # table, we actually extend them <=> Left outer join. + # If there is nothing in the left table we create an appropriate + # empty row for the cartesian => definition of right outer join. + + # We go through used, because map can be empty for outer + + foreach k [array names map] { + if {![info exists used($k)]} { + SingleRightCartesian map $k [Lrepeatn {} $w] + } + } + foreach k [array names used] { + if {![info exists map($k)]} { + set map($k) [::list [Lrepeatn {} $width]] + } + Cartesian map used $k + } + + incr width $w + return [array names map] +} + +proc ::struct::list::Dekey {keyedtable} { + set table [::list] + foreach row $keyedtable {lappend table [lindex $row 1]} + return $table +} + +# ::struct::list::Lswap -- +# +# Exchange two elements of a list. +# +# Parameters: +# listvar Name of the variable containing the list to manipulate. +# i, j Indices of the list elements to exchange. +# +# Results: +# The modified list +# +# Side effects: +# None + +proc ::struct::list::Lswap {listvar i j} { + upvar $listvar list + + if {($i < 0) || ($j < 0)} { + return -code error {list index out of range} + } + set len [llength $list] + if {($i >= $len) || ($j >= $len)} { + return -code error {list index out of range} + } + + if {$i != $j} { + set tmp [lindex $list $i] + lset list $i [lindex $list $j] + lset list $j $tmp + } + return $list +} + +# ::struct::list::Lfirstperm -- +# +# Returns the lexicographically first permutation of the +# specified list. +# +# Parameters: +# list The list whose first permutation is sought. +# +# Results: +# A modified list containing the lexicographically first +# permutation of the input. +# +# Side effects: +# None + +proc ::struct::list::Lfirstperm {list} { + return [lsort $list] +} + +# ::struct::list::Lnextperm -- +# +# Accepts a permutation of a set of elements and returns the +# next permutatation in lexicographic sequence. +# +# Parameters: +# list The list containing the current permutation. +# +# Results: +# A modified list containing the lexicographically next +# permutation after the input permutation. +# +# Side effects: +# None + +proc ::struct::list::Lnextperm {perm} { + # Find the smallest subscript j such that we have already visited + # all permutations beginning with the first j elements. + + set len [expr {[llength $perm] - 1}] + + set j $len + set ajp1 [lindex $perm $j] + while { $j > 0 } { + incr j -1 + set aj [lindex $perm $j] + if { [string compare $ajp1 $aj] > 0 } { + set foundj {} + break + } + set ajp1 $aj + } + if { ![info exists foundj] } return + + # Find the smallest element greater than the j'th among the elements + # following aj. Let its index be l, and interchange aj and al. + + set l $len + while { [string compare $aj [set al [lindex $perm $l]]] >= 0 } { + incr l -1 + } + lset perm $j $al + lset perm $l $aj + + # Reverse a_j+1 ... an + + set k [expr {$j + 1}] + set l $len + while { $k < $l } { + set al [lindex $perm $l] + lset perm $l [lindex $perm $k] + lset perm $k $al + incr k + incr l -1 + } + + return $perm +} + +# ::struct::list::Lpermutations -- +# +# Returns a list containing all the permutations of the +# specified list, in lexicographic order. +# +# Parameters: +# list The list whose permutations are sought. +# +# Results: +# A list of lists, containing all permutations of the +# input. +# +# Side effects: +# None + +proc ::struct::list::Lpermutations {list} { + + if {[llength $list] < 2} { + return [::list $list] + } + + set res {} + set p [Lfirstperm $list] + while {[llength $p]} { + lappend res $p + set p [Lnextperm $p] + } + return $res +} + +# ::struct::list::Lforeachperm -- +# +# Executes a script for all the permutations of the +# specified list, in lexicographic order. +# +# Parameters: +# var Name of the loop variable. +# list The list whose permutations are sought. +# body The tcl script to run per permutation of +# the input. +# +# Results: +# The empty string. +# +# Side effects: +# None + +proc ::struct::list::Lforeachperm {var list body} { + upvar $var loopvar + + if {[llength $list] < 2} { + set loopvar $list + # TODO run body. + + # The first invocation of the body, also the last, as only one + # permutation is possible. That makes handling of the result + # codes easier. + + set code [catch {uplevel 1 $body} result] + + # decide what to do upon the return code: + # + # 0 - the body executed successfully + # 1 - the body raised an error + # 2 - the body invoked [return] + # 3 - the body invoked [break] + # 4 - the body invoked [continue] + # everything else - return and pass on the results + # + switch -exact -- $code { + 0 {} + 1 { + return -errorinfo [ErrorInfoAsCaller uplevel foreachperm] \ + -errorcode $::errorCode -code error $result + } + 3 {} + 4 {} + default { + # Includes code 2 + return -code $code $result + } + } + return + } + + set p [Lfirstperm $list] + while {[llength $p]} { + set loopvar $p + + set code [catch {uplevel 1 $body} result] + + # decide what to do upon the return code: + # + # 0 - the body executed successfully + # 1 - the body raised an error + # 2 - the body invoked [return] + # 3 - the body invoked [break] + # 4 - the body invoked [continue] + # everything else - return and pass on the results + # + switch -exact -- $code { + 0 {} + 1 { + return -errorinfo [ErrorInfoAsCaller uplevel foreachperm] \ + -errorcode $::errorCode -code error $result + } + 3 { + # FRINK: nocheck + return + } + 4 {} + default { + return -code $code $result + } + } + set p [Lnextperm $p] + } + return +} + +proc ::struct::list::Lshuffle {list} { + for {set i [llength $list]} {$i > 1} {lset list $j $t} { + set j [expr {int(rand() * $i)}] + set t [lindex $list [incr i -1]] + lset list $i [lindex $list $j] + } + return $list +} + +# ### ### ### ######### ######### ######### + +proc ::struct::list::ErrorInfoAsCaller {find replace} { + set info $::errorInfo + set i [string last "\n (\"$find" $info] + if {$i == -1} {return $info} + set result [string range $info 0 [incr i 6]] ;# keep "\n (\"" + append result $replace ;# $find -> $replace + incr i [string length $find] + set j [string first ) $info [incr i]] ;# keep rest of parenthetical + append result [string range $info $i $j] + return $result +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'list::list' into the general structure namespace. + namespace import -force list::list + namespace export list +} +package provide struct::list 1.8.5 diff --git a/src/bootsupport/lib/struct/list.test.tcl b/src/bootsupport/lib/struct/list.test.tcl new file mode 100644 index 00000000..ae0403a9 --- /dev/null +++ b/src/bootsupport/lib/struct/list.test.tcl @@ -0,0 +1,1292 @@ + +namespace eval ::struct::list::test {} + +proc ::struct::list::test::main {} { + test list-lcs-1.1 {longestCommonSubsequence, no args} { + catch { lcs } msg + set msg + } [tcltest::wrongNumArgs ::struct::list::LlongestCommonSubsequence \ + {sequence1 sequence2 ?maxOccurs?} 0] + + test list-lcs-1.2 {longestCommonSubsequence, one arg} { + catch { lcs x } msg + set msg + } [tcltest::wrongNumArgs ::struct::list::LlongestCommonSubsequence \ + {sequence1 sequence2 ?maxOccurs?} 1] + + test list-lcs-2.1 {longestCommonSubsequence, two empty lists} { + list [catch { lcs {} {} } msg] $msg + } {0 {{} {}}} + + test list-lcs-2.2 {longestCommonSubsequence, insert 1 into an empty list} { + list [catch { lcs {} {a} } msg] $msg + } {0 {{} {}}} + + test list-lcs-2.3 {longestCommonSubsequence, delete 1 from singleton list} { + list [catch { lcs {a} {} } msg] $msg + } {0 {{} {}}} + + test list-lcs-2.4 {longestCommonSubsequence, preserve singleton list} { + list [catch { lcs {a} {a} } msg] $msg + } {0 {0 0}} + + test list-lcs-2.5 {longestCommonSubsequence, 1-element change in singleton list} { + list [catch { lcs {a} {b} } msg] $msg + } {0 {{} {}}} + + test list-lcs-2.6 {longestCommonSubsequence, insert 1 in front of singleton list} { + list [catch { lcs {a} {b a} } msg] $msg + } {0 {0 1}} + + test list-lcs-2.7 {longestCommonSubsequence, insert 1 at end of singleton list} { + list [catch {lcs {a} {a b}} msg] $msg + } {0 {0 0}} + + test list-lcs-2.8 {longestCommonSubsequence, duplicate element} { + list [catch {lcs {a} {a a}} msg] $msg + } {0 {0 0}} + + test list-lcs-2.9 {longestCommonSubsequence, interchange 2} { + list [catch {lcs {a b} {b a}} msg] $msg + } {0 {1 0}} + + test list-lcs-2.10 {longestCommonSubsequence, insert before 2} { + list [catch {lcs {a b} {b a b}} msg] $msg + } {0 {{0 1} {1 2}}} + + test list-lcs-2.11 {longestCommonSubsequence, insert inside 2} { + list [catch {lcs {a b} {a a b}} msg] $msg + } {0 {{0 1} {0 2}}} + + test list-lcs-2.12 {longestCommonSubsequence, insert after 2} { + list [catch {lcs {a b} {a b a}} msg] $msg + } {0 {{0 1} {0 1}}} + + test list-lcs-2.13 {longestCommonSubsequence, delete first of 2} { + list [catch {lcs {a b} b} msg] $msg + } {0 {1 0}} + + test list-lcs-2.14 {longestCommonSubsequence, delete second of 2} { + list [catch {lcs {a b} a} msg] $msg + } {0 {0 0}} + + test list-lcs-2.15 {longestCommonSubsequence, change first of 2} { + list [catch {lcs {a b} {c b}} msg] $msg + } {0 {1 1}} + + test list-lcs-2.16 {longestCommonSubsequence, change first of 2 to dupe} { + list [catch {lcs {a b} {b b}} msg] $msg + } {0 {1 0}} + + test list-lcs-2.17 {longestCommonSubsequence, change second of 2} { + list [catch {lcs {a b} {a c}} msg] $msg + } {0 {0 0}} + + test list-lcs-2.18 {longestCommonSubsequence, change second of 2 to dupe} { + list [catch {lcs {a b} {a a}} msg] $msg + } {0 {0 0}} + + test list-lcs-2.19 {longestCommonSubsequence, mixed changes} { + list [catch {lcs {a b r a c a d a b r a} {b r i c a b r a c}} msg] $msg + } {0 {{1 2 4 5 8 9 10} {0 1 3 4 5 6 7}}} + + test list-lcs-2.20 {longestCommonSubsequence, mixed changes} { + list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a}} msg] $msg + } {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} + + test list-lcs-3.1 {longestCommonSubsequence, length limit} { + list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a} 5} msg] $msg + } {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} + + test list-lcs-3.2 {longestCommonSubsequence, length limit} { + list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a} 4} msg] $msg + } {0 {{0 1 3 5 6} {1 2 4 8 9}}} + + test list-lcs-3.3 {longestCommonSubsequence, length limit} { + list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a} 1} msg] $msg + } {0 {3 4}} + + test list-lcs-3.4 {longestCommonSubsequence, stupid length limit} { + list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a} 0} msg] $msg + } {0 {{} {}}} + + + #---------------------------------------------------------------------- + + interp alias {} lcs2 {} ::struct::list::list longestCommonSubsequence2 + + test list-lcs2-1.1 {longestCommonSubsequence2, no args} { + catch { lcs2 } msg + set msg + } [tcltest::wrongNumArgs ::struct::list::LlongestCommonSubsequence2 \ + {sequence1 sequence2 ?maxOccurs?} 0] + + test list-lcs2-1.2 {longestCommonSubsequence2, one arg} { + catch { lcs2 x } msg + set msg + } [tcltest::wrongNumArgs ::struct::list::LlongestCommonSubsequence2 \ + {sequence1 sequence2 ?maxOccurs?} 1] + + test list-lcs2-2.1 {longestCommonSubsequence2, two empty lists} { + list [catch { lcs2 {} {} } msg] $msg + } {0 {{} {}}} + + test list-lcs2-2.2 {longestCommonSubsequence2, insert 1 into an empty list} { + list [catch { lcs2 {} {a} } msg] $msg + } {0 {{} {}}} + + test list-lcs2-2.3 {longestCommonSubsequence2, delete 1 from singleton list} { + list [catch { lcs2 {a} {} } msg] $msg + } {0 {{} {}}} + + test list-lcs2-2.4 {longestCommonSubsequence2, preserve singleton list} { + list [catch { lcs2 {a} {a} } msg] $msg + } {0 {0 0}} + + test list-lcs2-2.5 {longestCommonSubsequence2, 1-element change in singleton list} { + list [catch { lcs2 {a} {b} } msg] $msg + } {0 {{} {}}} + + test list-lcs2-2.6 {longestCommonSubsequence2, insert 1 in front of singleton list} { + list [catch { lcs2 {a} {b a} } msg] $msg + } {0 {0 1}} + + test list-lcs2-2.7 {longestCommonSubsequence2, insert 1 at end of singleton list} { + list [catch {lcs2 {a} {a b}} msg] $msg + } {0 {0 0}} + + test list-lcs2-2.8 {longestCommonSubsequence2, duplicate element} { + list [catch {lcs2 {a} {a a}} msg] $msg + } {0 {0 0}} + + test list-lcs2-2.9 {longestCommonSubsequence2, interchange 2} { + list [catch {lcs2 {a b} {b a}} msg] $msg + } {0 {1 0}} + + test list-lcs2-2.10 {longestCommonSubsequence2, insert before 2} { + list [catch {lcs2 {a b} {b a b}} msg] $msg + } {0 {{0 1} {1 2}}} + + test list-lcs2-2.11 {longestCommonSubsequence2, insert inside 2} { + list [catch {lcs2 {a b} {a a b}} msg] $msg + } {0 {{0 1} {0 2}}} + + test list-lcs2-2.12 {longestCommonSubsequence2, insert after 2} { + list [catch {lcs2 {a b} {a b a}} msg] $msg + } {0 {{0 1} {0 1}}} + + test list-lcs2-2.13 {longestCommonSubsequence2, delete first of 2} { + list [catch {lcs2 {a b} a} msg] $msg + } {0 {0 0}} + + test list-lcs2-2.14 {longestCommonSubsequence2, delete second of 2} { + list [catch {lcs2 {a b} b} msg] $msg + } {0 {1 0}} + + test list-lcs2-2.15 {longestCommonSubsequence2, change first of 2} { + list [catch {lcs2 {a b} {c b}} msg] $msg + } {0 {1 1}} + + test list-lcs2-2.16 {longestCommonSubsequence2, change first of 2 to dupe} { + list [catch {lcs2 {a b} {b b}} msg] $msg + } {0 {1 0}} + + test list-lcs2-2.17 {longestCommonSubsequence2, change second of 2} { + list [catch {lcs2 {a b} {a c}} msg] $msg + } {0 {0 0}} + + test list-lcs2-2.18 {longestCommonSubsequence2, change second of 2 to dupe} { + list [catch {lcs2 {a b} {a a}} msg] $msg + } {0 {0 0}} + + test list-lcs2-2.19 {longestCommonSubsequence2, mixed changes} { + list [catch {lcs2 {a b r a c a d a b r a} {b r i c a b r a c}} msg] $msg + } {0 {{1 2 4 5 8 9 10} {0 1 3 4 5 6 7}}} + + test list-lcs2-2.20 {longestCommonSubsequence2, mixed changes} { + list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a}} msg] $msg + } {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} + + test list-lcs2-3.1 {longestCommonSubsequence2, length limit} { + list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a} 5} msg] $msg + } {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} + + test list-lcs2-3.2 {longestCommonSubsequence2, length limit} { + list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a} 4} msg] $msg + } {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} + + test list-lcs2-3.3 {longestCommonSubsequence2, length limit} { + list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a} 1} msg] $msg + } {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} + + test list-lcs2-3.4 {longestCommonSubsequence2, stupid length limit} { + list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a} 0} msg] $msg + } {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} + + + #---------------------------------------------------------------------- + + interp alias {} lcsi {} ::struct::list::list lcsInvert + interp alias {} lcsim {} ::struct::list::list lcsInvertMerge + + test list-lcsInv-4.0 {longestCommonSubsequence, mixed changes} { + + # sequence 1 = a b r a c a d a b r a + # lcs 1 = 1 2 4 5 8 9 10 + # lcs 2 = 0 1 3 4 5 6 7 + # sequence 2 = b r i c a b r a c + # + # Inversion = deleted {0 0} {-1 0} + # changed {3 3} {2 2} + # deleted {6 7} {4 5} + # added {10 11} {8 8} + + list [catch {lcsi [lcs {a b r a c a d a b r a} {b r i c a b r a c}] 11 9} msg] $msg + } {0 {{deleted {0 0} {-1 0}} {changed {3 3} {2 2}} {deleted {6 7} {4 5}} {added {10 11} {8 8}}}} + + test list-lcsInv-4.1 {longestCommonSubsequence, mixed changes} { + + # sequence 1 = a b r a c a d a b r a + # lcs 1 = 1 2 4 5 8 9 10 + # lcs 2 = 0 1 3 4 5 6 7 + # sequence 2 = b r i c a b r a c + # + # Inversion/Merge = deleted {0 0} {-1 0} + # unchanged {1 2} {0 1} + # changed {3 3} {2 2} + # unchanged {4 5} {3 4} + # deleted {6 7} {4 5} + # unchanged {8 10} {5 7} + # added {10 11} {8 8} + + list [catch {lcsim [lcs {a b r a c a d a b r a} {b r i c a b r a c}] 11 9} msg] $msg + } {0 {{deleted {0 0} {-1 0}} {unchanged {1 2} {0 1}} {changed {3 3} {2 2}} {unchanged {4 5} {3 4}} {deleted {6 7} {4 5}} {unchanged {8 10} {5 7}} {added {10 11} {8 8}}}} + + + proc diff2 {s1 s2} { + set l1 [split $s1 {}] + set l2 [split $s2 {}] + set x [lcs $l1 $l2] + lcsim $x [llength $l1] [llength $l2] + } + test list-lcsInv-4.2 {lcsInvertMerge} { + # Handling of 'unchanged' chunks at the beginning of the result + # (when result actually empty). + + diff2 ab "a b" + } {{unchanged {0 0} {0 0}} {added {0 1} {1 1}} {unchanged {1 1} {2 2}}} + + test list-lcsInv-4.3 {lcsInvertMerge} { + diff2 abcde afcge + } {{unchanged {0 0} {0 0}} {changed {1 1} {1 1}} {unchanged {2 2} {2 2}} {changed {3 3} {3 3}} {unchanged {4 4} {4 4}}} + + #---------------------------------------------------------------------- + + interp alias {} reverse {} ::struct::list::list reverse + + test reverse-1.1 {reverse method} { + reverse {a b c} + } {c b a} + + test reverse-1.2 {reverse method} { + reverse a + } {a} + + test reverse-1.3 {reverse method} { + reverse {} + } {} + + test reverse-2.1 {reverse errors} { + list [catch {reverse} msg] $msg + } [list 1 [tcltest::wrongNumArgs ::struct::list::Lreverse {sequence} 0]] + + #---------------------------------------------------------------------- + + interp alias {} assign {} ::struct::list::list assign + + test assign-4.1 {assign method} { + catch {unset ::x ::y} + list [assign {foo bar} x y] $x $y + } {{} foo bar} + + test assign-4.2 {assign method} { + catch {unset x y} + list [assign {foo bar baz} x y] $x $y + } {baz foo bar} + + test assign-4.3 {assign method} { + catch {unset x y z} + list [assign {foo bar} x y z] $x $y $z + } {{} foo bar {}} + + if {[package vcompare [package provide Tcl] 8.5] < 0} { + # 8.4 + set err [tcltest::wrongNumArgs {::struct::list::Lassign} {sequence v args} 1] + } else { + # 8.5+ + #set err [tcltest::wrongNumArgs {lassign} {list varName ?varName ...?} 1] + set err [tcltest::wrongNumArgs {::struct::list::Lassign} {list varName ?varName ...?} 1] + } + + # In 8.6+ assign is the native lassign and it does nothing gracefully, + # per TIP 323, making assign-4.4 not an error anymore. + test assign-4.4 {assign method} {!tcl8.6plus} { + catch {assign {foo bar}} msg ; set msg + } $err + + test assign-4.5 {assign method} { + list [assign {foo bar} x] $x + } {bar foo} + + catch {unset x y z} + + #---------------------------------------------------------------------- + + interp alias {} flatten {} ::struct::list::list flatten + + test flatten-1.1 {flatten command} { + flatten {1 2 3 {4 5} {6 7} {{8 9}} 10} + } {1 2 3 4 5 6 7 {8 9} 10} + + test flatten-1.2 {flatten command} { + flatten -full {1 2 3 {4 5} {6 7} {{8 9}} 10} + } {1 2 3 4 5 6 7 8 9 10} + + test flatten-1.3 {flatten command} { + flatten {a b} + } {a b} + + test flatten-1.4 {flatten command} { + flatten [list "\[a\]" "\[b\]"] + } {{[a]} {[b]}} + + test flatten-1.5 {flatten command} { + flatten [list "'" "\""] + } {' {"}} ; # " help emacs highlighting + + test flatten-1.6 {flatten command} { + flatten [list "{" "}"] + } "\\\{ \\\}" + + test flatten-1.7 {check -- argument termination} { + flatten -full -- {1 2 3 {4 5} {6 7} {{8 9}} 10} + } {1 2 3 4 5 6 7 8 9 10} + + test flatten-2.1 {flatten errors} { + list [catch {flatten} msg] $msg + } {1 {wrong#args: should be "::struct::list::Lflatten ?-full? ?--? sequence"}} + + test flatten-2.2 {flatten errors} { + list [catch {flatten -all {a {b c d} {e {f g}}}} msg] $msg + } {1 {Unknown option "-all", should be either -full, or --}} + + + #---------------------------------------------------------------------- + + interp alias {} map {} ::struct::list::list map + + proc cc {a} {return $a$a} + proc + {a} {expr {$a + $a}} + proc * {a} {expr {$a * $a}} + proc projection {n list} {::lindex $list $n} + + test map-4.1 {map command} { + map {a b c d} cc + } {aa bb cc dd} + + test map-4.2 {map command} { + map {1 2 3 4 5} + + } {2 4 6 8 10} + + test map-4.3 {map command} { + map {1 2 3 4 5} * + } {1 4 9 16 25} + + test map-4.4 {map command} { + map {} * + } {} + + test map-4.5 {map command} { + map {{a b c} {1 2 3} {d f g}} {projection 1} + } {b 2 f} + + + #---------------------------------------------------------------------- + + interp alias {} mapfor {} ::struct::list::list mapfor + + test mapfor-4.1 {mapfor command} { + mapfor x {a b c d} { set x $x$x } + } {aa bb cc dd} + + test mapfor-4.2 {mapfor command} { + mapfor x {1 2 3 4 5} {expr {$x + $x}} + } {2 4 6 8 10} + + test mapfor-4.3 {mapfor command} { + mapfor x {1 2 3 4 5} {expr {$x * $x}} + } {1 4 9 16 25} + + test mapfor-4.4 {mapfor command} { + mapfor x {} {expr {$x * $x}} + } {} + + test mapfor-4.5 {mapfor command} { + mapfor x {{a b c} {1 2 3} {d f g}} {lindex $x 1} + } {b 2 f} + + #---------------------------------------------------------------------- + + interp alias {} fold {} ::struct::list::list fold + + proc cc {a b} {return $a$b} + proc + {a b} {expr {$a + $b}} + proc * {a b} {expr {$a * $b}} + + test fold-4.1 {fold command} { + fold {a b c d} {} cc + } {abcd} + + test fold-4.2 {fold command} { + fold {1 2 3 4 5} 0 + + } {15} + + test fold-4.3 {fold command} { + fold {1 2 3 4 5} 1 * + } {120} + + test fold-4.4 {fold command} { + fold {} 1 * + } {1} + + #---------------------------------------------------------------------- + + interp alias {} filter {} ::struct::list::list filter + + proc even {i} {expr {($i % 2) == 0}} + + test filter-4.1 {filter command} { + filter {1 2 3 4 5 6 7 8} even + } {2 4 6 8} + + test filter-4.2 {filter command} { + filter {} even + } {} + + test filter-4.3 {filter command} { + filter {3 5 7} even + } {} + + test filter-4.4 {filter command} { + filter {2 4 6} even + } {2 4 6} + + # Alternate which elements are filtered by using a global variable + # flag. Used to test that the `cmdprefix' is evaluated in the caller's + # scope. + # + # The flag variable should be set on the -setup phase. + + proc alternating {_} { + upvar 1 flag flag; + set flag [expr {!($flag)}]; + return $flag; + } + + test filter-4.5 {filter evaluates cmdprefix on outer scope} -setup { + set flag 1 + } -body { + filter {1 2 3 4 5 6} alternating + } -cleanup { + unset flag + } -result {2 4 6} + + #---------------------------------------------------------------------- + + interp alias {} filterfor {} ::struct::list::list filterfor + + test filterfor-4.1 {filterfor command} { + filterfor i {1 2 3 4 5 6 7 8} {($i % 2) == 0} + } {2 4 6 8} + + test filterfor-4.2 {filterfor command} { + filterfor i {} {($i % 2) == 0} + } {} + + test filterfor-4.3 {filterfor command} { + filterfor i {3 5 7} {($i % 2) == 0} + } {} + + test filterfor-4.4 {filterfor command} { + filterfor i {2 4 6} {($i % 2) == 0} + } {2 4 6} + + #---------------------------------------------------------------------- + + interp alias {} lsplit {} ::struct::list::list split + + proc even {i} {expr {($i % 2) == 0}} + + test split-4.1 {split command} { + lsplit {1 2 3 4 5 6 7 8} even + } {{2 4 6 8} {1 3 5 7}} + + test split-4.2 {split command} { + lsplit {} even + } {{} {}} + + test split-4.3 {split command} { + lsplit {3 5 7} even + } {{} {3 5 7}} + + test split-4.4 {split command} { + lsplit {2 4 6} even + } {{2 4 6} {}} + + test split-4.5 {split command} { + list [lsplit {1 2 3 4 5 6 7 8} even pass fail] $pass $fail + } {{4 4} {2 4 6 8} {1 3 5 7}} + + test split-4.6 {split command} { + list [lsplit {} even pass fail] $pass $fail + } {{0 0} {} {}} + + test split-4.7 {split command} { + list [lsplit {3 5 7} even pass fail] $pass $fail + } {{0 3} {} {3 5 7}} + + test split-4.8 {split command} { + list [lsplit {2 4 6} even pass fail] $pass $fail + } {{3 0} {2 4 6} {}} + + + # See test filter-4.5 for explanations. + + test split-4.9 {split evaluates cmdprefix on outer scope} -setup { + set flag 1 + } -body { + list [lsplit {1 2 3 4 5 6 7 8} alternating pass fail] $pass $fail + } -cleanup { + unset flag + } -result {{4 4} {2 4 6 8} {1 3 5 7}} + + #---------------------------------------------------------------------- + + interp alias {} shift {} ::struct::list::list shift + + test shift-4.1 {shift command} { + set v {1 2 3 4 5 6 7 8} + list [shift v] $v + } {1 {2 3 4 5 6 7 8}} + + test shift-4.2 {shift command} { + set v {1} + list [shift v] $v + } {1 {}} + + test shift-4.3 {shift command} { + set v {} + list [shift v] $v + } {{} {}} + + #---------------------------------------------------------------------- + + interp alias {} iota {} ::struct::list::list iota + + test iota-4.1 {iota command} { + iota 0 + } {} + + test iota-4.2 {iota command} { + iota 1 + } {0} + + test iota-4.3 {iota command} { + iota 11 + } {0 1 2 3 4 5 6 7 8 9 10} + + + #---------------------------------------------------------------------- + + interp alias {} repeatn {} ::struct::list::list repeatn + + test repeatn-4.1 {repeatn command} { + repeatn 0 + } {} + + test repeatn-4.2 {repeatn command} { + repeatn 0 3 + } {0 0 0} + + test repeatn-4.3 {repeatn command} { + repeatn 0 3 4 + } {{0 0 0} {0 0 0} {0 0 0} {0 0 0}} + + test repeatn-4.4 {repeatn command} { + repeatn 0 {3 4} + } {{0 0 0} {0 0 0} {0 0 0} {0 0 0}} + + #---------------------------------------------------------------------- + + interp alias {} repeat {} ::struct::list::list repeat + + if {[package vcompare [package provide Tcl] 8.5] < 0} { + # 8.4 + set err [tcltest::wrongNumArgs {::struct::list::Lrepeat} {positiveCount value args} 0] + } elseif {![package vsatisfies [package provide Tcl] 8.6]} { + # 8.5+ + #set err [tcltest::wrongNumArgs {lrepeat} {positiveCount value ?value ...?} 0] + set err [tcltest::wrongNumArgs {::struct::list::Lrepeat} {positiveCount value ?value ...?} 0] + } else { + # 8.6+ + set err [tcltest::wrongNumArgs {::struct::list::Lrepeat} {count ?value ...?} 1] + } + test repeat-4.1 {repeat command} { + catch {repeat} msg + set msg + } $err + + + if {[package vcompare [package provide Tcl] 8.5] < 0} { + # 8.4 + set err [tcltest::wrongNumArgs {::struct::list::Lrepeat} {positiveCount value args} 1] + } elseif {![package vsatisfies [package provide Tcl] 8.6]} { + # 8.5+ + #set err [tcltest::wrongNumArgs {lrepeat} {positiveCount value ?value ...?} 1] + set err [tcltest::wrongNumArgs {::struct::list::Lrepeat} {positiveCount value ?value ...?} 1] + } else { + # 8.6+ + set err [tcltest::wrongNumArgs {::struct::list::Lrepeat} {count ?value ...?} 1] + } + # In 8.6+ repeat is the native lrepeat and it does nothing gracefully, + # per TIP 323, making repeat-4.2 not an error anymore. + test repeat-4.2 {repeat command} {!tcl8.6plus} { + catch {repeat a} msg + set msg + } $err + + test repeat-4.3 {repeat command} { + catch {repeat a b} msg + set msg + } {expected integer but got "a"} + + # In 8.6+ repeat is the native lrepeat and it does nothing gracefully, + # per TIP 323, making repeat-4.2 not an error anymore. + test repeat-4.4 {repeat command} {!tcl8.6plus} { + catch {repeat 0 b} msg + set msg + } {must have a count of at least 1} + + if {![package vsatisfies [package provide Tcl] 8.6]} { + # before 8.6 + set err {must have a count of at least 1} + } else { + # 8.6+, native lrepeat changed error message. + set err {bad count "-1": must be integer >= 0} + } + test repeat-4.5 {repeat command} { + catch {repeat -1 b} msg + set msg + } $err + + test repeat-4.6 {repeat command} { + repeat 1 b c + } {b c} + + test repeat-4.7 {repeat command} { + repeat 3 a + } {a a a} + + test repeat-4.8 {repeat command} { + repeat 3 [repeat 3 0] + } {{0 0 0} {0 0 0} {0 0 0}} + + test repeat-4.9 {repeat command} { + repeat 3 a b c + } {a b c a b c a b c} + + test repeat-4.10 {repeat command} { + repeat 3 [repeat 2 a] b c + } {{a a} b c {a a} b c {a a} b c} + + #---------------------------------------------------------------------- + + interp alias {} equal {} ::struct::list::list equal + + test equal-4.1 {equal command} { + equal 0 0 + } 1 + + test equal-4.2 {equal command} { + equal 0 1 + } 0 + + test equal-4.3 {equal command} { + equal {0 0 0} {0 0} + } 0 + + test equal-4.4 {equal command} { + equal {{0 2 3} 1} {{0 2 3} 1} + } 1 + + test equal-4.5 {equal command} { + equal [list [list a]] {{a}} + } 1 + + test equal-4.6 {equal command} { + equal {{a}} [list [list a]] + } 1 + + test equal-4.7 {equal command} { + set a {{a}} + set b [list [list a]] + expr {[equal $a $b] == [equal $b $a]} + } 1 + + test equal-4.8 {equal command} { + set a {{a b}} + set b [list [list a b]] + expr {[equal $a $b] == [equal $b $a]} + } 1 + + test equal-4.9 {equal command} { + set a {{a} {b}} + set b [list [list a] [list b]] + expr {[equal $a $b] == [equal $b $a]} + } 1 + + #---------------------------------------------------------------------- + + interp alias {} delete {} ::struct::list::list delete + + test delete-1.0 {delete command} { + catch {delete} msg + set msg + } {wrong # args: should be "::struct::list::Ldelete var item"} + + test delete-1.1 {delete command} { + catch {delete x} msg + set msg + } {wrong # args: should be "::struct::list::Ldelete var item"} + + test delete-1.2 {delete command} { + set l {} + delete l x + set l + } {} + + test delete-1.3 {delete command} { + set l {a x b} + delete l x + set l + } {a b} + + test delete-1.4 {delete command} { + set l {x a b} + delete l x + set l + } {a b} + + test delete-1.5 {delete command} { + set l {a b x} + delete l x + set l + } {a b} + + test delete-1.6 {delete command} { + set l {a b} + delete l x + set l + } {a b} + + catch { unset l } + #---------------------------------------------------------------------- + + interp alias {} dbjoin {} ::struct::list::list dbJoin + interp alias {} dbjoink {} ::struct::list::list dbJoinKeyed + + #---------------------------------------------------------------------- + # Input data sets ... + + set empty {} + set table_as [list \ + {0 foo} \ + {1 snarf} \ + {2 blue} \ + ] + set table_am [list \ + {0 foo} \ + {0 bar} \ + {1 snarf} \ + {1 rim} \ + {2 blue} \ + {2 dog} \ + ] + set table_bs [list \ + {0 bagel} \ + {1 snatz} \ + {3 driver} \ + ] + set table_bm [list \ + {0 bagel} \ + {0 loaf} \ + {1 snatz} \ + {1 grid} \ + {3 driver} \ + {3 tcl} \ + ] + set table_cs [list \ + {0 smurf} \ + {3 bird} \ + {4 galapagos} \ + ] + set table_cm [list \ + {0 smurf} \ + {0 blt} \ + {3 bird} \ + {3 itcl} \ + {4 galapagos} \ + {4 tk} \ + ] + + #---------------------------------------------------------------------- + # Result data sets ... + + set nyi __not_yet_written__ + + set ijss [list \ + [list 0 foo 0 bagel] \ + [list 1 snarf 1 snatz] \ + ] + set ijsm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + ] + set ijms [list \ + [list 0 foo 0 bagel] \ + [list 0 bar 0 bagel] \ + [list 1 snarf 1 snatz] \ + [list 1 rim 1 snatz] \ + ] + set ijmm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 0 bar 0 bagel] \ + [list 0 bar 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + [list 1 rim 1 snatz] \ + [list 1 rim 1 grid] \ + ] + + set ljss [list \ + [list 0 foo 0 bagel] \ + [list 1 snarf 1 snatz] \ + [list 2 blue {} {}] \ + ] + set ljsm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + [list 2 blue {} {}] \ + ] + set ljms [list \ + [list 0 foo 0 bagel] \ + [list 0 bar 0 bagel] \ + [list 1 snarf 1 snatz] \ + [list 1 rim 1 snatz] \ + [list 2 blue {} {}] \ + [list 2 dog {} {}] \ + ] + set ljmm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 0 bar 0 bagel] \ + [list 0 bar 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + [list 1 rim 1 snatz] \ + [list 1 rim 1 grid] \ + [list 2 blue {} {}] \ + [list 2 dog {} {}] \ + ] + + set rjss [list \ + [list 0 foo 0 bagel] \ + [list 1 snarf 1 snatz] \ + [list {} {} 3 driver] \ + ] + set rjsm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + [list {} {} 3 driver] \ + [list {} {} 3 tcl] \ + ] + set rjms [list \ + [list 0 foo 0 bagel] \ + [list 0 bar 0 bagel] \ + [list 1 snarf 1 snatz] \ + [list 1 rim 1 snatz] \ + [list {} {} 3 driver] \ + ] + set rjmm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 0 bar 0 bagel] \ + [list 0 bar 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + [list 1 rim 1 snatz] \ + [list 1 rim 1 grid] \ + [list {} {} 3 driver] \ + [list {} {} 3 tcl] \ + ] + + set fjss [list \ + [list 0 foo 0 bagel] \ + [list 1 snarf 1 snatz] \ + [list 2 blue {} {}] \ + [list {} {} 3 driver] \ + ] + set fjsm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + [list 2 blue {} {}] \ + [list {} {} 3 driver] \ + [list {} {} 3 tcl] \ + ] + set fjms [list \ + [list 0 foo 0 bagel] \ + [list 0 bar 0 bagel] \ + [list 1 snarf 1 snatz] \ + [list 1 rim 1 snatz] \ + [list 2 blue {} {}] \ + [list 2 dog {} {}] \ + [list {} {} 3 driver] \ + ] + set fjmm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 0 bar 0 bagel] \ + [list 0 bar 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + [list 1 rim 1 snatz] \ + [list 1 rim 1 grid] \ + [list 2 blue {} {}] \ + [list 2 dog {} {}] \ + [list {} {} 3 driver] \ + [list {} {} 3 tcl] \ + ] + + set ijmmm { + {0 bar 0 bagel 0 blt} + {0 bar 0 bagel 0 smurf} + {0 bar 0 loaf 0 blt} + {0 bar 0 loaf 0 smurf} + {0 foo 0 bagel 0 blt} + {0 foo 0 bagel 0 smurf} + {0 foo 0 loaf 0 blt} + {0 foo 0 loaf 0 smurf} + } + set ljmmm { + {0 bar 0 bagel 0 blt} + {0 bar 0 bagel 0 smurf} + {0 bar 0 loaf 0 blt} + {0 bar 0 loaf 0 smurf} + {0 foo 0 bagel 0 blt} + {0 foo 0 bagel 0 smurf} + {0 foo 0 loaf 0 blt} + {0 foo 0 loaf 0 smurf} + {1 rim 1 grid {} {}} + {1 rim 1 snatz {} {}} + {1 snarf 1 grid {} {}} + {1 snarf 1 snatz {} {}} + {2 blue {} {} {} {}} + {2 dog {} {} {} {}} + } + set rjmmm { + {0 bar 0 bagel 0 blt} + {0 bar 0 bagel 0 smurf} + {0 bar 0 loaf 0 blt} + {0 bar 0 loaf 0 smurf} + {0 foo 0 bagel 0 blt} + {0 foo 0 bagel 0 smurf} + {0 foo 0 loaf 0 blt} + {0 foo 0 loaf 0 smurf} + {{} {} 3 driver 3 bird} + {{} {} 3 driver 3 itcl} + {{} {} 3 tcl 3 bird} + {{} {} 3 tcl 3 itcl} + {{} {} {} {} 4 galapagos} + {{} {} {} {} 4 tk} + } + set fjmmm { + {0 bar 0 bagel 0 blt} + {0 bar 0 bagel 0 smurf} + {0 bar 0 loaf 0 blt} + {0 bar 0 loaf 0 smurf} + {0 foo 0 bagel 0 blt} + {0 foo 0 bagel 0 smurf} + {0 foo 0 loaf 0 blt} + {0 foo 0 loaf 0 smurf} + {1 rim 1 grid {} {}} + {1 rim 1 snatz {} {}} + {1 snarf 1 grid {} {}} + {1 snarf 1 snatz {} {}} + {2 blue {} {} {} {}} + {2 dog {} {} {} {}} + {{} {} 3 driver 3 bird} + {{} {} 3 driver 3 itcl} + {{} {} 3 tcl 3 bird} + {{} {} 3 tcl 3 itcl} + {{} {} {} {} 4 galapagos} + {{} {} {} {} 4 tk} + } + + #---------------------------------------------------------------------- + # Helper, translation to keyed format. + + proc keyed {table} { + # Get the key out of the row, hardwired to column 0 + set res [list] + foreach row $table {lappend res [list [lindex $row 0] $row]} + return $res + } + + #---------------------------------------------------------------------- + # I. One table joins + + set n 0 ; # Counter for test cases + foreach {jtype inout} { + -inner empty -inner table_as -inner table_am + -left empty -left table_as -left table_am + -right empty -right table_as -right table_am + -full empty -full table_as -full table_am + } { + test dbjoin-1.$n "1-table join $jtype $inout" { + dbjoin $jtype 0 [set $inout] + } [set $inout] ; # {} + + test dbjoinKeyed-1.$n "1-table join $jtype $inout" { + dbjoink $jtype [keyed [set $inout]] + } [set $inout] ; # {} + + incr n + } + + #---------------------------------------------------------------------- + # II. Two table joins + + set n 0 ; # Counter for test cases + foreach {jtype left right result} { + -inner empty empty empty + -inner empty table_bs empty + -inner table_as empty empty + -inner table_as table_bs ijss + -inner table_as table_bm ijsm + -inner table_am table_bs ijms + -inner table_am table_bm ijmm + + -left empty empty empty + -left empty table_bs empty + -left table_as empty table_as + -left table_as table_bs ljss + -left table_as table_bm ljsm + -left table_am table_bs ljms + -left table_am table_bm ljmm + + -right empty empty empty + -right empty table_bs table_bs + -right table_as empty empty + -right table_as table_bs rjss + -right table_as table_bm rjsm + -right table_am table_bs rjms + -right table_am table_bm rjmm + + -full empty empty empty + -full empty table_bs table_bs + -full table_as empty table_as + -full table_as table_bs fjss + -full table_as table_bm fjsm + -full table_am table_bs fjms + -full table_am table_bm fjmm + } { + test dbjoin-2.$n "2-table join $jtype ($left $right) = $result" { + lsort [dbjoin $jtype 0 [set $left] 0 [set $right]] + } [lsort [set $result]] + + test dbjoinKeyed-2.$n "2-table join $jtype ($left $right) = $result" { + lsort [dbjoink $jtype [keyed [set $left]] [keyed [set $right]]] + } [lsort [set $result]] + + incr n + } + + #---------------------------------------------------------------------- + # III. Three table joins + + set n 0 ; # Counter for test cases + foreach {jtype left middle right result} { + -inner table_am table_bm table_cm ijmmm + -left table_am table_bm table_cm ljmmm + -right table_am table_bm table_cm rjmmm + -full table_am table_bm table_cm fjmmm + } { + test dbjoin-3.$n "3-table join $jtype ($left $middle $right) = $result" { + lsort [dbjoin $jtype 0 [set $left] 0 [set $middle] 0 [set $right]] + } [lsort [set $result]] + + test dbjoinKeyed-3.$n "3-table join $jtype ($left $middle $right) = $result" { + lsort [dbjoink $jtype [keyed [set $left]] [keyed [set $middle]] [keyed [set $right]]] + } [lsort [set $result]] + + incr n + } + + #---------------------------------------------------------------------- + + interp alias {} swap {} ::struct::list::list swap + + foreach {n list i j err res} { + 0 {} 0 0 1 {list index out of range} + 1 {} 3 4 1 {list index out of range} + 2 {a b c d e} -1 0 1 {list index out of range} + 3 {a b c d e} 0 -1 1 {list index out of range} + 4 {a b c d e} 6 0 1 {list index out of range} + 5 {a b c d e} 0 6 1 {list index out of range} + 6 {a b c d e} 0 0 0 {a b c d e} + 7 {a b c d e} 0 1 0 {b a c d e} + 8 {a b c d e} 1 0 0 {b a c d e} + 9 {a b c d e} 0 4 0 {e b c d a} + 10 {a b c d e} 4 0 0 {e b c d a} + 11 {a b c d e} 2 4 0 {a b e d c} + 12 {a b c d e} 4 2 0 {a b e d c} + 13 {a b c d e} 1 3 0 {a d c b e} + 14 {a b c d e} 3 1 0 {a d c b e} + } { + if {$err} { + test swap-1.$n {swap command error} { + set l $list + catch {swap l $i $j} msg + set msg + } $res ; # {} + } else { + test swap-1.$n {swap command} { + set l $list + swap l $i $j + } $res ; # {} + } + } + + + #---------------------------------------------------------------------- + + interp alias {} firstperm {} ::struct::list::list firstperm + interp alias {} nextperm {} ::struct::list::list nextperm + interp alias {} foreachperm {} ::struct::list::list foreachperm + interp alias {} permutations {} ::struct::list::list permutations + + test permutations-0.0 {permutations command, single element list} { + permutations a + } a + + + array set ps { + {Tom Dick Harry Bob} { + 0 {Bob Dick Harry Tom} {Tom Harry Bob Dick} + { + {Bob Dick Harry Tom} {Bob Dick Tom Harry} + {Bob Harry Dick Tom} {Bob Harry Tom Dick} + {Bob Tom Dick Harry} {Bob Tom Harry Dick} + {Dick Bob Harry Tom} {Dick Bob Tom Harry} + {Dick Harry Bob Tom} {Dick Harry Tom Bob} + {Dick Tom Bob Harry} {Dick Tom Harry Bob} + {Harry Bob Dick Tom} {Harry Bob Tom Dick} + {Harry Dick Bob Tom} {Harry Dick Tom Bob} + {Harry Tom Bob Dick} {Harry Tom Dick Bob} + {Tom Bob Dick Harry} {Tom Bob Harry Dick} + {Tom Dick Bob Harry} {Tom Dick Harry Bob} + {Tom Harry Bob Dick} {Tom Harry Dick Bob} + } + } + {3 2 1 4} { + 1 {1 2 3 4} {3 2 4 1} + { + {1 2 3 4} {1 2 4 3} {1 3 2 4} {1 3 4 2} + {1 4 2 3} {1 4 3 2} {2 1 3 4} {2 1 4 3} + {2 3 1 4} {2 3 4 1} {2 4 1 3} {2 4 3 1} + {3 1 2 4} {3 1 4 2} {3 2 1 4} {3 2 4 1} + {3 4 1 2} {3 4 2 1} {4 1 2 3} {4 1 3 2} + {4 2 1 3} {4 2 3 1} {4 3 1 2} {4 3 2 1} + } + } + } + + foreach k [array names ps] { + foreach {n firstp nextp allp} $ps($k) break + + test firstperm-1.$n {firstperm command} { + firstperm $k + } $firstp ; # {} + + test nextperm-1.$n {nextperm command} { + nextperm $k + } $nextp ; # {} + + # Note: The lrange below is necessary a trick/hack to kill the + # existing string representation of allp, and get a pure list out + # of it. Otherwise the string based comparison of test will fail, + # seeing different string reps of the same list. + + test permutations-1.$n {permutations command} { + permutations $k + } [lrange $allp 0 end] ; # {} + + test foreachperm-1.$n {foreachperm command} { + set res {} + foreachperm x $k {lappend res $x} + set res + } [lrange $allp 0 end] ; # {} + } + + test nextperm-2.0 {bug 3593689, busyloop} { + nextperm {1 10 9 8 7 6 5 4 3 2} + } {1 2 10 3 4 5 6 7 8 9} + + #---------------------------------------------------------------------- + + interp alias {} shuffle {} ::struct::list::list shuffle + + test shuffle-1.0 {} -body { + shuffle + } -returnCodes error -result {wrong # args: should be "::struct::list::Lshuffle list"} + + test shuffle-2.0 {shuffle nothing} -body { + shuffle {} + } -result {} + + test shuffle-2.1 {shuffle single} -body { + shuffle {a} + } -result {a} + + foreach {k n data} { + 1 2 {a b} + 2 4 {c d b a} + 3 9 {0 1 2 3 4 5 6 7 8} + 4 15 {a b c d e f 8 6 4 2 0 1 3 5 7} + } { + test shuffle-2.2.$k "shuffle $n" -body { + lsort [shuffle $data] + } -result [lsort $data] + } +} + +package provide struct::list::test 1.8.4 diff --git a/src/bootsupport/lib/struct/map.tcl b/src/bootsupport/lib/struct/map.tcl new file mode 100644 index 00000000..41094def --- /dev/null +++ b/src/bootsupport/lib/struct/map.tcl @@ -0,0 +1,104 @@ +# map.tcl -- +# Copyright (c) 2009-2019 Andreas Kupries +# +# Object wrapper around array/dict. Useful as key/value store in +# larger systems. +# +# Examples: +# - configuration mgmt in doctools v2 import/export managers +# - pt import/export managers +# +# Each object manages a key/value map. + +# ### ### ### ######### ######### ######### +## Requisites + +package require Tcl 8.4 +package require snit + +# ### ### ### ######### ######### ######### +## API + +# ATTENTION: +## +# From an API point of view the code below is equivalent to the much +# shorter `snit::type struct::map { ... }`. +# +# Then why the more complex form ? +# +# When snit compiles the class to Tcl code, and later on when methods +# are executed it will happen in the `struct` namespace. The moment +# this package is used together with `struct::set` all unqualified +# `set` statements will go bonkers, eiter in snit, or, here, in method +# `set`, because they get resolved to the `struct::set` dispatcher +# instead of `::set`. Moving the implementation a level deeper makes +# the `struct::map` namespace the context, with no conflict. + +# Future / TODO: Convert all the OO stuff here over to TclOO, as much +# as possible (snit configure/cget support is currently still better, +# ditto hierarchical methods). + +namespace eval ::struct {} + +proc ::struct::map {args} { + uplevel 1 [linsert $args 0 struct::map::I] +} + +snit::type ::struct::map::I { + + # ### ### ### ######### ######### ######### + ## Options :: None + + # ### ### ### ######### ######### ######### + ## Creating, destruction + + # Default constructor. + # Default destructor. + + # ### ### ### ######### ######### ######### + ## Public methods. Reading and writing the map. + + method names {} { + return [array names mymap] + } + + method get {} { + return [array get mymap] + } + + method set {name {value {}}} { + # 7 instead of 3 in the condition below, because of the 4 + # implicit arguments snit is providing to each method. + if {[llength [info level 0]] == 7} { + ::set mymap($name) $value + } elseif {![info exists mymap($name)]} { + return -code error "can't read \"$name\": no such variable" + } + return $mymap($name) + } + + method unset {args} { + if {![llength $args]} { lappend args * } + foreach pattern $args { + array unset mymap $pattern + } + return + } + + # ### ### ### ######### ######### ######### + ## Internal methods :: None. + + # ### ### ### ######### ######### ######### + ## State :: Map data, Tcl array + + variable mymap -array {} + + ## + # ### ### ### ######### ######### ######### +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide struct::map 1 +return diff --git a/src/bootsupport/lib/struct/matrix.tcl b/src/bootsupport/lib/struct/matrix.tcl new file mode 100644 index 00000000..ee098eae --- /dev/null +++ b/src/bootsupport/lib/struct/matrix.tcl @@ -0,0 +1,2806 @@ +# matrix.tcl -- +# +# Implementation of a matrix data structure for Tcl. +# +# Copyright (c) 2001-2013,2019,2022 by Andreas Kupries +# +# Heapsort code Copyright (c) 2003 by Edwin A. Suominen , +# based on concepts in "Introduction to Algorithms" by Thomas H. Cormen et al. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.5 +package require textutil::wcswidth ;# TermWidth, for _columnwidth and related places + +namespace eval ::struct {} + +namespace eval ::struct::matrix { + # Data storage in the matrix module + # ------------------------------- + # + # One namespace per object, containing + # + # - Two scalar variables containing the current number of rows and columns. + # - Four array variables containing the array data, the caches for + # row heights and column widths and the information about linked arrays. + # + # The variables are + # - columns #columns in data + # - rows #rows in data + # - data cell contents + # - colw cache of column widths + # - rowh cache of row heights + # - link information about linked arrays + # - lock boolean flag to disable MatTraceIn while in MatTraceOut [#532783] + # - unset string used to convey information about 'unset' traces from MatTraceIn to MatTraceOut. + + # counter is used to give a unique name for unnamed matrices + variable counter 0 + + # Only export one command, the one used to instantiate a new matrix + namespace export matrix +} + +# ::struct::matrix::matrix -- +# +# Create a new matrix with a given name; if no name is given, use +# matrixX, where X is a number. +# +# Arguments: +# name Optional name of the matrix; if null or not given, generate one. +# +# Results: +# name Name of the matrix created + +proc ::struct::matrix::matrix {args} { + variable counter + + set src {} + set srctype {} + + switch -exact -- [llength [info level 0]] { + 1 { + # Missing name, generate one. + incr counter + set name "matrix${counter}" + } + 2 { + # Standard call. New empty matrix. + set name [lindex $args 0] + } + 4 { + # Copy construction. + foreach {name as src} $args break + switch -exact -- $as { + = - := - as { + set srctype matrix + } + deserialize { + set srctype serial + } + default { + return -code error \ + "wrong # args: should be \"matrix ?name ?=|:=|as|deserialize source??\"" + } + } + } + default { + # Error. + return -code error \ + "wrong # args: should be \"matrix ?name ?=|:=|as|deserialize source??\"" + } + } + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + set name "$ns$name" + } + + if { [llength [info commands $name]] } { + return -code error "command \"$name\" already exists, unable to create matrix" + } + + # Set up the namespace + namespace eval $name { + variable columns 0 + variable rows 0 + + variable data + variable colw + variable rowh + variable link + variable lock + variable unset + + array set data {} + array set colw {} + array set rowh {} + array set link {} + set lock 0 + set unset {} + } + + # Create the command to manipulate the matrix + interp alias {} $name {} ::struct::matrix::MatrixProc $name + + # Automatic execution of assignment if a source + # is present. + if {$src != {}} { + switch -exact -- $srctype { + matrix {_= $name $src} + serial {_deserialize $name $src} + default { + return -code error \ + "Internal error, illegal srctype \"$srctype\"" + } + } + } + return $name +} + +########################## +# Private functions follow + +# ::struct::matrix::MatrixProc -- +# +# Command that processes all matrix object commands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand to invoke. +# args Arguments for subcommand. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::MatrixProc {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub _$cmd + if {[llength [info commands ::struct::matrix::$sub]] == 0} { + set optlist [lsort [info commands ::struct::matrix::_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + if {[string match __* $p]} {continue} + lappend xlist [string range $p 1 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_= -- +# +# Assignment operator. Copies the source matrix into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the matrix object we are copying into. +# source Name of the matrix object providing us with the +# data to copy. +# +# Results: +# Nothing. + +proc ::struct::matrix::_= {name source} { + _deserialize $name [$source serialize] + return +} + +# ::struct::matrix::_--> -- +# +# Reverse assignment operator. Copies this matrix into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the matrix object to copy +# dest Name of the matrix object we are copying to. +# +# Results: +# Nothing. + +proc ::struct::matrix::_--> {name dest} { + $dest deserialize [_serialize $name] + return +} + +# ::struct::matrix::_add -- +# +# Command that processes all 'add' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'add' to invoke. +# args Arguments for subcommand of 'add'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_add {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name add option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __add_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__add_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 6 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_delete -- +# +# Command that processes all 'delete' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'delete' to invoke. +# args Arguments for subcommand of 'delete'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_delete {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name delete option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __delete_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__delete_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 9 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_format -- +# +# Command that processes all 'format' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'format' to invoke. +# args Arguments for subcommand of 'format'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_format {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name format option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __format_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__format_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 9 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_get -- +# +# Command that processes all 'get' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'get' to invoke. +# args Arguments for subcommand of 'get'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_get {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name get option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __get_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__get_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 6 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_insert -- +# +# Command that processes all 'insert' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'insert' to invoke. +# args Arguments for subcommand of 'insert'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_insert {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name insert option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __insert_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__insert_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 9 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_search -- +# +# Command that processes all 'search' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# args Arguments for search. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_search {name args} { + set mode exact + set nocase 0 + + while {1} { + switch -glob -- [lindex $args 0] { + -exact - -glob - -regexp { + set mode [string range [lindex $args 0] 1 end] + set args [lrange $args 1 end] + } + -nocase { + set nocase 1 + set args [lrange $args 1 end] + } + -* { + return -code error \ + "invalid option \"[lindex $args 0]\":\ + should be -nocase, -exact, -glob, or -regexp" + } + default { + break + } + } + } + + # Possible argument signatures after option processing + # + # \ | args + # --+-------------------------------------------------------- + # 2 | all pattern + # 3 | row row pattern, column col pattern + # 6 | rect ctl rtl cbr rbr pattern + # + # All range specifications are internally converted into a + # rectangle. + + switch -exact -- [llength $args] { + 2 - 3 - 6 {} + default { + return -code error \ + "wrong # args: should be\ + \"$name search ?option...? (all|row row|column col|rect c r c r) pattern\"" + } + } + + set range [lindex $args 0] + set pattern [lindex $args end] + set args [lrange $args 1 end-1] + + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + + switch -exact -- $range { + all { + set ctl 0 ; set cbr $columns ; incr cbr -1 + set rtl 0 ; set rbr $rows ; incr rbr -1 + } + column { + set ctl [ChkColumnIndex $name [lindex $args 0]] + set cbr $ctl + set rtl 0 ; set rbr $rows ; incr rbr -1 + } + row { + set rtl [ChkRowIndex $name [lindex $args 0]] + set ctl 0 ; set cbr $columns ; incr cbr -1 + set rbr $rtl + } + rect { + foreach {ctl rtl cbr rbr} $args break + set ctl [ChkColumnIndex $name $ctl] + set rtl [ChkRowIndex $name $rtl] + set cbr [ChkColumnIndex $name $cbr] + set rbr [ChkRowIndex $name $rbr] + if {($ctl > $cbr) || ($rtl > $rbr)} { + return -code error "Invalid cell indices, wrong ordering" + } + } + default { + return -code error "invalid range spec \"$range\": should be all, column, row, or rect" + } + } + + if {$nocase} { + set pattern [string tolower $pattern] + } + + set matches [list] + for {set r $rtl} {$r <= $rbr} {incr r} { + for {set c $ctl} {$c <= $cbr} {incr c} { + set v $data($c,$r) + if {$nocase} { + set v [string tolower $v] + } + switch -exact -- $mode { + exact {set matched [string equal $pattern $v]} + glob {set matched [string match $pattern $v]} + regexp {set matched [regexp -- $pattern $v]} + } + if {$matched} { + lappend matches [list $c $r] + } + } + } + return $matches +} + +# ::struct::matrix::_set -- +# +# Command that processes all 'set' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'set' to invoke. +# args Arguments for subcommand of 'set'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_set {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name set option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __set_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__set_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 6 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_sort -- +# +# Command that processes all 'sort' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'sort' to invoke. +# args Arguments for subcommand of 'sort'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_sort {name cmd args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name sort option ?arg arg ...?\"" + } + if {[string equal $cmd "rows"]} { + set code r + set byrows 1 + } elseif {[string equal $cmd "columns"]} { + set code c + set byrows 0 + } else { + return -code error \ + "bad option \"$cmd\": must be columns, or rows" + } + + set revers 0 ;# Default: -increasing + while {1} { + switch -glob -- [lindex $args 0] { + -increasing {set revers 0} + -decreasing {set revers 1} + default { + if {[llength $args] > 1} { + return -code error \ + "invalid option \"[lindex $args 0]\":\ + should be -increasing, or -decreasing" + } + break + } + } + set args [lrange $args 1 end] + } + # ASSERT: [llength $args] == 1 + + if {[llength $args] != 1} { + return -code error "wrong # args: should be \"$name sort option ?arg arg ...?\"" + } + + set key [lindex $args 0] + + if {$byrows} { + set key [ChkColumnIndex $name $key] + variable ${name}::rows + + # Adapted by EAS from BUILD-MAX-HEAP(A) of CRLS 6.3 + set heapSize $rows + } else { + set key [ChkRowIndex $name $key] + variable ${name}::columns + + # Adapted by EAS from BUILD-MAX-HEAP(A) of CRLS 6.3 + set heapSize $columns + } + + for {set i [expr {int($heapSize/2)-1}]} {$i>=0} {incr i -1} { + SortMaxHeapify $name $i $key $code $heapSize $revers + } + + # Adapted by EAS from remainder of HEAPSORT(A) of CRLS 6.4 + for {set i [expr {$heapSize-1}]} {$i>=1} {incr i -1} { + if {$byrows} { + SwapRows $name 0 $i + } else { + SwapColumns $name 0 $i + } + incr heapSize -1 + SortMaxHeapify $name 0 $key $code $heapSize $revers + } + return +} + +# ::struct::matrix::_swap -- +# +# Command that processes all 'swap' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'swap' to invoke. +# args Arguments for subcommand of 'swap'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_swap {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name swap option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __swap_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__swap_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 7 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::__add_column -- +# +# Extends the matrix by one column and then acts like +# "setcolumn" (see below) on this new column if there were +# "values" supplied. Without "values" the new cells will be set +# to the empty string. The new column is appended immediately +# behind the last existing column. +# +# Arguments: +# name Name of the matrix object. +# values Optional values to set into the new row. +# +# Results: +# None. + +proc ::struct::matrix::__add_column {name {values {}}} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::rowh + + if {[set l [llength $values]] < $rows} { + # Missing values. Fill up with empty strings + + for {} {$l < $rows} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $rows} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$rows - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + + # - The new column is not added to the width cache, the other + # columns are not touched, the cache therefore unchanged. + # - The rows are either removed from the height cache or left + # unchanged, depending on the contents set into the cell. + + set r 0 + foreach v $values { + if {$v != {}} { + # Data changed unpredictably, invalidate cache + catch {unset rowh($r)} + } ; # {else leave the row unchanged} + set data($columns,$r) $v + incr r + } + incr columns + return +} + +# ::struct::matrix::__add_row -- +# +# Extends the matrix by one row and then acts like "setrow" (see +# below) on this new row if there were "values" +# supplied. Without "values" the new cells will be set to the +# empty string. The new row is appended immediately behind the +# last existing row. +# +# Arguments: +# name Name of the matrix object. +# values Optional values to set into the new row. +# +# Results: +# None. + +proc ::struct::matrix::__add_row {name {values {}}} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::colw + + if {[set l [llength $values]] < $columns} { + # Missing values. Fill up with empty strings + + for {} {$l < $columns} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $columns} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$columns - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + + # - The new row is not added to the height cache, the other + # rows are not touched, the cache therefore unchanged. + # - The columns are either removed from the width cache or left + # unchanged, depending on the contents set into the cell. + + set c 0 + foreach v $values { + if {$v != {}} { + # Data changed unpredictably, invalidate cache + catch {unset colw($c)} + } ; # {else leave the row unchanged} + set data($c,$rows) $v + incr c + } + incr rows + return +} + +# ::struct::matrix::__add_columns -- +# +# Extends the matrix by "n" columns. The new cells will be set +# to the empty string. The new columns are appended immediately +# behind the last existing column. A value of "n" equal to or +# smaller than 0 is not allowed. +# +# Arguments: +# name Name of the matrix object. +# n The number of new columns to create. +# +# Results: +# None. + +proc ::struct::matrix::__add_columns {name n} { + if {$n <= 0} { + return -code error "A value of n <= 0 is not allowed" + } + AddColumns $name $n + return +} + +proc ::struct::matrix::AddColumns {name n} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + + # The new values set into the cell is always the empty + # string. These have a length and height of 0, i.e. the don't + # influence cached widths and heights as they are at least that + # big. IOW there is no need to touch and change the width and + # height caches. + + while {$n > 0} { + for {set r 0} {$r < $rows} {incr r} { + set data($columns,$r) "" + } + incr columns + incr n -1 + } + + return +} + +# ::struct::matrix::__add_rows -- +# +# Extends the matrix by "n" rows. The new cells will be set to +# the empty string. The new rows are appended immediately behind +# the last existing row. A value of "n" equal to or smaller than +# 0 is not allowed. +# +# Arguments: +# name Name of the matrix object. +# n The number of new rows to create. +# +# Results: +# None. + +proc ::struct::matrix::__add_rows {name n} { + if {$n <= 0} { + return -code error "A value of n <= 0 is not allowed" + } + AddRows $name $n + return +} + +proc ::struct::matrix::AddRows {name n} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + + # The new values set into the cell is always the empty + # string. These have a length and height of 0, i.e. the don't + # influence cached widths and heights as they are at least that + # big. IOW there is no need to touch and change the width and + # height caches. + + while {$n > 0} { + for {set c 0} {$c < $columns} {incr c} { + set data($c,$rows) "" + } + incr rows + incr n -1 + } + return +} + +# ::struct::matrix::_cells -- +# +# Returns the number of cells currently managed by the +# matrix. This is the product of "rows" and "columns". +# +# Arguments: +# name Name of the matrix object. +# +# Results: +# The number of cells in the matrix. + +proc ::struct::matrix::_cells {name} { + variable ${name}::rows + variable ${name}::columns + return [expr {$rows * $columns}] +} + +# ::struct::matrix::_cellsize -- +# +# Returns the length of the string representation of the value +# currently contained in the addressed cell. +# +# Arguments: +# name Name of the matrix object. +# column Column index of the cell to query +# row Row index of the cell to query +# +# Results: +# The number of cells in the matrix. + +proc ::struct::matrix::_cellsize {name column row} { + set column [ChkColumnIndex $name $column] + set row [ChkRowIndex $name $row] + + variable ${name}::data + return [string length $data($column,$row)] +} + +# ::struct::matrix::_columns -- +# +# Returns the number of columns currently managed by the +# matrix. +# +# Arguments: +# name Name of the matrix object. +# +# Results: +# The number of columns in the matrix. + +proc ::struct::matrix::_columns {name} { + variable ${name}::columns + return $columns +} + +# ::struct::matrix::_columnwidth -- +# +# Returns the length of the longest string representation of all +# the values currently contained in the cells of the addressed +# column if these are all spanning only one line. For cell +# values spanning multiple lines the length of their longest +# line goes into the computation. +# +# Arguments: +# name Name of the matrix object. +# column The index of the column whose width is asked for. +# +# Results: +# See description. + +proc ::struct::matrix::_columnwidth {name column} { + set column [ChkColumnIndex $name $column] + + variable ${name}::colw + + if {![info exists colw($column)]} { + variable ${name}::rows + variable ${name}::data + + set width 0 + for {set r 0} {$r < $rows} {incr r} { + foreach line [split $data($column,$r) \n] { + set len [TermWidth $line] + if {$len > $width} { + set width $len + } + } + } + + set colw($column) $width + } + + return $colw($column) +} + +# ::struct::matrix::__delete_column -- +# +# Deletes the specified column from the matrix and shifts all +# columns with higher indices one index down. +# +# Arguments: +# name Name of the matrix. +# column The index of the column to delete. +# +# Results: +# None. + +proc ::struct::matrix::__delete_column {name column} { + set column [ChkColumnIndex $name $column] + + variable ${name}::data + variable ${name}::rows + variable ${name}::columns + variable ${name}::colw + variable ${name}::rowh + + # Move all data from the higher columns down and then delete the + # superfluous data in the old last column. Move the data in the + # width cache too, take partial fill into account there too. + # Invalidate the height cache for all rows. + + for {set r 0} {$r < $rows} {incr r} { + for {set c $column; set cn [expr {$c + 1}]} {$cn < $columns} {incr c ; incr cn} { + set data($c,$r) $data($cn,$r) + if {[info exists colw($cn)]} { + set colw($c) $colw($cn) + unset colw($cn) + } + } + unset data($c,$r) + catch {unset rowh($r)} + } + incr columns -1 + return +} + +# ::struct::matrix::__delete_columns -- +# +# Shrink the matrix by "n" columns (from the right). +# A value of "n" equal to or smaller than 0 is not +# allowed, nor is "n" allowed to be greater than the +# number of columns in the matrix. +# +# Arguments: +# name Name of the matrix object. +# n The number of columns to remove. +# +# Results: +# None. + +proc ::struct::matrix::__delete_columns {name n} { + if {$n <= 0} { + return -code error "A value of n <= 0 is not allowed" + } + + variable ${name}::columns + + if {$n > $columns} { + return -code error "A value of n > #columns is not allowed" + } + + DeleteColumns $name $n + return +} + +# ::struct::matrix::__delete_row -- +# +# Deletes the specified row from the matrix and shifts all +# row with higher indices one index down. +# +# Arguments: +# name Name of the matrix. +# row The index of the row to delete. +# +# Results: +# None. + +proc ::struct::matrix::__delete_row {name row} { + set row [ChkRowIndex $name $row] + + variable ${name}::data + variable ${name}::rows + variable ${name}::columns + variable ${name}::colw + variable ${name}::rowh + + # Move all data from the higher rows down and then delete the + # superfluous data in the old last row. Move the data in the + # height cache too, take partial fill into account there too. + # Invalidate the width cache for all columns. + + for {set c 0} {$c < $columns} {incr c} { + for {set r $row; set rn [expr {$r + 1}]} {$rn < $rows} {incr r ; incr rn} { + set data($c,$r) $data($c,$rn) + if {[info exists rowh($rn)]} { + set rowh($r) $rowh($rn) + unset rowh($rn) + } + } + unset data($c,$r) + catch {unset colw($c)} + } + incr rows -1 + return +} + +# ::struct::matrix::__delete_rows -- +# +# Shrink the matrix by "n" rows (from the bottom). +# A value of "n" equal to or smaller than 0 is not +# allowed, nor is "n" allowed to be greater than the +# number of rows in the matrix. +# +# Arguments: +# name Name of the matrix object. +# n The number of rows to remove. +# +# Results: +# None. + +proc ::struct::matrix::__delete_rows {name n} { + if {$n <= 0} { + return -code error "A value of n <= 0 is not allowed" + } + + variable ${name}::rows + + if {$n > $rows} { + return -code error "A value of n > #rows is not allowed" + } + + DeleteRows $name $n + return +} + +# ::struct::matrix::_deserialize -- +# +# Assignment operator. Copies a serialization into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the matrix object we are copying into. +# serial Serialized matrix to copy from. +# +# Results: +# Nothing. + +proc ::struct::matrix::_deserialize {name serial} { + # As we destroy the original matrix as part of + # the copying process we don't have to deal + # with issues like node names from the new matrix + # interfering with the old ... + + # I. Get the serialization of the source matrix + # and check it for validity. + + CheckSerialization $serial r c values + + # Get all the relevant data into the scope + + variable ${name}::rows + variable ${name}::columns + + # Resize the destination matrix for the new data + + if {$r > $rows} { + AddRows $name [expr {$r - $rows}] + } elseif {$r < $rows} { + DeleteRows $name [expr {$rows - $r}] + } + if {$c > $columns} { + AddColumns $name [expr {$c - $columns}] + } elseif {$c < $columns} { + DeleteColumns $name [expr {$columns - $c}] + } + + set rows $r + set columns $c + + # Copy the new data over the old information. + + set row 0 + foreach rv $values { + SetRow $name $row $rv + incr row + } + while {$row < $rows} { + # Fill with empty rows if there are not enough. + SetRow $name $row {} + incr row + } + return +} + +# ::struct::matrix::_destroy -- +# +# Destroy a matrix, including its associated command and data storage. +# +# Arguments: +# name Name of the matrix to destroy. +# +# Results: +# None. + +proc ::struct::matrix::_destroy {name} { + variable ${name}::link + + # Unlink all existing arrays before destroying the object so that + # we don't leave dangling references / traces. + + foreach avar [array names link] { + _unlink $name $avar + } + + namespace delete $name + interp alias {} $name {} +} + +# ::struct::matrix::__format_2string -- +# +# Formats the matrix using the specified report object and +# returns the string containing the result of this +# operation. The report has to support the "printmatrix" method. +# +# Arguments: +# name Name of the matrix. +# report Name of the report object specifying the formatting. +# +# Results: +# A string containing the formatting result. + +proc ::struct::matrix::__format_2string {name {report {}}} { + if {$report == {}} { + # Use an internal hardwired simple report to format the matrix. + # 1. Go through all columns and compute the column widths. + # 2. Then iterate through all rows and dump then into a + # string, formatted to the number of characters per columns + + array set cw {} + set cols [_columns $name] + for {set c 0} {$c < $cols} {incr c} { + set cw($c) [_columnwidth $name $c] + } + + set result [list] + set n [_rows $name] + for {set r 0} {$r < $n} {incr r} { + set rh [_rowheight $name $r] + if {$rh < 2} { + # Simple row. + set line [list] + for {set c 0} {$c < $cols} {incr c} { + set val [__get_cell $name $c $r] + lappend line "$val[string repeat " " [expr {$cw($c)-[TermWidth $val]}]]" + } + lappend result [join $line " "] + } else { + # Complex row, multiple passes + for {set h 0} {$h < $rh} {incr h} { + set line [list] + for {set c 0} {$c < $cols} {incr c} { + set val [lindex [split [__get_cell $name $c $r] \n] $h] + lappend line "$val[string repeat " " [expr {$cw($c)-[TermWidth $val]}]]" + } + lappend result [join $line " "] + } + } + } + return [join $result \n] + } else { + return [$report printmatrix $name] + } +} + +# ::struct::matrix::__format_2chan -- +# +# Formats the matrix using the specified report object and +# writes the string containing the result of this operation into +# the channel. The report has to support the +# "printmatrix2channel" method. +# +# Arguments: +# name Name of the matrix. +# report Name of the report object specifying the formatting. +# chan Handle of the channel to write to. +# +# Results: +# None. + +proc ::struct::matrix::__format_2chan {name {report {}} {chan stdout}} { + if {$report == {}} { + # Use an internal hardwired simple report to format the matrix. + # We delegate this to the string formatter and print its result. + puts -nonewline $chan [__format_2string $name] + } else { + $report printmatrix2channel $name $chan + } + return +} + +# ::struct::matrix::__get_cell -- +# +# Returns the value currently contained in the cell identified +# by row and column index. +# +# Arguments: +# name Name of the matrix. +# column Column index of the addressed cell. +# row Row index of the addressed cell. +# +# Results: +# value Value currently stored in the addressed cell. + +proc ::struct::matrix::__get_cell {name column row} { + set column [ChkColumnIndex $name $column] + set row [ChkRowIndex $name $row] + + variable ${name}::data + return $data($column,$row) +} + +# ::struct::matrix::__get_column -- +# +# Returns a list containing the values from all cells in the +# column identified by the index. The contents of the cell in +# row 0 are stored as the first element of this list. +# +# Arguments: +# name Name of the matrix. +# column Column index of the addressed cell. +# +# Results: +# List of values stored in the addressed row. + +proc ::struct::matrix::__get_column {name column} { + set column [ChkColumnIndex $name $column] + return [GetColumn $name $column] +} + +proc ::struct::matrix::GetColumn {name column} { + variable ${name}::data + variable ${name}::rows + + set result [list] + for {set r 0} {$r < $rows} {incr r} { + lappend result $data($column,$r) + } + return $result +} + +# ::struct::matrix::__get_rect -- +# +# Returns a list of lists of cell values. The values stored in +# the result come from the submatrix whose top-left and +# bottom-right cells are specified by "column_tl", "row_tl" and +# "column_br", "row_br" resp. Note that the following equations +# have to be true: column_tl <= column_br and row_tl <= row_br. +# The result is organized as follows: The outer list is the list +# of rows, its elements are lists representing a single row. The +# row with the smallest index is the first element of the outer +# list. The elements of the row lists represent the selected +# cell values. The cell with the smallest index is the first +# element in each row list. +# +# Arguments: +# name Name of the matrix. +# column_tl Column index of the top-left cell of the area. +# row_tl Row index of the top-left cell of the the area +# column_br Column index of the bottom-right cell of the area. +# row_br Row index of the bottom-right cell of the the area +# +# Results: +# List of a list of values stored in the addressed area. + +proc ::struct::matrix::__get_rect {name column_tl row_tl column_br row_br} { + set column_tl [ChkColumnIndex $name $column_tl] + set row_tl [ChkRowIndex $name $row_tl] + set column_br [ChkColumnIndex $name $column_br] + set row_br [ChkRowIndex $name $row_br] + + if { + ($column_tl > $column_br) || + ($row_tl > $row_br) + } { + return -code error "Invalid cell indices, wrong ordering" + } + return [GetRect $name $column_tl $row_tl $column_br $row_br] +} + +proc ::struct::matrix::GetRect {name column_tl row_tl column_br row_br} { + variable ${name}::data + set result [list] + + for {set r $row_tl} {$r <= $row_br} {incr r} { + set row [list] + for {set c $column_tl} {$c <= $column_br} {incr c} { + lappend row $data($c,$r) + } + lappend result $row + } + + return $result +} + +# ::struct::matrix::__get_row -- +# +# Returns a list containing the values from all cells in the +# row identified by the index. The contents of the cell in +# column 0 are stored as the first element of this list. +# +# Arguments: +# name Name of the matrix. +# row Row index of the addressed cell. +# +# Results: +# List of values stored in the addressed row. + +proc ::struct::matrix::__get_row {name row} { + set row [ChkRowIndex $name $row] + return [GetRow $name $row] +} + +proc ::struct::matrix::GetRow {name row} { + variable ${name}::data + variable ${name}::columns + + set result [list] + for {set c 0} {$c < $columns} {incr c} { + lappend result $data($c,$row) + } + return $result +} + +# ::struct::matrix::__insert_column -- +# +# Extends the matrix by one column and then acts like +# "setcolumn" (see below) on this new column if there were +# "values" supplied. Without "values" the new cells will be set +# to the empty string. The new column is inserted just before +# the column specified by the given index. This means, if +# "column" is less than or equal to zero, then the new column is +# inserted at the beginning of the matrix, before the first +# column. If "column" has the value "Bend", or if it is greater +# than or equal to the number of columns in the matrix, then the +# new column is appended to the matrix, behind the last +# column. The old column at the chosen index and all columns +# with higher indices are shifted one index upward. +# +# Arguments: +# name Name of the matrix. +# column Index of the column where to insert. +# values Optional values to set the cells to. +# +# Results: +# None. + +proc ::struct::matrix::__insert_column {name column {values {}}} { + # Allow both negative and too big indices. + set column [ChkColumnIndexAll $name $column] + + variable ${name}::columns + + if {$column > $columns} { + # Same as 'addcolumn' + __add_column $name $values + return + } + + variable ${name}::data + variable ${name}::rows + variable ${name}::rowh + variable ${name}::colw + + set firstcol $column + if {$firstcol < 0} { + set firstcol 0 + } + + if {[set l [llength $values]] < $rows} { + # Missing values. Fill up with empty strings + + for {} {$l < $rows} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $rows} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$rows - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + # Invalidate all rows, move all columns + + # Move all data from the higher columns one up and then insert the + # new data into the freed space. Move the data in the + # width cache too, take partial fill into account there too. + # Invalidate the height cache for all rows. + + for {set r 0} {$r < $rows} {incr r} { + for {set cn $columns ; set c [expr {$cn - 1}]} {$c >= $firstcol} {incr c -1 ; incr cn -1} { + set data($cn,$r) $data($c,$r) + if {[info exists colw($c)]} { + set colw($cn) $colw($c) + unset colw($c) + } + } + set data($firstcol,$r) [lindex $values $r] + catch {unset rowh($r)} + } + incr columns + return +} + +# ::struct::matrix::__insert_row -- +# +# Extends the matrix by one row and then acts like "setrow" (see +# below) on this new row if there were "values" +# supplied. Without "values" the new cells will be set to the +# empty string. The new row is inserted just before the row +# specified by the given index. This means, if "row" is less +# than or equal to zero, then the new row is inserted at the +# beginning of the matrix, before the first row. If "row" has +# the value "end", or if it is greater than or equal to the +# number of rows in the matrix, then the new row is appended to +# the matrix, behind the last row. The old row at that index and +# all rows with higher indices are shifted one index upward. +# +# Arguments: +# name Name of the matrix. +# row Index of the row where to insert. +# values Optional values to set the cells to. +# +# Results: +# None. + +proc ::struct::matrix::__insert_row {name row {values {}}} { + # Allow both negative and too big indices. + set row [ChkRowIndexAll $name $row] + + variable ${name}::rows + + if {$row > $rows} { + # Same as 'addrow' + __add_row $name $values + return + } + + variable ${name}::data + variable ${name}::columns + variable ${name}::rowh + variable ${name}::colw + + set firstrow $row + if {$firstrow < 0} { + set firstrow 0 + } + + if {[set l [llength $values]] < $columns} { + # Missing values. Fill up with empty strings + + for {} {$l < $columns} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $columns} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$columns - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + # Invalidate all columns, move all rows + + # Move all data from the higher rows one up and then insert the + # new data into the freed space. Move the data in the + # height cache too, take partial fill into account there too. + # Invalidate the width cache for all columns. + + for {set c 0} {$c < $columns} {incr c} { + for {set rn $rows ; set r [expr {$rn - 1}]} {$r >= $firstrow} {incr r -1 ; incr rn -1} { + set data($c,$rn) $data($c,$r) + if {[info exists rowh($r)]} { + set rowh($rn) $rowh($r) + unset rowh($r) + } + } + set data($c,$firstrow) [lindex $values $c] + catch {unset colw($c)} + } + incr rows + return +} + +# ::struct::matrix::_link -- +# +# Links the matrix to the specified array variable. This means +# that the contents of all cells in the matrix is stored in the +# array too, with all changes to the matrix propagated there +# too. The contents of the cell "(column,row)" is stored in the +# array using the key "column,row". If the option "-transpose" +# is specified the key "row,column" will be used instead. It is +# possible to link the matrix to more than one array. Note that +# the link is bidirectional, i.e. changes to the array are +# mirrored in the matrix too. +# +# Arguments: +# name Name of the matrix object. +# option Either empty of '-transpose'. +# avar Name of the variable to link to +# +# Results: +# None + +proc ::struct::matrix::_link {name args} { + switch -exact -- [llength $args] { + 0 { + return -code error "$name: wrong # args: link ?-transpose? arrayvariable" + } + 1 { + set transpose 0 + set variable [lindex $args 0] + } + 2 { + foreach {t variable} $args break + if {[string compare $t -transpose]} { + return -code error "$name: illegal syntax: link ?-transpose? arrayvariable" + } + set transpose 1 + } + default { + return -code error "$name: wrong # args: link ?-transpose? arrayvariable" + } + } + + variable ${name}::link + + if {[info exists link($variable)]} { + return -code error "$name link: Variable \"$variable\" already linked to matrix" + } + + # Ok, a new variable we are linked to. Record this information, + # dump our current contents into the array, at last generate the + # traces actually performing the link. + + set link($variable) $transpose + + upvar #0 $variable array + variable ${name}::data + + foreach key [array names data] { + foreach {c r} [split $key ,] break + if {$transpose} { + set array($r,$c) $data($key) + } else { + set array($c,$r) $data($key) + } + } + + trace variable array wu [list ::struct::matrix::MatTraceIn $variable $name] + trace variable data w [list ::struct::matrix::MatTraceOut $variable $name] + return +} + +# ::struct::matrix::_links -- +# +# Retrieves the names of all array variable the matrix is +# officially linked to. +# +# Arguments: +# name Name of the matrix object. +# +# Results: +# List of variables the matrix is linked to. + +proc ::struct::matrix::_links {name} { + variable ${name}::link + return [array names link] +} + +# ::struct::matrix::_rowheight -- +# +# Returns the height of the specified row in lines. This is the +# highest number of lines spanned by a cell over all cells in +# the row. +# +# Arguments: +# name Name of the matrix +# row Index of the row queried for its height +# +# Results: +# The height of the specified row in lines. + +proc ::struct::matrix::_rowheight {name row} { + set row [ChkRowIndex $name $row] + + variable ${name}::rowh + + if {![info exists rowh($row)]} { + variable ${name}::columns + variable ${name}::data + + set height 1 + for {set c 0} {$c < $columns} {incr c} { + set cheight [llength [split $data($c,$row) \n]] + if {$cheight > $height} { + set height $cheight + } + } + + set rowh($row) $height + } + return $rowh($row) +} + +# ::struct::matrix::_rows -- +# +# Returns the number of rows currently managed by the matrix. +# +# Arguments: +# name Name of the matrix object. +# +# Results: +# The number of rows in the matrix. + +proc ::struct::matrix::_rows {name} { + variable ${name}::rows + return $rows +} + +# ::struct::matrix::_serialize -- +# +# Serialize a matrix object (partially) into a transportable value. +# If only a rectangle is serialized the result will be a sub- +# matrix in the mathematical sense of the word. +# +# Arguments: +# name Name of the matrix. +# args rectangle to place into the serialized matrix +# +# Results: +# A list structure describing the part of the matrix which was serialized. + +proc ::struct::matrix::_serialize {name args} { + + # all - boolean flag - set if and only if the all nodes of the + # matrix are chosen for serialization. Because if that is true we + # can skip the step finding the relevant arcs and simply take all + # arcs. + + set nargs [llength $args] + if {($nargs != 0) && ($nargs != 4)} { + return -code error "$name: wrong # args: serialize ?column_tl row_tl column_br row_br?" + } + + variable ${name}::rows + variable ${name}::columns + + if {$nargs == 4} { + foreach {column_tl row_tl column_br row_br} $args break + + set column_tl [ChkColumnIndex $name $column_tl] + set row_tl [ChkRowIndex $name $row_tl] + set column_br [ChkColumnIndex $name $column_br] + set row_br [ChkRowIndex $name $row_br] + + if { + ($column_tl > $column_br) || + ($row_tl > $row_br) + } { + return -code error "Invalid cell indices, wrong ordering" + } + set rn [expr {$row_br - $row_tl + 1}] + set cn [expr {$column_br - $column_tl + 1}] + } else { + set column_tl 0 + set row_tl 0 + set column_br [expr {$columns - 1}] + set row_br [expr {$rows - 1}] + set rn $rows + set cn $columns + } + + # We could optimize and remove empty cells to the right and rows + # to the bottom. For now we don't. + + return [list \ + $rn $cn \ + [GetRect $name $column_tl $row_tl $column_br $row_br]] +} + +# ::struct::matrix::__set_cell -- +# +# Sets the value in the cell identified by row and column index +# to the data in the third argument. +# +# Arguments: +# name Name of the matrix object. +# column Column index of the cell to set. +# row Row index of the cell to set. +# value The new value of the cell. +# +# Results: +# None. + +proc ::struct::matrix::__set_cell {name column row value} { + set column [ChkColumnIndex $name $column] + set row [ChkRowIndex $name $row] + + variable ${name}::data + + if {![string compare $value $data($column,$row)]} { + # No change, ignore call! + return + } + + set data($column,$row) $value + + if {$value != {}} { + variable ${name}::colw + variable ${name}::rowh + catch {unset colw($column)} + catch {unset rowh($row)} + } + return +} + +# ::struct::matrix::__set_column -- +# +# Sets the values in the cells identified by the column index to +# the elements of the list provided as the third argument. Each +# element of the list is assigned to one cell, with the first +# element going into the cell in row 0 and then upward. If there +# are less values in the list than there are rows the remaining +# rows are set to the empty string. If there are more values in +# the list than there are rows the superfluous elements are +# ignored. The matrix is not extended by this operation. +# +# Arguments: +# name Name of the matrix. +# column Index of the column to set. +# values Values to set into the column. +# +# Results: +# None. + +proc ::struct::matrix::__set_column {name column values} { + set column [ChkColumnIndex $name $column] + + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::rowh + variable ${name}::colw + + if {[set l [llength $values]] < $rows} { + # Missing values. Fill up with empty strings + + for {} {$l < $rows} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $rows} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$rows - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + + # - Invalidate the column in the width cache. + # - The rows are either removed from the height cache or left + # unchanged, depending on the contents set into the cell. + + set r 0 + foreach v $values { + if {$v != {}} { + # Data changed unpredictably, invalidate cache + catch {unset rowh($r)} + } ; # {else leave the row unchanged} + set data($column,$r) $v + incr r + } + catch {unset colw($column)} + return +} + +# ::struct::matrix::__set_rect -- +# +# Takes a list of lists of cell values and writes them into the +# submatrix whose top-left cell is specified by the two +# indices. If the sublists of the outer list are not of equal +# length the shorter sublists will be filled with empty strings +# to the length of the longest sublist. If the submatrix +# specified by the top-left cell and the number of rows and +# columns in the "values" extends beyond the matrix we are +# modifying the over-extending parts of the values are ignored, +# i.e. essentially cut off. This subcommand expects its input in +# the format as returned by "getrect". +# +# Arguments: +# name Name of the matrix object. +# column Column index of the topleft cell to set. +# row Row index of the topleft cell to set. +# values Values to set. +# +# Results: +# None. + +proc ::struct::matrix::__set_rect {name column row values} { + # Allow negative indices! + set column [ChkColumnIndexNeg $name $column] + set row [ChkRowIndexNeg $name $row] + + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::colw + variable ${name}::rowh + + if {$row < 0} { + # Remove rows from the head of values to restrict it to the + # overlapping area. + + set values [lrange $values [expr {0 - $row}] end] + set row 0 + } + + # Restrict it at the end too. + if {($row + [llength $values]) > $rows} { + set values [lrange $values 0 [expr {$rows - $row - 1}]] + } + + # Same for columns, but store it in some vars as this is required + # in a loop. + set firstcol 0 + if {$column < 0} { + set firstcol [expr {0 - $column}] + set column 0 + } + + # Now pan through values and area and copy the external data into + # the matrix. + + set r $row + foreach line $values { + set line [lrange $line $firstcol end] + + set l [expr {$column + [llength $line]}] + if {$l > $columns} { + set line [lrange $line 0 [expr {$columns - $column - 1}]] + } elseif {$l < [expr {$columns - $firstcol}]} { + # We have to take the offset into the line into account + # or we add fillers we don't need, overwriting part of the + # data array we shouldn't. + + for {} {$l < [expr {$columns - $firstcol}]} {incr l} { + lappend line {} + } + } + + set c $column + foreach cell $line { + if {$cell != {}} { + catch {unset rowh($r)} + catch {unset colw($c)} + } + set data($c,$r) $cell + incr c + } + incr r + } + return +} + +# ::struct::matrix::__set_row -- +# +# Sets the values in the cells identified by the row index to +# the elements of the list provided as the third argument. Each +# element of the list is assigned to one cell, with the first +# element going into the cell in column 0 and then upward. If +# there are less values in the list than there are columns the +# remaining columns are set to the empty string. If there are +# more values in the list than there are columns the superfluous +# elements are ignored. The matrix is not extended by this +# operation. +# +# Arguments: +# name Name of the matrix. +# row Index of the row to set. +# values Values to set into the row. +# +# Results: +# None. + +proc ::struct::matrix::__set_row {name row values} { + set row [ChkRowIndex $name $row] + SetRow $name $row $values +} + +proc ::struct::matrix::SetRow {name row values} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::colw + variable ${name}::rowh + + if {[set l [llength $values]] < $columns} { + # Missing values. Fill up with empty strings + + for {} {$l < $columns} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $columns} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$columns - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + + # - Invalidate the row in the height cache. + # - The columns are either removed from the width cache or left + # unchanged, depending on the contents set into the cell. + + set c 0 + foreach v $values { + if {$v != {}} { + # Data changed unpredictably, invalidate cache + catch {unset colw($c)} + } ; # {else leave the row unchanged} + set data($c,$row) $v + incr c + } + catch {unset rowh($row)} + return +} + +# ::struct::matrix::__swap_columns -- +# +# Swaps the contents of the two specified columns. +# +# Arguments: +# name Name of the matrix. +# column_a Index of the first column to swap +# column_b Index of the second column to swap +# +# Results: +# None. + +proc ::struct::matrix::__swap_columns {name column_a column_b} { + set column_a [ChkColumnIndex $name $column_a] + set column_b [ChkColumnIndex $name $column_b] + return [SwapColumns $name $column_a $column_b] +} + +proc ::struct::matrix::SwapColumns {name column_a column_b} { + variable ${name}::data + variable ${name}::rows + variable ${name}::colw + + # Note: This operation does not influence the height cache for all + # rows and the width cache only insofar as its contents has to be + # swapped too for the two columns we are touching. Note that the + # cache might be partially filled or not at all, so we don't have + # to "swap" in some situations. + + for {set r 0} {$r < $rows} {incr r} { + set tmp $data($column_a,$r) + set data($column_a,$r) $data($column_b,$r) + set data($column_b,$r) $tmp + } + + set cwa [info exists colw($column_a)] + set cwb [info exists colw($column_b)] + + if {$cwa && $cwb} { + set tmp $colw($column_a) + set colw($column_a) $colw($column_b) + set colw($column_b) $tmp + } elseif {$cwa} { + # Move contents, don't swap. + set colw($column_b) $colw($column_a) + unset colw($column_a) + } elseif {$cwb} { + # Move contents, don't swap. + set colw($column_a) $colw($column_b) + unset colw($column_b) + } ; # else {nothing to do at all} + return +} + +# ::struct::matrix::__swap_rows -- +# +# Swaps the contents of the two specified rows. +# +# Arguments: +# name Name of the matrix. +# row_a Index of the first row to swap +# row_b Index of the second row to swap +# +# Results: +# None. + +proc ::struct::matrix::__swap_rows {name row_a row_b} { + set row_a [ChkRowIndex $name $row_a] + set row_b [ChkRowIndex $name $row_b] + return [SwapRows $name $row_a $row_b] +} + +proc ::struct::matrix::SwapRows {name row_a row_b} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rowh + + # Note: This operation does not influence the width cache for all + # columns and the height cache only insofar as its contents has to be + # swapped too for the two rows we are touching. Note that the + # cache might be partially filled or not at all, so we don't have + # to "swap" in some situations. + + for {set c 0} {$c < $columns} {incr c} { + set tmp $data($c,$row_a) + set data($c,$row_a) $data($c,$row_b) + set data($c,$row_b) $tmp + } + + set rha [info exists rowh($row_a)] + set rhb [info exists rowh($row_b)] + + if {$rha && $rhb} { + set tmp $rowh($row_a) + set rowh($row_a) $rowh($row_b) + set rowh($row_b) $tmp + } elseif {$rha} { + # Move contents, don't swap. + set rowh($row_b) $rowh($row_a) + unset rowh($row_a) + } elseif {$rhb} { + # Move contents, don't swap. + set rowh($row_a) $rowh($row_b) + unset rowh($row_b) + } ; # else {nothing to do at all} + return +} + +# ::struct::matrix::_transpose -- +# +# Exchanges rows and columns of the matrix +# +# Arguments: +# name Name of the matrix. +# +# Results: +# None. + +proc ::struct::matrix::_transpose {name} { + variable ${name}::rows + variable ${name}::columns + + if {$rows == 0} { + # Change the dimensions. + # There is no data to shift. + # The row/col caches are empty too. + + set rows $columns + set columns 0 + return + + } elseif {$columns == 0} { + # Change the dimensions. + # There is no data to shift. + # The row/col caches are empty too. + + set columns $rows + set rows 0 + return + } + + variable ${name}::data + variable ${name}::rowh + variable ${name}::colw + + # Exchanging the row/col caches is easy, independent of the actual + # dimensions of the matrix. + + set rhc [array get rowh] + set cwc [array get colw] + + unset rowh ; array set rowh $cwc + unset colw ; array set colw $rhc + + if {$rows == $columns} { + # A square matrix. We have to swap data around, but there is + # need to resize any of the arrays. Only the core is present. + + set n $columns + + } elseif {$rows > $columns} { + # Rectangular matrix, we have to delete rows, and add columns. + + for {set r $columns} {$r < $rows} {incr r} { + for {set c 0} {$c < $columns} {incr c} { + set data($r,$c) $data($c,$r) + unset data($c,$r) + } + } + + set n $columns ; # Size of the core. + } else { + # rows < columns. Rectangular matrix, we have to delete + # columns, and add rows. + + for {set c $rows} {$c < $columns} {incr c} { + for {set r 0} {$r < $rows} {incr r} { + set data($r,$c) $data($c,$r) + unset data($c,$r) + } + } + + set n $rows ; # Size of the core. + } + + set tmp $rows + set rows $columns + set columns $tmp + + # Whatever the actual dimensions, a square core is always + # present. The data of this core is now shuffled + + for {set i 0} {$i < $n} {incr i} { + for {set j $i ; incr j} {$j < $n} {incr j} { + set tmp $data($i,$j) + set data($i,$j) $data($j,$i) + set data($j,$i) $tmp + } + } + return +} + +# ::struct::matrix::_unlink -- +# +# Removes the link between the matrix and the specified +# arrayvariable, if there is one. +# +# Arguments: +# name Name of the matrix. +# avar Name of the linked array. +# +# Results: +# None. + +proc ::struct::matrix::_unlink {name avar} { + + variable ${name}::link + + if {![info exists link($avar)]} { + # Ignore unlinking of unknown variables. + return + } + + # Delete the traces first, then remove the link management + # information from the object. + + upvar #0 $avar array + variable ${name}::data + + trace vdelete array wu [list ::struct::matrix::MatTraceIn $avar $name] + trace vdelete date w [list ::struct::matrix::MatTraceOut $avar $name] + + unset link($avar) + return +} + +# ::struct::matrix::ChkColumnIndex -- +# +# Helper to check and transform column indices. Returns the +# absolute index number belonging to the specified +# index. Rejects indices out of the valid range of columns. +# +# Arguments: +# matrix Matrix to look at +# column The incoming index to check and transform +# +# Results: +# The absolute index to the column + +proc ::struct::matrix::ChkColumnIndex {name column} { + variable ${name}::columns + + switch -regexp -- $column { + {end-[0-9]+} { + set column [string map {end- ""} $column] + set cc [expr {$columns - 1 - $column}] + if {($cc < 0) || ($cc >= $columns)} { + return -code error "bad column index end-$column, column does not exist" + } + return $cc + } + end { + if {$columns <= 0} { + return -code error "bad column index $column, column does not exist" + } + return [expr {$columns - 1}] + } + {[0-9]+} { + if {($column < 0) || ($column >= $columns)} { + return -code error "bad column index $column, column does not exist" + } + return $column + } + default { + return -code error "bad column index \"$column\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkRowIndex -- +# +# Helper to check and transform row indices. Returns the +# absolute index number belonging to the specified +# index. Rejects indices out of the valid range of rows. +# +# Arguments: +# matrix Matrix to look at +# row The incoming index to check and transform +# +# Results: +# The absolute index to the row + +proc ::struct::matrix::ChkRowIndex {name row} { + variable ${name}::rows + + switch -regexp -- $row { + {end-[0-9]+} { + set row [string map {end- ""} $row] + set rr [expr {$rows - 1 - $row}] + if {($rr < 0) || ($rr >= $rows)} { + return -code error "bad row index end-$row, row does not exist" + } + return $rr + } + end { + if {$rows <= 0} { + return -code error "bad row index $row, row does not exist" + } + return [expr {$rows - 1}] + } + {[0-9]+} { + if {($row < 0) || ($row >= $rows)} { + return -code error "bad row index $row, row does not exist" + } + return $row + } + default { + return -code error "bad row index \"$row\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkColumnIndexNeg -- +# +# Helper to check and transform column indices. Returns the +# absolute index number belonging to the specified +# index. Rejects indices out of the valid range of columns +# (Accepts negative indices). +# +# Arguments: +# matrix Matrix to look at +# column The incoming index to check and transform +# +# Results: +# The absolute index to the column + +proc ::struct::matrix::ChkColumnIndexNeg {name column} { + variable ${name}::columns + + switch -regexp -- $column { + {end-[0-9]+} { + set column [string map {end- ""} $column] + set cc [expr {$columns - 1 - $column}] + if {$cc >= $columns} { + return -code error "bad column index end-$column, column does not exist" + } + return $cc + } + end { + return [expr {$columns - 1}] + } + {[0-9]+} { + if {$column >= $columns} { + return -code error "bad column index $column, column does not exist" + } + return $column + } + default { + return -code error "bad column index \"$column\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkRowIndexNeg -- +# +# Helper to check and transform row indices. Returns the +# absolute index number belonging to the specified +# index. Rejects indices out of the valid range of rows +# (Accepts negative indices). +# +# Arguments: +# matrix Matrix to look at +# row The incoming index to check and transform +# +# Results: +# The absolute index to the row + +proc ::struct::matrix::ChkRowIndexNeg {name row} { + variable ${name}::rows + + switch -regexp -- $row { + {end-[0-9]+} { + set row [string map {end- ""} $row] + set rr [expr {$rows - 1 - $row}] + if {$rr >= $rows} { + return -code error "bad row index end-$row, row does not exist" + } + return $rr + } + end { + return [expr {$rows - 1}] + } + {[0-9]+} { + if {$row >= $rows} { + return -code error "bad row index $row, row does not exist" + } + return $row + } + default { + return -code error "bad row index \"$row\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkColumnIndexAll -- +# +# Helper to transform column indices. Returns the +# absolute index number belonging to the specified +# index. +# +# Arguments: +# matrix Matrix to look at +# column The incoming index to check and transform +# +# Results: +# The absolute index to the column + +proc ::struct::matrix::ChkColumnIndexAll {name column} { + variable ${name}::columns + + switch -regexp -- $column { + {end-[0-9]+} { + set column [string map {end- ""} $column] + set cc [expr {$columns - 1 - $column}] + return $cc + } + end { + return $columns + } + {[0-9]+} { + return $column + } + default { + return -code error "bad column index \"$column\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkRowIndexAll -- +# +# Helper to transform row indices. Returns the +# absolute index number belonging to the specified +# index. +# +# Arguments: +# matrix Matrix to look at +# row The incoming index to check and transform +# +# Results: +# The absolute index to the row + +proc ::struct::matrix::ChkRowIndexAll {name row} { + variable ${name}::rows + + switch -regexp -- $row { + {end-[0-9]+} { + set row [string map {end- ""} $row] + set rr [expr {$rows - 1 - $row}] + return $rr + } + end { + return $rows + } + {[0-9]+} { + return $row + } + default { + return -code error "bad row index \"$row\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::MatTraceIn -- +# +# Helper propagating changes made to an array +# into the matrix the array is linked to. +# +# Arguments: +# avar Name of the array which was changed. +# name Matrix to write the changes to. +# var,idx,op Standard trace arguments +# +# Results: +# None. + +proc ::struct::matrix::MatTraceIn {avar name var idx op} { + # Propagate changes in the linked array back into the matrix. + + variable ${name}::lock + if {$lock} {return} + + # We have to cover two possibilities when encountering an "unset" operation ... + # 1. The external array was destroyed: perform automatic unlink. + # 2. An individual element was unset: Set the corresponding cell to the empty string. + # See SF Tcllib Bug #532791. + + if {(![string compare $op u]) && ($idx == {})} { + # Possibility 1: Array was destroyed + $name unlink $avar + return + } + + upvar #0 $avar array + variable ${name}::data + variable ${name}::link + + set transpose $link($avar) + if {$transpose} { + foreach {r c} [split $idx ,] break + } else { + foreach {c r} [split $idx ,] break + } + + # Use standard method to propagate the change. + # => Get automatically index checks, cache updates, ... + + if {![string compare $op u]} { + # Unset possibility 2: Element was unset. + # Note: Setting the cell to the empty string will + # invoke MatTraceOut for this array and thus try + # to recreate the destroyed element of the array. + # We don't want this. But we do want to propagate + # the change to other arrays, as "unset". To do + # all of this we use another state variable to + # signal this situation. + + variable ${name}::unset + set unset $avar + + $name set cell $c $r "" + + set unset {} + return + } + + $name set cell $c $r $array($idx) + return +} + +# ::struct::matrix::MatTraceOut -- +# +# Helper propagating changes made to the matrix into the linked arrays. +# +# Arguments: +# avar Name of the array to write the changes to. +# name Matrix which was changed. +# var,idx,op Standard trace arguments +# +# Results: +# None. + +proc ::struct::matrix::MatTraceOut {avar name var idx op} { + # Propagate changes in the matrix data array into the linked array. + + variable ${name}::unset + + if {![string compare $avar $unset]} { + # Do not change the variable currently unsetting + # one of its elements. + return + } + + variable ${name}::lock + set lock 1 ; # Disable MatTraceIn [#532783] + + upvar #0 $avar array + variable ${name}::data + variable ${name}::link + + set transpose $link($avar) + + if {$transpose} { + foreach {r c} [split $idx ,] break + } else { + foreach {c r} [split $idx ,] break + } + + if {$unset != {}} { + # We are currently propagating the unset of an + # element in a different linked array to this + # array. We make sure that this is an unset too. + + unset array($c,$r) + } else { + set array($c,$r) $data($idx) + } + set lock 0 + return +} + +# ::struct::matrix::SortMaxHeapify -- +# +# Helper for the 'sort' method. Performs the central algorithm +# which converts the matrix into a heap, easily sortable. +# +# Arguments: +# name Matrix object which is sorted. +# i Index of the row/column currently being sorted. +# key Index of the column/row to sort the rows/columns by. +# rowCol Indicator if we are sorting rows ('r'), or columns ('c'). +# heapSize Number of rows/columns to sort. +# rev Boolean flag, set if sorting is done revers (-decreasing). +# +# Sideeffects: +# Transforms the matrix into a heap of rows/columns, +# swapping them around. +# +# Results: +# None. + +proc ::struct::matrix::SortMaxHeapify {name i key rowCol heapSize {rev 0}} { + # MAX-HEAPIFY, adapted by EAS from CLRS 6.2 + switch $rowCol { + r { set A [GetColumn $name $key] } + c { set A [GetRow $name $key] } + } + # Weird expressions below for clarity, as CLRS uses A[1...n] + # format and TCL uses A[0...n-1] + set left [expr {int(2*($i+1) -1)}] + set right [expr {int(2*($i+1)+1 -1)}] + + # left, right are tested as < rather than <= because they are + # in A[0...n-1] + if { + $left < $heapSize && + ( !$rev && [lindex $A $left] > [lindex $A $i] || + $rev && [lindex $A $left] < [lindex $A $i] ) + } { + set largest $left + } else { + set largest $i + } + + if { + $right < $heapSize && + ( !$rev && [lindex $A $right] > [lindex $A $largest] || + $rev && [lindex $A $right] < [lindex $A $largest] ) + } { + set largest $right + } + + if { $largest != $i } { + switch $rowCol { + r { SwapRows $name $i $largest } + c { SwapColumns $name $i $largest } + } + SortMaxHeapify $name $largest $key $rowCol $heapSize $rev + } + return +} + +# ::struct::matrix::CheckSerialization -- +# +# Validate the serialization of a matrix. +# +# Arguments: +# ser Serialization to validate. +# rvar Variable to store the number of rows into. +# cvar Variable to store the number of columns into. +# dvar Variable to store the matrix data into. +# +# Results: +# none + +proc ::struct::matrix::CheckSerialization {ser rvar cvar dvar} { + upvar 1 \ + $rvar rows \ + $cvar columns \ + $dvar data + + # Overall length ok ? + if {[llength $ser] != 3} { + return -code error \ + "error in serialization: list length not 3." + } + + foreach {r c d} $ser break + + # Check rows/columns information + + if {![string is integer -strict $r] || ($r < 0)} { + return -code error \ + "error in serialization: bad number of rows \"$r\"." + } + if {![string is integer -strict $c] || ($c < 0)} { + return -code error \ + "error in serialization: bad number of columns \"$c\"." + } + + # Validate data against rows/columns. We can have less data than + # rows or columns, the missing cells will be initialized to the + # empty string. But too many is considered as a signal of + # being something wrong. + + if {[llength $d] > $r} { + return -code error \ + "error in serialization: data for to many rows." + } + foreach rv $d { + if {[llength $rv] > $c} { + return -code error \ + "error in serialization: data for to many columns." + } + } + + # Ok. The data is now ready for the caller. + + set data $d + set rows $r + set columns $c + return +} + +# ::struct::matrix::DeleteRows -- +# +# Deletes n rows from the bottom of the matrix. +# +# Arguments: +# name Name of the matrix. +# n The number of rows to delete (no greater than the number of rows). +# +# Results: +# None. + +proc ::struct::matrix::DeleteRows {name n} { + variable ${name}::data + variable ${name}::rows + variable ${name}::columns + variable ${name}::colw + variable ${name}::rowh + + # Move all data from the higher rows down and then delete the + # superfluous data in the old last row. Move the data in the + # height cache too, take partial fill into account there too. + # Invalidate the width cache for all columns. + + set rowstart [expr {$rows - $n}] + + for {set c 0} {$c < $columns} {incr c} { + for {set r $rowstart} {$r < $rows} {incr r} { + unset data($c,$r) + catch {unset rowh($r)} + } + catch {unset colw($c)} + } + set rows $rowstart + return +} + +# ::struct::matrix::DeleteColumns -- +# +# Deletes n columns from the right of the matrix. +# +# Arguments: +# name Name of the matrix. +# n The number of columns to delete. +# +# Results: +# None. + +proc ::struct::matrix::DeleteColumns {name n} { + variable ${name}::data + variable ${name}::rows + variable ${name}::columns + variable ${name}::colw + variable ${name}::rowh + + # Move all data from the higher columns down and then delete the + # superfluous data in the old last column. Move the data in the + # width cache too, take partial fill into account there too. + # Invalidate the height cache for all rows. + + set colstart [expr {$columns - $n}] + + for {set r 0} {$r < $rows} {incr r} { + for {set c $colstart} {$c < $columns} {incr c} { + unset data($c,$r) + catch {unset colw($c)} + } + catch {unset rowh($r)} + } + set columns $colstart + return +} + +# ::struct::matrix::TermWidth -- +# +# Computes the number of terminal columns taken by the input string. +# This discounts ANSI color codes as zero-width, and asian characters +# as double-width. +# +# Arguments: +# str String to process +# +# Results: +# Number of terminal columns covered by string argument + +proc ::struct::matrix::TermWidth {str} { + # Look for ANSI color control sequences and remove them. Avoid counting their characters as such + # sequences as a whole represent a state change, and are logically of zero/no width. + # Further use wcswidth to account for double-wide Asian characters. + + regsub -all "\033\\\[\[0-9;\]*m" $str {} str + return [textutil::wcswidth $str] +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'matrix::matrix' into the general structure namespace. + namespace import -force matrix::matrix + namespace export matrix +} +package provide struct::matrix 2.1 diff --git a/src/bootsupport/lib/struct/pkgIndex.tcl b/src/bootsupport/lib/struct/pkgIndex.tcl new file mode 100644 index 00000000..a76d377b --- /dev/null +++ b/src/bootsupport/lib/struct/pkgIndex.tcl @@ -0,0 +1,29 @@ +if {![package vsatisfies [package provide Tcl] 8.2]} {return} +package ifneeded struct 2.1 [list source [file join $dir struct.tcl]] +package ifneeded struct 1.4 [list source [file join $dir struct1.tcl]] + +package ifneeded struct::queue 1.4.5 [list source [file join $dir queue.tcl]] +package ifneeded struct::stack 1.5.3 [list source [file join $dir stack.tcl]] +package ifneeded struct::tree 2.1.2 [list source [file join $dir tree.tcl]] +package ifneeded struct::pool 1.2.3 [list source [file join $dir pool.tcl]] +package ifneeded struct::record 1.2.2 [list source [file join $dir record.tcl]] +package ifneeded struct::set 2.2.3 [list source [file join $dir sets.tcl]] +package ifneeded struct::prioqueue 1.4 [list source [file join $dir prioqueue.tcl]] +package ifneeded struct::skiplist 1.3 [list source [file join $dir skiplist.tcl]] + +package ifneeded struct::graph 1.2.1 [list source [file join $dir graph1.tcl]] +package ifneeded struct::tree 1.2.2 [list source [file join $dir tree1.tcl]] + +if {![package vsatisfies [package provide Tcl] 8.4]} {return} +package ifneeded struct::list 1.8.5 [list source [file join $dir list.tcl]] +package ifneeded struct::list::test 1.8.4 [list source [file join $dir list.test.tcl]] +package ifneeded struct::graph 2.4.3 [list source [file join $dir graph.tcl]] +package ifneeded struct::map 1 [list source [file join $dir map.tcl]] + +if {![package vsatisfies [package provide Tcl] 8.5]} {return} + +package ifneeded struct::matrix 2.1 [list source [file join $dir matrix.tcl]] + +if {![package vsatisfies [package provide Tcl] 8.6]} {return} +package ifneeded struct::disjointset 1.1 [list source [file join $dir disjointset.tcl]] +package ifneeded struct::graph::op 0.11.3 [list source [file join $dir graphops.tcl]] diff --git a/src/bootsupport/lib/struct/pool.tcl b/src/bootsupport/lib/struct/pool.tcl new file mode 100644 index 00000000..e2557cec --- /dev/null +++ b/src/bootsupport/lib/struct/pool.tcl @@ -0,0 +1,715 @@ +################################################################################ +# pool.tcl +# +# +# Author: Erik Leunissen +# +# +# Acknowledgement: +# The author is grateful for the advice provided by +# Andreas Kupries during the development of this code. +# +################################################################################ + +package require cmdline + +namespace eval ::struct {} +namespace eval ::struct::pool { + + # a list of all current pool names + variable pools {} + + # counter is used to give a unique name to a pool if + # no name was supplied, e.g. pool1, pool2 etc. + variable counter 0 + + # `commands' is the list of subcommands recognized by a pool-object command + variable commands {add clear destroy info maxsize release remove request} + + # All errors with corresponding (unformatted) messages. + # The format strings will be replaced by the appropriate + # values when an error occurs. + variable Errors + array set Errors { + BAD_SUBCMD {Bad subcommand "%s": must be %s} + DUPLICATE_ITEM_IN_ARGS {Duplicate item `%s' in arguments.} + DUPLICATE_POOLNAME {The pool `%s' already exists.} + EXCEED_MAXSIZE "This command would increase the total number of items\ + \nbeyond the maximum size of the pool. No items registered." + FORBIDDEN_ALLOCID "The value -1 is not allowed as an allocID." + INVALID_POOLSIZE {The pool currently holds %s items.\ + Can't set maxsize to a value less than that.} + ITEM_ALREADY_IN_POOL {`%s' already is a member of the pool. No items registered.} + ITEM_NOT_IN_POOL {`%s' is not a member of %s.} + ITEM_NOT_ALLOCATED {Can't release `%s' because it isn't allocated.} + ITEM_STILL_ALLOCATED {Can't remove `%s' because it is still allocated.} + NONINT_REQSIZE {The second argument must be a positive integer value} + SOME_ITEMS_NOT_FREE {Couldn't %s `%s' because some items are still allocated.} + UNKNOWN_ARG {Unknown argument `%s'} + UNKNOWN_POOL {Nothing known about `%s'.} + VARNAME_EXISTS {A variable `::struct::pool::%s' already exists.} + WRONG_INFO_TYPE "Expected second argument to be one of:\ + \n allitems, allocstate, cursize, freeitems, maxsize,\ + \nbut received: `%s'." + WRONG_NARGS "wrong#args" + } + + namespace export pool +} + +# A small helper routine to generate structured errors + +if {[package vsatisfies [package present Tcl] 8.5]} { + # Tcl 8.5+, have expansion operator and syntax. And option -level. + proc ::struct::pool::Error {error args} { + variable Errors + return -code error -level 1 \ + -errorcode [list STRUCT POOL $error {*}$args] \ + [format $Errors($error) {*}$args] + } +} else { + # Tcl 8.4. No expansion operator available. Nor -level. + # Construct the pieces explicitly, via linsert/eval hop&dance. + proc ::struct::pool::Error {error args} { + variable Errors + lappend code STRUCT POOL $error + eval [linsert $args 0 lappend code] + set msg [eval [linsert $args 0 format $Errors($error)]] + return -code error -errorcode $code $msg + } +} + +# A small helper routine to check list membership +proc ::struct::pool::lmember {list element} { + if { [lsearch -exact $list $element] >= 0 } { + return 1 + } else { + return 0 + } +} + +# General note +# ============ +# +# All procedures below use the following method to reference +# a particular pool-object: +# +# variable $poolname +# upvar #0 ::struct::pool::$poolname pool +# upvar #0 ::struct::pool::Allocstate_$poolname state +# +# Therefore, the names `pool' and `state' refer to a particular +# instance of a pool. +# +# In the comments to the code below, the words `pool' and `state' +# also refer to a particular pool. +# + +# ::struct::pool::create +# +# Creates a new instance of a pool (a pool-object). +# ::struct::pool::pool (see right below) is an alias to this procedure. +# +# +# Arguments: +# poolname: name of the pool-object +# maxsize: the maximum number of elements that the pool is allowed +# consist of. +# +# +# Results: +# the name of the newly created pool +# +# +# Side effects: +# - Registers the pool-name in the variable `pools'. +# +# - Creates the pool array which holds general state about the pool. +# The following elements are initialized: +# pool(freeitems): a list of non-allocated items +# pool(cursize): the current number of elements in the pool +# pool(maxsize): the maximum allowable number of pool elements +# Additional state may be hung off this array as long as the three +# elements above are not corrupted. +# +# - Creates a separate array `state' that will hold allocation state +# of the pool elements. +# +# - Creates an object-procedure that has the same name as the pool. +# +proc ::struct::pool::create { {poolname ""} {maxsize 10} } { + variable pools + variable counter + + # check maxsize argument + if { ![string equal $maxsize 10] } { + if { ![regexp {^\+?[1-9][0-9]*$} $maxsize] } { + Error NONINT_REQSIZE + } + } + + # create a name if no name was supplied + if { [string length $poolname]==0 } { + incr counter + set poolname pool$counter + set incrcnt 1 + } + + # check whether there exists a pool named $poolname + if { [lmember $pools $poolname] } { + if { [::info exists incrcnt] } { + incr counter -1 + } + Error DUPLICATE_POOLNAME $poolname + } + + # check whether the namespace variable exists + if { [::info exists ::struct::pool::$poolname] } { + if { [::info exists incrcnt] } { + incr counter -1 + } + Error VARNAME_EXISTS $poolname + } + + variable $poolname + + # register + lappend pools $poolname + + # create and initialize the new pool data structure + upvar #0 ::struct::pool::$poolname pool + set pool(freeitems) {} + set pool(maxsize) $maxsize + set pool(cursize) 0 + + # the array that holds allocation state + upvar #0 ::struct::pool::Allocstate_$poolname state + array set state {} + + # create a pool-object command and map it to the pool commands + interp alias {} ::$poolname {} ::struct::pool::poolCmd $poolname + return $poolname +} + +# +# This alias provides compatibility with the implementation of the +# other data structures (stack, queue etc...) in the tcllib::struct package. +# +proc ::struct::pool::pool { {poolname ""} {maxsize 10} } { + ::struct::pool::create $poolname $maxsize +} + + +# ::struct::pool::poolCmd +# +# This proc constitutes a level of indirection between the pool-object +# subcommand and the pool commands (below); it's sole function is to pass +# the command along to one of the pool commands, and receive any results. +# +# Arguments: +# poolname: name of the pool-object +# subcmd: the subcommand, which identifies the pool-command to +# which calls will be passed. +# args: any arguments. They will be inspected by the pool-command +# to which this call will be passed along. +# +# Results: +# Whatever result the pool command returns, is once more returned. +# +# Side effects: +# Dispatches the call onto a specific pool command and receives any results. +# +proc ::struct::pool::poolCmd {poolname subcmd args} { + # check the subcmd argument + if { [lsearch -exact $::struct::pool::commands $subcmd] == -1 } { + set optlist [join $::struct::pool::commands ", "] + set optlist [linsert $optlist "end-1" "or"] + Error BAD_SUBCMD $subcmd $optlist + } + + # pass the call to the pool command indicated by the subcmd argument, + # and return the result from that command. + return [eval [linsert $args 0 ::struct::pool::$subcmd $poolname]] +} + + +# ::struct::pool::destroy +# +# Destroys a pool-object, its associated variables and "object-command" +# +# Arguments: +# poolname: name of the pool-object +# forceArg: if set to `-force', the pool-object will be destroyed +# regardless the allocation state of its objects. +# +# Results: +# none +# +# Side effects: +# - unregisters the pool name in the variable `pools'. +# - unsets `pool' and `state' (poolname specific variables) +# - destroys the "object-procedure" that was associated with the pool. +# +proc ::struct::pool::destroy {poolname {forceArg ""}} { + variable pools + + # check forceArg argument + if { [string length $forceArg] } { + if { [string equal $forceArg -force] } { + set force 1 + } else { + Error UNKNOWN_ARG $forceArg + } + } else { + set force 0 + } + + set index [lsearch -exact $pools $poolname] + if {$index == -1 } { + Error UNKNOWN_POOL $poolname + } + + if { !$force } { + # check for any lingering allocated items + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + if { [llength $pool(freeitems)] != $pool(cursize) } { + Error SOME_ITEMS_NOT_FREE destroy $poolname + } + } + + rename ::$poolname {} + unset ::struct::pool::$poolname + catch {unset ::struct::pool::Allocstate_$poolname} + set pools [lreplace $pools $index $index] + + return +} + + +# ::struct::pool::add +# +# Add items to the pool +# +# Arguments: +# poolname: name of the pool-object +# args: the items to add +# +# Results: +# none +# +# Side effects: +# sets the initial allocation state of the added items to -1 (free) +# +proc ::struct::pool::add {poolname args} { + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + + # argument check + if { [llength $args] == 0 } { + Error WRONG_NARGS + } + + # will this operation exceed the size limit of the pool? + if {[expr { $pool(cursize) + [llength $args] }] > $pool(maxsize) } { + Error EXCEED_MAXSIZE + } + + + # check for duplicate items on the command line + set N [llength $args] + if { $N > 1} { + for {set i 0} {$i<=$N} {incr i} { + foreach item [lrange $args [expr {$i+1}] end] { + if { [string equal [lindex $args $i] $item]} { + Error DUPLICATE_ITEM_IN_ARGS $item + } + } + } + } + + # check whether the items exist yet in the pool + foreach item $args { + if { [lmember [array names state] $item] } { + Error ITEM_ALREADY_IN_POOL $item + } + } + + # add items to the pool, and initialize their allocation state + foreach item $args { + lappend pool(freeitems) $item + set state($item) -1 + incr pool(cursize) + } + return +} + + + +# ::struct::pool::clear +# +# Removes all items from the pool and clears corresponding +# allocation state. +# +# +# Arguments: +# poolname: name of the pool-object +# forceArg: if set to `-force', all items are removed +# regardless their allocation state. +# +# Results: +# none +# +# Side effects: +# see description above +# +proc ::struct::pool::clear {poolname {forceArg ""} } { + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + + # check forceArg argument + if { [string length $forceArg] } { + if { [string equal $forceArg -force] } { + set force 1 + } else { + Error UNKNOWN_ARG $forceArg + } + } else { + set force 0 + } + + # check whether some items are still allocated + if { !$force } { + if { [llength $pool(freeitems)] != $pool(cursize) } { + Error SOME_ITEMS_NOT_FREE clear $poolname + } + } + + # clear the pool, clean up state and adjust the pool size + set pool(freeitems) {} + array unset state + array set state {} + set pool(cursize) 0 + return +} + + + +# ::struct::pool::info +# +# Returns information about the pool in data structures that allow +# further programmatic use. +# +# Arguments: +# poolname: name of the pool-object +# type: the type of info requested +# +# +# Results: +# The info requested +# +# +# Side effects: +# none +# +proc ::struct::pool::info {poolname type args} { + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + + # check the number of arguments + if { [string equal $type allocID] } { + if { [llength $args]!=1 } { + Error WRONG_NARGS + } + } elseif { [llength $args] > 0 } { + Error WRONG_NARGS + } + + switch $type { + allitems { + return [array names state] + } + allocstate { + return [array get state] + } + allocID { + set item [lindex $args 0] + if {![lmember [array names state] $item]} { + Error ITEM_NOT_IN_POOL $item $poolname + } + return $state($item) + } + cursize { + return $pool(cursize) + } + freeitems { + return $pool(freeitems) + } + maxsize { + return $pool(maxsize) + } + default { + Error WRONG_INFO_TYPE $type + } + } +} + + +# ::struct::pool::maxsize +# +# Returns the current or sets a new maximum size of the pool. +# As far as querying only is concerned, this is an alias for +# `::struct::pool::info maxsize'. +# +# +# Arguments: +# poolname: name of the pool-object +# reqsize: if supplied, it is the requested size of the pool, i.e. +# the maximum number of elements in the pool. +# +# +# Results: +# The current/new maximum size of the pool. +# +# +# Side effects: +# Sets pool(maxsize) if a new size is supplied. +# +proc ::struct::pool::maxsize {poolname {reqsize ""} } { + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + + if { [string length $reqsize] } { + if { [regexp {^\+?[1-9][0-9]*$} $reqsize] } { + if { $pool(cursize) <= $reqsize } { + set pool(maxsize) $reqsize + } else { + Error INVALID_POOLSIZE $pool(cursize) + } + } else { + Error NONINT_REQSIZE + } + } + return $pool(maxsize) +} + + +# ::struct::pool::release +# +# Deallocates an item +# +# +# Arguments: +# poolname: name of the pool-object +# item: name of the item to be released +# +# +# Results: +# none +# +# Side effects: +# - sets the item's allocation state to free (-1) +# - appends item to the list of free items +# +proc ::struct::pool::release {poolname item} { + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + + # Is item in the pool? + if {![lmember [array names state] $item]} { + Error ITEM_NOT_IN_POOL $item $poolname + } + + # check whether item was allocated + if { $state($item) == -1 } { + Error ITEM_NOT_ALLOCATED $item + } else { + + # set item free and return it to the pool of free items + set state($item) -1 + lappend pool(freeitems) $item + + } + return +} + +# ::struct::pool::remove +# +# Removes an item from the pool +# +# +# Arguments: +# poolname: name of the pool-object +# item: the item to be removed +# forceArg: if set to `-force', the item is removed +# regardless its allocation state. +# +# Results: +# none +# +# Side effects: +# - cleans up allocation state related to the item +# +proc ::struct::pool::remove {poolname item {forceArg ""} } { + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + + # check forceArg argument + if { [string length $forceArg] } { + if { [string equal $forceArg -force] } { + set force 1 + } else { + Error UNKNOWN_ARG $forceArg + } + } else { + set force 0 + } + + # Is item in the pool? + if {![lmember [array names state] $item]} { + Error ITEM_NOT_IN_POOL $item $poolname + } + + set index [lsearch $pool(freeitems) $item] + if { $index >= 0} { + + # actual removal + set pool(freeitems) [lreplace $pool(freeitems) $index $index] + + } elseif { !$force } { + Error ITEM_STILL_ALLOCATED $item + } + + # clean up state and adjust the pool size + unset state($item) + incr pool(cursize) -1 + return +} + + + +# ::struct::pool::request +# +# Handles requests for an item, taking into account a preference +# for a particular item if supplied. +# +# +# Arguments: +# poolname: name of the pool-object +# +# itemvar: variable to which the item-name will be assigned +# if the request is honored. +# +# args: an optional sequence of key-value pairs, indicating the +# following options: +# -prefer: the preferred item to allocate. +# -allocID: An ID for the entity to which the item will be +# allocated. This facilitates reverse lookups. +# +# Results: +# +# 1 if the request was honored; an item is allocated +# 0 if the request couldn't be honored; no item is allocated +# +# The user is strongly advised to check the return values +# when calling this procedure. +# +# +# Side effects: +# +# if the request is honored: +# - sets allocation state to $allocID (or dummyID if it was not supplied) +# if allocation was succesful. Allocation state is maintained in the +# namespace variable state (see: `General note' above) +# - sets the variable passed via `itemvar' to the allocated item. +# +# if the request is denied, no side effects occur. +# +proc ::struct::pool::request {poolname itemvar args} { + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + + # check args + set nargs [llength $args] + if { ! ($nargs==0 || $nargs==2 || $nargs==4) } { + if { ![string equal $args -?] && ![string equal $args -help]} { + Error WRONG_NARGS + } + } elseif { $nargs } { + foreach {name value} $args { + if { ![string match -* $name] } { + Error UNKNOWN_ARG $name + } + } + } + + set allocated 0 + + # are there any items available? + if { [llength $pool(freeitems)] > 0} { + + # process command options + set options [cmdline::getoptions args { \ + {prefer.arg {} {The preference for a particular item}} \ + {allocID.arg {} {An ID for the entity to which the item will be allocated} } \ + } \ + "usage: $poolname request itemvar ?options?:"] + foreach {key value} $options { + set $key $value + } + + if { $allocID == -1 } { + Error FORBIDDEN_ALLOCID + } + + # let `item' point to a variable two levels up the call stack + upvar 2 $itemvar item + + # check whether a preference was supplied + if { [string length $prefer] } { + if {![lmember [array names state] $prefer]} { + Error ITEM_NOT_IN_POOL $prefer $poolname + } + if { $state($prefer) == -1 } { + set index [lsearch $pool(freeitems) $prefer] + set item $prefer + } else { + return 0 + } + } else { + set index 0 + set item [lindex $pool(freeitems) 0] + } + + # do the actual allocation + set pool(freeitems) [lreplace $pool(freeitems) $index $index] + if { [string length $allocID] } { + set state($item) $allocID + } else { + set state($item) dummyID + } + set allocated 1 + } + return $allocated +} + + +# EOF pool.tcl + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'pool::pool' into the general structure namespace. + namespace import -force pool::pool + namespace export pool +} +package provide struct::pool 1.2.3 diff --git a/src/bootsupport/lib/struct/prioqueue.tcl b/src/bootsupport/lib/struct/prioqueue.tcl new file mode 100644 index 00000000..44f657d6 --- /dev/null +++ b/src/bootsupport/lib/struct/prioqueue.tcl @@ -0,0 +1,535 @@ +# prioqueue.tcl -- +# +# Priority Queue implementation for Tcl. +# +# adapted from queue.tcl +# Copyright (c) 2002,2003 Michael Schlenker +# Copyright (c) 2008 Alejandro Paz +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: prioqueue.tcl,v 1.10 2008/09/04 04:35:02 andreas_kupries Exp $ + +package require Tcl 8.2 + +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" \ + "remove" \ + "size" \ + "peekpriority" \ + ] + + variable sortopt [list \ + "-integer" \ + "-real" \ + "-ascii" \ + "-dictionary" \ + ] + + # this is a simple design decision, that integer and real + # are sorted decreasing (-1), and -ascii and -dictionary are sorted -increasing (1) + # the values here map to the sortopt list + # could be changed to something configurable. + variable sortdir [list \ + "-1" \ + "-1" \ + "1" \ + "1" \ + ] + + + + # 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 [linsert $args 0 ::struct::prioqueue::_$cmd $name]] +} + +# ::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 + } + } + + # sort by priorities + set opt [lindex $sortopt $queues_sorting($name)] + set dir [lindex $sortdir $queues_sorting($name)] + + # add only if check has passed + foreach {item prio} $args { + set new [list $prio $item] + set queues($name) [__linsertsorted [K $queues($name) [set queues($name) ""]] $new $opt $dir] + } + return +} + +# ::struct::prioqueue::_remove -- +# +# Delete an item together with it's related priority value from the queue. +# +# Arguments: +# name name of the queue object +# item item to be removed +# +# Results: +# None. + +if {[package vcompare [package present Tcl] 8.5] < 0} { + # 8.4-: We have -index option for lsearch, so we use glob to allow + # us to create a pattern which can ignore the priority value. We + # quote everything in the item to prevent it from being + # glob-matched, exact matching is required. + + proc ::struct::prioqueue::_remove {name item} { + variable queues + set queuelist $queues($name) + set itemrep "* \\[join [split $item {}] "\\"]" + set foundat [lsearch -glob $queuelist $itemrep] + + # the item to remove was not found if foundat remains at -1, + # nothing to replace then + if {$foundat < 0} return + set queues($name) [lreplace $queuelist $foundat $foundat] + return + } +} else { + # 8.5+: We have the -index option, allowing us to exactly address + # the column used to search. + + proc ::struct::prioqueue::_remove {name item} { + variable queues + set queuelist $queues($name) + set foundat [lsearch -index 1 -exact $queuelist $item] + + # the item to remove was not found if foundat remains at -1, + # nothing to replace then + if {$foundat < 0} return + set queues($name) [lreplace $queuelist $foundat $foundat] + 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)] +} + +# ::struct::prioqueue::__linsertsorted +# +# Helper proc for inserting into a sorted list. +# +# + +proc ::struct::prioqueue::__linsertsorted {list newElement sortopt sortdir} { + + set cmpcmd __elementcompare${sortopt} + set pos -1 + set newPrio [lindex $newElement 0] + + # do a binary search + set lower -1 + set upper [llength $list] + set bound [expr {$upper+1}] + set pivot 0 + + if {$upper > 0} { + while {$lower +1 != $upper } { + + # get the pivot element + set pivot [expr {($lower + $upper) / 2}] + set element [lindex $list $pivot] + set prio [lindex $element 0] + + # check + set test [$cmpcmd $prio $newPrio $sortdir] + if {$test == 0} { + set pos $pivot + set upper $pivot + # now break as we need the last item + break + } elseif {$test > 0 } { + # search lower section + set upper $pivot + set bound $upper + set pos -1 + } else { + # search upper section + set lower $pivot + set pos $bound + } + } + + + if {$pos == -1} { + # we do an insert before the pivot element + set pos $pivot + } + + # loop to the last matching element to + # keep a stable insertion order + while {[$cmpcmd $prio $newPrio $sortdir]==0} { + incr pos + if {$pos > [llength $list]} {break} + set element [lindex $list $pos] + set prio [lindex $element 0] + } + + } else { + set pos 0 + } + + # do the insert without copying + linsert [K $list [set list ""]] $pos $newElement +} + +# ::struct::prioqueue::__elementcompare +# +# Compare helpers with the sort options. +# +# + +proc ::struct::prioqueue::__elementcompare-integer {prio newPrio sortdir} { + return [expr {$prio < $newPrio ? -1*$sortdir : ($prio != $newPrio)*$sortdir}] +} + +proc ::struct::prioqueue::__elementcompare-real {prio newPrio sortdir} { + return [expr {$prio < $newPrio ? -1*$sortdir : ($prio != $newPrio)*$sortdir}] +} + +proc ::struct::prioqueue::__elementcompare-ascii {prio newPrio sortdir} { + return [expr {[string compare $prio $newPrio]*$sortdir}] +} + +proc ::struct::prioqueue::__elementcompare-dictionary {prio newPrio sortdir} { + # need to use lsort to access -dictionary sorting + set tlist [lsort -increasing -dictionary [list $prio $newPrio]] + set e1 [string equal [lindex $tlist 0] $prio] + set e2 [string equal [lindex $tlist 1] $prio] + return [expr {$e1 > $e2 ? -1*$sortdir : ($e1 != $e2)*$sortdir}] +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'prioqueue::prioqueue' into the general structure namespace. + namespace import -force prioqueue::prioqueue + namespace export prioqueue +} + +package provide struct::prioqueue 1.4 diff --git a/src/bootsupport/lib/struct/queue.tcl b/src/bootsupport/lib/struct/queue.tcl new file mode 100644 index 00000000..7f5dcd91 --- /dev/null +++ b/src/bootsupport/lib/struct/queue.tcl @@ -0,0 +1,187 @@ +# queue.tcl -- +# +# Implementation of a queue data structure for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2008 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: queue.tcl,v 1.16 2012/11/21 22:36:18 andreas_kupries Exp $ + +# @mdgen EXCLUDE: queue_c.tcl + +package require Tcl 8.4 +namespace eval ::struct::queue {} + +# ### ### ### ######### ######### ######### +## Management of queue implementations. + +# ::struct::queue::LoadAccelerator -- +# +# Loads a named implementation, if possible. +# +# Arguments: +# key Name of the implementation to load. +# +# Results: +# A boolean flag. True if the implementation +# was successfully loaded; and False otherwise. + +proc ::struct::queue::LoadAccelerator {key} { + variable accel + set r 0 + switch -exact -- $key { + critcl { + # Critcl implementation of queue requires Tcl 8.4. + if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} + if {[catch {package require tcllibc}]} {return 0} + set r [llength [info commands ::struct::queue_critcl]] + } + tcl { + variable selfdir + if { + [package vsatisfies [package provide Tcl] 8.5] && + ![catch {package require TclOO 0.6.1-}] + } { + source [file join $selfdir queue_oo.tcl] + } else { + source [file join $selfdir queue_tcl.tcl] + } + set r 1 + } + default { + return -code error "invalid accelerator/impl. package $key:\ + must be one of [join [KnownImplementations] {, }]" + } + } + set accel($key) $r + return $r +} + +# ::struct::queue::SwitchTo -- +# +# Activates a loaded named implementation. +# +# Arguments: +# key Name of the implementation to activate. +# +# Results: +# None. + +proc ::struct::queue::SwitchTo {key} { + variable accel + variable loaded + + if {[string equal $key $loaded]} { + # No change, nothing to do. + return + } elseif {![string equal $key ""]} { + # Validate the target implementation of the switch. + + if {![info exists accel($key)]} { + return -code error "Unable to activate unknown implementation \"$key\"" + } elseif {![info exists accel($key)] || !$accel($key)} { + return -code error "Unable to activate missing implementation \"$key\"" + } + } + + # Deactivate the previous implementation, if there was any. + + if {![string equal $loaded ""]} { + rename ::struct::queue ::struct::queue_$loaded + } + + # Activate the new implementation, if there is any. + + if {![string equal $key ""]} { + rename ::struct::queue_$key ::struct::queue + } + + # Remember the active implementation, for deactivation by future + # switches. + + set loaded $key + return +} + +# ::struct::queue::Implementations -- +# +# Determines which implementations are +# present, i.e. loaded. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. + +proc ::struct::queue::Implementations {} { + variable accel + set res {} + foreach n [array names accel] { + if {!$accel($n)} continue + lappend res $n + } + return $res +} + +# ::struct::queue::KnownImplementations -- +# +# Determines which implementations are known +# as possible implementations. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. In the order +# of preference, most prefered first. + +proc ::struct::queue::KnownImplementations {} { + return {critcl tcl} +} + +proc ::struct::queue::Names {} { + return { + critcl {tcllibc based} + tcl {pure Tcl} + } +} + +# ### ### ### ######### ######### ######### +## Initialization: Data structures. + +namespace eval ::struct::queue { + variable selfdir [file dirname [info script]] + variable accel + array set accel {tcl 0 critcl 0} + variable loaded {} +} + +# ### ### ### ######### ######### ######### +## Initialization: Choose an implementation, +## most prefered first. Loads only one of the +## possible implementations. And activates it. + +namespace eval ::struct::queue { + variable e + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Export the constructor command. + namespace export queue +} + +package provide struct::queue 1.4.5 diff --git a/src/bootsupport/lib/struct/queue_c.tcl b/src/bootsupport/lib/struct/queue_c.tcl new file mode 100644 index 00000000..30b1aec6 --- /dev/null +++ b/src/bootsupport/lib/struct/queue_c.tcl @@ -0,0 +1,151 @@ +# queuec.tcl -- +# +# Implementation of a queue data structure for Tcl. +# This code based on critcl, API compatible to the PTI [x]. +# [x] Pure Tcl Implementation. +# +# Copyright (c) 2008 Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: queue_c.tcl,v 1.2 2011/04/21 17:51:55 andreas_kupries Exp $ + +package require critcl +# @sak notprovided struct_queuec +package provide struct_queuec 1.3.1 +package require Tcl 8.4 + +namespace eval ::struct { + # Supporting code for the main command. + + critcl::cheaders queue/*.h + critcl::csources queue/*.c + + critcl::ccode { + /* -*- c -*- */ + + #include + #include + #include + #include + + /* .................................................. */ + /* Global queue management, per interp + */ + + typedef struct QDg { + long int counter; + char buf [50]; + } QDg; + + static void + QDgrelease (ClientData cd, Tcl_Interp* interp) + { + ckfree((char*) cd); + } + + static CONST char* + QDnewName (Tcl_Interp* interp) + { +#define KEY "tcllib/struct::queue/critcl" + + Tcl_InterpDeleteProc* proc = QDgrelease; + QDg* qdg; + + qdg = Tcl_GetAssocData (interp, KEY, &proc); + if (qdg == NULL) { + qdg = (QDg*) ckalloc (sizeof (QDg)); + qdg->counter = 0; + + Tcl_SetAssocData (interp, KEY, proc, + (ClientData) qdg); + } + + qdg->counter ++; + sprintf (qdg->buf, "queue%ld", qdg->counter); + return qdg->buf; + +#undef KEY + } + + static void + QDdeleteCmd (ClientData clientData) + { + /* Release the whole queue. */ + qu_delete ((Q*) clientData); + } + } + + # Main command, queue creation. + + critcl::ccommand queue_critcl {dummy interp objc objv} { + /* Syntax + * - epsilon |1 + * - name |2 + */ + + CONST char* name; + Q* qd; + Tcl_Obj* fqn; + Tcl_CmdInfo ci; + +#define USAGE "?name?" + + if ((objc != 2) && (objc != 1)) { + Tcl_WrongNumArgs (interp, 1, objv, USAGE); + return TCL_ERROR; + } + + if (objc < 2) { + name = QDnewName (interp); + } else { + name = Tcl_GetString (objv [1]); + } + + if (!Tcl_StringMatch (name, "::*")) { + /* Relative name. Prefix with current namespace */ + + Tcl_Eval (interp, "namespace current"); + fqn = Tcl_GetObjResult (interp); + fqn = Tcl_DuplicateObj (fqn); + Tcl_IncrRefCount (fqn); + + if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { + Tcl_AppendToObj (fqn, "::", -1); + } + Tcl_AppendToObj (fqn, name, -1); + } else { + fqn = Tcl_NewStringObj (name, -1); + Tcl_IncrRefCount (fqn); + } + Tcl_ResetResult (interp); + + if (Tcl_GetCommandInfo (interp, + Tcl_GetString (fqn), + &ci)) { + Tcl_Obj* err; + + err = Tcl_NewObj (); + Tcl_AppendToObj (err, "command \"", -1); + Tcl_AppendObjToObj (err, fqn); + Tcl_AppendToObj (err, "\" already exists, unable to create queue", -1); + + Tcl_DecrRefCount (fqn); + Tcl_SetObjResult (interp, err); + return TCL_ERROR; + } + + qd = qu_new(); + qd->cmd = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn), + qums_objcmd, (ClientData) qd, + QDdeleteCmd); + + Tcl_SetObjResult (interp, fqn); + Tcl_DecrRefCount (fqn); + return TCL_OK; + } +} + +# ### ### ### ######### ######### ######### +## Ready diff --git a/src/bootsupport/lib/struct/queue_oo.tcl b/src/bootsupport/lib/struct/queue_oo.tcl new file mode 100644 index 00000000..e6e1fe73 --- /dev/null +++ b/src/bootsupport/lib/struct/queue_oo.tcl @@ -0,0 +1,228 @@ +# queue.tcl -- +# +# Queue implementation for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2008-2010 Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: queue_oo.tcl,v 1.2 2010/09/10 17:31:04 andreas_kupries Exp $ + +package require Tcl 8.5 +package require TclOO 0.6.1- ; # This includes 1 and higher. + +# Cleanup first +catch {namespace delete ::struct::queue::queue_oo} +catch {rename ::struct::queue::queue_oo {}} +oo::class create ::struct::queue::queue_oo { + + variable qat qret qadd + + # variable qat - Index in qret of next element to return + # variable qret - List of elements waiting for return + # variable qadd - List of elements added and not yet reached for return. + + constructor {} { + set qat 0 + set qret [list] + set qadd [list] + return + } + + # clear -- + # + # Clear a queue. + # + # Results: + # None. + + method clear {} { + set qat 0 + set qret [list] + set qadd [list] + return + } + + # get -- + # + # Get an item from a queue. + # + # Arguments: + # 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. + + method get {{count 1}} { + if { $count < 1 } { + return -code error "invalid item count $count" + } elseif { $count > [my size] } { + return -code error "insufficient items in queue to fill request" + } + + my Shift? + + if { $count == 1 } { + # Handle this as a special case, so single item gets aren't + # listified + + set item [lindex $qret $qat] + incr qat + my Shift? + return $item + } + + # Otherwise, return a list of items + + if {$count > ([llength $qret] - $qat)} { + # Need all of qret (from qat on) and parts of qadd, maybe all. + set max [expr {$qat + $count - 1 - [llength $qret]}] + set result [concat [lrange $qret $qat end] [lrange $qadd 0 $max]] + my Shift + set qat $max + } else { + # Request can be satisified from qret alone. + set max [expr {$qat + $count - 1}] + set result [lrange $qret $qat $max] + set qat $max + } + + incr qat + my Shift? + return $result + } + + # peek -- + # + # Retrieve the value of an item on the queue without removing it. + # + # Arguments: + # count number of items to peek; defaults to 1 + # + # Results: + # items top count items from the queue; if there are not enough items + # to fulfill the request, throws an error. + + method peek {{count 1}} { + variable queues + if { $count < 1 } { + return -code error "invalid item count $count" + } elseif { $count > [my size] } { + return -code error "insufficient items in queue to fill request" + } + + my Shift? + + if { $count == 1 } { + # Handle this as a special case, so single item pops aren't + # listified + return [lindex $qret $qat] + } + + # Otherwise, return a list of items + + if {$count > [llength $qret] - $qat} { + # Need all of qret (from qat on) and parts of qadd, maybe all. + set over [expr {$qat + $count - 1 - [llength $qret]}] + return [concat [lrange $qret $qat end] [lrange $qadd 0 $over]] + } else { + # Request can be satisified from qret alone. + return [lrange $qret $qat [expr {$qat + $count - 1}]] + } + } + + # put -- + # + # Put an item into a queue. + # + # Arguments: + # args items to put. + # + # Results: + # None. + + method put {args} { + if {![llength $args]} { + return -code error "wrong # args: should be \"[self] put item ?item ...?\"" + } + foreach item $args { + lappend qadd $item + } + return + } + + # unget -- + # + # Put an item into a queue. At the _front_! + # + # Arguments: + # item item to put at the front of the queue + # + # Results: + # None. + + method unget {item} { + if {![llength $qret]} { + set qret [list $item] + } elseif {$qat == 0} { + set qret [linsert [my K $qret [unset qret]] 0 $item] + } else { + # step back and modify return buffer + incr qat -1 + set qret [lreplace [my K $qret [unset qret]] $qat $qat $item] + } + return + } + + # size -- + # + # Return the number of objects on a queue. + # + # Results: + # count number of items on the queue. + + method size {} { + return [expr { + [llength $qret] + [llength $qadd] - $qat + }] + } + + # ### ### ### ######### ######### ######### + + method Shift? {} { + if {$qat < [llength $qret]} return + # inlined Shift + set qat 0 + set qret $qadd + set qadd [list] + return + } + + method Shift {} { + set qat 0 + set qret $qadd + set qadd [list] + return + } + + method K {x y} { set x } +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'queue::queue' into the general structure namespace for + # pickup by the main management. + + proc queue_tcl {args} { + if {[llength $args]} { + uplevel 1 [::list ::struct::queue::queue_oo create {*}$args] + } else { + uplevel 1 [::list ::struct::queue::queue_oo new] + } + } +} diff --git a/src/bootsupport/lib/struct/queue_tcl.tcl b/src/bootsupport/lib/struct/queue_tcl.tcl new file mode 100644 index 00000000..78f93bd5 --- /dev/null +++ b/src/bootsupport/lib/struct/queue_tcl.tcl @@ -0,0 +1,383 @@ +# queue.tcl -- +# +# Queue implementation for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2008-2010 Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: queue_tcl.tcl,v 1.2 2010/03/24 06:13:00 andreas_kupries Exp $ + +namespace eval ::struct::queue { + # counter is used to give a unique name for unnamed queues + variable counter 0 + + # Only export one command, the one used to instantiate a new queue + namespace export queue_tcl +} + +# ::struct::queue::queue_tcl -- +# +# 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_tcl {args} { + variable I::qat + variable I::qret + variable I::qadd + variable counter + + switch -exact -- [llength [info level 0]] { + 1 { + # Missing name, generate one. + incr counter + set name "queue${counter}" + } + 2 { + # Standard call. New empty queue. + set name [lindex $args 0] + } + default { + # Error. + return -code error \ + "wrong # args: should be \"queue ?name?\"" + } + } + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + + set name "$ns$name" + } + if {[llength [info commands $name]]} { + return -code error \ + "command \"$name\" already exists, unable to create queue" + } + + # Initialize the queue as empty + set qat($name) 0 + set qret($name) [list] + set qadd($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 + +if {[package vsatisfies [package provide Tcl] 8.5]} { + # In 8.5+ we can do an ensemble for fast dispatch. + + proc ::struct::queue::QueueProc {name cmd args} { + # Shuffle method to front and then simply run the ensemble. + # Dispatch, argument checking, and error message generation + # are all done in the C-level. + + I $cmd $name {*}$args + } + + namespace eval ::struct::queue::I { + namespace export clear destroy get peek \ + put unget size + namespace ensemble create + } + +} else { + # Before 8.5 we have to code our own dispatch, including error + # checking. + + proc ::struct::queue::QueueProc {name cmd args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + if { [llength [info commands ::struct::queue::I::$cmd]] == 0 } { + set optlist [lsort [info commands ::struct::queue::I::*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + if {($p eq "K") || ($p eq "Shift") || ($p eq "Shift?")} continue + lappend xlist $p + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + + uplevel 1 [linsert $args 0 ::struct::queue::I::$cmd $name] + } +} + +namespace eval ::struct::queue::I { + # The arrays hold all of the queues which were made. + variable qat ; # Index in qret of next element to return + variable qret ; # List of elements waiting for return + variable qadd ; # List of elements added and not yet reached for return. +} + +# ::struct::queue::I::clear -- +# +# Clear a queue. +# +# Arguments: +# name name of the queue object. +# +# Results: +# None. + +proc ::struct::queue::I::clear {name} { + variable qat + variable qret + variable qadd + set qat($name) 0 + set qret($name) [list] + set qadd($name) [list] + return +} + +# ::struct::queue::I::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::I::destroy {name} { + variable qat ; unset qat($name) + variable qret ; unset qret($name) + variable qadd ; unset qadd($name) + interp alias {} $name {} + return +} + +# ::struct::queue::I::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::I::get {name {count 1}} { + if { $count < 1 } { + error "invalid item count $count" + } elseif { $count > [size $name] } { + error "insufficient items in queue to fill request" + } + + Shift? $name + + variable qat ; upvar 0 qat($name) AT + variable qret ; upvar 0 qret($name) RET + variable qadd ; upvar 0 qadd($name) ADD + + if { $count == 1 } { + # Handle this as a special case, so single item gets aren't + # listified + + set item [lindex $RET $AT] + incr AT + Shift? $name + return $item + } + + # Otherwise, return a list of items + + if {$count > ([llength $RET] - $AT)} { + # Need all of RET (from AT on) and parts of ADD, maybe all. + set max [expr {$count - ([llength $RET] - $AT) - 1}] + set result [concat [lrange $RET $AT end] [lrange $ADD 0 $max]] + Shift $name + set AT $max + } else { + # Request can be satisified from RET alone. + set max [expr {$AT + $count - 1}] + set result [lrange $RET $AT $max] + set AT $max + } + + incr AT + Shift? $name + return $result +} + +# ::struct::queue::I::peek -- +# +# Retrieve 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 fulfill the request, throws an error. + +proc ::struct::queue::I::peek {name {count 1}} { + variable queues + if { $count < 1 } { + error "invalid item count $count" + } elseif { $count > [size $name] } { + error "insufficient items in queue to fill request" + } + + Shift? $name + + variable qat ; upvar 0 qat($name) AT + variable qret ; upvar 0 qret($name) RET + variable qadd ; upvar 0 qadd($name) ADD + + if { $count == 1 } { + # Handle this as a special case, so single item pops aren't + # listified + return [lindex $RET $AT] + } + + # Otherwise, return a list of items + + if {$count > [llength $RET] - $AT} { + # Need all of RET (from AT on) and parts of ADD, maybe all. + set over [expr {$count - ([llength $RET] - $AT) - 1}] + return [concat [lrange $RET $AT end] [lrange $ADD 0 $over]] + } else { + # Request can be satisified from RET alone. + return [lrange $RET $AT [expr {$AT + $count - 1}]] + } +} + +# ::struct::queue::I::put -- +# +# Put an item into a queue. +# +# Arguments: +# name name of the queue object +# args items to put. +# +# Results: +# None. + +proc ::struct::queue::I::put {name args} { + variable qadd + if { [llength $args] == 0 } { + error "wrong # args: should be \"$name put item ?item ...?\"" + } + foreach item $args { + lappend qadd($name) $item + } + return +} + +# ::struct::queue::I::unget -- +# +# Put an item into a queue. At the _front_! +# +# Arguments: +# name name of the queue object +# item item to put at the front of the queue +# +# Results: +# None. + +proc ::struct::queue::I::unget {name item} { + variable qat ; upvar 0 qat($name) AT + variable qret ; upvar 0 qret($name) RET + + if {![llength $RET]} { + set RET [list $item] + } elseif {$AT == 0} { + set RET [linsert [K $RET [unset RET]] 0 $item] + } else { + # step back and modify return buffer + incr AT -1 + set RET [lreplace [K $RET [unset RET]] $AT $AT $item] + } + return +} + +# ::struct::queue::I::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::I::size {name} { + variable qat + variable qret + variable qadd + return [expr { + [llength $qret($name)] + [llength $qadd($name)] - $qat($name) + }] +} + +# ### ### ### ######### ######### ######### + +proc ::struct::queue::I::Shift? {name} { + variable qat + variable qret + if {$qat($name) < [llength $qret($name)]} return + Shift $name + return +} + +proc ::struct::queue::I::Shift {name} { + variable qat + variable qret + variable qadd + set qat($name) 0 + set qret($name) $qadd($name) + set qadd($name) [list] + return +} + +proc ::struct::queue::I::K {x y} { set x } + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'queue::queue' into the general structure namespace for + # pickup by the main management. + namespace import -force queue::queue_tcl +} + diff --git a/src/bootsupport/lib/struct/record.tcl b/src/bootsupport/lib/struct/record.tcl new file mode 100644 index 00000000..6c58dd78 --- /dev/null +++ b/src/bootsupport/lib/struct/record.tcl @@ -0,0 +1,830 @@ +#============================================================ +# ::struct::record -- +# +# Implements a container data structure similar to a 'C' +# structure. It hides the ugly details about keeping the +# data organized by using a combination of arrays, lists +# and namespaces. +# +# Each record definition is kept in a master array +# (_recorddefn) under the ::struct::record namespace. Each +# instance of a record is kept within a separate namespace +# for each record definition. Hence, instances of +# the same record definition are managed under the +# same namespace. This avoids possible collisions, and +# also limits one big global array mechanism. +# +# Copyright (c) 2002 by Brett Schwarz +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# This code may be distributed under the same terms as Tcl. +# +#============================================================ +# +#### FIX ERROR MESSAGES SO THEY MAKE SENSE (Wrong args) + +namespace eval ::struct {} + +namespace eval ::struct::record { + + ## + ## array of lists that holds the definition (variables) for each + ## record + ## + ## _recorddefn(some_record) var1 var2 var3 ... + ## + variable _recorddefn + + ## + ## holds the count for each record in cases where the instance is + ## automatically generated + ## + ## _count(some_record) 0 + ## + + ## This is not a count, but an id generator. Its value has to + ## increase monotonicaly. + + variable _count + + ## + ## array that holds the defining record's name for each instances + ## + ## _defn(some_instances) name_of_defining_record + ## + variable _defn + array set _defn {} + + ## + ## This holds the defaults for a record definition. If no + ## default is given for a member of a record, then the value is + ## assigned to the empty string + ## + variable _defaults + + ## + ## These are the possible sub commands + ## + variable commands + set commands [list define delete exists show] + + ## + ## This keeps track of the level that we are in when handling + ## nested records. This is kind of a hack, and probably can be + ## handled better + ## + set _level 0 + + namespace export record +} + +#------------------------------------------------------------ +# ::struct::record::record -- +# +# main command used to access the other sub commands +# +# Arguments: +# cmd_ The sub command (i.e. define, show, delete, exists) +# args arguments to pass to the sub command +# +# Results: +# none returned +#------------------------------------------------------------ +# +proc ::struct::record::record {cmd_ args} { + variable commands + + if {[lsearch $commands $cmd_] < 0} { + error "Sub command \"$cmd_\" is not recognized. Must be [join $commands ,]" + } + + set cmd_ [string totitle "$cmd_"] + return [uplevel 1 ::struct::record::${cmd_} $args] + +}; # end proc ::struct::record::record + + +#------------------------------------------------------------ +# ::struct::record::Define -- +# +# Used to define a record +# +# Arguments: +# defn_ the name of the record definition +# vars_ the variables of the record (as a list) +# args instances to be create during definition +# +# Results: +# Returns the name of the definition during successful +# creation. +#------------------------------------------------------------ +# +proc ::struct::record::Define {defn_ vars_ args} { + variable _recorddefn + variable _count + variable _defaults + + # puts .([info level 0])... + + set defn_ [Qualify $defn_] + + if {[info exists _recorddefn($defn_)]} { + error "Record definition $defn_ already exists" + } + + if {[lsearch [info commands] $defn_] >= 0} { + error "Structure definition name can not be a Tcl command name" + } + + set _defaults($defn_) [list] + set _recorddefn($defn_) [list] + + ## + ## Loop through the members of the record + ## definition + ## + foreach V $vars_ { + set len [llength $V] + set D "" + + if {$len == 2} { + ## 2 --> there is a default value + ## assigned to the member + + set D [lindex $V 1] + set V [lindex $V 0] + + } elseif {$len == 3} { + ## 3 --> there is a nested record + ## definition given as a member + ## V = ('record' record-name field-name) + + if {![string match "record" "[lindex $V 0]"]} { + Delete record $defn_ + error "$V is a Bad member for record definition. Definition creation aborted." + } + + set new [lindex $V 1] + set new [Qualify $new] + # puts .\tchild=$new + ## + ## Right now, there can not be circular records + ## so, we abort the creation + ## + if {[string match "$defn_" "$new"]} { + # puts .\tabort + Delete record $defn_ + error "Can not have circular records. Structure was not created." + } + + ## + ## Will take care of the nested record later + ## We just join by :: because this is how it + ## use to be declared, so the parsing code + ## is already there. + ## + set V [join [lrange $V 1 2] "::"] + } + + # puts .\tfield($V)=default($D) + + lappend _recorddefn($defn_) $V + lappend _defaults($defn_) $D + } + + # Create class command as alias to instance creator. + uplevel #0 [list interp alias \ + {} $defn_ \ + {} ::struct::record::Create $defn_] + + set _count($defn_) 0 + + # Create class namespace. This will hold all the instance information. + namespace eval ::struct::record${defn_} { + variable values + variable instances + variable record + + set instances [list] + } + + set ::struct::record${defn_}::record $defn_ + + ## + ## If there were args given (instances), then + ## create them now + ## + foreach A $args { + uplevel 1 [list ::struct::record::Create $defn_ $A] + } + + # puts .=>${defn_} + return $defn_ + +}; # end proc ::struct::record::Define + + +#------------------------------------------------------------ +# ::struct::record::Create -- +# +# Creates an instance of a record definition +# +# Arguments: +# defn_ the name of the record definition +# inst_ the name of the instances to create +# args values to set to the record's members +# +# Results: +# Returns the name of the instance for a successful creation +#------------------------------------------------------------ +# +proc ::struct::record::Create {defn_ inst_ args} { + variable _recorddefn + variable _count + variable _defn + variable _defaults + variable _level + + # puts .([info level 0])... + + set inst_ [Qualify "$inst_"] + + ## + ## test to see if the record + ## definition has been defined yet + ## + if {![info exists _recorddefn($defn_)]} { + error "Structure $defn_ does not exist" + } + + ## + ## if there was no argument given, + ## then assume that the record + ## variable is automatically + ## generated + ## + if {[string match "[Qualify #auto]" "$inst_"]} { + set c $_count($defn_) + set inst_ [format "%s%s" ${defn_} $_count($defn_)] + incr _count($defn_) + } + + ## + ## Test to see if this instance is already + ## created. This avoids any collisions with + ## previously created instances + ## + if {[info exists _defn($inst_)]} { + incr _count($defn_) -1 + error "Instances $inst_ already exists" + } + + set _defn($inst_) $defn_ + + ## + ## Initialize record variables to defaults + ## + + # Create instance command as alias of instance dispatcher. + uplevel #0 [list interp alias {} ${inst_} {} ::struct::record::Cmd $inst_] + + # Locate manager namespace, i.e. class namespace for new instance + set nsi [Ns $inst_] + # puts .\tnsi=$nsi + + # Import the state of the manager namespace + upvar 0 ${nsi}values __values + upvar 0 ${nsi}instances __instances + + set cnt 0 + foreach V $_recorddefn($defn_) D $_defaults($defn_) { + + # puts .\tfield($V)=default($D) + + set __values($inst_,$V) $D + + ## + ## Test to see if there is a nested record + ## + if {[regexp -- {([\w]*)::([\w]*)} $V -> def inst]} { + + if {$_level == 0} { + set _level 2 + } + + ## + ## This is to guard against if the creation had failed, + ## that there isn't any lingering variables/alias around + ## + set def [Qualify $def $_level] + + if {![info exists _recorddefn($def)]} { + Delete inst "$inst_" + return + } + + ## + ## evaluate the nested record. If there were values for + ## the variables passed in, then we assume that the + ## value for this nested record is a list corresponding + ## the the nested list's variables, and so we pass that + ## to the nested record's instantiation. We then get + ## rid of those args for later processing. + ## + set cnt_plus [expr {$cnt + 1}] + set mem [lindex $args $cnt] + if {![string match "" "$mem"]} { + if {![string match "-$inst" "$mem"]} { + Delete inst "$inst_" + error "$inst is not a member of $defn_" + } + } + incr _level + set narg [lindex $args $cnt_plus] + + # Create instance of the nested record. + eval [linsert $narg 0 Create $def ${inst_}.${inst}] + + set args [lreplace $args $cnt $cnt_plus] + + incr _level -1 + } else { + # Regular field, not a nested record. Create alias for + # field access. + uplevel #0 [list interp alias \ + {} ${inst_}.$V \ + {} ::struct::record::Access $defn_ $inst_ $V] + incr cnt 2 + } + }; # end foreach variable + + # Remember new instance. + lappend __instances $inst_ + + # Apply field values handed to the instance constructor. + foreach {k v} $args { + Access $defn_ $inst_ [string trimleft "$k" -] $v + }; # end foreach arg {} + + if {$_level == 2} { + set _level 0 + } + + # puts .=>${inst_} + return $inst_ + +}; # end proc ::struct::record::Create + + +#------------------------------------------------------------ +# ::struct::record::Access -- +# +# Provides a common proc to access the variables +# from the aliases create for each variable in the record +# +# Arguments: +# defn_ the name of the record to access +# inst_ the name of the instance to create +# var_ the variable of the record to access +# args a value to set to var_ (if any) +# +# Results: +# Returns the value of the record member (var_) +#------------------------------------------------------------ +# +proc ::struct::record::Access {defn_ inst_ var_ args} { + + variable _recorddefn + variable _defn + + set i [lsearch $_recorddefn($defn_) $var_] + + if {$i < 0} { + error "$var_ does not exist in record $defn_" + } + + if {![info exists _defn($inst_)]} { + + error "$inst_ does not exist" + } + + if {[set idx [lsearch $args "="]] >= 0} { + set args [lreplace $args $idx $idx] + } + + set nsi [Ns $inst_] + # puts .\tnsi=$nsi + + # Import the state of the manager namespace + upvar 0 ${nsi}values __values + + ## + ## If a value was given, then set it + ## + if {[llength $args] != 0} { + + set val_ [lindex $args 0] + + set __values($inst_,$var_) $val_ + } + + return $__values($inst_,$var_) + +}; # end proc ::struct::record::Access + + +#------------------------------------------------------------ +# ::struct::record::Cmd -- +# +# Used to process the set/get requests. +# +# Arguments: +# inst_ the record instance name +# args For 'get' this is the record members to +# retrieve. For 'set' this is a member/value +# pair. +# +# Results: +# For 'set' returns the empty string. For 'get' it returns +# the member values. +#------------------------------------------------------------ +# +proc ::struct::record::Cmd {inst_ args} { + + variable _defn + + set result [list] + + set len [llength $args] + if {$len <= 1} {return [Show values "$inst_"]} + + set cmd [lindex $args 0] + + if {[string match "cget" "$cmd"]} { + + set cnt 0 + foreach k [lrange $args 1 end] { + if {[catch {set r [${inst_}.[string trimleft ${k} -]]} err]} { + error "Bad option \"$k\"" + } + + lappend result $r + incr cnt + } + if {$cnt == 1} {set result [lindex $result 0]} + return $result + + } elseif {[string match "config*" "$cmd"]} { + + set L [lrange $args 1 end] + foreach {k v} $L { + ${inst_}.[string trimleft ${k} -] $v + } + + } else { + error "Wrong argument. + must be \"object cget|configure args\"" + } + + return [list] + +}; # end proc ::struct::record::Cmd + + +#------------------------------------------------------------ +# ::struct::record::Ns -- +# +# This just constructs a fully qualified namespace for a +# particular instance. +# +# Arguments; +# inst_ instance to construct the namespace for. +# +# Results: +# Returns the fully qualified namespace for the instance +#------------------------------------------------------------ +# +proc ::struct::record::Ns {inst_} { + + variable _defn + + if {[catch {set ret $_defn($inst_)} err]} { + return $inst_ + } + + return [format "%s%s%s" "::struct::record" $ret "::"] + +}; # end proc ::struct::record::Ns + + +#------------------------------------------------------------ +# ::struct::record::Show -- +# +# Display info about the record that exist +# +# Arguments: +# what_ subcommand +# record_ record or instance to process +# +# Results: +# if what_ = record, then return list of records +# definition names. +# if what_ = members, then return list of members +# or members of the record. +# if what_ = instance, then return a list of instances +# with record definition of record_ +# if what_ = values, then it will return the values +# for a particular instance +#------------------------------------------------------------ +# +proc ::struct::record::Show {what_ {record_ ""}} { + variable _recorddefn + variable _defn + variable _defaults + + set record_ [Qualify $record_] + + ## + ## We just prepend :: to the record_ argument + ## + #if {![string match "::*" "$record_"]} {set record_ "::$record_"} + + if {[string match "record*" "$what_"]} { + # Show record + + return [lsort [array names _recorddefn]] + } + + if {[string match "mem*" "$what_"]} { + # Show members + + if {[string match "" "$record_"] || ![info exists _recorddefn($record_)]} { + error "Bad arguments while accessing members. Bad record name" + } + + set res [list] + set cnt 0 + foreach m $_recorddefn($record_) { + set def [lindex $_defaults($record_) $cnt] + if {[regexp -- {([\w]+)::([\w]+)} $m m d i]} { + lappend res [list record $d $i] + } elseif {![string match "" "$def"]} { + lappend res [list $m $def] + } else { + lappend res $m + } + + incr cnt + } + + return $res + } + + if {[string match "inst*" "$what_"]} { + # Show instances + + if {![namespace exists ::struct::record${record_}]} { + return [list] + } + + # Import the state of the manager namespace + upvar 0 ::struct::record${record_}::instances __instances + + if {![info exists __instances]} { + return [list] + } + return [lsort $__instances] + + } + + if {[string match "val*" "$what_"]} { + # Show values + + set nsi [Ns $record_] + upvar 0 ${nsi}::instances __instances + upvar 0 ${nsi}::values __values + upvar 0 ${nsi}::record __record + + if {[string match "" "$record_"] || + ([lsearch $__instances $record_] < 0)} { + + error "Wrong arguments to values. Bad instance name" + } + + set ret [list] + foreach k $_recorddefn($__record) { + set v $__values($record_,$k) + + if {[regexp -- {([\w]*)::([\w]*)} $k m def inst]} { + set v [::struct::record::Show values ${record_}.${inst}] + } + + lappend ret -[namespace tail $k] $v + } + return $ret + + } + + # Bogus submethod + return [list] + +}; # end proc ::struct::record::Show + + +#------------------------------------------------------------ +# ::struct::record::Delete -- +# +# Deletes a record instance or a record definition +# +# Arguments: +# sub_ what to delete. Either 'instance' or 'record' +# item_ the specific record instance or definition +# delete. +# +# Returns: +# none +# +#------------------------------------------------------------ +# +proc ::struct::record::Delete {sub_ item_} { + variable _recorddefn + variable _defn + variable _count + variable _defaults + + # puts .([info level 0])... + + set item_ [Qualify $item_] + + switch -- $sub_ { + instance - + instances - + inst { + # puts .instance + # puts .is-instance=[Exists instance $item_] + + if {[Exists instance $item_]} { + + # Locate manager namespace, i.e. class namespace for + # instance to remove + set nsi [Ns $item_] + # puts .\tnsi=$nsi + + # Import the state of the manager namespace + upvar 0 ${nsi}values __values + upvar 0 ${nsi}instances __instances + upvar 0 ${nsi}record __record + # puts .\trecord=$__record + + # Remove instance from state + set i [lsearch $__instances $item_] + set __instances [lreplace $__instances $i $i] + unset _defn($item_) + + # Process instance fields. + + foreach V $_recorddefn($__record) { + # puts .\tfield($V)=/clear + + if {[regexp -- {([\w]*)::([\w]*)} $V m def inst]} { + # Nested record detected. + # Determine associated instance and delete recursively. + Delete inst ${item_}.${inst} + } else { + # Delete field accessor alias + # puts .de-alias\t($item_.$V) + uplevel #0 [list interp alias {} ${item_}.$V {}] + } + + unset __values($item_,$V) + } + + # Auto-generated id numbers increase monotonically. + # Reverting here causes the next auto to fail, claiming + # that the instance exists. + # incr _count($ns) -1 + + } else { + #error "$item_ is not a instance" + } + } + record - + records { + # puts .record + ## + ## Delete the instances for this + ## record + ## + # puts .get-instances + foreach I [Show instance "$item_"] { + catch { + # puts .di/$I + Delete instance "$I" + } + } + + catch { + unset _recorddefn($item_) + unset _defaults($item_) + unset _count($item_) + namespace delete ::struct::record${item_} + } + } + default { + error "Wrong arguments to delete" + } + + }; # end switch + + # Remove alias associated with instance or record (class) + # puts .de-alias\t($item_) + catch { uplevel #0 [list interp alias {} $item_ {}]} + + # puts ./ + return + +}; # end proc ::struct::record::Delete + + +#------------------------------------------------------------ +# ::struct::record::Exists -- +# +# Tests whether a record definition or record +# instance exists. +# +# Arguments: +# sub_ what to test. Either 'instance' or 'record' +# item_ the specific record instance or definition +# that needs to be tested. +# +# Tests to see if a particular instance exists +# +#------------------------------------------------------------ +# +proc ::struct::record::Exists {sub_ item_} { + + # puts .([info level 0])... + + set item_ [Qualify $item_] + + switch -glob -- $sub_ { + inst* { + variable _defn + return [info exists _defn($item_)] + } + record { + variable _recorddefn + return [info exists _recorddefn($item_)] + } + default { + error "Wrong arguments. Must be exists record|instance target" + } + }; # end switch + +}; # end proc ::struct::record::Exists + + +#------------------------------------------------------------ +# ::struct::record::Qualify -- +# +# Contructs the qualified name of the calling scope. This +# defaults to 2 levels since there is an extra proc call in +# between. +# +# Arguments: +# item_ the command that needs to be qualified +# level_ how many levels to go up (default = 2) +# +# Results: +# the item_ passed in fully qualified +# +#------------------------------------------------------------ +# +proc ::struct::record::Qualify {item_ {level_ 2}} { + if {![string match "::*" "$item_"]} { + set ns [uplevel $level_ [list namespace current]] + + if {![string match "::" "$ns"]} { + append ns "::" + } + + set item_ "$ns${item_}" + } + + return "$item_" + +}; # end proc ::struct::record::Qualify + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'record::record' into the general structure namespace. + namespace import -force record::record + namespace export record +} + +package provide struct::record 1.2.2 +return diff --git a/src/bootsupport/lib/struct/sets.tcl b/src/bootsupport/lib/struct/sets.tcl new file mode 100644 index 00000000..88316377 --- /dev/null +++ b/src/bootsupport/lib/struct/sets.tcl @@ -0,0 +1,189 @@ +#---------------------------------------------------------------------- +# +# sets.tcl -- +# +# Definitions for the processing of sets. +# +# Copyright (c) 2004-2008 by Andreas Kupries. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: sets.tcl,v 1.17 2008/03/09 04:24:37 andreas_kupries Exp $ +# +#---------------------------------------------------------------------- + +# @mdgen EXCLUDE: sets_c.tcl + +package require Tcl 8.2 + +namespace eval ::struct::set {} + +# ### ### ### ######### ######### ######### +## Management of set implementations. + +# ::struct::set::LoadAccelerator -- +# +# Loads a named implementation, if possible. +# +# Arguments: +# key Name of the implementation to load. +# +# Results: +# A boolean flag. True if the implementation +# was successfully loaded; and False otherwise. + +proc ::struct::set::LoadAccelerator {key} { + variable accel + set r 0 + switch -exact -- $key { + critcl { + # Critcl implementation of set requires Tcl 8.4. + if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} + if {[catch {package require tcllibc}]} {return 0} + set r [llength [info commands ::struct::set_critcl]] + } + tcl { + variable selfdir + source [file join $selfdir sets_tcl.tcl] + set r 1 + } + default { + return -code error "invalid accelerator/impl. package $key:\ + must be one of [join [KnownImplementations] {, }]" + } + } + set accel($key) $r + return $r +} + +# ::struct::set::SwitchTo -- +# +# Activates a loaded named implementation. +# +# Arguments: +# key Name of the implementation to activate. +# +# Results: +# None. + +proc ::struct::set::SwitchTo {key} { + variable accel + variable loaded + + if {[string equal $key $loaded]} { + # No change, nothing to do. + return + } elseif {![string equal $key ""]} { + # Validate the target implementation of the switch. + + if {![info exists accel($key)]} { + return -code error "Unable to activate unknown implementation \"$key\"" + } elseif {![info exists accel($key)] || !$accel($key)} { + return -code error "Unable to activate missing implementation \"$key\"" + } + } + + # Deactivate the previous implementation, if there was any. + + if {![string equal $loaded ""]} { + rename ::struct::set ::struct::set_$loaded + } + + # Activate the new implementation, if there is any. + + if {![string equal $key ""]} { + rename ::struct::set_$key ::struct::set + } + + # Remember the active implementation, for deactivation by future + # switches. + + set loaded $key + return +} + +proc ::struct::set::Loaded {} { + variable loaded + return $loaded +} + +# ::struct::set::Implementations -- +# +# Determines which implementations are +# present, i.e. loaded. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. + +proc ::struct::set::Implementations {} { + variable accel + set res {} + foreach n [array names accel] { + if {!$accel($n)} continue + lappend res $n + } + return $res +} + +# ::struct::set::KnownImplementations -- +# +# Determines which implementations are known +# as possible implementations. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. In the order +# of preference, most prefered first. + +proc ::struct::set::KnownImplementations {} { + return {critcl tcl} +} + +proc ::struct::set::Names {} { + return { + critcl {tcllibc based} + tcl {pure Tcl} + } +} + +# ### ### ### ######### ######### ######### +## Initialization: Data structures. + +namespace eval ::struct::set { + variable selfdir [file dirname [info script]] + variable accel + array set accel {tcl 0 critcl 0} + variable loaded {} +} + +# ### ### ### ######### ######### ######### +## Initialization: Choose an implementation, +## most prefered first. Loads only one of the +## possible implementations. And activates it. + +namespace eval ::struct::set { + variable e + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Export the constructor command. + namespace export set +} + +package provide struct::set 2.2.3 diff --git a/src/bootsupport/lib/struct/sets_c.tcl b/src/bootsupport/lib/struct/sets_c.tcl new file mode 100644 index 00000000..cd07f925 --- /dev/null +++ b/src/bootsupport/lib/struct/sets_c.tcl @@ -0,0 +1,93 @@ +#---------------------------------------------------------------------- +# +# sets_tcl.tcl -- +# +# Definitions for the processing of sets. C implementation. +# +# Copyright (c) 2007 by Andreas Kupries. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: sets_c.tcl,v 1.3 2008/03/25 07:15:34 andreas_kupries Exp $ +# +#---------------------------------------------------------------------- + +package require critcl +# @sak notprovided struct_setc +package provide struct_setc 2.1.1 +package require Tcl 8.4 + +namespace eval ::struct { + # Supporting code for the main command. + + catch { + #critcl::cheaders -g + #critcl::debug memory symbols + } + + critcl::cheaders sets/*.h + critcl::csources sets/*.c + + critcl::ccode { + /* -*- c -*- */ + + #include + } + + # Main command, set creation. + + critcl::ccommand set_critcl {dummy interp objc objv} { + /* Syntax - dispatcher to the sub commands. + */ + + static CONST char* methods [] = { + "add", "contains", "difference", "empty", + "equal","exclude", "include", "intersect", + "intersect3", "size", "subsetof", "subtract", + "symdiff", "union", + NULL + }; + enum methods { + S_add, S_contains, S_difference, S_empty, + S_equal,S_exclude, S_include, S_intersect, + S_intersect3, S_size, S_subsetof, S_subtract, + S_symdiff, S_union + }; + + int m; + + if (objc < 2) { + Tcl_WrongNumArgs (interp, objc, objv, "cmd ?arg ...?"); + return TCL_ERROR; + } else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option", + 0, &m) != TCL_OK) { + return TCL_ERROR; + } + + /* Dispatch to methods. They check the #args in detail before performing + * the requested functionality + */ + + switch (m) { + case S_add: return sm_ADD (NULL, interp, objc, objv); + case S_contains: return sm_CONTAINS (NULL, interp, objc, objv); + case S_difference: return sm_DIFFERENCE (NULL, interp, objc, objv); + case S_empty: return sm_EMPTY (NULL, interp, objc, objv); + case S_equal: return sm_EQUAL (NULL, interp, objc, objv); + case S_exclude: return sm_EXCLUDE (NULL, interp, objc, objv); + case S_include: return sm_INCLUDE (NULL, interp, objc, objv); + case S_intersect: return sm_INTERSECT (NULL, interp, objc, objv); + case S_intersect3: return sm_INTERSECT3 (NULL, interp, objc, objv); + case S_size: return sm_SIZE (NULL, interp, objc, objv); + case S_subsetof: return sm_SUBSETOF (NULL, interp, objc, objv); + case S_subtract: return sm_SUBTRACT (NULL, interp, objc, objv); + case S_symdiff: return sm_SYMDIFF (NULL, interp, objc, objv); + case S_union: return sm_UNION (NULL, interp, objc, objv); + } + /* Not coming to this place */ + } +} + +# ### ### ### ######### ######### ######### +## Ready diff --git a/src/bootsupport/lib/struct/sets_tcl.tcl b/src/bootsupport/lib/struct/sets_tcl.tcl new file mode 100644 index 00000000..a2e1fde3 --- /dev/null +++ b/src/bootsupport/lib/struct/sets_tcl.tcl @@ -0,0 +1,452 @@ +#---------------------------------------------------------------------- +# +# sets_tcl.tcl -- +# +# Definitions for the processing of sets. +# +# Copyright (c) 2004-2008 by Andreas Kupries. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: sets_tcl.tcl,v 1.4 2008/03/09 04:38:47 andreas_kupries Exp $ +# +#---------------------------------------------------------------------- + +package require Tcl 8.0 + +namespace eval ::struct::set { + # Only export one command, the one used to instantiate a new tree + namespace export set_tcl +} + +########################## +# Public functions + +# ::struct::set::set -- +# +# Command that access all set commands. +# +# Arguments: +# cmd Name of the subcommand to dispatch to. +# args Arguments for the subcommand. +# +# Results: +# Whatever the result of the subcommand is. + +proc ::struct::set::set_tcl {cmd args} { + # Do minimal args checks here + if { [llength [info level 0]] == 1 } { + return -code error "wrong # args: should be \"$cmd ?arg arg ...?\"" + } + ::set sub S_$cmd + if { [llength [info commands ::struct::set::$sub]] == 0 } { + ::set optlist [info commands ::struct::set::S_*] + ::set xlist {} + foreach p $optlist { + lappend xlist [string range $p 17 end] + } + return -code error \ + "bad option \"$cmd\": must be [linsert [join [lsort $xlist] ", "] "end-1" "or"]" + } + return [uplevel 1 [linsert $args 0 ::struct::set::$sub]] +} + +########################## +# Implementations of the functionality. +# + +# ::struct::set::S_empty -- +# +# Determines emptiness of the set +# +# Parameters: +# set -- The set to check for emptiness. +# +# Results: +# A boolean value. True indicates that the set is empty. +# +# Side effects: +# None. +# +# Notes: + +proc ::struct::set::S_empty {set} { + return [expr {[llength $set] == 0}] +} + +# ::struct::set::S_size -- +# +# Computes the cardinality of the set. +# +# Parameters: +# set -- The set to inspect. +# +# Results: +# An integer greater than or equal to zero. +# +# Side effects: +# None. + +proc ::struct::set::S_size {set} { + return [llength [Cleanup $set]] +} + +# ::struct::set::S_contains -- +# +# Determines if the item is in the set. +# +# Parameters: +# set -- The set to inspect. +# item -- The element to look for. +# +# Results: +# A boolean value. True indicates that the element is present. +# +# Side effects: +# None. + +proc ::struct::set::S_contains {set item} { + return [expr {[lsearch -exact $set $item] >= 0}] +} + +# ::struct::set::S_union -- +# +# Computes the union of the arguments. +# +# Parameters: +# args -- List of sets to unify. +# +# Results: +# The union of the arguments. +# +# Side effects: +# None. + +proc ::struct::set::S_union {args} { + switch -exact -- [llength $args] { + 0 {return {}} + 1 {return [lindex $args 0]} + } + foreach setX $args { + foreach x $setX {::set ($x) {}} + } + return [array names {}] +} + + +# ::struct::set::S_intersect -- +# +# Computes the intersection of the arguments. +# +# Parameters: +# args -- List of sets to intersect. +# +# Results: +# The intersection of the arguments +# +# Side effects: +# None. + +proc ::struct::set::S_intersect {args} { + switch -exact -- [llength $args] { + 0 {return {}} + 1 {return [lindex $args 0]} + } + ::set res [lindex $args 0] + foreach set [lrange $args 1 end] { + if {[llength $res] && [llength $set]} { + ::set res [Intersect $res $set] + } else { + # Squash 'res'. Otherwise we get the wrong result if res + # is not empty, but 'set' is. + ::set res {} + break + } + } + return $res +} + +proc ::struct::set::Intersect {A B} { + if {[llength $A] == 0} {return {}} + if {[llength $B] == 0} {return {}} + + # This is slower than local vars, but more robust + if {[llength $B] > [llength $A]} { + ::set res $A + ::set A $B + ::set B $res + } + ::set res {} + foreach x $A {::set ($x) {}} + foreach x $B { + if {[info exists ($x)]} { + lappend res $x + } + } + return $res +} + +# ::struct::set::S_difference -- +# +# Compute difference of two sets. +# +# Parameters: +# A, B -- Sets to compute the difference for. +# +# Results: +# A - B +# +# Side effects: +# None. + +proc ::struct::set::S_difference {A B} { + if {[llength $A] == 0} {return {}} + if {[llength $B] == 0} {return $A} + + array set tmp {} + foreach x $A {::set tmp($x) .} + foreach x $B {catch {unset tmp($x)}} + return [array names tmp] +} + +if {0} { + # Tcllib SF Bug 1002143. We cannot use the implementation below. + # It will treat set elements containing '(' and ')' as array + # elements, and this screws up the storage of elements as the name + # of local vars something fierce. No way around this. Disabling + # this code and always using the other implementation (s.a.) is + # the only possible fix. + + if {[package vcompare [package provide Tcl] 8.4] < 0} { + # Tcl 8.[23]. Use explicit array to perform the operation. + } else { + # Tcl 8.4+, has 'unset -nocomplain' + + proc ::struct::set::S_difference {A B} { + if {[llength $A] == 0} {return {}} + if {[llength $B] == 0} {return $A} + + # Get the variable B out of the way, avoid collisions + # prepare for "pure list optimization" + ::set ::struct::set::tmp [lreplace $B -1 -1 unset -nocomplain] + unset B + + # unset A early: no local variables left + foreach [lindex [list $A [unset A]] 0] {.} {break} + + eval $::struct::set::tmp + return [info locals] + } + } +} + +# ::struct::set::S_symdiff -- +# +# Compute symmetric difference of two sets. +# +# Parameters: +# A, B -- The sets to compute the s.difference for. +# +# Results: +# The symmetric difference of the two input sets. +# +# Side effects: +# None. + +proc ::struct::set::S_symdiff {A B} { + # symdiff == (A-B) + (B-A) == (A+B)-(A*B) + if {[llength $A] == 0} {return $B} + if {[llength $B] == 0} {return $A} + return [S_union \ + [S_difference $A $B] \ + [S_difference $B $A]] +} + +# ::struct::set::S_intersect3 -- +# +# Return intersection and differences for two sets. +# +# Parameters: +# A, B -- The sets to inspect. +# +# Results: +# List containing A*B, A-B, and B-A +# +# Side effects: +# None. + +proc ::struct::set::S_intersect3 {A B} { + return [list \ + [S_intersect $A $B] \ + [S_difference $A $B] \ + [S_difference $B $A]] +} + +# ::struct::set::S_equal -- +# +# Compares two sets for equality. +# +# Parameters: +# a First set to compare. +# b Second set to compare. +# +# Results: +# A boolean. True if the lists are equal. +# +# Side effects: +# None. + +proc ::struct::set::S_equal {A B} { + ::set A [Cleanup $A] + ::set B [Cleanup $B] + + # Equal if of same cardinality and difference is empty. + + if {[::llength $A] != [::llength $B]} {return 0} + return [expr {[llength [S_difference $A $B]] == 0}] +} + + +proc ::struct::set::Cleanup {A} { + # unset A to avoid collisions + if {[llength $A] < 2} {return $A} + # We cannot use variables to avoid an explicit array. The set + # elements may look like namespace vars (i.e. contain ::), and + # such elements break that, cannot be proc-local variables. + array set S {} + foreach item $A {set S($item) .} + return [array names S] +} + +# ::struct::set::S_include -- +# +# Add an element to a set. +# +# Parameters: +# Avar -- Reference to the set variable to extend. +# element -- The item to add to the set. +# +# Results: +# None. +# +# Side effects: +# The set in the variable referenced by Avar is extended +# by the element (if the element was not already present). + +proc ::struct::set::S_include {Avar element} { + # Avar = Avar + {element} + upvar 1 $Avar A + if {![info exists A] || ![S_contains $A $element]} { + lappend A $element + } + return +} + +# ::struct::set::S_exclude -- +# +# Remove an element from a set. +# +# Parameters: +# Avar -- Reference to the set variable to shrink. +# element -- The item to remove from the set. +# +# Results: +# None. +# +# Side effects: +# The set in the variable referenced by Avar is shrunk, +# the element remove (if the element was actually present). + +proc ::struct::set::S_exclude {Avar element} { + # Avar = Avar - {element} + upvar 1 $Avar A + if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} + while {[::set pos [lsearch -exact $A $element]] >= 0} { + ::set A [lreplace [K $A [::set A {}]] $pos $pos] + } + return +} + +# ::struct::set::S_add -- +# +# Add a set to a set. Similar to 'union', but the first argument +# is a variable. +# +# Parameters: +# Avar -- Reference to the set variable to extend. +# B -- The set to add to the set in Avar. +# +# Results: +# None. +# +# Side effects: +# The set in the variable referenced by Avar is extended +# by all the elements in B. + +proc ::struct::set::S_add {Avar B} { + # Avar = Avar + B + upvar 1 $Avar A + if {![info exists A]} {set A {}} + ::set A [S_union [K $A [::set A {}]] $B] + return +} + +# ::struct::set::S_subtract -- +# +# Remove a set from a set. Similar to 'difference', but the first argument +# is a variable. +# +# Parameters: +# Avar -- Reference to the set variable to shrink. +# B -- The set to remove from the set in Avar. +# +# Results: +# None. +# +# Side effects: +# The set in the variable referenced by Avar is shrunk, +# all elements of B are removed. + +proc ::struct::set::S_subtract {Avar B} { + # Avar = Avar - B + upvar 1 $Avar A + if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} + ::set A [S_difference [K $A [::set A {}]] $B] + return +} + +# ::struct::set::S_subsetof -- +# +# A predicate checking if the first set is a subset +# or equal to the second set. +# +# Parameters: +# A -- The possible subset. +# B -- The set to compare to. +# +# Results: +# A boolean value, true if A is subset of or equal to B +# +# Side effects: +# None. + +proc ::struct::set::S_subsetof {A B} { + # A subset|== B <=> (A == A*B) + return [S_equal $A [S_intersect $A $B]] +} + +# ::struct::set::K -- +# Performance helper command. + +proc ::struct::set::K {x y} {::set x} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Put 'set::set' into the general structure namespace + # for pickup by the main management. + + namespace import -force set::set_tcl +} diff --git a/src/bootsupport/lib/struct/skiplist.tcl b/src/bootsupport/lib/struct/skiplist.tcl new file mode 100644 index 00000000..579f0ef3 --- /dev/null +++ b/src/bootsupport/lib/struct/skiplist.tcl @@ -0,0 +1,437 @@ +# skiplist.tcl -- +# +# Implementation of a skiplist data structure for Tcl. +# +# To quote the inventor of skip lists, William Pugh: +# Skip lists are a probabilistic data structure that seem likely +# to supplant balanced trees as the implementation method of +# choice for many applications. Skip list algorithms have the +# same asymptotic expected time bounds as balanced trees and are +# simpler, faster and use less space. +# +# For more details on how skip lists work, see Pugh, William. Skip +# lists: a probabilistic alternative to balanced trees in +# Communications of the ACM, June 1990, 33(6) 668-676. Also, see +# ftp://ftp.cs.umd.edu/pub/skipLists/ +# +# Copyright (c) 2000 by Keith Vetter +# This software is licensed under a BSD license as described in tcl/tk +# license.txt file but with the copyright held by Keith Vetter. +# +# TODO: +# customize key comparison to a user supplied routine + +namespace eval ::struct {} + +namespace eval ::struct::skiplist { + # Data storage in the skiplist module + # ------------------------------- + # + # For each skiplist, we have the following arrays + # state - holds the current level plus some magic constants + # nodes - all the nodes in the skiplist, including a dummy header node + + # counter is used to give a unique name for unnamed skiplists + variable counter 0 + + # Internal constants + variable MAXLEVEL 16 + variable PROB .5 + variable MAXINT [expr {0x7FFFFFFF}] + + # commands is the list of subcommands recognized by the skiplist + variable commands [list \ + "destroy" \ + "delete" \ + "insert" \ + "search" \ + "size" \ + "walk" \ + ] + + # State variables that can be set in the instantiation + variable vars [list maxlevel probability] + + # Only export one command, the one used to instantiate a new skiplist + namespace export skiplist +} + +# ::struct::skiplist::skiplist -- +# +# Create a new skiplist with a given name; if no name is given, use +# skiplistX, where X is a number. +# +# Arguments: +# name name of the skiplist; if null, generate one. +# +# Results: +# name name of the skiplist created + +proc ::struct::skiplist::skiplist {{name ""} args} { + set usage "skiplist name ?-maxlevel ##? ?-probability ##?" + variable counter + + if { [llength [info level 0]] == 1 } { + incr counter + set name "skiplist${counter}" + } + + if { ![string equal [info commands ::$name] ""] } { + error "command \"$name\" already exists, unable to create skiplist" + } + + # Handle the optional arguments + set more_eval "" + for {set i 0} {$i < [llength $args]} {incr i} { + set flag [lindex $args $i] + incr i + if { $i >= [llength $args] } { + error "value for \"$flag\" missing: should be \"$usage\"" + } + set value [lindex $args $i] + switch -glob -- $flag { + "-maxl*" { + set n [catch {set value [expr $value]}] + if {$n || $value <= 0} { + error "value for the maxlevel option must be greater than 0" + } + append more_eval "; set state(maxlevel) $value" + } + "-prob*" { + set n [catch {set value [expr $value]}] + if {$n || $value <= 0 || $value >= 1} { + error "probability must be between 0 and 1" + } + append more_eval "; set state(prob) $value" + } + default { + error "unknown option \"$flag\": should be \"$usage\"" + } + } + } + + # Set up the namespace for this skiplist + namespace eval ::struct::skiplist::skiplist$name { + variable state + variable nodes + + # NB. maxlevel and prob may be overridden by $more_eval at the end + set state(maxlevel) $::struct::skiplist::MAXLEVEL + set state(prob) $::struct::skiplist::PROB + set state(level) 1 + set state(cnt) 0 + set state(size) 0 + + set nodes(nil,key) $::struct::skiplist::MAXINT + set nodes(header,key) "---" + set nodes(header,value) "---" + + for {set i 1} {$i < $state(maxlevel)} {incr i} { + set nodes(header,$i) nil + } + } $more_eval + + # Create the command to manipulate the skiplist + interp alias {} ::$name {} ::struct::skiplist::SkiplistProc $name + + return $name +} + +########################### +# Private functions follow + +# ::struct::skiplist::SkiplistProc -- +# +# Command that processes all skiplist object commands. +# +# Arguments: +# name name of the skiplist object to manipulate. +# args command name and args for the command +# +# Results: +# Varies based on command to perform + +proc ::struct::skiplist::SkiplistProc {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 { [llength [info commands ::struct::skiplist::_$cmd]] == 0 } { + variable commands + set optlist [join $commands ", "] + set optlist [linsert $optlist "end-1" "or"] + error "bad option \"$cmd\": must be $optlist" + } + eval [linsert $args 0 ::struct::skiplist::_$cmd $name] +} + +## ::struct::skiplist::_destroy -- +# +# Destroy a skiplist, including its associated command and data storage. +# +# Arguments: +# name name of the skiplist. +# +# Results: +# None. + +proc ::struct::skiplist::_destroy {name} { + namespace delete ::struct::skiplist::skiplist$name + interp alias {} ::$name {} +} + +# ::struct::skiplist::_search -- +# +# Searches for a key in a skiplist +# +# Arguments: +# name name of the skiplist. +# key key for the node to search for +# +# Results: +# 0 if not found +# [list 1 node_value] if found + +proc ::struct::skiplist::_search {name key} { + upvar ::struct::skiplist::skiplist${name}::state state + upvar ::struct::skiplist::skiplist${name}::nodes nodes + + set x header + for {set i $state(level)} {$i >= 1} {incr i -1} { + while {1} { + set fwd $nodes($x,$i) + if {$nodes($fwd,key) == $::struct::skiplist::MAXINT} break + if {$nodes($fwd,key) >= $key} break + set x $fwd + } + } + set x $nodes($x,1) + if {$nodes($x,key) == $key} { + return [list 1 $nodes($x,value)] + } + return 0 +} + +# ::struct::skiplist::_insert -- +# +# Add a node to a skiplist. +# +# Arguments: +# name name of the skiplist. +# key key for the node to insert +# value value of the node to insert +# +# Results: +# 0 if new node was created +# level if existing node was updated + +proc ::struct::skiplist::_insert {name key value} { + upvar ::struct::skiplist::skiplist${name}::state state + upvar ::struct::skiplist::skiplist${name}::nodes nodes + + set x header + for {set i $state(level)} {$i >= 1} {incr i -1} { + while {1} { + set fwd $nodes($x,$i) + if {$nodes($fwd,key) == $::struct::skiplist::MAXINT} break + if {$nodes($fwd,key) >= $key} break + set x $fwd + } + set update($i) $x + } + set x $nodes($x,1) + + # Does the node already exist? + if {$nodes($x,key) == $key} { + set nodes($x,value) $value + return 0 + } + + # Here to insert item + incr state(size) + set lvl [randomLevel $state(prob) $state(level) $state(maxlevel)] + + # Did the skip list level increase??? + if {$lvl > $state(level)} { + for {set i [expr {$state(level) + 1}]} {$i <= $lvl} {incr i} { + set update($i) header + } + set state(level) $lvl + } + + # Create a unique new node name and fill in the key, value parts + set x [incr state(cnt)] + set nodes($x,key) $key + set nodes($x,value) $value + + for {set i 1} {$i <= $lvl} {incr i} { + set nodes($x,$i) $nodes($update($i),$i) + set nodes($update($i),$i) $x + } + + return $lvl +} + +# ::struct::skiplist::_delete -- +# +# Deletes a node from a skiplist +# +# Arguments: +# name name of the skiplist. +# key key for the node to delete +# +# Results: +# 1 if we deleted a node +# 0 otherwise + +proc ::struct::skiplist::_delete {name key} { + upvar ::struct::skiplist::skiplist${name}::state state + upvar ::struct::skiplist::skiplist${name}::nodes nodes + + set x header + for {set i $state(level)} {$i >= 1} {incr i -1} { + while {1} { + set fwd $nodes($x,$i) + if {$nodes($fwd,key) >= $key} break + set x $fwd + } + set update($i) $x + } + set x $nodes($x,1) + + # Did we find a node to delete? + if {$nodes($x,key) != $key} { + return 0 + } + + # Here when we found a node to delete + incr state(size) -1 + + # Unlink this node from all the linked lists that include to it + for {set i 1} {$i <= $state(level)} {incr i} { + set fwd $nodes($update($i),$i) + if {$nodes($fwd,key) != $key} break + set nodes($update($i),$i) $nodes($x,$i) + } + + # Delete all traces of this node + foreach v [array names nodes($x,*)] { + unset nodes($v) + } + + # Fix up the level in case it went down + while {$state(level) > 1} { + if {! [string equal "nil" $nodes(header,$state(level))]} break + incr state(level) -1 + } + + return 1 +} + +# ::struct::skiplist::_size -- +# +# Returns how many nodes are in the skiplist +# +# Arguments: +# name name of the skiplist. +# +# Results: +# number of nodes in the skiplist + +proc ::struct::skiplist::_size {name} { + upvar ::struct::skiplist::skiplist${name}::state state + + return $state(size) +} + +# ::struct::skiplist::_walk -- +# +# Walks a skiplist performing a specified command on each node. +# Command is executed at the global level with the actual command +# executed is: command key value +# +# Arguments: +# name name of the skiplist. +# cmd command to run on each node +# +# Results: +# none. + +proc ::struct::skiplist::_walk {name cmd} { + upvar ::struct::skiplist::skiplist${name}::nodes nodes + + for {set x $nodes(header,1)} {$x != "nil"} {set x $nodes($x,1)} { + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy $nodes($x,key) $nodes($x,value) + uplevel 2 $cmdcpy + } +} + +# ::struct::skiplist::randomLevel -- +# +# Generates a random level for a new node. We limit it to 1 greater +# than the current level. +# +# Arguments: +# prob probability to use in generating level +# level current biggest level +# maxlevel biggest possible level +# +# Results: +# an integer between 1 and $maxlevel + +proc ::struct::skiplist::randomLevel {prob level maxlevel} { + + set lvl 1 + while {(rand() < $prob) && ($lvl < $maxlevel)} { + incr lvl + } + + if {$lvl > $level} { + set lvl [expr {$level + 1}] + } + + return $lvl +} + +# ::struct::skiplist::_dump -- +# +# Dumps out a skip list. Useful for debugging. +# +# Arguments: +# name name of the skiplist. +# +# Results: +# none. + +proc ::struct::skiplist::_dump {name} { + upvar ::struct::skiplist::skiplist${name}::state state + upvar ::struct::skiplist::skiplist${name}::nodes nodes + + + puts "Current level $state(level)" + puts "Maxlevel: $state(maxlevel)" + puts "Probability: $state(prob)" + puts "" + puts "NODE KEY FORWARD" + for {set x header} {$x != "nil"} {set x $nodes($x,1)} { + puts -nonewline [format "%-6s %3s %4s" $x $nodes($x,key) $nodes($x,1)] + for {set i 2} {[info exists nodes($x,$i)]} {incr i} { + puts -nonewline [format %4s $nodes($x,$i)] + } + puts "" + } +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'skiplist::skiplist' into the general structure namespace. + namespace import -force skiplist::skiplist + namespace export skiplist +} +package provide struct::skiplist 1.3 diff --git a/src/bootsupport/lib/struct/stack.tcl b/src/bootsupport/lib/struct/stack.tcl new file mode 100644 index 00000000..0dcbca2b --- /dev/null +++ b/src/bootsupport/lib/struct/stack.tcl @@ -0,0 +1,187 @@ +# stack.tcl -- +# +# Implementation of a stack data structure for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2008 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: stack.tcl,v 1.20 2012/11/21 22:36:18 andreas_kupries Exp $ + +# @mdgen EXCLUDE: stack_c.tcl + +package require Tcl 8.4 +namespace eval ::struct::stack {} + +# ### ### ### ######### ######### ######### +## Management of stack implementations. + +# ::struct::stack::LoadAccelerator -- +# +# Loads a named implementation, if possible. +# +# Arguments: +# key Name of the implementation to load. +# +# Results: +# A boolean flag. True if the implementation +# was successfully loaded; and False otherwise. + +proc ::struct::stack::LoadAccelerator {key} { + variable accel + set r 0 + switch -exact -- $key { + critcl { + # Critcl implementation of stack requires Tcl 8.4. + if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} + if {[catch {package require tcllibc}]} {return 0} + set r [llength [info commands ::struct::stack_critcl]] + } + tcl { + variable selfdir + if { + [package vsatisfies [package provide Tcl] 8.5] && + ![catch {package require TclOO 0.6.1-} mx] + } { + source [file join $selfdir stack_oo.tcl] + } else { + source [file join $selfdir stack_tcl.tcl] + } + set r 1 + } + default { + return -code error "invalid accelerator/impl. package $key:\ + must be one of [join [KnownImplementations] {, }]" + } + } + set accel($key) $r + return $r +} + +# ::struct::stack::SwitchTo -- +# +# Activates a loaded named implementation. +# +# Arguments: +# key Name of the implementation to activate. +# +# Results: +# None. + +proc ::struct::stack::SwitchTo {key} { + variable accel + variable loaded + + if {[string equal $key $loaded]} { + # No change, nothing to do. + return + } elseif {![string equal $key ""]} { + # Validate the target implementation of the switch. + + if {![info exists accel($key)]} { + return -code error "Unable to activate unknown implementation \"$key\"" + } elseif {![info exists accel($key)] || !$accel($key)} { + return -code error "Unable to activate missing implementation \"$key\"" + } + } + + # Deactivate the previous implementation, if there was any. + + if {![string equal $loaded ""]} { + rename ::struct::stack ::struct::stack_$loaded + } + + # Activate the new implementation, if there is any. + + if {![string equal $key ""]} { + rename ::struct::stack_$key ::struct::stack + } + + # Remember the active implementation, for deactivation by future + # switches. + + set loaded $key + return +} + +# ::struct::stack::Implementations -- +# +# Determines which implementations are +# present, i.e. loaded. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. + +proc ::struct::stack::Implementations {} { + variable accel + set res {} + foreach n [array names accel] { + if {!$accel($n)} continue + lappend res $n + } + return $res +} + +# ::struct::stack::KnownImplementations -- +# +# Determines which implementations are known +# as possible implementations. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. In the order +# of preference, most prefered first. + +proc ::struct::stack::KnownImplementations {} { + return {critcl tcl} +} + +proc ::struct::stack::Names {} { + return { + critcl {tcllibc based} + tcl {pure Tcl} + } +} + +# ### ### ### ######### ######### ######### +## Initialization: Data structures. + +namespace eval ::struct::stack { + variable selfdir [file dirname [info script]] + variable accel + array set accel {tcl 0 critcl 0} + variable loaded {} +} + +# ### ### ### ######### ######### ######### +## Initialization: Choose an implementation, +## most prefered first. Loads only one of the +## possible implementations. And activates it. + +namespace eval ::struct::stack { + variable e + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Export the constructor command. + namespace export stack +} + +package provide struct::stack 1.5.3 diff --git a/src/bootsupport/lib/struct/stack_c.tcl b/src/bootsupport/lib/struct/stack_c.tcl new file mode 100644 index 00000000..8345d80c --- /dev/null +++ b/src/bootsupport/lib/struct/stack_c.tcl @@ -0,0 +1,156 @@ +# stackc.tcl -- +# +# Implementation of a stack data structure for Tcl. +# This code based on critcl, API compatible to the PTI [x]. +# [x] Pure Tcl Implementation. +# +# Copyright (c) 2008 Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: stack_c.tcl,v 1.1 2008/06/19 23:03:35 andreas_kupries Exp $ + +package require critcl +# @sak notprovided struct_stackc +package provide struct_stackc 1.3.1 +package require Tcl 8.4 + +namespace eval ::struct { + # Supporting code for the main command. + + catch { + #critcl::cheaders -g + #critcl::debug memory symbols + } + + critcl::cheaders stack/*.h + critcl::csources stack/*.c + + critcl::ccode { + /* -*- c -*- */ + + #include + #include + #include + #include + + /* .................................................. */ + /* Global stack management, per interp + */ + + typedef struct SDg { + long int counter; + char buf [50]; + } SDg; + + static void + SDgrelease (ClientData cd, Tcl_Interp* interp) + { + ckfree((char*) cd); + } + + static CONST char* + SDnewName (Tcl_Interp* interp) + { +#define KEY "tcllib/struct::stack/critcl" + + Tcl_InterpDeleteProc* proc = SDgrelease; + SDg* sdg; + + sdg = Tcl_GetAssocData (interp, KEY, &proc); + if (sdg == NULL) { + sdg = (SDg*) ckalloc (sizeof (SDg)); + sdg->counter = 0; + + Tcl_SetAssocData (interp, KEY, proc, + (ClientData) sdg); + } + + sdg->counter ++; + sprintf (sdg->buf, "stack%ld", sdg->counter); + return sdg->buf; + +#undef KEY + } + + static void + SDdeleteCmd (ClientData clientData) + { + /* Release the whole stack. */ + st_delete ((S*) clientData); + } + } + + # Main command, stack creation. + + critcl::ccommand stack_critcl {dummy interp objc objv} { + /* Syntax + * - epsilon |1 + * - name |2 + */ + + CONST char* name; + S* sd; + Tcl_Obj* fqn; + Tcl_CmdInfo ci; + +#define USAGE "?name?" + + if ((objc != 2) && (objc != 1)) { + Tcl_WrongNumArgs (interp, 1, objv, USAGE); + return TCL_ERROR; + } + + if (objc < 2) { + name = SDnewName (interp); + } else { + name = Tcl_GetString (objv [1]); + } + + if (!Tcl_StringMatch (name, "::*")) { + /* Relative name. Prefix with current namespace */ + + Tcl_Eval (interp, "namespace current"); + fqn = Tcl_GetObjResult (interp); + fqn = Tcl_DuplicateObj (fqn); + Tcl_IncrRefCount (fqn); + + if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { + Tcl_AppendToObj (fqn, "::", -1); + } + Tcl_AppendToObj (fqn, name, -1); + } else { + fqn = Tcl_NewStringObj (name, -1); + Tcl_IncrRefCount (fqn); + } + Tcl_ResetResult (interp); + + if (Tcl_GetCommandInfo (interp, + Tcl_GetString (fqn), + &ci)) { + Tcl_Obj* err; + + err = Tcl_NewObj (); + Tcl_AppendToObj (err, "command \"", -1); + Tcl_AppendObjToObj (err, fqn); + Tcl_AppendToObj (err, "\" already exists, unable to create stack", -1); + + Tcl_DecrRefCount (fqn); + Tcl_SetObjResult (interp, err); + return TCL_ERROR; + } + + sd = st_new(); + sd->cmd = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn), + stms_objcmd, (ClientData) sd, + SDdeleteCmd); + + Tcl_SetObjResult (interp, fqn); + Tcl_DecrRefCount (fqn); + return TCL_OK; + } +} + +# ### ### ### ######### ######### ######### +## Ready diff --git a/src/bootsupport/lib/struct/stack_oo.tcl b/src/bootsupport/lib/struct/stack_oo.tcl new file mode 100644 index 00000000..f7520c15 --- /dev/null +++ b/src/bootsupport/lib/struct/stack_oo.tcl @@ -0,0 +1,296 @@ +# stack.tcl -- +# +# Stack implementation for Tcl 8.6+, or 8.5 + TclOO +# +# Copyright (c) 2010 Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: stack_oo.tcl,v 1.4 2010/09/10 17:31:04 andreas_kupries Exp $ + +package require Tcl 8.5 +package require TclOO 0.6.1- ; # This includes 1 and higher. + +# Cleanup first +catch {namespace delete ::struct::stack::stack_oo} +catch {rename ::struct::stack::stack_oo {}} + +oo::class create ::struct::stack::stack_oo { + + variable mystack + + constructor {} { + set mystack {} + return + } + + # clear -- + # + # Clear a stack. + # + # Results: + # None. + + method clear {} { + set mystack {} + return + } + + # get -- + # + # Retrieve the whole contents of the stack. + # + # Results: + # items list of all items in the stack. + + method get {} { + return [lreverse $mystack] + } + + method getr {} { + return $mystack + } + + # peek -- + # + # Retrieve the value of an item on the stack without popping it. + # + # Arguments: + # count number of items to pop; defaults to 1 + # + # Results: + # items top count items from the stack; if there are not enough items + # to fulfill the request, throws an error. + + method peek {{count 1}} { + if { $count < 1 } { + return -code error "invalid item count $count" + } elseif { $count > [llength $mystack] } { + return -code error "insufficient items on stack to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item peeks are not + # listified + return [lindex $mystack end] + } + + # Otherwise, return a list of items + incr count -1 + return [lreverse [lrange $mystack end-$count end]] + } + + method peekr {{count 1}} { + if { $count < 1 } { + return -code error "invalid item count $count" + } elseif { $count > [llength $mystack] } { + return -code error "insufficient items on stack to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item peeks are not + # listified + return [lindex $mystack end] + } + + # Otherwise, return a list of items, in reversed order. + incr count -1 + return [lrange $mystack end-$count end] + } + + # trim -- + # + # Pop items off a stack until a maximum size is reached. + # + # Arguments: + # count requested size of the stack. + # + # Results: + # item List of items trimmed, may be empty. + + method trim {newsize} { + if { ![string is integer -strict $newsize]} { + return -code error "expected integer but got \"$newsize\"" + } elseif { $newsize < 0 } { + return -code error "invalid size $newsize" + } elseif { $newsize >= [llength $mystack] } { + # Stack is smaller than requested, do nothing. + return {} + } + + # newsize < [llength $mystack] + # pop '[llength $mystack]' - newsize elements. + + if {!$newsize} { + set result [lreverse [my K $mystack [unset mystack]]] + set mystack {} + } else { + set result [lreverse [lrange $mystack $newsize end]] + set mystack [lreplace [my K $mystack [unset mystack]] $newsize end] + } + + return $result + } + + method trim* {newsize} { + if { ![string is integer -strict $newsize]} { + return -code error "expected integer but got \"$newsize\"" + } elseif { $newsize < 0 } { + return -code error "invalid size $newsize" + } + + if { $newsize >= [llength $mystack] } { + # Stack is smaller than requested, do nothing. + return + } + + # newsize < [llength $mystack] + # pop '[llength $mystack]' - newsize elements. + + # No results, compared to trim. + + if {!$newsize} { + set mystack {} + } else { + set mystack [lreplace [my K $mystack [unset mystack]] $newsize end] + } + + return + } + + # pop -- + # + # Pop an item off a stack. + # + # Arguments: + # 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. + + method pop {{count 1}} { + if { $count < 1 } { + return -code error "invalid item count $count" + } + + set ssize [llength $mystack] + + if { $count > $ssize } { + return -code error "insufficient items on stack to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item pops are not + # listified + set item [lindex $mystack end] + if {$count == $ssize} { + set mystack [list] + } else { + set mystack [lreplace [my K $mystack [unset mystack]] end end] + } + return $item + } + + # Otherwise, return a list of items, and remove the items from the + # stack. + if {$count == $ssize} { + set result [lreverse [my K $mystack [unset mystack]]] + set mystack [list] + } else { + incr count -1 + set result [lreverse [lrange $mystack end-$count end]] + set mystack [lreplace [my K $mystack [unset mystack]] end-$count end] + } + return $result + } + + # push -- + # + # Push an item onto a stack. + # + # Arguments: + # args items to push. + # + # Results: + # None. + + method push {args} { + if {![llength $args]} { + return -code error "wrong # args: should be \"[self] push item ?item ...?\"" + } + + lappend mystack {*}$args + return + } + + # rotate -- + # + # Rotate the top count number of items by step number of steps. + # + # Arguments: + # count number of items to rotate. + # steps number of steps to rotate. + # + # Results: + # None. + + method rotate {count steps} { + set len [llength $mystack] + if { $count > $len } { + return -code 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}] + + if {$steps == 0} return + + for {set i 0} {$i < $steps} {incr i} { + set item [lindex $mystack end] + set mystack [linsert \ + [lreplace \ + [my K $mystack [unset mystack]] \ + end end] $start $item] + } + return + } + + # size -- + # + # Return the number of objects on a stack. + # + # Results: + # count number of items on the stack. + + method size {} { + return [llength $mystack] + } + + # ### ### ### ######### ######### ######### + + method K {x y} { set x } +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'stack::stack' into the general structure namespace for + # pickup by the main management. + + proc stack_tcl {args} { + if {[llength $args]} { + uplevel 1 [::list ::struct::stack::stack_oo create {*}$args] + } else { + uplevel 1 [::list ::struct::stack::stack_oo new] + } + } +} diff --git a/src/bootsupport/lib/struct/stack_tcl.tcl b/src/bootsupport/lib/struct/stack_tcl.tcl new file mode 100644 index 00000000..a11f6355 --- /dev/null +++ b/src/bootsupport/lib/struct/stack_tcl.tcl @@ -0,0 +1,505 @@ +# stack.tcl -- +# +# Stack implementation for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: stack_tcl.tcl,v 1.3 2010/03/15 17:17:38 andreas_kupries Exp $ + +namespace eval ::struct::stack { + # counter is used to give a unique name for unnamed stacks + variable counter 0 + + # Only export one command, the one used to instantiate a new stack + namespace export stack_tcl +} + +# ::struct::stack::stack_tcl -- +# +# 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_tcl {args} { + variable I::stacks + variable counter + + switch -exact -- [llength [info level 0]] { + 1 { + # Missing name, generate one. + incr counter + set name "stack${counter}" + } + 2 { + # Standard call. New empty stack. + set name [lindex $args 0] + } + default { + # Error. + return -code error \ + "wrong # args: should be \"stack ?name?\"" + } + } + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + + set name "$ns$name" + } + if {[llength [info commands $name]]} { + return -code 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 + +if {[package vsatisfies [package provide Tcl] 8.5]} { + # In 8.5+ we can do an ensemble for fast dispatch. + + proc ::struct::stack::StackProc {name cmd args} { + # Shuffle method to front and then simply run the ensemble. + # Dispatch, argument checking, and error message generation + # are all done in the C-level. + + I $cmd $name {*}$args + } + + namespace eval ::struct::stack::I { + namespace export clear destroy get getr peek peekr \ + trim trim* pop push rotate size + namespace ensemble create + } + +} else { + # Before 8.5 we have to code our own dispatch, including error + # checking. + + proc ::struct::stack::StackProc {name cmd args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + if {![llength [info commands ::struct::stack::I::$cmd]]} { + set optlist [lsort [info commands ::struct::stack::I::*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + if {($p eq "K") || ($p eq "lreverse")} continue + lappend xlist $p + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + + uplevel 1 [linsert $args 0 ::struct::stack::I::$cmd $name] + } +} + +# ### ### ### ######### ######### ######### + +namespace eval ::struct::stack::I { + # The stacks array holds all of the stacks you've made + variable stacks +} + +# ### ### ### ######### ######### ######### + +# ::struct::stack::I::clear -- +# +# Clear a stack. +# +# Arguments: +# name name of the stack object. +# +# Results: +# None. + +proc ::struct::stack::I::clear {name} { + variable stacks + set stacks($name) {} + return +} + +# ::struct::stack::I::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::I::destroy {name} { + variable stacks + unset stacks($name) + interp alias {} $name {} + return +} + +# ::struct::stack::I::get -- +# +# Retrieve the whole contents of the stack. +# +# Arguments: +# name name of the stack object. +# +# Results: +# items list of all items in the stack. + +proc ::struct::stack::I::get {name} { + variable stacks + return [lreverse $stacks($name)] +} + +proc ::struct::stack::I::getr {name} { + variable stacks + return $stacks($name) +} + +# ::struct::stack::I::peek -- +# +# Retrieve 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 fulfill the request, throws an error. + +proc ::struct::stack::I::peek {name {count 1}} { + variable stacks + upvar 0 stacks($name) mystack + + if { $count < 1 } { + return -code error "invalid item count $count" + } elseif { $count > [llength $mystack] } { + return -code error "insufficient items on stack to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item peeks are not + # listified + return [lindex $mystack end] + } + + # Otherwise, return a list of items + incr count -1 + return [lreverse [lrange $mystack end-$count end]] +} + +proc ::struct::stack::I::peekr {name {count 1}} { + variable stacks + upvar 0 stacks($name) mystack + + if { $count < 1 } { + return -code error "invalid item count $count" + } elseif { $count > [llength $mystack] } { + return -code error "insufficient items on stack to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item peeks are not + # listified + return [lindex $mystack end] + } + + # Otherwise, return a list of items, in reversed order. + incr count -1 + return [lrange $mystack end-$count end] +} + +# ::struct::stack::I::trim -- +# +# Pop items off a stack until a maximum size is reached. +# +# Arguments: +# name name of the stack object. +# count requested size of the stack. +# +# Results: +# item List of items trimmed, may be empty. + +proc ::struct::stack::I::trim {name newsize} { + variable stacks + upvar 0 stacks($name) mystack + + if { ![string is integer -strict $newsize]} { + return -code error "expected integer but got \"$newsize\"" + } elseif { $newsize < 0 } { + return -code error "invalid size $newsize" + } elseif { $newsize >= [llength $mystack] } { + # Stack is smaller than requested, do nothing. + return {} + } + + # newsize < [llength $mystack] + # pop '[llength $mystack]' - newsize elements. + + if {!$newsize} { + set result [lreverse [K $mystack [unset mystack]]] + set mystack {} + } else { + set result [lreverse [lrange $mystack $newsize end]] + set mystack [lreplace [K $mystack [unset mystack]] $newsize end] + } + + return $result +} + +proc ::struct::stack::I::trim* {name newsize} { + if { ![string is integer -strict $newsize]} { + return -code error "expected integer but got \"$newsize\"" + } elseif { $newsize < 0 } { + return -code error "invalid size $newsize" + } + + variable stacks + upvar 0 stacks($name) mystack + + if { $newsize >= [llength $mystack] } { + # Stack is smaller than requested, do nothing. + return + } + + # newsize < [llength $mystack] + # pop '[llength $mystack]' - newsize elements. + + # No results, compared to trim. + + if {!$newsize} { + set mystack {} + } else { + set mystack [lreplace [K $mystack [unset mystack]] $newsize end] + } + + return +} + +# ::struct::stack::I::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::I::pop {name {count 1}} { + variable stacks + upvar 0 stacks($name) mystack + + if { $count < 1 } { + return -code error "invalid item count $count" + } + set ssize [llength $mystack] + if { $count > $ssize } { + return -code error "insufficient items on stack to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item pops are not + # listified + set item [lindex $mystack end] + if {$count == $ssize} { + set mystack [list] + } else { + set mystack [lreplace [K $mystack [unset mystack]] end end] + } + return $item + } + + # Otherwise, return a list of items, and remove the items from the + # stack. + if {$count == $ssize} { + set result [lreverse [K $mystack [unset mystack]]] + set mystack [list] + } else { + incr count -1 + set result [lreverse [lrange $mystack end-$count end]] + set mystack [lreplace [K $mystack [unset mystack]] end-$count end] + } + return $result + + # ------------------------------------------------------- + + set newsize [expr {[llength $mystack] - $count}] + + if {!$newsize} { + set result [lreverse [K $mystack [unset mystack]]] + set mystack {} + } else { + set result [lreverse [lrange $mystack $newsize end]] + set mystack [lreplace [K $mystack [unset mystack]] $newsize end] + } + + if {$count == 1} { + set result [lindex $result 0] + } + + return $result +} + +# ::struct::stack::I::push -- +# +# Push an item onto a stack. +# +# Arguments: +# name name of the stack object +# args items to push. +# +# Results: +# None. + +if {[package vsatisfies [package provide Tcl] 8.5]} { + + proc ::struct::stack::I::push {name args} { + if {![llength $args]} { + return -code error "wrong # args: should be \"$name push item ?item ...?\"" + } + + variable stacks + upvar 0 stacks($name) mystack + + lappend mystack {*}$args + return + } +} else { + proc ::struct::stack::I::push {name args} { + if {![llength $args]} { + return -code error "wrong # args: should be \"$name push item ?item ...?\"" + } + + variable stacks + upvar 0 stacks($name) mystack + + if {[llength $args] == 1} { + lappend mystack [lindex $args 0] + } else { + eval [linsert $args 0 lappend mystack] + } + return + } +} + +# ::struct::stack::I::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::I::rotate {name count steps} { + variable stacks + upvar 0 stacks($name) mystack + set len [llength $mystack] + if { $count > $len } { + return -code 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}] + + if {$steps == 0} return + + for {set i 0} {$i < $steps} {incr i} { + set item [lindex $mystack end] + set mystack [linsert \ + [lreplace \ + [K $mystack [unset mystack]] \ + end end] $start $item] + } + return +} + +# ::struct::stack::I::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::I::size {name} { + variable stacks + return [llength $stacks($name)] +} + +# ### ### ### ######### ######### ######### + +proc ::struct::stack::I::K {x y} { set x } + +if {![llength [info commands lreverse]]} { + proc ::struct::stack::I::lreverse {x} { + # assert (llength(x) > 1) + set l [llength $x] + if {$l <= 1} { return $x } + set r [list] + while {$l} { lappend r [lindex $x [incr l -1]] } + return $r + } +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'stack::stack' into the general structure namespace for + # pickup by the main management. + namespace import -force stack::stack_tcl +} diff --git a/src/bootsupport/lib/struct/struct.tcl b/src/bootsupport/lib/struct/struct.tcl new file mode 100644 index 00000000..c909472b --- /dev/null +++ b/src/bootsupport/lib/struct/struct.tcl @@ -0,0 +1,18 @@ +package require Tcl 8.2 +package require struct::graph 2.0 +package require struct::queue 1.2.1 +package require struct::stack 1.2.1 +package require struct::tree 2.0 +package require struct::matrix 2.0 +package require struct::pool 1.2.1 +package require struct::record 1.2.1 +package require struct::list 1.4 +package require struct::set 2.1 +package require struct::prioqueue 1.3 +package require struct::skiplist 1.3 + +namespace eval ::struct { + namespace export * +} + +package provide struct 2.1 diff --git a/src/bootsupport/lib/struct/struct1.tcl b/src/bootsupport/lib/struct/struct1.tcl new file mode 100644 index 00000000..7ff3e392 --- /dev/null +++ b/src/bootsupport/lib/struct/struct1.tcl @@ -0,0 +1,17 @@ +package require Tcl 8.2 +package require struct::graph 1.2.1 +package require struct::queue 1.2.1 +package require struct::stack 1.2.1 +package require struct::tree 1.2.1 +package require struct::matrix 1.2.1 +package require struct::pool 1.2.1 +package require struct::record 1.2.1 +package require struct::list 1.4 +package require struct::prioqueue 1.3 +package require struct::skiplist 1.3 + +namespace eval ::struct { + namespace export * +} + +package provide struct 1.4 diff --git a/src/bootsupport/lib/struct/tree.tcl b/src/bootsupport/lib/struct/tree.tcl new file mode 100644 index 00000000..d3430f44 --- /dev/null +++ b/src/bootsupport/lib/struct/tree.tcl @@ -0,0 +1,183 @@ +# tree.tcl -- +# +# Implementation of a tree data structure for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: tree.tcl,v 1.45 2009/06/22 18:21:59 andreas_kupries Exp $ + +# @mdgen EXCLUDE: tree_c.tcl + +package require Tcl 8.2 +package require struct::list + +namespace eval ::struct::tree {} + +# ### ### ### ######### ######### ######### +## Management of tree implementations. + +# ::struct::tree::LoadAccelerator -- +# +# Loads a named implementation, if possible. +# +# Arguments: +# key Name of the implementation to load. +# +# Results: +# A boolean flag. True if the implementation +# was successfully loaded; and False otherwise. + +proc ::struct::tree::LoadAccelerator {key} { + variable accel + set r 0 + switch -exact -- $key { + critcl { + # Critcl implementation of tree requires Tcl 8.4. + if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} + if {[catch {package require tcllibc}]} {return 0} + set r [llength [info commands ::struct::tree_critcl]] + } + tcl { + variable selfdir + source [file join $selfdir tree_tcl.tcl] + set r 1 + } + default { + return -code error "invalid accelerator/impl. package $key:\ + must be one of [join [KnownImplementations] {, }]" + } + } + set accel($key) $r + return $r +} + +# ::struct::tree::SwitchTo -- +# +# Activates a loaded named implementation. +# +# Arguments: +# key Name of the implementation to activate. +# +# Results: +# None. + +proc ::struct::tree::SwitchTo {key} { + variable accel + variable loaded + + if {[string equal $key $loaded]} { + # No change, nothing to do. + return + } elseif {![string equal $key ""]} { + # Validate the target implementation of the switch. + + if {![info exists accel($key)]} { + return -code error "Unable to activate unknown implementation \"$key\"" + } elseif {![info exists accel($key)] || !$accel($key)} { + return -code error "Unable to activate missing implementation \"$key\"" + } + } + + # Deactivate the previous implementation, if there was any. + + if {![string equal $loaded ""]} { + rename ::struct::tree ::struct::tree_$loaded + rename ::struct::tree::prune ::struct::tree::prune_$loaded + } + + # Activate the new implementation, if there is any. + + if {![string equal $key ""]} { + rename ::struct::tree_$key ::struct::tree + rename ::struct::tree::prune_$key ::struct::tree::prune + } + + # Remember the active implementation, for deactivation by future + # switches. + + set loaded $key + return +} + +# ::struct::tree::Implementations -- +# +# Determines which implementations are +# present, i.e. loaded. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. + +proc ::struct::tree::Implementations {} { + variable accel + set res {} + foreach n [array names accel] { + if {!$accel($n)} continue + lappend res $n + } + return $res +} + +# ::struct::tree::KnownImplementations -- +# +# Determines which implementations are known +# as possible implementations. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. In the order +# of preference, most prefered first. + +proc ::struct::tree::KnownImplementations {} { + return {critcl tcl} +} + +proc ::struct::tree::Names {} { + return { + critcl {tcllibc based} + tcl {pure Tcl} + } +} + +# ### ### ### ######### ######### ######### +## Initialization: Data structures. + +namespace eval ::struct::tree { + variable selfdir [file dirname [info script]] + variable accel + array set accel {tcl 0 critcl 0} + variable loaded {} +} + +# ### ### ### ######### ######### ######### +## Initialization: Choose an implementation, +## most prefered first. Loads only one of the +## possible implementations. And activates it. + +namespace eval ::struct::tree { + variable e + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Export the constructor command. + namespace export tree +} + +package provide struct::tree 2.1.2 diff --git a/src/bootsupport/lib/struct/tree1.tcl b/src/bootsupport/lib/struct/tree1.tcl new file mode 100644 index 00000000..726396e9 --- /dev/null +++ b/src/bootsupport/lib/struct/tree1.tcl @@ -0,0 +1,1485 @@ +# tree.tcl -- +# +# Implementation of a tree data structure for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: tree1.tcl,v 1.5 2005/10/04 17:15:05 andreas_kupries Exp $ + +package require Tcl 8.2 + +namespace eval ::struct {} + +namespace eval ::struct::tree { + # Data storage in the tree module + # ------------------------------- + # + # There's a lot of bits to keep track of for each tree: + # nodes + # node values + # node relationships + # + # It would quickly become unwieldy to try to keep these in arrays or lists + # within the tree namespace itself. Instead, each tree structure will get + # its own namespace. Each namespace contains: + # children array mapping nodes to their children list + # parent array mapping nodes to their parent node + # node:$node array mapping keys to values for the node $node + + # counter is used to give a unique name for unnamed trees + variable counter 0 + + # Only export one command, the one used to instantiate a new tree + namespace export tree +} + +# ::struct::tree::tree -- +# +# Create a new tree with a given name; if no name is given, use +# treeX, where X is a number. +# +# Arguments: +# name Optional name of the tree; if null or not given, generate one. +# +# Results: +# name Name of the tree created + +proc ::struct::tree::tree {{name ""}} { + variable counter + + if {[llength [info level 0]] == 1} { + incr counter + set name "tree${counter}" + } + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 namespace current] + if {"::" != $ns} { + append ns "::" + } + + set name "$ns$name" + } + if {[llength [info commands $name]]} { + return -code error \ + "command \"$name\" already exists, unable to create tree" + } + + # Set up the namespace for the object, + # identical to the object command. + namespace eval $name { + # Set up root node's child list + variable children + set children(root) [list] + + # Set root node's parent + variable parent + set parent(root) [list] + + # Set up the node attribute mapping + variable attribute + array set attribute {} + + # Set up a counter for use in creating unique node names + variable nextUnusedNode + set nextUnusedNode 1 + + # Set up a counter for use in creating node attribute arrays. + variable nextAttr + set nextAttr 0 + } + + # Create the command to manipulate the tree + interp alias {} ::$name {} ::struct::tree::TreeProc $name + + return $name +} + +########################## +# Private functions follow + +# ::struct::tree::TreeProc -- +# +# Command that processes all tree object commands. +# +# Arguments: +# name Name of the tree object to manipulate. +# cmd Subcommand to invoke. +# args Arguments for subcommand. +# +# Results: +# Varies based on command to perform + +proc ::struct::tree::TreeProc {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub _$cmd + if { [llength [info commands ::struct::tree::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::tree::_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 1 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + return [uplevel 1 [linsert $args 0 ::struct::tree::$sub $name]] +} + +# ::struct::tree::_children -- +# +# Return the child list for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# children List of children for the node. + +proc ::struct::tree::_children {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + return $children($node) +} + +# ::struct::tree::_cut -- +# +# Destroys the specified node of a tree, but not its children. +# These children are made into children of the parent of the +# destroyed node at the index of the destroyed node. +# +# Arguments: +# name Name of the tree object. +# node Node to look up and cut. +# +# Results: +# None. + +proc ::struct::tree::_cut {name node} { + if { [string equal $node "root"] } { + # Can't delete the special root node + return -code error "cannot cut root node" + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::parent + variable ${name}::children + + # Locate our parent, children and our location in the parent + set parentNode $parent($node) + set childNodes $children($node) + + set index [lsearch -exact $children($parentNode) $node] + + # Excise this node from the parent list, + set newChildren [lreplace $children($parentNode) $index $index] + + # Put each of the children of $node into the parent's children list, + # in the place of $node, and update the parent pointer of those nodes. + foreach child $childNodes { + set newChildren [linsert $newChildren $index $child] + set parent($child) $parentNode + incr index + } + set children($parentNode) $newChildren + + KillNode $name $node + return +} + +# ::struct::tree::_delete -- +# +# Remove a node from a tree, including all of its values. Recursively +# removes the node's children. +# +# Arguments: +# name Name of the tree. +# node Node to delete. +# +# Results: +# None. + +proc ::struct::tree::_delete {name node} { + if { [string equal $node "root"] } { + # Can't delete the special root node + return -code error "cannot delete root node" + } + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + variable ${name}::parent + + # Remove this node from its parent's children list + set parentNode $parent($node) + set index [lsearch -exact $children($parentNode) $node] + set children($parentNode) [lreplace $children($parentNode) $index $index] + + # Yes, we could use the stack structure implemented in ::struct::stack, + # but it's slower than inlining it. Since we don't need a sophisticated + # stack, don't bother. + set st [list] + foreach child $children($node) { + lappend st $child + } + + KillNode $name $node + + while { [llength $st] > 0 } { + set node [lindex $st end] + set st [lreplace $st end end] + foreach child $children($node) { + lappend st $child + } + + KillNode $name $node + } + return +} + +# ::struct::tree::_depth -- +# +# Return the depth (distance from the root node) of a given node. +# +# Arguments: +# name Name of the tree. +# node Node to find. +# +# Results: +# depth Number of steps from node to the root node. + +proc ::struct::tree::_depth {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + variable ${name}::parent + set depth 0 + while { ![string equal $node "root"] } { + incr depth + set node $parent($node) + } + return $depth +} + +# ::struct::tree::_destroy -- +# +# Destroy a tree, including its associated command and data storage. +# +# Arguments: +# name Name of the tree to destroy. +# +# Results: +# None. + +proc ::struct::tree::_destroy {name} { + namespace delete $name + interp alias {} ::$name {} +} + +# ::struct::tree::_exists -- +# +# Test for existance of a given node in a tree. +# +# Arguments: +# name Name of the tree to query. +# node Node to look for. +# +# Results: +# 1 if the node exists, 0 else. + +proc ::struct::tree::_exists {name node} { + return [info exists ${name}::parent($node)] +} + +# ::struct::tree::_get -- +# +# Get a keyed value from a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# flag Optional flag specifier; if present, must be "-key". +# key Optional key to lookup; defaults to data. +# +# Results: +# value Value associated with the key given. + +proc ::struct::tree::_get {name node {flag -key} {key data}} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # except for the default key 'data'. + + if {[string equal $key data]} { + return "" + } + return -code error "invalid key \"$key\" for node \"$node\"" + } + + upvar ${name}::$attribute($node) data + if {![info exists data($key)]} { + return -code error "invalid key \"$key\" for node \"$node\"" + } + return $data($key) +} + +# ::struct::tree::_getall -- +# +# Get a serialized list of key/value pairs from a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# +# Results: +# value A serialized list of key/value pairs. + +proc ::struct::tree::_getall {name node args} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if {[llength $args]} { + return -code error "wrong # args: should be \"$name getall $node\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # Only default key is present, invisibly. + return {data {}} + } + + upvar ${name}::$attribute($node) data + return [array get data] +} + +# ::struct::tree::_keys -- +# +# Get a list of keys from a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# +# Results: +# value A serialized list of key/value pairs. + +proc ::struct::tree::_keys {name node args} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if {[llength $args]} { + return -code error "wrong # args: should be \"$name keys $node\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # except for the default key 'data'. + return {data} + } + + upvar ${name}::$attribute($node) data + return [array names data] +} + +# ::struct::tree::_keyexists -- +# +# Test for existance of a given key for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# flag Optional flag specifier; if present, must be "-key". +# key Optional key to lookup; defaults to data. +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::tree::_keyexists {name node {flag -key} {key data}} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if {![string equal $flag "-key"]} { + return -code error "invalid option \"$flag\": should be -key" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # except for the default key 'data'. + + return [string equal $key data] + } + + upvar ${name}::$attribute($node) data + return [info exists data($key)] +} + +# ::struct::tree::_index -- +# +# Determine the index of node with in its parent's list of children. +# +# Arguments: +# name Name of the tree. +# node Node to look up. +# +# Results: +# index The index of the node in its parent + +proc ::struct::tree::_index {name node} { + if { [string equal $node "root"] } { + # The special root node has no parent, thus no index in it either. + return -code error "cannot determine index of root node" + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + variable ${name}::parent + + # Locate the parent and ourself in its list of children + set parentNode $parent($node) + + return [lsearch -exact $children($parentNode) $node] +} + +# ::struct::tree::_insert -- +# +# Add a node to a tree; if the node(s) specified already exist, they +# will be moved to the given location. +# +# Arguments: +# name Name of the tree. +# parentNode Parent to add the node to. +# index Index at which to insert. +# args Node(s) to insert. If none is given, the routine +# will insert a single node with a unique name. +# +# Results: +# nodes List of nodes inserted. + +proc ::struct::tree::_insert {name parentNode index args} { + if { [llength $args] == 0 } { + # No node name was given; generate a unique one + set args [list [GenerateUniqueNodeName $name]] + } + if { ![_exists $name $parentNode] } { + return -code error "parent node \"$parentNode\" does not exist in tree \"$name\"" + } + + variable ${name}::parent + variable ${name}::children + + # Make sure the index is numeric + if { ![string is integer $index] } { + # If the index is not numeric, make it numeric by lsearch'ing for + # the value at index, then incrementing index (because "end" means + # just past the end for inserts) + set val [lindex $children($parentNode) $index] + set index [expr {[lsearch -exact $children($parentNode) $val] + 1}] + } + + foreach node $args { + if {[_exists $name $node] } { + # Move the node to its new home + if { [string equal $node "root"] } { + return -code error "cannot move root node" + } + + # Cannot make a node its own descendant (I'm my own grandpaw...) + set ancestor $parentNode + while { ![string equal $ancestor "root"] } { + if { [string equal $ancestor $node] } { + return -code error "node \"$node\" cannot be its own descendant" + } + set ancestor $parent($ancestor) + } + # Remove this node from its parent's children list + set oldParent $parent($node) + set ind [lsearch -exact $children($oldParent) $node] + set children($oldParent) [lreplace $children($oldParent) $ind $ind] + + # If the node is moving within its parent, and its old location + # was before the new location, decrement the new location, so that + # it gets put in the right spot + if { [string equal $oldParent $parentNode] && $ind < $index } { + incr index -1 + } + } else { + # Set up the new node + set children($node) [list] + } + + # Add this node to its parent's children list + set children($parentNode) [linsert $children($parentNode) $index $node] + + # Update the parent pointer for this node + set parent($node) $parentNode + incr index + } + + return $args +} + +# ::struct::tree::_isleaf -- +# +# Return whether the given node of a tree is a leaf or not. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# isleaf True if the node is a leaf; false otherwise. + +proc ::struct::tree::_isleaf {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + return [expr {[llength $children($node)] == 0}] +} + +# ::struct::tree::_move -- +# +# Move a node (and all its subnodes) from where ever it is to a new +# location in the tree. +# +# Arguments: +# name Name of the tree +# parentNode Parent to add the node to. +# index Index at which to insert. +# node Node to move; the node must exist in the tree. +# args Additional nodes to move; these nodes must exist +# in the tree. +# +# Results: +# None. + +proc ::struct::tree::_move {name parentNode index node args} { + set args [linsert $args 0 $node] + + # Can only move a node to a real location in the tree + if { ![_exists $name $parentNode] } { + return -code error "parent node \"$parentNode\" does not exist in tree \"$name\"" + } + + variable ${name}::parent + variable ${name}::children + + # Make sure the index is numeric + if { ![string is integer $index] } { + # If the index is not numeric, make it numeric by lsearch'ing for + # the value at index, then incrementing index (because "end" means + # just past the end for inserts) + set val [lindex $children($parentNode) $index] + set index [expr {[lsearch -exact $children($parentNode) $val] + 1}] + } + + # Validate all nodes to move before trying to move any. + foreach node $args { + if { [string equal $node "root"] } { + return -code error "cannot move root node" + } + + # Can only move real nodes + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Cannot move a node to be a descendant of itself + set ancestor $parentNode + while { ![string equal $ancestor "root"] } { + if { [string equal $ancestor $node] } { + return -code error "node \"$node\" cannot be its own descendant" + } + set ancestor $parent($ancestor) + } + } + + # Remove all nodes from their current parent's children list + foreach node $args { + set oldParent $parent($node) + set ind [lsearch -exact $children($oldParent) $node] + + set children($oldParent) [lreplace $children($oldParent) $ind $ind] + + # Update the nodes parent value + set parent($node) $parentNode + } + + # Add all nodes to their new parent's children list + set children($parentNode) \ + [eval [list linsert $children($parentNode) $index] $args] + + return +} + +# ::struct::tree::_next -- +# +# Return the right sibling for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to retrieve right sibling for. +# +# Results: +# sibling The right sibling for the node, or null if node was +# the rightmost child of its parent. + +proc ::struct::tree::_next {name node} { + # The 'root' has no siblings. + if { [string equal $node "root"] } { + return {} + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Locate the parent and our place in its list of children. + variable ${name}::parent + variable ${name}::children + + set parentNode $parent($node) + set index [lsearch -exact $children($parentNode) $node] + + # Go to the node to the right and return its name. + return [lindex $children($parentNode) [incr index]] +} + +# ::struct::tree::_numchildren -- +# +# Return the number of immediate children for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# numchildren Number of immediate children for the node. + +proc ::struct::tree::_numchildren {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + return [llength $children($node)] +} + +# ::struct::tree::_parent -- +# +# Return the name of the parent node of a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to look up. +# +# Results: +# parent Parent of node $node + +proc ::struct::tree::_parent {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + # FRINK: nocheck + return [set ${name}::parent($node)] +} + +# ::struct::tree::_previous -- +# +# Return the left sibling for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# sibling The left sibling for the node, or null if node was +# the leftmost child of its parent. + +proc ::struct::tree::_previous {name node} { + # The 'root' has no siblings. + if { [string equal $node "root"] } { + return {} + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Locate the parent and our place in its list of children. + variable ${name}::parent + variable ${name}::children + + set parentNode $parent($node) + set index [lsearch -exact $children($parentNode) $node] + + # Go to the node to the right and return its name. + return [lindex $children($parentNode) [incr index -1]] +} + +# ::struct::tree::_serialize -- +# +# Serialize a tree object (partially) into a transportable value. +# +# Arguments: +# name Name of the tree. +# node Root node of the serialized tree. +# +# Results: +# A list structure describing the part of the tree which was serialized. + +proc ::struct::tree::_serialize {name {node root}} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + Serialize $name $node tree attr + return [list $tree [array get attr]] +} + +# ::struct::tree::_set -- +# +# Set or get a value for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to modify or query. +# args Optional arguments specifying a key and a value. Format is +# ?-key key? ?value? +# If no key is specified, the key "data" is used. +# +# Results: +# val Value associated with the given key of the given node + +proc ::struct::tree::_set {name node args} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if {[llength $args] > 3} { + return -code error "wrong # args: should be \"$name set [list $node] ?-key key?\ + ?value?\"" + } + + # Process the arguments ... + + set key "data" + set haveValue 0 + if {[llength $args] > 1} { + foreach {flag key} $args break + if {![string match "${flag}*" "-key"]} { + return -code error "invalid option \"$flag\": should be key" + } + if {[llength $args] == 3} { + set haveValue 1 + set value [lindex $args end] + } + } elseif {[llength $args] == 1} { + set haveValue 1 + set value [lindex $args end] + } + + if {$haveValue} { + # Setting a value. This may have to create + # the attribute array for this particular + # node + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # so create it as we need it. + GenAttributeStorage $name $node + } + upvar ${name}::$attribute($node) data + + return [set data($key) $value] + } else { + # Getting a value + + return [_get $name $node -key $key] + } +} + +# ::struct::tree::_append -- +# +# Append a value for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to modify or query. +# args Optional arguments specifying a key and a value. Format is +# ?-key key? ?value? +# If no key is specified, the key "data" is used. +# +# Results: +# val Value associated with the given key of the given node + +proc ::struct::tree::_append {name node args} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if { + ([llength $args] != 1) && + ([llength $args] != 3) + } { + return -code error "wrong # args: should be \"$name set [list $node] ?-key key?\ + value\"" + } + if {[llength $args] == 3} { + foreach {flag key} $args break + if {![string equal $flag "-key"]} { + return -code error "invalid option \"$flag\": should be -key" + } + } else { + set key "data" + } + + set value [lindex $args end] + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # so create it as we need it. + GenAttributeStorage $name $node + } + upvar ${name}::$attribute($node) data + + return [append data($key) $value] +} + +# ::struct::tree::_lappend -- +# +# lappend a value for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to modify or query. +# args Optional arguments specifying a key and a value. Format is +# ?-key key? ?value? +# If no key is specified, the key "data" is used. +# +# Results: +# val Value associated with the given key of the given node + +proc ::struct::tree::_lappend {name node args} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if { + ([llength $args] != 1) && + ([llength $args] != 3) + } { + return -code error "wrong # args: should be \"$name lappend [list $node] ?-key key?\ + value\"" + } + if {[llength $args] == 3} { + foreach {flag key} $args break + if {![string equal $flag "-key"]} { + return -code error "invalid option \"$flag\": should be -key" + } + } else { + set key "data" + } + + set value [lindex $args end] + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # so create it as we need it. + GenAttributeStorage $name $node + } + upvar ${name}::$attribute($node) data + + return [lappend data($key) $value] +} + +# ::struct::tree::_size -- +# +# Return the number of descendants of a given node. The default node +# is the special root node. +# +# Arguments: +# name Name of the tree. +# node Optional node to start counting from (default is root). +# +# Results: +# size Number of descendants of the node. + +proc ::struct::tree::_size {name {node root}} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # If the node is the root, we can do the cheap thing and just count the + # number of nodes (excluding the root node) that we have in the tree with + # array names + if { [string equal $node "root"] } { + set size [llength [array names ${name}::parent]] + return [expr {$size - 1}] + } + + # Otherwise we have to do it the hard way and do a full tree search + variable ${name}::children + set size 0 + set st [list ] + foreach child $children($node) { + lappend st $child + } + while { [llength $st] > 0 } { + set node [lindex $st end] + set st [lreplace $st end end] + incr size + foreach child $children($node) { + lappend st $child + } + } + return $size +} + +# ::struct::tree::_splice -- +# +# Add a node to a tree, making a range of children from the given +# parent children of the new node. +# +# Arguments: +# name Name of the tree. +# parentNode Parent to add the node to. +# from Index at which to insert. +# to Optional end of the range of children to replace. +# Defaults to 'end'. +# node Optional node name; if given, must be unique. If not +# given, a unique name will be generated. +# +# Results: +# node Name of the node added to the tree. + +proc ::struct::tree::_splice {name parentNode from {to end} args} { + if { [llength $args] == 0 } { + # No node name given; generate a unique node name + set node [GenerateUniqueNodeName $name] + } else { + set node [lindex $args 0] + } + + if { [_exists $name $node] } { + return -code error "node \"$node\" already exists in tree \"$name\"" + } + + variable ${name}::children + variable ${name}::parent + + # Save the list of children that are moving + set moveChildren [lrange $children($parentNode) $from $to] + + # Remove those children from the parent + set children($parentNode) [lreplace $children($parentNode) $from $to] + + # Add the new node + _insert $name $parentNode $from $node + + # Move the children + set children($node) $moveChildren + foreach child $moveChildren { + set parent($child) $node + } + + return $node +} + +# ::struct::tree::_swap -- +# +# Swap two nodes in a tree. +# +# Arguments: +# name Name of the tree. +# node1 First node to swap. +# node2 Second node to swap. +# +# Results: +# None. + +proc ::struct::tree::_swap {name node1 node2} { + # Can't swap the magic root node + if {[string equal $node1 "root"] || [string equal $node2 "root"]} { + return -code error "cannot swap root node" + } + + # Can only swap two real nodes + if {![_exists $name $node1]} { + return -code error "node \"$node1\" does not exist in tree \"$name\"" + } + if {![_exists $name $node2]} { + return -code error "node \"$node2\" does not exist in tree \"$name\"" + } + + # Can't swap a node with itself + if {[string equal $node1 $node2]} { + return -code error "cannot swap node \"$node1\" with itself" + } + + # Swapping nodes means swapping their labels and values + variable ${name}::children + variable ${name}::parent + + set parent1 $parent($node1) + set parent2 $parent($node2) + + # Replace node1 with node2 in node1's parent's children list, and + # node2 with node1 in node2's parent's children list + set i1 [lsearch -exact $children($parent1) $node1] + set i2 [lsearch -exact $children($parent2) $node2] + + set children($parent1) [lreplace $children($parent1) $i1 $i1 $node2] + set children($parent2) [lreplace $children($parent2) $i2 $i2 $node1] + + # Make node1 the parent of node2's children, and vis versa + foreach child $children($node2) { + set parent($child) $node1 + } + foreach child $children($node1) { + set parent($child) $node2 + } + + # Swap the children lists + set children1 $children($node1) + set children($node1) $children($node2) + set children($node2) $children1 + + if { [string equal $node1 $parent2] } { + set parent($node1) $node2 + set parent($node2) $parent1 + } elseif { [string equal $node2 $parent1] } { + set parent($node1) $parent2 + set parent($node2) $node1 + } else { + set parent($node1) $parent2 + set parent($node2) $parent1 + } + + # Swap the values + # More complicated now with the possibility that nodes do not have + # attribute storage associated with them. + + variable ${name}::attribute + + if { + [set ia [info exists attribute($node1)]] || + [set ib [info exists attribute($node2)]] + } { + # At least one of the nodes has attribute data. We simply swap + # the references to the arrays containing them. No need to + # copy the actual data around. + + if {$ia && $ib} { + set tmp $attribute($node1) + set attribute($node1) $attribute($node2) + set attribute($node2) $tmp + } elseif {$ia} { + set attribute($node2) $attribute($node1) + unset attribute($node1) + } elseif {$ib} { + set attribute($node1) $attribute($node2) + unset attribute($node2) + } else { + return -code error "Impossible condition." + } + } ; # else: No attribute storage => Nothing to do {} + + return +} + +# ::struct::tree::_unset -- +# +# Remove a keyed value from a node. +# +# Arguments: +# name Name of the tree. +# node Node to modify. +# args Optional additional args specifying which key to unset; +# if given, must be of the form "-key key". If not given, +# the key "data" is unset. +# +# Results: +# None. + +proc ::struct::tree::_unset {name node {flag -key} {key data}} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if {![string match "${flag}*" "-key"]} { + return -code error "invalid option \"$flag\": should be \"$name unset\ + [list $node] ?-key key?\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # except for the default key 'data'. + GenAttributeStorage $name $node + } + upvar ${name}::$attribute($node) data + + catch {unset data($key)} + return +} + +# ::struct::tree::_walk -- +# +# Walk a tree using a pre-order depth or breadth first +# search. Pre-order DFS is the default. At each node that is visited, +# a command will be called with the name of the tree and the node. +# +# Arguments: +# name Name of the tree. +# node Node at which to start. +# args Optional additional arguments specifying the type and order of +# the tree walk, and the command to execute at each node. +# Format is +# ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd +# +# Results: +# None. + +proc ::struct::tree::_walk {name node args} { + set usage "$name walk $node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd" + + if {[llength $args] > 6 || [llength $args] < 2} { + return -code error "wrong # args: should be \"$usage\"" + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Set defaults + set type dfs + set order pre + set cmd "" + + for {set i 0} {$i < [llength $args]} {incr i} { + set flag [lindex $args $i] + incr i + if { $i >= [llength $args] } { + return -code error "value for \"$flag\" missing: should be \"$usage\"" + } + switch -glob -- $flag { + "-type" { + set type [string tolower [lindex $args $i]] + } + "-order" { + set order [string tolower [lindex $args $i]] + } + "-command" { + set cmd [lindex $args $i] + } + default { + return -code error "unknown option \"$flag\": should be \"$usage\"" + } + } + } + + # Make sure we have a command to run, otherwise what's the point? + if { [string equal $cmd ""] } { + return -code error "no command specified: should be \"$usage\"" + } + + # Validate that the given type is good + switch -exact -- $type { + "dfs" - "bfs" { + set type $type + } + default { + return -code error "invalid search type \"$type\": should be dfs, or bfs" + } + } + + # Validate that the given order is good + switch -exact -- $order { + "pre" - "post" - "in" - "both" { + set order $order + } + default { + return -code error "invalid search order \"$order\":\ + should be pre, post, both, or in" + } + } + + if {[string equal $order "in"] && [string equal $type "bfs"]} { + return -code error "unable to do a ${order}-order breadth first walk" + } + + # Do the walk + variable ${name}::children + set st [list ] + lappend st $node + + # Compute some flags for the possible places of command evaluation + set leave [expr {[string equal $order post] || [string equal $order both]}] + set enter [expr {[string equal $order pre] || [string equal $order both]}] + set touch [string equal $order in] + + if {$leave} { + set lvlabel leave + } elseif {$touch} { + # in-order does not provide a sense + # of nesting for the parent, hence + # no enter/leave, just 'visit'. + set lvlabel visit + } + + if { [string equal $type "dfs"] } { + # Depth-first walk, several orders of visiting nodes + # (pre, post, both, in) + + array set visited {} + + while { [llength $st] > 0 } { + set node [lindex $st end] + + if {[info exists visited($node)]} { + # Second time we are looking at this 'node'. + # Pop it, then evaluate the command (post, both, in). + + set st [lreplace $st end end] + + if {$leave || $touch} { + # Evaluate the command at this node + WalkCall $name $node $lvlabel $cmd + } + } else { + # First visit of this 'node'. + # Do *not* pop it from the stack so that we are able + # to visit again after its children + + # Remember it. + set visited($node) . + + if {$enter} { + # Evaluate the command at this node (pre, both) + WalkCall $name $node "enter" $cmd + } + + # Add the children of this node to the stack. + # The exact behaviour depends on the chosen + # order. For pre, post, both-order we just + # have to add them in reverse-order so that + # they will be popped left-to-right. For in-order + # we have rearrange the stack so that the parent + # is revisited immediately after the first child. + # (but only if there is ore than one child,) + + set clist $children($node) + set len [llength $clist] + + if {$touch && ($len > 1)} { + # Pop node from stack, insert into list of children + set st [lreplace $st end end] + set clist [linsert $clist 1 $node] + incr len + } + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + lappend st [lindex $clist $i] + } + } + } + } else { + # Breadth first walk (pre, post, both) + # No in-order possible. Already captured. + + if {$leave} { + set backward $st + } + + while { [llength $st] > 0 } { + set node [lindex $st 0] + set st [lreplace $st 0 0] + + if {$enter} { + # Evaluate the command at this node + WalkCall $name $node "enter" $cmd + } + + # Add this node's children + # And create a mirrored version in case of post/both order. + + foreach child $children($node) { + lappend st $child + if {$leave} { + set backward [linsert $backward 0 $child] + } + } + } + + if {$leave} { + foreach node $backward { + # Evaluate the command at this node + WalkCall $name $node "leave" $cmd + } + } + } + return +} + +# ::struct::tree::WalkCall -- +# +# Helper command to 'walk' handling the evaluation +# of the user-specified command. Information about +# the tree, node and current action are substituted +# into the command before it evaluation. +# +# Arguments: +# tree Tree we are walking +# node Node we are at. +# action The current action. +# cmd The command to call, already partially substituted. +# +# Results: +# None. + +proc ::struct::tree::WalkCall {tree node action cmd} { + set subs [list %n [list $node] %a [list $action] %t [list $tree] %% %] + uplevel 2 [string map $subs $cmd] + return +} + +# ::struct::tree::GenerateUniqueNodeName -- +# +# Generate a unique node name for the given tree. +# +# Arguments: +# name Name of the tree to generate a unique node name for. +# +# Results: +# node Name of a node guaranteed to not exist in the tree. + +proc ::struct::tree::GenerateUniqueNodeName {name} { + variable ${name}::nextUnusedNode + while {[_exists $name "node${nextUnusedNode}"]} { + incr nextUnusedNode + } + return "node${nextUnusedNode}" +} + +# ::struct::tree::KillNode -- +# +# Delete all data of a node. +# +# Arguments: +# name Name of the tree containing the node +# node Name of the node to delete. +# +# Results: +# none + +proc ::struct::tree::KillNode {name node} { + variable ${name}::parent + variable ${name}::children + variable ${name}::attribute + + # Remove all record of $node + unset parent($node) + unset children($node) + + if {[info exists attribute($node)]} { + # FRINK: nocheck + unset ${name}::$attribute($node) + unset attribute($node) + } + return +} + +# ::struct::tree::GenAttributeStorage -- +# +# Create an array to store the attrributes of a node in. +# +# Arguments: +# name Name of the tree containing the node +# node Name of the node which got attributes. +# +# Results: +# none + +proc ::struct::tree::GenAttributeStorage {name node} { + variable ${name}::nextAttr + variable ${name}::attribute + + set attr "a[incr nextAttr]" + set attribute($node) $attr + upvar ${name}::$attr data + set data(data) "" + return +} + +# ::struct::tree::Serialize -- +# +# Serialize a tree object (partially) into a transportable value. +# +# Arguments: +# name Name of the tree. +# node Root node of the serialized tree. +# +# Results: +# None + +proc ::struct::tree::Serialize {name node tvar avar} { + upvar 1 $tvar tree $avar attr + + variable ${name}::children + variable ${name}::attribute + + # Store attribute data + if {[info exists attribute($node)]} { + set attr($node) [array get ${name}::$attribute($node)] + } else { + set attr($node) {} + } + + # Build tree structure as nested list. + + set subtrees [list] + foreach c $children($node) { + Serialize $name $c sub attr + lappend subtrees $sub + } + + set tree [list $node $subtrees] + return +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'tree::tree' into the general structure namespace. + namespace import -force tree::tree + namespace export tree +} +package provide struct::tree 1.2.2 diff --git a/src/bootsupport/lib/struct/tree_c.tcl b/src/bootsupport/lib/struct/tree_c.tcl new file mode 100644 index 00000000..d8f112a8 --- /dev/null +++ b/src/bootsupport/lib/struct/tree_c.tcl @@ -0,0 +1,208 @@ +# treec.tcl -- +# +# Implementation of a tree data structure for Tcl. +# This code based on critcl, API compatible to the PTI [x]. +# [x] Pure Tcl Implementation. +# +# Copyright (c) 2005 Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: tree_c.tcl,v 1.6 2008/03/25 07:15:34 andreas_kupries Exp $ + +package require critcl +# @sak notprovided struct_treec +package provide struct_treec 2.1.1 +package require Tcl 8.2 + +namespace eval ::struct { + # Supporting code for the main command. + + catch { + #critcl::cheaders -g + #critcl::debug memory symbols + } + + critcl::cheaders tree/*.h + critcl::csources tree/*.c + + critcl::ccode { + /* -*- c -*- */ + + #include + #include + #include + #include + #include + + /* .................................................. */ + /* Global tree management, per interp + */ + + typedef struct TDg { + long int counter; + char buf [50]; + } TDg; + + static void + TDgrelease (ClientData cd, Tcl_Interp* interp) + { + ckfree((char*) cd); + } + + static CONST char* + TDnewName (Tcl_Interp* interp) + { +#define KEY "tcllib/struct::tree/critcl" + + Tcl_InterpDeleteProc* proc = TDgrelease; + TDg* tdg; + + tdg = Tcl_GetAssocData (interp, KEY, &proc); + if (tdg == NULL) { + tdg = (TDg*) ckalloc (sizeof (TDg)); + tdg->counter = 0; + + Tcl_SetAssocData (interp, KEY, proc, + (ClientData) tdg); + } + + tdg->counter ++; + sprintf (tdg->buf, "tree%ld", tdg->counter); + return tdg->buf; + +#undef KEY + } + + static void + TDdeleteCmd (ClientData clientData) + { + /* Release the whole tree. */ + t_delete ((T*) clientData); + } + } + + # Main command, tree creation. + + critcl::ccommand tree_critcl {dummy interp objc objv} { + /* Syntax + * - epsilon |1 + * - name |2 + * - name =|:=|as|deserialize source |4 + */ + + CONST char* name; + T* td; + Tcl_Obj* fqn; + Tcl_CmdInfo ci; + +#define USAGE "?name ?=|:=|as|deserialize source??" + + if ((objc != 4) && (objc != 2) && (objc != 1)) { + Tcl_WrongNumArgs (interp, 1, objv, USAGE); + return TCL_ERROR; + } + + if (objc < 2) { + name = TDnewName (interp); + } else { + name = Tcl_GetString (objv [1]); + } + + if (!Tcl_StringMatch (name, "::*")) { + /* Relative name. Prefix with current namespace */ + + Tcl_Eval (interp, "namespace current"); + fqn = Tcl_GetObjResult (interp); + fqn = Tcl_DuplicateObj (fqn); + Tcl_IncrRefCount (fqn); + + if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { + Tcl_AppendToObj (fqn, "::", -1); + } + Tcl_AppendToObj (fqn, name, -1); + } else { + fqn = Tcl_NewStringObj (name, -1); + Tcl_IncrRefCount (fqn); + } + Tcl_ResetResult (interp); + + if (Tcl_GetCommandInfo (interp, + Tcl_GetString (fqn), + &ci)) { + Tcl_Obj* err; + + err = Tcl_NewObj (); + Tcl_AppendToObj (err, "command \"", -1); + Tcl_AppendObjToObj (err, fqn); + Tcl_AppendToObj (err, "\" already exists, unable to create tree", -1); + + Tcl_DecrRefCount (fqn); + Tcl_SetObjResult (interp, err); + return TCL_ERROR; + } + + if (objc == 4) { + Tcl_Obj* type = objv[2]; + Tcl_Obj* src = objv[3]; + int srctype; + + static CONST char* types [] = { + ":=", "=", "as", "deserialize", NULL + }; + enum types { + T_ASSIGN, T_IS, T_AS, T_DESER + }; + + if (Tcl_GetIndexFromObj (interp, type, types, "type", + 0, &srctype) != TCL_OK) { + Tcl_DecrRefCount (fqn); + Tcl_ResetResult (interp); + Tcl_WrongNumArgs (interp, 1, objv, USAGE); + return TCL_ERROR; + } + + td = t_new (); + + switch (srctype) { + case T_ASSIGN: + case T_AS: + case T_IS: + if (tms_assign (interp, td, src) != TCL_OK) { + t_delete (td); + Tcl_DecrRefCount (fqn); + return TCL_ERROR; + } + break; + + case T_DESER: + if (t_deserialize (td, interp, src) != TCL_OK) { + t_delete (td); + Tcl_DecrRefCount (fqn); + return TCL_ERROR; + } + break; + } + } else { + td = t_new (); + } + + td->cmd = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn), + tms_objcmd, (ClientData) td, + TDdeleteCmd); + + Tcl_SetObjResult (interp, fqn); + Tcl_DecrRefCount (fqn); + return TCL_OK; + } + + namespace eval tree { + critcl::ccommand prune_critcl {dummy interp objc objv} { + return 5; + } + } +} + +# ### ### ### ######### ######### ######### +## Ready diff --git a/src/bootsupport/lib/struct/tree_tcl.tcl b/src/bootsupport/lib/struct/tree_tcl.tcl new file mode 100644 index 00000000..fbbc3575 --- /dev/null +++ b/src/bootsupport/lib/struct/tree_tcl.tcl @@ -0,0 +1,2442 @@ +# tree.tcl -- +# +# Implementation of a tree data structure for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: tree_tcl.tcl,v 1.5 2009/06/22 18:21:59 andreas_kupries Exp $ + +package require Tcl 8.2 +package require struct::list + +namespace eval ::struct::tree { + # Data storage in the tree module + # ------------------------------- + # + # There's a lot of bits to keep track of for each tree: + # nodes + # node values + # node relationships + # + # It would quickly become unwieldy to try to keep these in arrays or lists + # within the tree namespace itself. Instead, each tree structure will get + # its own namespace. Each namespace contains: + # children array mapping nodes to their children list + # parent array mapping nodes to their parent node + # node:$node array mapping keys to values for the node $node + + # counter is used to give a unique name for unnamed trees + variable counter 0 + + # Only export one command, the one used to instantiate a new tree + namespace export tree_tcl +} + +# ::struct::tree::tree_tcl -- +# +# Create a new tree with a given name; if no name is given, use +# treeX, where X is a number. +# +# Arguments: +# name Optional name of the tree; if null or not given, generate one. +# +# Results: +# name Name of the tree created + +proc ::struct::tree::tree_tcl {args} { + variable counter + + set src {} + set srctype {} + + switch -exact -- [llength [info level 0]] { + 1 { + # Missing name, generate one. + incr counter + set name "tree${counter}" + } + 2 { + # Standard call. New empty tree. + set name [lindex $args 0] + } + 4 { + # Copy construction. + foreach {name as src} $args break + switch -exact -- $as { + = - := - as { + set srctype tree + } + deserialize { + set srctype serial + } + default { + return -code error \ + "wrong # args: should be \"tree ?name ?=|:=|as|deserialize source??\"" + } + } + } + default { + # Error. + return -code error \ + "wrong # args: should be \"tree ?name ?=|:=|as|deserialize source??\"" + } + } + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + + set name "$ns$name" + } + if {[llength [info commands $name]]} { + return -code error \ + "command \"$name\" already exists, unable to create tree" + } + + # Set up the namespace for the object, + # identical to the object command. + namespace eval $name { + variable rootname + set rootname root + + # Set up root node's child list + variable children + set children(root) [list] + + # Set root node's parent + variable parent + set parent(root) [list] + + # Set up the node attribute mapping + variable attribute + array set attribute {} + + # Set up a counter for use in creating unique node names + variable nextUnusedNode + set nextUnusedNode 1 + + # Set up a counter for use in creating node attribute arrays. + variable nextAttr + set nextAttr 0 + } + + # Create the command to manipulate the tree + interp alias {} $name {} ::struct::tree::TreeProc $name + + # Automatic execution of assignment if a source + # is present. + if {$src != {}} { + switch -exact -- $srctype { + tree { + set code [catch {_= $name $src} msg] + if {$code} { + namespace delete $name + interp alias {} $name {} + return -code $code -errorinfo $::errorInfo -errorcode $::errorCode $msg + } + } + serial { + set code [catch {_deserialize $name $src} msg] + if {$code} { + namespace delete $name + interp alias {} $name {} + return -code $code -errorinfo $::errorInfo -errorcode $::errorCode $msg + } + } + default { + return -code error \ + "Internal error, illegal srctype \"$srctype\"" + } + } + } + + # Give object to caller for use. + return $name +} + +# ::struct::tree::prune_tcl -- +# +# Abort the walk script, and ignore any children of the +# node we are currently at. +# +# Arguments: +# None. +# +# Results: +# None. +# +# Sideeffects: +# +# Stops the execution of the script and throws a signal to the +# surrounding walker to go to the next node, and ignore the +# children of the current node. + +proc ::struct::tree::prune_tcl {} { + return -code 5 +} + +########################## +# Private functions follow + +# ::struct::tree::TreeProc -- +# +# Command that processes all tree object commands. +# +# Arguments: +# name Name of the tree object to manipulate. +# cmd Subcommand to invoke. +# args Arguments for subcommand. +# +# Results: +# Varies based on command to perform + +proc ::struct::tree::TreeProc {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub _$cmd + if { [llength [info commands ::struct::tree::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::tree::_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 1 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + + set code [catch {uplevel 1 [linsert $args 0 ::struct::tree::$sub $name]} result] + + if {$code == 1} { + return -errorinfo [ErrorInfoAsCaller uplevel $sub] \ + -errorcode $::errorCode -code error $result + } elseif {$code == 2} { + return -code $code $result + } + return $result +} + +# ::struct::tree::_:= -- +# +# Assignment operator. Copies the source tree into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the tree object we are copying into. +# source Name of the tree object providing us with the +# data to copy. +# +# Results: +# Nothing. + +proc ::struct::tree::_= {name source} { + _deserialize $name [$source serialize] + return +} + +# ::struct::tree::_--> -- +# +# Reverse assignment operator. Copies this tree into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the tree object to copy +# dest Name of the tree object we are copying to. +# +# Results: +# Nothing. + +proc ::struct::tree::_--> {name dest} { + $dest deserialize [_serialize $name] + return +} + +# ::struct::tree::_ancestors -- +# +# Return the list of all parent nodes of a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to look up. +# +# Results: +# parents List of parents of node $node. +# Immediate ancestor (parent) first, +# Root of tree (ancestor of all) last. + +proc ::struct::tree::_ancestors {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::parent + set a {} + while {[info exists parent($node)]} { + set node $parent($node) + if {$node == {}} break + lappend a $node + } + return $a +} + +# ::struct::tree::_attr -- +# +# Return attribute data for one key and multiple nodes, possibly all. +# +# Arguments: +# name Name of the tree object. +# key Name of the attribute to retrieve. +# +# Results: +# children Dictionary mapping nodes to attribute data. + +proc ::struct::tree::_attr {name key args} { + # Syntax: + # + # t attr key + # t attr key -nodes {nodelist} + # t attr key -glob nodepattern + # t attr key -regexp nodepattern + + variable ${name}::attribute + + set usage "wrong # args: should be \"[list $name] attr key ?-nodes list|-glob pattern|-regexp pattern?\"" + if {([llength $args] != 0) && ([llength $args] != 2)} { + return -code error $usage + } elseif {[llength $args] == 0} { + # This automatically restricts the list + # to nodes which can have the attribute + # in question. + + set nodes [array names attribute] + } else { + # Determine a list of nodes to look at + # based on the chosen restriction. + + foreach {mode value} $args break + switch -exact -- $mode { + -nodes { + # This is the only branch where we have to + # perform an explicit restriction to the + # nodes which have attributes. + set nodes {} + foreach n $value { + if {![info exists attribute($n)]} continue + lappend nodes $n + } + } + -glob { + set nodes [array names attribute $value] + } + -regexp { + set nodes {} + foreach n [array names attribute] { + if {![regexp -- $value $n]} continue + lappend nodes $n + } + } + default { + return -code error $usage + } + } + } + + # Without possibly matching nodes + # the result has to be empty. + + if {![llength $nodes]} { + return {} + } + + # Now locate matching keys and their values. + + set result {} + foreach n $nodes { + upvar ${name}::$attribute($n) data + if {[info exists data($key)]} { + lappend result $n $data($key) + } + } + + return $result +} + +# ::struct::tree::_deserialize -- +# +# Assignment operator. Copies a serialization into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the tree object we are copying into. +# serial Serialized tree to copy from. +# +# Results: +# Nothing. + +proc ::struct::tree::_deserialize {name serial} { + # As we destroy the original tree as part of + # the copying process we don't have to deal + # with issues like node names from the new tree + # interfering with the old ... + + # I. Get the serialization of the source tree + # and check it for validity. + + CheckSerialization $serial attr p c rn + + # Get all the relevant data into the scope + + variable ${name}::rootname + variable ${name}::children + variable ${name}::parent + variable ${name}::attribute + variable ${name}::nextAttr + + # Kill the existing parent/children information and insert the new + # data in their place. + + foreach n [array names parent] { + unset parent($n) children($n) + } + array set parent [array get p] + array set children [array get c] + unset p c + + set nextAttr 0 + foreach a [array names attribute] { + unset ${name}::$attribute($a) + } + foreach n [array names attr] { + GenAttributeStorage $name $n + array set ${name}::$attribute($n) $attr($n) + } + + set rootname $rn + + ## Debug ## Dump internals ... + if {0} { + puts "___________________________________ $name" + puts $rootname + parray children + parray parent + parray attribute + puts ___________________________________ + } + return +} + +# ::struct::tree::_children -- +# +# Return the list of children for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# children List of children for the node. + +proc ::struct::tree::_children {name args} { + # args := ?-all? node ?filter cmdprefix? + + # '-all' implies that not only the direct children of the + # node, but all their children, and so on, are returned. + # + # 'filter cmd' implies that only those nodes in the result list + # which pass the test 'cmd' are placed into the final result. + + set usage "wrong # args: should be \"[list $name] children ?-all? node ?filter cmd?\"" + + if {([llength $args] < 1) || ([llength $args] > 4)} { + return -code error $usage + } + if {[string equal [lindex $args 0] -all]} { + set all 1 + set args [lrange $args 1 end] + } else { + set all 0 + } + + # args := node ?filter cmdprefix? + + if {([llength $args] != 1) && ([llength $args] != 3)} { + return -code error $usage + } + if {[llength $args] == 3} { + foreach {node _const_ cmd} $args break + if {![string equal $_const_ filter] || ![llength $cmd]} { + return -code error $usage + } + } else { + set node [lindex $args 0] + set cmd {} + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + if {$all} { + set result [DescendantsCore $name $node] + } else { + variable ${name}::children + set result $children($node) + } + + if {[llength $cmd]} { + lappend cmd $name + set result [uplevel 1 [list ::struct::list filter $result $cmd]] + } + + return $result +} + +# ::struct::tree::_cut -- +# +# Destroys the specified node of a tree, but not its children. +# These children are made into children of the parent of the +# destroyed node at the index of the destroyed node. +# +# Arguments: +# name Name of the tree object. +# node Node to look up and cut. +# +# Results: +# None. + +proc ::struct::tree::_cut {name node} { + variable ${name}::rootname + + if { [string equal $node $rootname] } { + # Can't delete the special root node + return -code error "cannot cut root node" + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::parent + variable ${name}::children + + # Locate our parent, children and our location in the parent + set parentNode $parent($node) + set childNodes $children($node) + + set index [lsearch -exact $children($parentNode) $node] + + # Excise this node from the parent list, + set newChildren [lreplace $children($parentNode) $index $index] + + # Put each of the children of $node into the parent's children list, + # in the place of $node, and update the parent pointer of those nodes. + foreach child $childNodes { + set newChildren [linsert $newChildren $index $child] + set parent($child) $parentNode + incr index + } + set children($parentNode) $newChildren + + KillNode $name $node + return +} + +# ::struct::tree::_delete -- +# +# Remove a node from a tree, including all of its values. Recursively +# removes the node's children. +# +# Arguments: +# name Name of the tree. +# node Node to delete. +# +# Results: +# None. + +proc ::struct::tree::_delete {name node} { + variable ${name}::rootname + if { [string equal $node $rootname] } { + # Can't delete the special root node + return -code error "cannot delete root node" + } + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + variable ${name}::parent + + # Remove this node from its parent's children list + set parentNode $parent($node) + set index [lsearch -exact $children($parentNode) $node] + ldelete children($parentNode) $index + + # Yes, we could use the stack structure implemented in ::struct::stack, + # but it's slower than inlining it. Since we don't need a sophisticated + # stack, don't bother. + set st [list] + foreach child $children($node) { + lappend st $child + } + + KillNode $name $node + + while {[llength $st] > 0} { + set node [lindex $st end] + ldelete st end + foreach child $children($node) { + lappend st $child + } + + KillNode $name $node + } + return +} + +# ::struct::tree::_depth -- +# +# Return the depth (distance from the root node) of a given node. +# +# Arguments: +# name Name of the tree. +# node Node to find. +# +# Results: +# depth Number of steps from node to the root node. + +proc ::struct::tree::_depth {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + variable ${name}::parent + variable ${name}::rootname + set depth 0 + while { ![string equal $node $rootname] } { + incr depth + set node $parent($node) + } + return $depth +} + +# ::struct::tree::_descendants -- +# +# Return the list containing all descendants of a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to look at. +# +# Results: +# desc (filtered) List of nodes descending from 'node'. + +proc ::struct::tree::_descendants {name node args} { + # children -all sucessor, allows filtering. + + set usage "wrong # args: should be \"[list $name] descendants node ?filter cmd?\"" + + if {[llength $args] > 2} { + return -code error $usage + } elseif {[llength $args] == 2} { + foreach {_const_ cmd} $args break + if {![string equal $_const_ filter] || ![llength $cmd]} { + return -code error $usage + } + } else { + set cmd {} + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + set result [DescendantsCore $name $node] + + if {[llength $cmd]} { + lappend cmd $name + set result [uplevel 1 [list ::struct::list filter $result $cmd]] + } + + return $result +} + +proc ::struct::tree::DescendantsCore {name node} { + # CORE for listing of node descendants. + # No checks ... + # No filtering ... + + variable ${name}::children + + # New implementation. Instead of keeping a second, and explicit, + # list of pending nodes to shift through (= copying of array data + # around), we reuse the result list for that, using a counter and + # direct access to list elements to keep track of what nodes have + # not been handled yet. This eliminates a whole lot of array + # copying within the list implementation in the Tcl core. The + # result is unchanged, i.e. the nodes are in the same order as + # before. + + set result $children($node) + set at 0 + + while {$at < [llength $result]} { + set n [lindex $result $at] + incr at + foreach c $children($n) { + lappend result $c + } + } + + return $result +} + +# ::struct::tree::_destroy -- +# +# Destroy a tree, including its associated command and data storage. +# +# Arguments: +# name Name of the tree to destroy. +# +# Results: +# None. + +proc ::struct::tree::_destroy {name} { + namespace delete $name + interp alias {} $name {} +} + +# ::struct::tree::_exists -- +# +# Test for existence of a given node in a tree. +# +# Arguments: +# name Name of the tree to query. +# node Node to look for. +# +# Results: +# 1 if the node exists, 0 else. + +proc ::struct::tree::_exists {name node} { + return [info exists ${name}::parent($node)] +} + +# ::struct::tree::_get -- +# +# Get a keyed value from a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# key Key to lookup. +# +# Results: +# value Value associated with the key given. + +proc ::struct::tree::_get {name node key} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, key has to be invalid. + return -code error "invalid key \"$key\" for node \"$node\"" + } + + upvar ${name}::$attribute($node) data + if {![info exists data($key)]} { + return -code error "invalid key \"$key\" for node \"$node\"" + } + return $data($key) +} + +# ::struct::tree::_getall -- +# +# Get a serialized list of key/value pairs from a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# +# Results: +# value A serialized list of key/value pairs. + +proc ::struct::tree::_getall {name node {pattern *}} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attributes ... + return {} + } + + upvar ${name}::$attribute($node) data + return [array get data $pattern] +} + +# ::struct::tree::_height -- +# +# Return the height (distance from the given node to its deepest child) +# +# Arguments: +# name Name of the tree. +# node Node we wish to know the height for.. +# +# Results: +# height Distance to deepest child of the node. + +proc ::struct::tree::_height {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + variable ${name}::parent + + if {[llength $children($node)] == 0} { + # No children, is a leaf, height is 0. + return 0 + } + + # New implementation. We iteratively compute the height for each + # node under the specified one, from the bottom up. The previous + # implementation, using recursion will fail if the encountered + # subtree has a height greater than the currently set recursion + # limit. + + array set h {} + + # NOTE: Check out if a for loop doing direct access, i.e. without + # list reversal, is faster. + + foreach n [struct::list reverse [DescendantsCore $name $node]] { + # Height of leafs + if {![llength $children($n)]} {set h($n) 0} + + # Height of our parent is max of our and previous height. + set p $parent($n) + if {![info exists h($p)] || ($h($n) >= $h($p))} { + set h($p) [expr {$h($n) + 1}] + } + } + + # NOTE: Check out how much we gain by caching the result. + # For all nodes we have this computed. Use cache here + # as well to cut the inspection of descendants down. + # This may degenerate into a recursive solution again + # however. + + return $h($node) +} + +# ::struct::tree::_keys -- +# +# Get a list of keys from a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# +# Results: +# value A serialized list of key/value pairs. + +proc ::struct::tree::_keys {name node {pattern *}} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node. + return {} + } + + upvar ${name}::$attribute($node) data + return [array names data $pattern] +} + +# ::struct::tree::_keyexists -- +# +# Test for existence of a given key for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# key Key to lookup. +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::tree::_keyexists {name node key} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, key cannot exist + return 0 + } + + upvar ${name}::$attribute($node) data + return [info exists data($key)] +} + +# ::struct::tree::_index -- +# +# Determine the index of node with in its parent's list of children. +# +# Arguments: +# name Name of the tree. +# node Node to look up. +# +# Results: +# index The index of the node in its parent + +proc ::struct::tree::_index {name node} { + variable ${name}::rootname + if { [string equal $node $rootname] } { + # The special root node has no parent, thus no index in it either. + return -code error "cannot determine index of root node" + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + variable ${name}::parent + + # Locate the parent and ourself in its list of children + set parentNode $parent($node) + + return [lsearch -exact $children($parentNode) $node] +} + +# ::struct::tree::_insert -- +# +# Add a node to a tree; if the node(s) specified already exist, they +# will be moved to the given location. +# +# Arguments: +# name Name of the tree. +# parentNode Parent to add the node to. +# index Index at which to insert. +# args Node(s) to insert. If none is given, the routine +# will insert a single node with a unique name. +# +# Results: +# nodes List of nodes inserted. + +proc ::struct::tree::_insert {name parentNode index args} { + if { [llength $args] == 0 } { + # No node name was given; generate a unique one + set args [list [GenerateUniqueNodeName $name]] + } + if { ![_exists $name $parentNode] } { + return -code error "parent node \"$parentNode\" does not exist in tree \"$name\"" + } + + variable ${name}::parent + variable ${name}::children + variable ${name}::rootname + + # Make sure the index is numeric + + if {[string equal $index "end"]} { + set index [llength $children($parentNode)] + } elseif {[regexp {^end-([0-9]+)$} $index -> n]} { + set index [expr {[llength $children($parentNode)] - $n}] + } + + foreach node $args { + if {[_exists $name $node] } { + # Move the node to its new home + if { [string equal $node $rootname] } { + return -code error "cannot move root node" + } + + # Cannot make a node its own descendant (I'm my own grandpa...) + set ancestor $parentNode + while { ![string equal $ancestor $rootname] } { + if { [string equal $ancestor $node] } { + return -code error "node \"$node\" cannot be its own descendant" + } + set ancestor $parent($ancestor) + } + # Remove this node from its parent's children list + set oldParent $parent($node) + set ind [lsearch -exact $children($oldParent) $node] + ldelete children($oldParent) $ind + + # If the node is moving within its parent, and its old location + # was before the new location, decrement the new location, so that + # it gets put in the right spot + if { [string equal $oldParent $parentNode] && $ind < $index } { + incr index -1 + } + } else { + # Set up the new node + set children($node) [list] + } + + # Add this node to its parent's children list + set children($parentNode) [linsert $children($parentNode) $index $node] + + # Update the parent pointer for this node + set parent($node) $parentNode + incr index + } + + return $args +} + +# ::struct::tree::_isleaf -- +# +# Return whether the given node of a tree is a leaf or not. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# isleaf True if the node is a leaf; false otherwise. + +proc ::struct::tree::_isleaf {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + return [expr {[llength $children($node)] == 0}] +} + +# ::struct::tree::_move -- +# +# Move a node (and all its subnodes) from where ever it is to a new +# location in the tree. +# +# Arguments: +# name Name of the tree +# parentNode Parent to add the node to. +# index Index at which to insert. +# node Node to move; the node must exist in the tree. +# args Additional nodes to move; these nodes must exist +# in the tree. +# +# Results: +# None. + +proc ::struct::tree::_move {name parentNode index node args} { + set args [linsert $args 0 $node] + + # Can only move a node to a real location in the tree + if { ![_exists $name $parentNode] } { + return -code error "parent node \"$parentNode\" does not exist in tree \"$name\"" + } + + variable ${name}::parent + variable ${name}::children + variable ${name}::rootname + + # Make sure the index is numeric + + if {[string equal $index "end"]} { + set index [llength $children($parentNode)] + } elseif {[regexp {^end-([0-9]+)$} $index -> n]} { + set index [expr {[llength $children($parentNode)] - $n}] + } + + # Validate all nodes to move before trying to move any. + foreach node $args { + if { [string equal $node $rootname] } { + return -code error "cannot move root node" + } + + # Can only move real nodes + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Cannot move a node to be a descendant of itself + set ancestor $parentNode + while { ![string equal $ancestor $rootname] } { + if { [string equal $ancestor $node] } { + return -code error "node \"$node\" cannot be its own descendant" + } + set ancestor $parent($ancestor) + } + } + + # Remove all nodes from their current parent's children list + foreach node $args { + set oldParent $parent($node) + set ind [lsearch -exact $children($oldParent) $node] + + ldelete children($oldParent) $ind + + # Update the nodes parent value + set parent($node) $parentNode + } + + # Add all nodes to their new parent's children list + set children($parentNode) \ + [eval [list linsert $children($parentNode) $index] $args] + + return +} + +# ::struct::tree::_next -- +# +# Return the right sibling for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to retrieve right sibling for. +# +# Results: +# sibling The right sibling for the node, or null if node was +# the rightmost child of its parent. + +proc ::struct::tree::_next {name node} { + # The 'root' has no siblings. + variable ${name}::rootname + if { [string equal $node $rootname] } { + return {} + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Locate the parent and our place in its list of children. + variable ${name}::parent + variable ${name}::children + + set parentNode $parent($node) + set index [lsearch -exact $children($parentNode) $node] + + # Go to the node to the right and return its name. + return [lindex $children($parentNode) [incr index]] +} + +# ::struct::tree::_numchildren -- +# +# Return the number of immediate children for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# numchildren Number of immediate children for the node. + +proc ::struct::tree::_numchildren {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + return [llength $children($node)] +} + +# ::struct::tree::_nodes -- +# +# Return a list containing all nodes known to the tree. +# +# Arguments: +# name Name of the tree object. +# +# Results: +# nodes List of nodes in the tree. + +proc ::struct::tree::_nodes {name} { + variable ${name}::children + return [array names children] +} + +# ::struct::tree::_parent -- +# +# Return the name of the parent node of a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to look up. +# +# Results: +# parent Parent of node $node + +proc ::struct::tree::_parent {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + # FRINK: nocheck + return [set ${name}::parent($node)] +} + +# ::struct::tree::_previous -- +# +# Return the left sibling for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# sibling The left sibling for the node, or null if node was +# the leftmost child of its parent. + +proc ::struct::tree::_previous {name node} { + # The 'root' has no siblings. + variable ${name}::rootname + if { [string equal $node $rootname] } { + return {} + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Locate the parent and our place in its list of children. + variable ${name}::parent + variable ${name}::children + + set parentNode $parent($node) + set index [lsearch -exact $children($parentNode) $node] + + # Go to the node to the right and return its name. + return [lindex $children($parentNode) [incr index -1]] +} + +# ::struct::tree::_rootname -- +# +# Query or change the name of the root node. +# +# Arguments: +# name Name of the tree. +# +# Results: +# The name of the root node + +proc ::struct::tree::_rootname {name} { + variable ${name}::rootname + return $rootname +} + +# ::struct::tree::_rename -- +# +# Change the name of any node. +# +# Arguments: +# name Name of the tree. +# node Name of node to be renamed +# newname New name for the node. +# +# Results: +# The new name of the node. + +proc ::struct::tree::_rename {name node newname} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if {[_exists $name $newname]} { + return -code error "unable to rename node to \"$newname\",\ + node of that name already present in the tree \"$name\"" + } + + set oldname $node + + # Perform the rename in the internal + # data structures. + + variable ${name}::rootname + variable ${name}::children + variable ${name}::parent + variable ${name}::attribute + + set children($newname) $children($oldname) + unset children($oldname) + set parent($newname) $parent($oldname) + unset parent($oldname) + + foreach c $children($newname) { + set parent($c) $newname + } + + if {[string equal $oldname $rootname]} { + set rootname $newname + } else { + set p $parent($newname) + set pos [lsearch -exact $children($p) $oldname] + lset children($p) $pos $newname + } + + if {[info exists attribute($oldname)]} { + set attribute($newname) $attribute($oldname) + unset attribute($oldname) + } + + return $newname +} + +# ::struct::tree::_serialize -- +# +# Serialize a tree object (partially) into a transportable value. +# +# Arguments: +# name Name of the tree. +# node Root node of the serialized tree. +# +# Results: +# A list structure describing the part of the tree which was serialized. + +proc ::struct::tree::_serialize {name args} { + if {[llength $args] > 1} { + return -code error \ + "wrong # args: should be \"[list $name] serialize ?node?\"" + } elseif {[llength $args] == 1} { + set node [lindex $args 0] + + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + } else { + variable ${name}::rootname + set node $rootname + } + + set tree [list] + Serialize $name $node tree + return $tree +} + +# ::struct::tree::_set -- +# +# Set or get a value for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to modify or query. +# args Optional argument specifying a value. +# +# Results: +# val Value associated with the given key of the given node + +proc ::struct::tree::_set {name node key args} { + if {[llength $args] > 1} { + return -code error "wrong # args: should be \"$name set node key\ + ?value?\"" + } + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Process the arguments ... + + if {[llength $args] > 0} { + # Setting the value. This may have to create + # the attribute array for this particular + # node + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # so create it as we need it now. + GenAttributeStorage $name $node + } + upvar ${name}::$attribute($node) data + + return [set data($key) [lindex $args end]] + } else { + # Getting the value + + return [_get $name $node $key] + } +} + +# ::struct::tree::_append -- +# +# Append a value for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to modify. +# key Name of attribute to modify. +# value Value to append +# +# Results: +# val Value associated with the given key of the given node + +proc ::struct::tree::_append {name node key value} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # so create it as we need it. + GenAttributeStorage $name $node + } + + upvar ${name}::$attribute($node) data + return [append data($key) $value] +} + +# ::struct::tree::_lappend -- +# +# lappend a value for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to modify or query. +# key Name of attribute to modify. +# value Value to append +# +# Results: +# val Value associated with the given key of the given node + +proc ::struct::tree::_lappend {name node key value} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # so create it as we need it. + GenAttributeStorage $name $node + } + + upvar ${name}::$attribute($node) data + return [lappend data($key) $value] +} + +# ::struct::tree::_leaves -- +# +# Return a list containing all leaf nodes known to the tree. +# +# Arguments: +# name Name of the tree object. +# +# Results: +# nodes List of leaf nodes in the tree. + +proc ::struct::tree::_leaves {name} { + variable ${name}::children + + set res {} + foreach n [array names children] { + if {[llength $children($n)]} continue + lappend res $n + } + return $res +} + +# ::struct::tree::_size -- +# +# Return the number of descendants of a given node. The default node +# is the special root node. +# +# Arguments: +# name Name of the tree. +# node Optional node to start counting from (default is root). +# +# Results: +# size Number of descendants of the node. + +proc ::struct::tree::_size {name args} { + variable ${name}::rootname + if {[llength $args] > 1} { + return -code error \ + "wrong # args: should be \"[list $name] size ?node?\"" + } elseif {[llength $args] == 1} { + set node [lindex $args 0] + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + } else { + # If the node is the root, we can do the cheap thing and just count the + # number of nodes (excluding the root node) that we have in the tree with + # array size. + + return [expr {[array size ${name}::parent] - 1}] + } + + # If the node is the root, we can do the cheap thing and just count the + # number of nodes (excluding the root node) that we have in the tree with + # array size. + + if { [string equal $node $rootname] } { + return [expr {[array size ${name}::parent] - 1}] + } + + # Otherwise we have to do it the hard way and do a full tree search + variable ${name}::children + set size 0 + set st [list ] + foreach child $children($node) { + lappend st $child + } + while { [llength $st] > 0 } { + set node [lindex $st end] + ldelete st end + incr size + foreach child $children($node) { + lappend st $child + } + } + return $size +} + +# ::struct::tree::_splice -- +# +# Add a node to a tree, making a range of children from the given +# parent children of the new node. +# +# Arguments: +# name Name of the tree. +# parentNode Parent to add the node to. +# from Index at which to insert. +# to Optional end of the range of children to replace. +# Defaults to 'end'. +# args Optional node name; if given, must be unique. If not +# given, a unique name will be generated. +# +# Results: +# node Name of the node added to the tree. + +proc ::struct::tree::_splice {name parentNode from {to end} args} { + + if { ![_exists $name $parentNode] } { + return -code error "node \"$parentNode\" does not exist in tree \"$name\"" + } + + if { [llength $args] == 0 } { + # No node name given; generate a unique node name + set node [GenerateUniqueNodeName $name] + } else { + set node [lindex $args 0] + } + + if { [_exists $name $node] } { + return -code error "node \"$node\" already exists in tree \"$name\"" + } + + variable ${name}::children + variable ${name}::parent + + if {[string equal $from "end"]} { + set from [expr {[llength $children($parentNode)] - 1}] + } elseif {[regexp {^end-([0-9]+)$} $from -> n]} { + set from [expr {[llength $children($parentNode)] - 1 - $n}] + } + if {[string equal $to "end"]} { + set to [expr {[llength $children($parentNode)] - 1}] + } elseif {[regexp {^end-([0-9]+)$} $to -> n]} { + set to [expr {[llength $children($parentNode)] - 1 - $n}] + } + + # Save the list of children that are moving + set moveChildren [lrange $children($parentNode) $from $to] + + # Remove those children from the parent + ldelete children($parentNode) $from $to + + # Add the new node + _insert $name $parentNode $from $node + + # Move the children + set children($node) $moveChildren + foreach child $moveChildren { + set parent($child) $node + } + + return $node +} + +# ::struct::tree::_swap -- +# +# Swap two nodes in a tree. +# +# Arguments: +# name Name of the tree. +# node1 First node to swap. +# node2 Second node to swap. +# +# Results: +# None. + +proc ::struct::tree::_swap {name node1 node2} { + # Can't swap the magic root node + variable ${name}::rootname + if {[string equal $node1 $rootname] || [string equal $node2 $rootname]} { + return -code error "cannot swap root node" + } + + # Can only swap two real nodes + if {![_exists $name $node1]} { + return -code error "node \"$node1\" does not exist in tree \"$name\"" + } + if {![_exists $name $node2]} { + return -code error "node \"$node2\" does not exist in tree \"$name\"" + } + + # Can't swap a node with itself + if {[string equal $node1 $node2]} { + return -code error "cannot swap node \"$node1\" with itself" + } + + # Swapping nodes means swapping their labels and values + variable ${name}::children + variable ${name}::parent + + set parent1 $parent($node1) + set parent2 $parent($node2) + + # Replace node1 with node2 in node1's parent's children list, and + # node2 with node1 in node2's parent's children list + set i1 [lsearch -exact $children($parent1) $node1] + set i2 [lsearch -exact $children($parent2) $node2] + + lset children($parent1) $i1 $node2 + lset children($parent2) $i2 $node1 + + # Make node1 the parent of node2's children, and vis versa + foreach child $children($node2) { + set parent($child) $node1 + } + foreach child $children($node1) { + set parent($child) $node2 + } + + # Swap the children lists + set children1 $children($node1) + set children($node1) $children($node2) + set children($node2) $children1 + + if { [string equal $node1 $parent2] } { + set parent($node1) $node2 + set parent($node2) $parent1 + } elseif { [string equal $node2 $parent1] } { + set parent($node1) $parent2 + set parent($node2) $node1 + } else { + set parent($node1) $parent2 + set parent($node2) $parent1 + } + + return +} + +# ::struct::tree::_unset -- +# +# Remove a keyed value from a node. +# +# Arguments: +# name Name of the tree. +# node Node to modify. +# key Name of attribute to unset. +# +# Results: +# None. + +proc ::struct::tree::_unset {name node key} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # nothing to do. + return + } + + upvar ${name}::$attribute($node) data + catch {unset data($key)} + + if {[array size data] == 0} { + # No attributes stored for this node, squash the whole array. + unset attribute($node) + unset data + } + return +} + +# ::struct::tree::_walk -- +# +# Walk a tree using a pre-order depth or breadth first +# search. Pre-order DFS is the default. At each node that is visited, +# a command will be called with the name of the tree and the node. +# +# Arguments: +# name Name of the tree. +# node Node at which to start. +# args Optional additional arguments specifying the type and order of +# the tree walk, and the command to execute at each node. +# Format is +# ?-type {bfs|dfs}? ?-order {pre|post|in|both}? a n script +# +# Results: +# None. + +proc ::struct::tree::_walk {name node args} { + set usage "$name walk node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? loopvar script" + + if {[llength $args] > 7 || [llength $args] < 2} { + return -code error "wrong # args: should be \"$usage\"" + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + set args [WalkOptions $args 2 $usage] + # Remainder is 'a n script' + + foreach {loopvariables script} $args break + + if {[llength $loopvariables] > 2} { + return -code error "too many loop variables, at most two allowed" + } elseif {[llength $loopvariables] == 2} { + foreach {avar nvar} $loopvariables break + } else { + set nvar [lindex $loopvariables 0] + set avar {} + } + + # Make sure we have a script to run, otherwise what's the point? + if { [string equal $script ""] } { + return -code error "no script specified, or empty" + } + + # Do the walk + variable ${name}::children + set st [list ] + lappend st $node + + # Compute some flags for the possible places of command evaluation + set leave [expr {[string equal $order post] || [string equal $order both]}] + set enter [expr {[string equal $order pre] || [string equal $order both]}] + set touch [string equal $order in] + + if {$leave} { + set lvlabel leave + } elseif {$touch} { + # in-order does not provide a sense + # of nesting for the parent, hence + # no enter/leave, just 'visit'. + set lvlabel visit + } + + set rcode 0 + set rvalue {} + + if {[string equal $type "dfs"]} { + # Depth-first walk, several orders of visiting nodes + # (pre, post, both, in) + + array set visited {} + + while { [llength $st] > 0 } { + set node [lindex $st end] + + if {[info exists visited($node)]} { + # Second time we are looking at this 'node'. + # Pop it, then evaluate the command (post, both, in). + + ldelete st end + + if {$leave || $touch} { + # Evaluate the script at this node + WalkCall $avar $nvar $name $node $lvlabel $script + # prune stops execution of loop here. + } + } else { + # First visit of this 'node'. + # Do *not* pop it from the stack so that we are able + # to visit again after its children + + # Remember it. + set visited($node) . + + if {$enter} { + # Evaluate the script at this node (pre, both). + # + # Note: As this is done before the children are + # looked at the script may change the children of + # this node and thus affect the walk. + + WalkCall $avar $nvar $name $node "enter" $script + # prune stops execution of loop here. + } + + # Add the children of this node to the stack. + # The exact behaviour depends on the chosen + # order. For pre, post, both-order we just + # have to add them in reverse-order so that + # they will be popped left-to-right. For in-order + # we have rearrange the stack so that the parent + # is revisited immediately after the first child. + # (but only if there is ore than one child,) + + set clist $children($node) + set len [llength $clist] + + if {$touch && ($len > 1)} { + # Pop node from stack, insert into list of children + ldelete st end + set clist [linsert $clist 1 $node] + incr len + } + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + lappend st [lindex $clist $i] + } + } + } + } else { + # Breadth first walk (pre, post, both) + # No in-order possible. Already captured. + + if {$leave} { + set backward $st + } + + while { [llength $st] > 0 } { + set node [lindex $st 0] + ldelete st 0 + + if {$enter} { + # Evaluate the script at this node + WalkCall $avar $nvar $name $node "enter" $script + # prune stops execution of loop here. + } + + # Add this node's children + # And create a mirrored version in case of post/both order. + + foreach child $children($node) { + lappend st $child + if {$leave} { + set backward [linsert $backward 0 $child] + } + } + } + + if {$leave} { + foreach node $backward { + # Evaluate the script at this node + WalkCall $avar $nvar $name $node "leave" $script + } + } + } + + if {$rcode != 0} { + return -code $rcode $rvalue + } + return +} + +proc ::struct::tree::_walkproc {name node args} { + set usage "$name walkproc node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? cmdprefix" + + if {[llength $args] > 6 || [llength $args] < 1} { + return -code error "wrong # args: should be \"$usage\"" + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + set args [WalkOptions $args 1 $usage] + # Remainder is 'n cmdprefix' + + set script [lindex $args 0] + + # Make sure we have a script to run, otherwise what's the point? + if { ![llength $script] } { + return -code error "no script specified, or empty" + } + + # Do the walk + variable ${name}::children + set st [list ] + lappend st $node + + # Compute some flags for the possible places of command evaluation + set leave [expr {[string equal $order post] || [string equal $order both]}] + set enter [expr {[string equal $order pre] || [string equal $order both]}] + set touch [string equal $order in] + + if {$leave} { + set lvlabel leave + } elseif {$touch} { + # in-order does not provide a sense + # of nesting for the parent, hence + # no enter/leave, just 'visit'. + set lvlabel visit + } + + set rcode 0 + set rvalue {} + + if {[string equal $type "dfs"]} { + # Depth-first walk, several orders of visiting nodes + # (pre, post, both, in) + + array set visited {} + + while { [llength $st] > 0 } { + set node [lindex $st end] + + if {[info exists visited($node)]} { + # Second time we are looking at this 'node'. + # Pop it, then evaluate the command (post, both, in). + + ldelete st end + + if {$leave || $touch} { + # Evaluate the script at this node + WalkCallProc $name $node $lvlabel $script + # prune stops execution of loop here. + } + } else { + # First visit of this 'node'. + # Do *not* pop it from the stack so that we are able + # to visit again after its children + + # Remember it. + set visited($node) . + + if {$enter} { + # Evaluate the script at this node (pre, both). + # + # Note: As this is done before the children are + # looked at the script may change the children of + # this node and thus affect the walk. + + WalkCallProc $name $node "enter" $script + # prune stops execution of loop here. + } + + # Add the children of this node to the stack. + # The exact behaviour depends on the chosen + # order. For pre, post, both-order we just + # have to add them in reverse-order so that + # they will be popped left-to-right. For in-order + # we have rearrange the stack so that the parent + # is revisited immediately after the first child. + # (but only if there is ore than one child,) + + set clist $children($node) + set len [llength $clist] + + if {$touch && ($len > 1)} { + # Pop node from stack, insert into list of children + ldelete st end + set clist [linsert $clist 1 $node] + incr len + } + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + lappend st [lindex $clist $i] + } + } + } + } else { + # Breadth first walk (pre, post, both) + # No in-order possible. Already captured. + + if {$leave} { + set backward $st + } + + while { [llength $st] > 0 } { + set node [lindex $st 0] + ldelete st 0 + + if {$enter} { + # Evaluate the script at this node + WalkCallProc $name $node "enter" $script + # prune stops execution of loop here. + } + + # Add this node's children + # And create a mirrored version in case of post/both order. + + foreach child $children($node) { + lappend st $child + if {$leave} { + set backward [linsert $backward 0 $child] + } + } + } + + if {$leave} { + foreach node $backward { + # Evaluate the script at this node + WalkCallProc $name $node "leave" $script + } + } + } + + if {$rcode != 0} { + return -code $rcode $rvalue + } + return +} + +proc ::struct::tree::WalkOptions {theargs n usage} { + upvar 1 type type order order + + # Set defaults + set type dfs + set order pre + + while {[llength $theargs]} { + set flag [lindex $theargs 0] + switch -exact -- $flag { + "-type" { + if {[llength $theargs] < 2} { + return -code error "value for \"$flag\" missing" + } + set type [string tolower [lindex $theargs 1]] + set theargs [lrange $theargs 2 end] + } + "-order" { + if {[llength $theargs] < 2} { + return -code error "value for \"$flag\" missing" + } + set order [string tolower [lindex $theargs 1]] + set theargs [lrange $theargs 2 end] + } + "--" { + set theargs [lrange $theargs 1 end] + break + } + default { + break + } + } + } + + if {[llength $theargs] == 0} { + return -code error "wrong # args: should be \"$usage\"" + } + if {[llength $theargs] != $n} { + return -code error "unknown option \"$flag\"" + } + + # Validate that the given type is good + switch -exact -- $type { + "dfs" - "bfs" { + set type $type + } + default { + return -code error "bad search type \"$type\": must be bfs or dfs" + } + } + + # Validate that the given order is good + switch -exact -- $order { + "pre" - "post" - "in" - "both" { + set order $order + } + default { + return -code error "bad search order \"$order\":\ + must be both, in, pre, or post" + } + } + + if {[string equal $order "in"] && [string equal $type "bfs"]} { + return -code error "unable to do a ${order}-order breadth first walk" + } + + return $theargs +} + +# ::struct::tree::WalkCall -- +# +# Helper command to 'walk' handling the evaluation +# of the user-specified command. Information about +# the tree, node and current action are substituted +# into the command before it evaluation. +# +# Arguments: +# tree Tree we are walking +# node Node we are at. +# action The current action. +# cmd The command to call, already partially substituted. +# +# Results: +# None. + +proc ::struct::tree::WalkCall {avar nvar tree node action cmd} { + + if {$avar != {}} { + upvar 2 $avar a ; set a $action + } + upvar 2 $nvar n ; set n $node + + set code [catch {uplevel 2 $cmd} result] + + # decide what to do upon the return code: + # + # 0 - the body executed successfully + # 1 - the body raised an error + # 2 - the body invoked [return] + # 3 - the body invoked [break] + # 4 - the body invoked [continue] + # 5 - the body invoked [struct::tree::prune] + # everything else - return and pass on the results + # + switch -exact -- $code { + 0 {} + 1 { + return -errorinfo [ErrorInfoAsCaller uplevel WalkCall] \ + -errorcode $::errorCode -code error $result + } + 3 { + # FRINK: nocheck + return -code break + } + 4 {} + 5 { + upvar order order + if {[string equal $order post] || [string equal $order in]} { + return -code error "Illegal attempt to prune ${order}-order walking" + } + return -code continue + } + default { + upvar 1 rcode rcode rvalue rvalue + set rcode $code + set rvalue $result + return -code break + #return -code $code $result + } + } + return {} +} + +proc ::struct::tree::WalkCallProc {tree node action cmd} { + + lappend cmd $tree $node $action + set code [catch {uplevel 2 $cmd} result] + + # decide what to do upon the return code: + # + # 0 - the body executed successfully + # 1 - the body raised an error + # 2 - the body invoked [return] + # 3 - the body invoked [break] + # 4 - the body invoked [continue] + # 5 - the body invoked [struct::tree::prune] + # everything else - return and pass on the results + # + switch -exact -- $code { + 0 {} + 1 { + return -errorinfo [ErrorInfoAsCaller uplevel WalkCallProc] \ + -errorcode $::errorCode -code error $result + } + 3 { + # FRINK: nocheck + return -code break + } + 4 {} + 5 { + upvar order order + if {[string equal $order post] || [string equal $order in]} { + return -code error "Illegal attempt to prune ${order}-order walking" + } + return -code continue + } + default { + upvar 1 rcode rcode rvalue rvalue + set rcode $code + set rvalue $result + return -code break + } + } + return {} +} + +proc ::struct::tree::ErrorInfoAsCaller {find replace} { + set info $::errorInfo + set i [string last "\n (\"$find" $info] + if {$i == -1} {return $info} + set result [string range $info 0 [incr i 6]] ;# keep "\n (\"" + append result $replace ;# $find -> $replace + incr i [string length $find] + set j [string first ) $info [incr i]] ;# keep rest of parenthetical + append result [string range $info $i $j] + return $result +} + +# ::struct::tree::GenerateUniqueNodeName -- +# +# Generate a unique node name for the given tree. +# +# Arguments: +# name Name of the tree to generate a unique node name for. +# +# Results: +# node Name of a node guaranteed to not exist in the tree. + +proc ::struct::tree::GenerateUniqueNodeName {name} { + variable ${name}::nextUnusedNode + while {[_exists $name "node${nextUnusedNode}"]} { + incr nextUnusedNode + } + return "node${nextUnusedNode}" +} + +# ::struct::tree::KillNode -- +# +# Delete all data of a node. +# +# Arguments: +# name Name of the tree containing the node +# node Name of the node to delete. +# +# Results: +# none + +proc ::struct::tree::KillNode {name node} { + variable ${name}::parent + variable ${name}::children + variable ${name}::attribute + + # Remove all record of $node + unset parent($node) + unset children($node) + + if {[info exists attribute($node)]} { + # FRINK: nocheck + unset ${name}::$attribute($node) + unset attribute($node) + } + return +} + +# ::struct::tree::GenAttributeStorage -- +# +# Create an array to store the attributes of a node in. +# +# Arguments: +# name Name of the tree containing the node +# node Name of the node which got attributes. +# +# Results: +# none + +proc ::struct::tree::GenAttributeStorage {name node} { + variable ${name}::nextAttr + variable ${name}::attribute + + set attr "a[incr nextAttr]" + set attribute($node) $attr + return +} + +# ::struct::tree::Serialize -- +# +# Serialize a tree object (partially) into a transportable value. +# +# Arguments: +# name Name of the tree. +# node Root node of the serialized tree. +# +# Results: +# None + +proc ::struct::tree::Serialize {name node tvar} { + upvar 1 $tvar tree + + variable ${name}::attribute + variable ${name}::parent + + # 'node' is the root of the tree to serialize. The precondition + # for the call is that this node is already stored in the list + # 'tvar', at index 'rootidx'. + + # The attribute data for 'node' goes immediately after the 'node' + # data. the node information is _not_ yet stored, and this command + # has to do this. + + + array set r {} + set loc($node) 0 + + lappend tree $node {} + if {[info exists attribute($node)]} { + upvar ${name}::$attribute($node) data + lappend tree [array get data] + } else { + # Encode nodes without attributes. + lappend tree {} + } + + foreach n [DescendantsCore $name $node] { + set loc($n) [llength $tree] + lappend tree $n $loc($parent($n)) + + if {[info exists attribute($n)]} { + upvar ${name}::$attribute($n) data + lappend tree [array get data] + } else { + # Encode nodes without attributes. + lappend tree {} + } + } + + return $tree +} + + +proc ::struct::tree::CheckSerialization {ser avar pvar cvar rnvar} { + upvar 1 $avar attr $pvar p $cvar ch $rnvar rn + + # Overall length ok ? + + if {[llength $ser] % 3} { + return -code error \ + "error in serialization: list length not a multiple of 3." + } + + set rn {} + array set p {} + array set ch {} + array set attr {} + + # Basic decoder pass + + foreach {node parent nattr} $ser { + + # Initialize children data, if not already done + if {![info exists ch($node)]} { + set ch($node) {} + } + # Attribute length ok ? Dictionary! + if {[llength $nattr] % 2} { + return -code error \ + "error in serialization: malformed attribute dictionary." + } + # Remember attribute data only for non-empty nodes + if {[llength $nattr]} { + set attr($node) $nattr + } + # Remember root + if {$parent == {}} { + lappend rn $node + set p($node) {} + continue + } + # Parent reference ok ? + if { + ![string is integer -strict $parent] || + ($parent % 3) || + ($parent < 0) || + ($parent >= [llength $ser]) + } { + return -code error \ + "error in serialization: bad parent reference \"$parent\"." + } + # Remember parent, and reconstruct children + + set p($node) [lindex $ser $parent] + lappend ch($p($node)) $node + } + + # Root node information ok ? + + if {[llength $rn] < 1} { + return -code error \ + "error in serialization: no root specified." + } elseif {[llength $rn] > 1} { + return -code error \ + "error in serialization: multiple root nodes." + } + set rn [lindex $rn 0] + + # Duplicate node names ? + + if {[array size ch] < ([llength $ser] / 3)} { + return -code error \ + "error in serialization: duplicate node names." + } + + # Cycles in the parent relationship ? + + array set visited {} + foreach n [array names p] { + if {[info exists visited($n)]} {continue} + array set _ {} + while {$n != {}} { + if {[info exists _($n)]} { + # Node already converted, cycle. + return -code error \ + "error in serialization: cycle detected." + } + set _($n) . + # root ? + if {$p($n) == {}} {break} + set n $p($n) + if {[info exists visited($n)]} {break} + set visited($n) . + } + unset _ + } + # Ok. The data is now ready for the caller. + + return +} + +########################## +# Private functions follow +# +# Do a compatibility version of [lset] for pre-8.4 versions of Tcl. +# This version does not do multi-arg [lset]! + +proc ::struct::tree::K { x y } { set x } + +if { [package vcompare [package provide Tcl] 8.4] < 0 } { + proc ::struct::tree::lset { var index arg } { + upvar 1 $var list + set list [::lreplace [K $list [set list {}]] $index $index $arg] + } +} + +proc ::struct::tree::ldelete {var index {end {}}} { + upvar 1 $var list + if {$end == {}} {set end $index} + set list [lreplace [K $list [set list {}]] $index $end] + return +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Put 'tree::tree' into the general structure namespace + # for pickup by the main management. + + namespace import -force tree::tree_tcl +} diff --git a/src/bootsupport/lib/term/ansi/code.tcl b/src/bootsupport/lib/term/ansi/code.tcl new file mode 100644 index 00000000..a8f7d3e9 --- /dev/null +++ b/src/bootsupport/lib/term/ansi/code.tcl @@ -0,0 +1,56 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - ANSI +## Generic commands to define commands for code sequences. + +# ### ### ### ######### ######### ######### +## Requirements + +namespace eval ::term::ansi::code {} + +# ### ### ### ######### ######### ######### +## API. Escape clauses, plain and bracket +## Used by 'define'd commands. + +proc ::term::ansi::code::esc {str} {return \033$str} +proc ::term::ansi::code::escb {str} {esc \[$str} + +# ### ### ### ######### ######### ######### +## API. Define command for named control code, or constant. +## (Simple definitions without arguments) + +proc ::term::ansi::code::define {name escape code} { + proc [Qualified $name] {} [list ::term::ansi::code::$escape $code] +} + +proc ::term::ansi::code::const {name code} { + proc [Qualified $name] {} [list return $code] +} + +# ### ### ### ######### ######### ######### +## Internal helper to construct fully-qualified names. + +proc ::term::ansi::code::Qualified {name} { + if {![string match ::* $name]} { + # Get the caller's namespace; append :: if it is not the + # global namespace, for separation from the actual name. + set ns [uplevel 2 [list namespace current]] + if {$ns ne "::"} {append ns ::} + set name $ns$name + } + return $name +} + +# ### ### ### ######### ######### ######### + +namespace eval ::term::ansi::code { + namespace export esc escb define const +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::ansi::code 0.2 + +## +# ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/ansi/code/attr.tcl b/src/bootsupport/lib/term/ansi/code/attr.tcl new file mode 100644 index 00000000..d7d062b8 --- /dev/null +++ b/src/bootsupport/lib/term/ansi/code/attr.tcl @@ -0,0 +1,108 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - ANSI - Attribute codes + +# ### ### ### ######### ######### ######### +## Requirements + +package require term::ansi::code ; # Constants + +namespace eval ::term::ansi::code::attr {} + +# ### ### ### ######### ######### ######### +## API. Symbolic names. + +proc ::term::ansi::code::attr::names {} { + variable attr + return $attr +} + +proc ::term::ansi::code::attr::import {{ns attr} args} { + if {![llength $args]} {set args *} + set args ::term::ansi::code::attr::[join $args " ::term::ansi::code::attr::"] + uplevel 1 [list namespace eval ${ns} [linsert $args 0 namespace import]] + return +} + +# ### ### ### ######### ######### ######### +## Internal - Setup + +proc ::term::ansi::code::attr::DEF {name value} { + variable attr + const $name $value + lappend attr $name + namespace export $name + return +} + +proc ::term::ansi::code::attr::INIT {} { + # ### ### ### ######### ######### ######### + ## + + # Colors. Foreground <=> Text + DEF fgblack 30 ; # Black + DEF fgred 31 ; # Red + DEF fggreen 32 ; # Green + DEF fgyellow 33 ; # Yellow + DEF fgblue 34 ; # Blue + DEF fgmagenta 35 ; # Magenta + DEF fgcyan 36 ; # Cyan + DEF fgwhite 37 ; # White + DEF fgdefault 39 ; # Default (Black) + + # Colors. Background. + DEF bgblack 40 ; # Black + DEF bgred 41 ; # Red + DEF bggreen 42 ; # Green + DEF bgyellow 43 ; # Yellow + DEF bgblue 44 ; # Blue + DEF bgmagenta 45 ; # Magenta + DEF bgcyan 46 ; # Cyan + DEF bgwhite 47 ; # White + DEF bgdefault 49 ; # Default (Transparent) + + # Non-color attributes. Activation. + DEF bold 1 ; # Bold + DEF dim 2 ; # Dim + DEF italic 3 ; # Italics + DEF underline 4 ; # Underscore + DEF blink 5 ; # Blink + DEF revers 7 ; # Reverse + DEF hidden 8 ; # Hidden + DEF strike 9 ; # StrikeThrough + + # Non-color attributes. Deactivation. + DEF nobold 22 ; # Bold + DEF nodim __ ; # Dim + DEF noitalic 23 ; # Italics + DEF nounderline 24 ; # Underscore + DEF noblink 25 ; # Blink + DEF norevers 27 ; # Reverse + DEF nohidden 28 ; # Hidden + DEF nostrike 29 ; # StrikeThrough + + # Remainder + DEF reset 0 ; # Reset + + ## + # ### ### ### ######### ######### ######### + return +} + +# ### ### ### ######### ######### ######### +## Data structures. + +namespace eval ::term::ansi::code::attr { + namespace import ::term::ansi::code::const + variable attr {} +} + +::term::ansi::code::attr::INIT + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::ansi::code::attr 0.1 + +## +# ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/ansi/code/ctrl.tcl b/src/bootsupport/lib/term/ansi/code/ctrl.tcl new file mode 100644 index 00000000..eb2e3b24 --- /dev/null +++ b/src/bootsupport/lib/term/ansi/code/ctrl.tcl @@ -0,0 +1,272 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - ANSI - Control codes + +## References +# [0] Google: ansi terminal control +# [1] http://vt100.net/docs/vt100-ug/chapter3.html +# [2] http://www.termsys.demon.co.uk/vtansi.htm +# [3] http://rrbrandt.dyndns.org:60000/docs/tut/redes/ansi.php +# [4] http://www.dee.ufcg.edu.br/~rrbrandt/tools/ansi.html +# [5] http://www.ecma-international.org/publications/standards/Ecma-048.htm + +# ### ### ### ######### ######### ######### +## Requirements + +package require term::ansi::code +package require term::ansi::code::attr + +namespace eval ::term::ansi::code::ctrl {} + +# ### ### ### ######### ######### ######### +## API. Symbolic names. + +proc ::term::ansi::code::ctrl::names {} { + variable ctrl + return $ctrl +} + +proc ::term::ansi::code::ctrl::import {{ns ctrl} args} { + if {![llength $args]} {set args *} + set args ::term::ansi::code::ctrl::[join $args " ::term::ansi::code::ctrl::"] + uplevel 1 [list namespace eval $ns [linsert $args 0 namespace import]] + return +} + +# ### ### ### ######### ######### ######### + +## TODO = symbolic key codes for skd. + +# ### ### ### ######### ######### ######### +## Internal - Setup + +proc ::term::ansi::code::ctrl::DEF {name esc value} { + variable ctrl + define $name $esc $value + lappend ctrl $name + namespace export $name + return +} + +proc ::term::ansi::code::ctrl::DEFC {name arguments script} { + variable ctrl + proc $name $arguments $script + lappend ctrl $name + namespace export $name + return +} + +proc ::term::ansi::code::ctrl::INIT {} { + # ### ### ### ######### ######### ######### + ## + + # Erasing + + DEF eeol escb K ; # Erase (to) End Of Line + DEF esol escb 1K ; # Erase (to) Start Of Line + DEF el escb 2K ; # Erase (current) Line + DEF ed escb J ; # Erase Down (to bottom) + DEF eu escb 1J ; # Erase Up (to top) + DEF es escb 2J ; # Erase Screen + + # Scrolling + + DEF sd esc D ; # Scroll Down + DEF su esc M ; # Scroll Up + + # Cursor Handling + + DEF ch escb H ; # Cursor Home + DEF sc escb s ; # Save Cursor + DEF rc escb u ; # Restore Cursor (Unsave) + DEF sca esc 7 ; # Save Cursor + Attributes + DEF rca esc 8 ; # Restore Cursor + Attributes + + # Tabbing + + DEF st esc H ; # Set Tab (@ current position) + DEF ct escb g ; # Clear Tab (@ current position) + DEF cat escb 3g ; # Clear All Tabs + + # Device Introspection + + DEF qdc escb c ; # Query Device Code + DEF qds escb 5n ; # Query Device Status + DEF qcp escb 6n ; # Query Cursor Position + DEF rd esc c ; # Reset Device + + # Linewrap on/off + + DEF elw escb 7h ; # Enable Line Wrap + DEF dlw escb 7l ; # Disable Line Wrap + + # Graphics Mode (aka use alternate font on/off) + + DEF eg esc F ; # Enter Graphics Mode + DEF lg esc G ; # Exit Graphics Mode + + ## + # ### ### ### ######### ######### ######### + + # ### ### ### ######### ######### ######### + ## Complex, parameterized codes + + # Select Character Set + # Choose which char set is used for default and + # alternate font. This does not change whether + # default or alternate font are used + + DEFC scs0 {tag} {esc ($tag} ; # Set default character set + DEFC scs1 {tag} {esc )$tag} ; # Set alternate character set + + # tags in A : United Kingdom Set + # B : ASCII Set + # 0 : Special Graphics + # 1 : Alternate Character ROM Standard Character Set + # 2 : Alternate Character ROM Special Graphics + + # Set Display Attributes + + DEFC sda {args} {escb [join $args \;]m} + + # Force Cursor Position (aka Go To) + + DEFC fcp {r c} {escb ${r}\;${c}f} + + # Cursor Up, Down, Forward, Backward + + DEFC cu {{n 1}} {escb [expr {$n == 1 ? "A" : "${n}A"}]} + DEFC cd {{n 1}} {escb [expr {$n == 1 ? "B" : "${n}B"}]} + DEFC cf {{n 1}} {escb [expr {$n == 1 ? "C" : "${n}C"}]} + DEFC cb {{n 1}} {escb [expr {$n == 1 ? "D" : "${n}D"}]} + + # Scroll Screen (entire display, or between rows start end, inclusive). + + DEFC ss {args} { + if {[llength $args] == 0} {return [escb r]} + if {[llength $args] == 2} {foreach {s e} $args break ; return [escb ${s};${e}r]} + return -code error "wrong\#args" + } + + # Set Key Definition + + DEFC skd {code str} {escb $code\;\"$str\"p} + + # Terminal title + + DEFC title {str} {esc \]0\;$str\007} + + # Switch to and from character/box graphics. + + DEFC gron {} {esc (0} + DEFC groff {} {esc (B} + + # Character graphics, box symbols + # - 4 corners, 4 t-junctions, + # one 4-way junction, 2 lines + + DEFC tlc {} {return [gron]l[groff]} ; # Top Left Corner + DEFC trc {} {return [gron]k[groff]} ; # Top Right Corner + DEFC brc {} {return [gron]j[groff]} ; # Bottom Right Corner + DEFC blc {} {return [gron]m[groff]} ; # Bottom Left Corner + + DEFC ltj {} {return [gron]t[groff]} ; # Left T Junction + DEFC ttj {} {return [gron]w[groff]} ; # Top T Junction + DEFC rtj {} {return [gron]u[groff]} ; # Right T Junction + DEFC btj {} {return [gron]v[groff]} ; # Bottom T Junction + + DEFC fwj {} {return [gron]n[groff]} ; # Four-Way Junction + + DEFC hl {} {return [gron]q[groff]} ; # Horizontal Line + DEFC vl {} {return [gron]x[groff]} ; # Vertical Line + + # Optimize character graphics. The generator commands above create + # way to many superfluous commands shifting into and out of the + # graphics mode. The command below removes all shifts which are + # not needed. To this end it also knows which characters will look + # the same in both modes, to handle strings created outside this + # package. + + DEFC groptim {string} { + variable grforw + variable grback + set offon [groff][gron] + set onoff [gron][groff] + while {![string equal $string [set new [string map \ + [list $offon {} $onoff {}] [string map \ + $grback [string map \ + $grforw $string]]]]]} { + set string $new + } + return $string + } + + ## + # ### ### ### ######### ######### ######### + + # ### ### ### ######### ######### ######### + ## Higher level operations + + # Clear screen <=> CursorHome + EraseDown + # Init (Fonts): Default ASCII, Alternate Graphics + # Show a block of text at a specific location. + + DEFC clear {} {return [ch][ed]} + DEFC init {} {return [scs0 B][scs1 0]} + + DEFC showat {r c text} { + if {![string length $text]} {return {}} + return [fcp $r $c][sca][join \ + [split $text \n] \ + [rca][cd][sca]][rca][cd] + } + + ## + # ### ### ### ######### ######### ######### + + # ### ### ### ######### ######### ######### + ## Attribute control (single attributes) + + foreach a [::term::ansi::code::attr::names] { + DEF sda_$a escb [::term::ansi::code::attr::$a]m + } + + ## + # ### ### ### ######### ######### ######### + return +} + +# ### ### ### ######### ######### ######### +## Data structures. + +namespace eval ::term::ansi::code::ctrl { + namespace import ::term::ansi::code::define + namespace import ::term::ansi::code::esc + namespace import ::term::ansi::code::escb + + variable grforw + variable grback + variable _ + + foreach _ { + ! \" # $ % & ' ( ) * + , - . / + 0 1 2 3 4 5 6 7 8 9 : ; < = > + ? @ A B C D E F G H I J K L M + N O P Q R S T U V W X Y Z [ ^ + \\ ] + } { + lappend grforw \016$_ $_\016 + lappend grback $_\017 \017$_ + } + unset _ +} + +::term::ansi::code::ctrl::INIT + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::ansi::code::ctrl 0.3 + +## +# ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/ansi/code/macros.tcl b/src/bootsupport/lib/term/ansi/code/macros.tcl new file mode 100644 index 00000000..1f1d47d3 --- /dev/null +++ b/src/bootsupport/lib/term/ansi/code/macros.tcl @@ -0,0 +1,93 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - ANSI - Higher level macros + +# ### ### ### ######### ######### ######### +## Requirements + +package require textutil::repeat +package require textutil::tabify +package require term::ansi::code::ctrl + +namespace eval ::term::ansi::code::macros {} + +# ### ### ### ######### ######### ######### +## API. Symbolic names. + +proc ::term::ansi::code::macros::import {{ns macros} args} { + if {![llength $args]} {set args *} + set args ::term::ansi::code::macros::[join $args " ::term::ansi::code::macros::"] + uplevel 1 [list namespace eval ${ns} [linsert $args 0 namespace import]] + return +} + +# ### ### ### ######### ######### ######### +## Higher level operations + +# Format a menu / framed block of text + +proc ::term::ansi::code::macros::menu {menu} { + # Menu = dict (label => char) + array set _ {} + set shift 0 + foreach {label c} $menu { + if {[string first $c $label] < 0} { + set shift 1 + break + } + } + set max 0 + foreach {label c} $menu { + set pos [string first $c $label] + if {$shift || ($pos < 0)} { + set xlabel "$c $label" + set pos 0 + } else { + set xlabel $label + } + set len [string length $xlabel] + if {$len > $max} {set max $len} + set _($label) " [string replace $xlabel $pos $pos \ + [cd::sda_fgred][cd::sda_bold][string index $xlabel $pos][cd::sda_reset]]" + } + + append ms [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]\n + foreach {l c} $menu {append ms $_($l)\n} + append ms [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc] + + return [cd::groptim $ms] +} + +proc ::term::ansi::code::macros::frame {string} { + set lines [split [textutil::tabify::untabify2 $string] \n] + set max 0 + foreach l $lines { + if {[set len [string length $l]] > $max} {set max $len} + } + append fs [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]\n + foreach l $lines { + append fs [cd::vl]${l}[textutil::repeat::strRepeat " " [expr {$max-[string length $l]}]][cd::vl]\n + } + append fs [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc] + return [cd::groptim $fs] +} + +## +# ### ### ### ######### ######### ######### + +# ### ### ### ######### ######### ######### +## Data structures. + +namespace eval ::term::ansi::code::macros { + term::ansi::code::ctrl::import cd + + namespace export menu frame +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::ansi::code::macros 0.1 + +## +# ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/ansi/ctrlunix.tcl b/src/bootsupport/lib/term/ansi/ctrlunix.tcl new file mode 100644 index 00000000..675348c7 --- /dev/null +++ b/src/bootsupport/lib/term/ansi/ctrlunix.tcl @@ -0,0 +1,91 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - ANSI - Control operations +## (Unix specific implementation). + +## This was originally taken from page 11820 (Pure Tcl Console Editor) +## of the Tcler's Wiki, however page 14693 (Reading a single character +## ...) is the same in a more self-contained manner. + +# ### ### ### ######### ######### ######### +## Requirements + +namespace eval ::term::ansi::ctrl::unix {} + +# ### ### ### ######### ######### ######### +## Make command easily available + +proc ::term::ansi::ctrl::unix::import {{ns ctrl} args} { + if {![llength $args]} {set args *} + set args ::term::ansi::ctrl::unix::[join $args " ::term::ansi::ctrl::unix::"] + uplevel 1 [list namespace eval ${ns} [linsert $args 0 namespace import]] + return +} + +# ### ### ### ######### ######### ######### +## API + +# We use the <@stdin because stty works out what terminal to work with +# using standard input on some platforms. On others it prefers +# /dev/tty instead, but putting in the redirection makes the code more +# portable + +proc ::term::ansi::ctrl::unix::raw {} { + variable stty + exec $stty raw -echo <@stdin + return +} + +proc ::term::ansi::ctrl::unix::cooked {} { + variable stty + exec $stty -raw echo <@stdin + return +} + +proc ::term::ansi::ctrl::unix::columns {} { + variable tput + return [exec $tput cols <@stdin] +} + +proc ::term::ansi::ctrl::unix::rows {} { + variable tput + return [exec $tput lines <@stdin] +} + +# ### ### ### ######### ######### ######### +## Package setup + +proc ::term::ansi::ctrl::unix::INIT {} { + variable tput [auto_execok tput] + variable stty [auto_execok stty] + + if {($stty eq "/usr/ucb/stty") && + ($::tcl_platform(os) eq "SunOS")} { + set stty /usr/bin/stty + } + + if {($tput eq "") || ($stty eq "")} { + return -code error \ + "The external requirements for the \ + use of this package (tput, stty in \ + \$PATH) are not met." + } + return +} + +namespace eval ::term::ansi::ctrl::unix { + variable tput {} + variable stty {} + + namespace export columns rows raw cooked +} + +::term::ansi::ctrl::unix::INIT + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::ansi::ctrl::unix 0.1.1 + +## +# ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/ansi/send.tcl b/src/bootsupport/lib/term/ansi/send.tcl new file mode 100644 index 00000000..d47f834a --- /dev/null +++ b/src/bootsupport/lib/term/ansi/send.tcl @@ -0,0 +1,92 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - ANSI - Control codes + +# ### ### ### ######### ######### ######### +## Requirements + +package require Tcl 8.4 +package require term::send +package require term::ansi::code::ctrl + +namespace eval ::term::ansi::send {} + +# ### ### ### ######### ######### ######### +## Make command easily available + +proc ::term::ansi::send::import {{ns send} args} { + if {![llength $args]} {set args *} + set args ::term::ansi::send::[join $args " ::term::ansi::send::"] + uplevel 1 [list namespace eval ${ns} [linsert $args 0 namespace import]] + return +} + +# ### ### ### ######### ######### ######### +## Internal - Setup. + +proc ::term::ansi::send::ChName {n} { + if {![string match *-* $n]} { + return ${n}ch + } + set nl [split $n -] + set stem [lindex $nl 0] + set sfx [join [lrange $nl 1 end] -] + return ${stem}ch-$sfx +} + +proc ::term::ansi::send::Args {n -> arv achv avv} { + upvar 1 $arv a $achv ach $avv av + set code ::term::ansi::code::ctrl::$n + set a [info args $code] + set av [expr { + [llength $a] + ? " \$[join $a { $}]" + : $a + }] + foreach a1 $a[set a {}] { + if {[info default $code $a1 default]} { + lappend a [list $a1 $default] + } else { + lappend a $a1 + } + } + set ach [linsert $a 0 ch] + return $code +} + +proc ::term::ansi::send::INIT {} { + foreach n [::term::ansi::code::ctrl::names] { + set nch [ChName $n] + set code [Args $n -> a ach av] + + if {[lindex $a end] eq "args"} { + # An args argument requires more care, and an eval + set av [lrange $av 0 end-1] + if {$av ne {}} {set av " $av"} + set gen "eval \[linsert \$args 0 $code$av\]" + #8.5: (written for clarity): set gen "$code$av {*}\$args" + } else { + set gen $code$av + } + + proc $n $a "wr \[$gen\]" ; namespace export $n + proc $nch $ach "wrch \$ch \[$gen\]" ; namespace export $nch + } + return +} + +namespace eval ::term::ansi::send { + namespace import ::term::send::wr + namespace import ::term::send::wrch + namespace export wr wrch +} + +::term::ansi::send::INIT + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::ansi::send 0.2 + +## +# ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/bind.tcl b/src/bootsupport/lib/term/bind.tcl new file mode 100644 index 00000000..8342442d --- /dev/null +++ b/src/bootsupport/lib/term/bind.tcl @@ -0,0 +1,132 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - string -> action mappings +## (bind objects). For use with 'receive listen'. +## In essence a DFA with tree structure. + +# ### ### ### ######### ######### ######### +## Requirements + +package require snit +package require term::receive +namespace eval ::term::receive::bind {} + +# ### ### ### ######### ######### ######### + +snit::type ::term::receive::bind { + + constructor {{dict {}}} { + foreach {str cmd} $dict {Register $str $cmd} + return + } + + method map {str cmd} { + Register $str $cmd + return + } + + method default {cmd} { + set default $cmd + return + } + + # ### ### ### ######### ######### ######### + ## + + method listen {{chan stdin}} { + #parray dfa + ::term::receive::listen $self $chan + return + } + + method unlisten {{chan stdin}} { + ::term::receive::unlisten $chan + return + } + + # ### ### ### ######### ######### ######### + ## + + variable default {} + variable state {} + + method reset {} { + set state {} + return + } + + method next {c} {Next $c ; return} + method process {str} { + foreach c [split $str {}] {Next $c} + return + } + + method eof {} {Eof ; return} + + proc Next {c} { + upvar 1 dfa dfa state state default default + set key [list $state $c] + + #puts -nonewline stderr "('$state' x '$c')" + + if {![info exists dfa($key)]} { + # Unknown sequence. Reset. Restart. + # Run it through the default action. + + if {$default ne ""} { + uplevel #0 [linsert $default end $state$c] + } + + #puts stderr =\ RESET + set state {} + } else { + foreach {what detail} $dfa($key) break + #puts -nonewline stderr "= $what '$detail'" + if {$what eq "t"} { + # Incomplete sequence. Next state. + set state $detail + #puts stderr " goto ('$state')" + } elseif {$what eq "a"} { + # Action, then reset. + set state {} + #puts stderr " run ($detail)" + uplevel #0 [linsert $detail end $state$c] + } else { + return -code error \ + "Internal error. Bad DFA." + } + } + return + } + + proc Eof {} {} + + # ### ### ### ######### ######### ######### + ## + + proc Register {str cmd} { + upvar 1 dfa dfa + set prefix {} + set last {{} {}} + foreach c [split $str {}] { + set key [list $prefix $c] + set next $prefix$c + set dfa($key) [list t $next] + set last $key + set prefix $next + } + set dfa($last) [list a $cmd] + } + variable dfa -array {} + + ## + # ### ### ### ######### ######### ######### +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::receive::bind 0.1 + +## +# ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/imenu.tcl b/src/bootsupport/lib/term/imenu.tcl new file mode 100644 index 00000000..42a7fab5 --- /dev/null +++ b/src/bootsupport/lib/term/imenu.tcl @@ -0,0 +1,202 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - string -> action mappings +## (menu objects). For use with 'receive listen'. +## In essence a DFA with tree structure. + +# ### ### ### ######### ######### ######### +## Requirements + +package require snit +package require textutil::repeat +package require textutil::tabify +package require term::ansi::send +package require term::receive::bind +package require term::ansi::code::ctrl + +namespace eval ::term::receive::menu {} + +# ### ### ### ######### ######### ######### + +snit::type ::term::interact::menu { + + option -in -default stdin + option -out -default stdout + option -column -default 0 + option -line -default 0 + option -height -default 25 + option -actions -default {} + option -hilitleft -default 0 + option -hilitright -default end + option -framed -default 0 -readonly 1 + + # ### ### ### ######### ######### ######### + ## + + constructor {dict args} { + $self configurelist $args + Save $dict + + install bind using ::term::receive::bind \ + ${selfns}::bind $options(-actions) + + $bind map [cd::cu] [mymethod Up] + $bind map [cd::cd] [mymethod Down] + $bind map \n [mymethod Select] + #$bind default [mymethod DEF] + + return + } + + # ### ### ### ######### ######### ######### + ## + + method interact {} { + Show + $bind listen $options(-in) + vwait [myvar done] + $bind unlisten $options(-in) + return $map($done) + } + + method done {} {set done $at ; return} + method clear {} {Clear ; return} + + # ### ### ### ######### ######### ######### + ## + + component bind + + # ### ### ### ######### ######### ######### + ## + + variable map -array {} + variable header + variable labels + variable footer + variable empty + + proc Save {dict} { + upvar 1 header header labels labels footer footer + upvar 1 empty empty at at map map top top + upvar 1 options(-height) height + + set max 0 + foreach {l code} $dict { + if {[set len [string length $l]] > $max} {set max $len} + } + + set header [cd::groptim [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]] + set footer [cd::groptim [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc]] + + set labels {} + set at 0 + foreach {l code} $dict { + set map($at) $code + lappend labels ${l}[textutil::repeat::strRepeat " " [expr {$max-[string length $l]}]] + incr at + } + + set h $height + if {$h > [llength $labels]} {set h [llength $labels]} + + set eline " [textutil::repeat::strRepeat { } $max]" + set empty $eline + for {set i 0} {$i <= $h} {incr i} { + append empty \n$eline + } + + set at 0 + set top 0 + return + } + + variable top 0 + variable at 0 + variable done . + + proc Show {} { + upvar 1 header header labels labels footer footer at at + upvar 1 options(-in) in options(-column) col top top + upvar 1 options(-out) out options(-line) row + upvar 1 options(-height) height options(-framed) framed + upvar 1 options(-hilitleft) left + upvar 1 options(-hilitright) right + + set bot [expr {$top + $height - 1}] + set fr [expr {$framed ? [cd::vl] : { }}] + + set text $header\n + set i $top + foreach l [lrange $labels $top $bot] { + append text $fr + if {$i != $at} { + append text $l + } else { + append text [string replace $l $left $right \ + [cd::sda_revers][string range $l $left $right][cd::sda_reset]] + } + append text $fr \n + incr i + } + append text $footer + + vt::wrch $out [cd::showat $row $col $text] + return + } + + proc Clear {} { + upvar 1 empty empty options(-column) col + upvar 1 options(-out) out options(-line) row + + vt::wrch $out [cd::showat $row $col $empty] + return + } + + # ### ### ### ######### ######### ######### + ## + + method Up {str} { + if {$at == 0} return + incr at -1 + if {$at < $top} {incr top -1} + Show + return + } + + method Down {str} { + upvar 0 options(-height) height + if {$at == ([llength $labels]-1)} return + incr at + set bot [expr {$top + $height - 1}] + if {$at > $bot} {incr top} + Show + return + } + + method Select {str} { + $self done + return + } + + method DEF {str} { + puts stderr "($str)" + exit + } + + ## + # ### ### ### ######### ######### ######### +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::term::interact::menu { + term::ansi::code::ctrl::import cd + term::ansi::send::import vt +} + +package provide term::interact::menu 0.1 + +## +# ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/ipager.tcl b/src/bootsupport/lib/term/ipager.tcl new file mode 100644 index 00000000..59c1c580 --- /dev/null +++ b/src/bootsupport/lib/term/ipager.tcl @@ -0,0 +1,206 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - string -> action mappings +## (pager objects). For use with 'receive listen'. +## In essence a DFA with tree structure. + +# ### ### ### ######### ######### ######### +## Requirements + +package require snit +package require textutil::repeat +package require textutil::tabify +package require term::ansi::send +package require term::receive::bind +package require term::ansi::code::ctrl + +namespace eval ::term::receive::pager {} + +# ### ### ### ######### ######### ######### + +snit::type ::term::interact::pager { + + option -in -default stdin + option -out -default stdout + option -column -default 0 + option -line -default 0 + option -height -default 25 + option -actions -default {} + + # ### ### ### ######### ######### ######### + ## + + constructor {str args} { + $self configurelist $args + Save $str + + install bind using ::term::receive::bind \ + ${selfns}::bind $options(-actions) + + $bind map [cd::cu] [mymethod Up] + $bind map [cd::cd] [mymethod Down] + $bind map \033\[5~ [mymethod PageUp] + $bind map \033\[6~ [mymethod PageDown] + $bind map \n [mymethod Done] + #$bind default [mymethod DEF] + + return + } + + # ### ### ### ######### ######### ######### + ## + + method interact {} { + Show + $bind listen $options(-in) + set interacting 1 + vwait [myvar done] + set interacting 0 + $bind unlisten $options(-in) + return + } + + method done {} {set done . ; return} + method clear {} {Clear ; return} + + method text {str} { + if {$interacting} {Clear} + Save $str + if {$interacting} {Show} + return + } + + # ### ### ### ######### ######### ######### + ## + + component bind + + # ### ### ### ######### ######### ######### + ## + + variable header + variable text + variable footer + variable empty + + proc Save {str} { + upvar 1 header header text text footer footer maxline maxline + upvar 1 options(-height) height empty empty at at + + set lines [split [textutil::tabify::untabify2 $str] \n] + + set max 0 + foreach l $lines { + if {[set len [string length $l]] > $max} {set max $len} + } + + set header [cd::groptim [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]] + set footer [cd::groptim [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc]] + + set text {} + foreach l $lines { + lappend text [cd::vl]${l}[textutil::repeat::strRepeat " " [expr {$max-[string length $l]}]][cd::vl] + } + + set h $height + if {$h > [llength $text]} {set h [llength $text]} + + set eline " [textutil::repeat::strRepeat { } $max]" + set empty $eline + for {set i 0} {$i <= $h} {incr i} { + append empty \n$eline + } + + set maxline [expr {[llength $text] - $height}] + if {$maxline < 0} {set maxline 0} + set at 0 + return + } + + variable interacting 0 + variable at 0 + variable maxline -1 + variable done . + + proc Show {} { + upvar 1 header header text text footer footer at at + upvar 1 options(-in) in options(-column) col + upvar 1 options(-out) out options(-line) row + upvar 1 options(-height) height + + set to [expr {$at + $height -1}] + + vt::wrch $out [cd::showat $row $col \ + $header\n[join [lrange $text $at $to] \n]\n$footer] + return + } + + proc Clear {} { + upvar 1 empty empty options(-column) col + upvar 1 options(-out) out options(-line) row + + vt::wrch $out [cd::showat $row $col $empty] + return + } + + # ### ### ### ######### ######### ######### + ## + + method Up {str} { + if {$at == 0} return + incr at -1 + Show + return + } + + method Down {str} { + if {$at >= $maxline} return + incr at + Show + return + } + + method PageUp {str} { + set newat [expr {$at - $options(-height) + 1}] + if {$newat < 0} {set newat 0} + if {$newat == $at} return + set at $newat + Show + return + } + + method PageDown {str} { + set newat [expr {$at + $options(-height) - 1}] + if {$newat >= $maxline} {set newat $maxline} + if {$newat == $at} return + set at $newat + Show + return + } + + method Done {str} { + $self done + return + } + + method DEF {str} { + puts stderr "($str)" + exit + } + + ## + # ### ### ### ######### ######### ######### +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::term::interact::pager { + term::ansi::code::ctrl::import cd + term::ansi::send::import vt +} + +package provide term::interact::pager 0.1 + +## +# ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/pkgIndex.tcl b/src/bootsupport/lib/term/pkgIndex.tcl new file mode 100644 index 00000000..bd06c3a8 --- /dev/null +++ b/src/bootsupport/lib/term/pkgIndex.tcl @@ -0,0 +1,13 @@ +if {![package vsatisfies [package provide Tcl] 8.4]} return +package ifneeded term 0.1 [list source [file join $dir term.tcl]] +package ifneeded term::ansi::code 0.2 [list source [file join $dir ansi/code.tcl]] +package ifneeded term::ansi::code::attr 0.1 [list source [file join $dir ansi/code/attr.tcl]] +package ifneeded term::ansi::code::ctrl 0.3 [list source [file join $dir ansi/code/ctrl.tcl]] +package ifneeded term::ansi::code::macros 0.1 [list source [file join $dir ansi/code/macros.tcl]] +package ifneeded term::ansi::ctrl::unix 0.1.1 [list source [file join $dir ansi/ctrlunix.tcl]] +package ifneeded term::ansi::send 0.2 [list source [file join $dir ansi/send.tcl]] +package ifneeded term::interact::menu 0.1 [list source [file join $dir imenu.tcl]] +package ifneeded term::interact::pager 0.1 [list source [file join $dir ipager.tcl]] +package ifneeded term::receive 0.1 [list source [file join $dir receive.tcl]] +package ifneeded term::receive::bind 0.1 [list source [file join $dir bind.tcl]] +package ifneeded term::send 0.1 [list source [file join $dir send.tcl]] diff --git a/src/bootsupport/lib/term/receive.tcl b/src/bootsupport/lib/term/receive.tcl new file mode 100644 index 00000000..393549c2 --- /dev/null +++ b/src/bootsupport/lib/term/receive.tcl @@ -0,0 +1,60 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - Generic receiver operations + +# ### ### ### ######### ######### ######### +## Requirements + +namespace eval ::term::receive {} + +# ### ### ### ######### ######### ######### +## API. Read character from specific channel, +## or default (stdin). Processing of +## character sequences. + +proc ::term::receive::getch {{chan stdin}} { + return [read $chan 1] +} + +proc ::term::receive::listen {cmd {chan stdin}} { + fconfigure $chan -blocking 0 + fileevent $chan readable \ + [list ::term::receive::Foreach $chan $cmd] + return +} + +proc ::term::receive::unlisten {{chan stdin}} { + fileevent $chan readable {} + return +} + +# ### ### ### ######### ######### ######### +## Internals + +proc ::term::receive::Foreach {chan cmd} { + set string [read $chan] + if {[string length $string]} { + #puts stderr "F($string)" + uplevel #0 [linsert $cmd end process $string] + } + if {[eof $chan]} { + close $chan + uplevel #0 [linsert $cmd end eof] + } + return +} + +# ### ### ### ######### ######### ######### +## Initialization + +namespace eval ::term::receive { + namespace export getch listen +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::receive 0.1 + +## +# ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/send.tcl b/src/bootsupport/lib/term/send.tcl new file mode 100644 index 00000000..c3e235de --- /dev/null +++ b/src/bootsupport/lib/term/send.tcl @@ -0,0 +1,34 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - Generic sender operations + +# ### ### ### ######### ######### ######### +## Requirements + +namespace eval ::term::send {} + +# ### ### ### ######### ######### ######### +## API. Write to channel, or default (stdout) + +proc ::term::send::wr {str} { + wrch stdout $str + return +} + +proc ::term::send::wrch {ch str} { + puts -nonewline $ch $str + flush $ch + return +} + +namespace eval ::term::send { + namespace export wr wrch +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::send 0.1 + +## +# ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/term.tcl b/src/bootsupport/lib/term/term.tcl new file mode 100644 index 00000000..01d4630c --- /dev/null +++ b/src/bootsupport/lib/term/term.tcl @@ -0,0 +1,19 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - Main :: Generic operations + +# Currently we have no generica at all. We make the package, but it +# provides nothing for now. + +# ### ### ### ######### ######### ######### +## Requirements + +namespace eval ::term {} + +# ### ### ### ######### ######### ######### +## Ready + +package provide term 0.1 + +## +# ### ### ### ######### ######### ######### diff --git a/src/bootsupport/modules/punk/ansi-0.1.0.tm b/src/bootsupport/modules/punk/ansi-0.1.1.tm similarity index 84% rename from src/bootsupport/modules/punk/ansi-0.1.0.tm rename to src/bootsupport/modules/punk/ansi-0.1.1.tm index a499afb3..af5f13ce 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.0.tm +++ b/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::ansi 0.1.0 +# Application punk::ansi 0.1.1 # Meta platform tcl # Meta license # @@ Meta End @@ -16,7 +16,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::ansi 0 0.1.0] +#[manpage_begin punkshell_module_punk::ansi 0 0.1.1] #[copyright "2023"] #[titledesc {Ansi string functions}] [comment {-- Name section and table of contents description --}] #[moddesc {punk Ansi library}] [comment {-- Description at end of page heading --}] @@ -276,7 +276,7 @@ namespace eval punk::ansi { variable SGR_setting_map { bold 1 dim 2 blink 5 fastblink 6 noblink 25 hide 8 normal 22 underline 4 doubleunderline 21 nounderline 24 strike 9 nostrike 29 italic 3 noitalic 23 - reverse 7 noreverse 27 defaultfg 39 defaultbg 49 + reverse 7 noreverse 27 defaultfg 39 defaultbg 49 nohide 28 overline 53 nooverline 55 frame 51 framecircle 52 noframe 54 } variable SGR_colour_map { @@ -561,10 +561,18 @@ namespace eval punk::ansi { #[para]A string created by any move_emit_return for punk::ansi would not behave in an intuitive manner compared to other punk::ansi move functions - so is deliberately omitted. set out "" - append out \033\[${row}\;${col}H$data - foreach {row col data} $args { + if {$row eq "this"} { + append out \033\[\;${col}G$data + } else { append out \033\[${row}\;${col}H$data } + foreach {row col data} $args { + if {$row eq "this"} { + append out \033\[\;${col}G$data + } else { + append out \033\[${row}\;${col}H$data + } + } return $out } proc move_forward {{n 1}} { @@ -587,8 +595,28 @@ namespace eval punk::ansi { #[call [fun move_down] [arg n]] return \033\[${n}B } + proc move_column {col} { + #*** !doctools + #[call [fun move_column] [arg col]] + return \x1b\[${col}g + } + proc move_row {row} { + #*** !doctools + #[call [fun move_row] [arg row]] + return \x1b\[${row}G + } # -- --- --- --- --- + proc save_cursor {} { + #*** !doctools + #[call [fun save_cursor]] + return \x1b\[s + } + proc restore_cursor {} { + #*** !doctools + #[call [fun restore_cursor]] + return \x1b\[u + } # -- --- --- --- --- proc erase_line {} { @@ -610,6 +638,43 @@ namespace eval punk::ansi { #see also clear_above clear_below # -- --- --- --- --- + proc scroll_up {n} { + #*** !doctools + #[call [fun scroll_up] [arg n]] + return \x1b\[${n}S + } + proc scroll_down {n} { + #*** !doctools + #[call [fun scroll_down] [arg n]] + return \x1b\[${n}T + } + + proc insert_spaces {count} { + #*** !doctools + #[call [fun insert_spaces] [arg count]] + return \x1b\[${count}@ + } + proc delete_characters {count} { + #*** !doctools + #[call [fun delete_characters] [arg count]] + return \x1b\[${count}P + } + proc erase_characters {count} { + #*** !doctools + #[call [fun erase_characters] [arg count]] + return \x1b\[${count}X + } + proc insert_lines {count} { + #*** !doctools + #[call [fun insert_lines] [arg count]] + return \x1b\[${count}L + } + proc delete_lines {count} { + #*** !doctools + #[call [fun delete_lines] [arg count]] + return \x1b\[${count}M + } + proc cursor_pos {} { #*** !doctools #[call [fun cursor_pos]] @@ -650,6 +715,7 @@ namespace eval punk::ansi { if {[string first \n $line] >= 0} { error "line_print_length must not contain newline characters" } + #what if line has \v (vertical tab) ie more than one logical screen line? #review - set line [punk::ansi::stripansi $line] @@ -657,6 +723,7 @@ namespace eval punk::ansi { set line [punk::char::strip_nonprinting_ascii $line] ;#only strip nonprinting after stripansi - some like BEL are part of ansi #backspace 0x08 only erases* printing characters anyway - so presumably order of processing doesn't matter #(* more correctly - moves cursor back) + #Note some terminals process backspace before \v - which seems quite wrong #backspace will not move beyond a preceding newline - but we have disallowed newlines for this function already #leading backspaces will eat into any string (even prompt in non-standard tclsh shell) that is prepended to the line # - but for the purposes of overtype we wouldn't want that - so we strip it here in the length calculation and should strip leading backspaces in the actual data concatenation operations too. @@ -671,6 +738,7 @@ namespace eval punk::ansi { set bs [format %c 0x08] #set line [string map [list "\r${bs}" "\r"] $line] ;#backsp following a \r will have no effect set line [string trim $line $bs] + #counterintuitively "x\b" still shows the x ie length is still one. The backspace just moves the position. There must be a char following \b for it to affect the length. set n 0 set chars [split $line ""] @@ -1014,7 +1082,7 @@ namespace eval punk::ansi::ansistring { #\UFFFD - replacement char or \U2426 - #using ISO 2047 graphical representations of control characters + #using ISO 2047 graphical representations of control characters - probably obsolete? #00 NUL Null ⎕ U+2395 NU #01 TC1, SOH Start of Heading ⌈ U+2308 SH #02 TC2, STX Start of Text ⊥ U+22A5 SX @@ -1049,8 +1117,207 @@ namespace eval punk::ansi::ansistring { #1F IS1 US Unit Separator ◳ U+25F3 US #20 SP Space △ U+25B3 SP #7F DEL Delete ▨ —[d] DT - proc VIEW {string} { - return [string map [list \033 \U2296 \007 \U237E] $string] + + #C0 control code visual representations + # Code Val Name 2X Description + # 2400 00 NUL NU Symbol for Null + # 2401 01 SOH SH Symbol for Start of Heading + # 2402 02 STX SX Symbol for Start of Text + # 2403 03 ETX EX Symbol for End of Text + # 2404 04 EOT ET Symbol for End of Transmission + # 2405 05 ENQ EQ Symbol for Enquiry + # 2406 06 ACK AK Symbol for Acknowledge + # 2407 07 BEL BL Symbol for Bell + # 2409 09 BS BS Symbol for Backspace + # 2409 09 HT HT Symbol for Horizontal Tab (1) + # 240A 0A LF LF Symbol for Line Feed (1) + # 240B 0B VT VT Symbol for Vertical Tab (1) + # 240C 0C FF FF Symbol for Form Feed (2) + # 240D 0D CR CR Symbol for Carriage Return (1) + # 240E 0E SO SO Symbol for Shift Out + # 240F 0F SI SI Symbol for Shift In + # 2410 10 DLE DL Symbol for Data Link Escape + # 2411 11 DC1 D1 Symbol for Device Control 1 (2) + # 2412 12 DC2 D2 Symbol for Device Control 2 (2) + # 2413 13 DC3 D3 Symbol for Device Control 3 (2) + # 2414 14 DC4 D4 Symbol for Device Control 4 (2) + # 2415 15 NAK NK Symbol for Negative Acknowledge + # 2416 16 SYN SY Symbol for Synchronous Idle + # 2417 17 ETB EB Symbol for End of Transmission Block + # 2418 18 CAN CN Symbol for Cancel + # 2419 19 EM EM Symbol for End of Medium + # 241A 1A SUB SU Symbol for Substitute + # 241B 1B ESC EC Symbol for Escape + # 241C 1C FS FS Symbol for Field Separator (3) + # 241D 1D GS GS Symbol for Group Separator (3) + # 241E 1E RS RS Symbol for Record Separator (3) + # 241F 1F US US Symbol for Unit Separator (3) + # 2420 20 SP SP Symbol for Space (4) + # 2421 7F DEL DT Symbol for Delete (4) + + #C1 control code visual representations + #Code Val Name 2X Description + # 80 80 80 (1) + # 81 81 81 (1) + # E022 82 BPH 82 Symbol for Break Permitted Here (2) + # E023 83 NBH 83 Symbol for No Break Here (2) + # E024 84 IND IN Symbol for Index (3) + # E025 85 NEL NL Symbol for Next Line (4) + # E026 86 SSA SS Symbol for Start Selected Area + # E027 87 ESA ES Symbol for End Selected Area + # E028 88 HTS HS Symbol for Character Tabulation Set + # E029 89 HTJ HJ Symbol for Character Tabulation with Justification + # E02A 8A VTS VS Symbol for Line Tabulation Set + # E02B 8B PLD PD Symbol for Partial Line Forward + # E02C 8C PLU PU Symbol for Partial Line Backward + # E02D 8D RI RI Symbol for Reverse Line Feed + # E02E 8E SS2 S2 Symbol for Single Shift 2 + # E02F 8F SS3 S3 Symbol for Single Shift 3 + # E030 90 DCS DC Symbol for Device Control String + # E031 91 PU1 P1 Symbol for Private Use 1 + # E032 92 PU2 P2 Symbol for Private Use 2 + # E033 93 STS SE Symbol for Set Transmit State + # E034 94 CCH CC Symbol for Cancel Character + # E035 95 MW MW Symbol for Message Waiting + # E036 96 SPA SP Symbol for Start Protected (Guarded) Area + # E037 97 EPA EP Symbol for End Protected (Guarded) Area + # E038 98 SOS 98 Symbol for Start of String (2) + # 99 99 (1) + # E03A 9A SCI 9A Symbol for Single Character Introducer (2) + # E03B 9B CSI CS Symbol for Control Sequence Introducer (5) + # E03C 9C ST ST Symbol for String Terminator + # E03D 9D OSC OS Symbol for Operating System Command + # E03E 9E PM PM Symbol for Privacy Message + # E03F 9F APC AP Symbol for Application Program Command + + proc VIEW {args} { + #*** !doctools + #[call [fun VIEW] [arg string]] + #[para]Return a string with specific ANSI control characters substituted with visual equivalents frome the appropriate unicode C0 and C1 visualisation sets + #[para]For debugging purposes, certain other standard control characters are converted to visual representation, for example backspace (mapped to \\U2408 '\U2408') + #[para]Horizontal tab is mapped to \\U2409 '\U2409'. For many of the punk terminal text operations, tabs have already been mapped to the appropriate number of spaces using textutil::tabify functions + #[para]As punkshell uses linefeed where possible in preference to crlf even on windows, cr is mapped to \\U240D '\U240D' - but lf is left as is. + + if {![llength $args]} { + return "" + } + + set string [lindex $args end] + set defaults [dict create\ + -esc 1\ + -cr 1\ + -lf 0\ + -vt 0\ + -ht 1\ + -bs 1\ + -sp 1\ + ] + set argopts [lrange $args 0 end-1] + if {[llength $argopts] % 2 != 0} { + error "ansistring VIEW options must be option-value pairs, received '$argopts'. Known opts [dict keys $defaults]" + } + set opts [dict merge $defaults $argopts] + # -- --- --- --- --- + set opt_esc [dict get $opts -esc] + set opt_cr [dict get $opts -cr] + set opt_lf [dict get $opts -lf] + set opt_vt [dict get $opts -vt] + set opt_ht [dict get $opts -ht] + set opt_bs [dict get $opts -bs] + set opt_sp [dict get $opts -sp] + # -- --- --- --- --- + + + #modern (c0 seem to have more terminal/font support - C1 can show 8bit c1 codes - but also seems to be limited support) + + #Goal is not to map every control character? + #Map of which elements we want to convert - done this way so we can see names of control's that are included: - ease of maintenance compared to just creating the string map directly + #ETX -ctrl-c + #EOT ctrl-d (EOF?) + #SYN ctrl-v + #SUB ctrl-z + #CAN ctrl-x + #FS ctrl-\ (SIGQUIT) + set visuals_interesting [dict create\ + NUL [list \x00 \u2400]\ + ETX [list \x03 \u2403]\ + EOT [list \x04 \u2404]\ + BEL [list \x07 \u2407]\ + SYN [list \x16 \u2416]\ + CAN [list \x18 \u2418]\ + SUB [list \x1a \u241a]\ + FS [list \x1c \u241c]\ + SOS [list \x98 \ue038]\ + CSI [list \x9b \ue03b]\ + ST [list \x9c \ue03c]\ + PM [list \x9e \ue03e]\ + APC [list \x9f \ue03f]\ + ] + #it turns out we need pretty much everything for debugging + set visuals [dict create\ + NUL [list \x00 \u2400]\ + SOH [list \x01 \u2401]\ + STX [list \x02 \u2402]\ + ETX [list \x03 \u2403]\ + EOT [list \x04 \u2404]\ + ENQ [list \x05 \u2405]\ + ACK [list \x06 \u2406]\ + BEL [list \x07 \u2407]\ + FF [list \x0c \u240c]\ + SO [list \x0e \u240e]\ + SF [list \x0f \u240f]\ + DLE [list \x10 \u2410]\ + DC1 [list \x11 \u2411]\ + DC2 [list \x12 \u2412]\ + DC3 [list \x13 \u2413]\ + DC4 [list \x14 \u2414]\ + NAK [list \x15 \u2415]\ + SYN [list \x16 \u2416]\ + ETB [list \x17 \u2417]\ + CAN [list \x18 \u2418]\ + EM [list \x19 \u2419]\ + SUB [list \x1a \u241a]\ + FS [list \x1c \u241c]\ + GS [list \x1d \u241d]\ + RS [list \x1e \u241e]\ + US [list \x1f \u241f]\ + DEL [list \x7f \u2421]\ + SOS [list \x98 \ue038]\ + CSI [list \x9b \ue03b]\ + ST [list \x9c \ue03c]\ + PM [list \x9e \ue03e]\ + APC [list \x9f \ue03f]\ + ] + if {$opt_esc} { + dict set visuals VT [list \x1b \u241b] + } + if {$opt_cr} { + dict set visuals CR [list \x0d \u240d] + } + if {$opt_lf} { + dict set visuals LF [list \x0a \u240a] + } + if {$opt_vt} { + dict set visuals VT [list \x0b \u240b] + } + if {$opt_ht} { + dict set visuals HT [list \x09 \u2409] + } + if {$opt_bs} { + dict set visuals BS [list \x08 \u2408] + } + if {$opt_sp} { + dict set visuals SP [list \x20 \u2420] + } + + set charmap [list] + dict for {nm chars} $visuals { + lappend charmap {*}$chars + } + return [string map $charmap $string] + + #ISO2047 - 7bit - limited set, limited support + #return [string map [list \033 \U2296 \007 \U237E] $string] } proc length {string} { @@ -1353,7 +1620,7 @@ namespace eval punk::ansi::internal { ## Ready package provide punk::ansi [namespace eval punk::ansi { variable version - set version 0.1.0 + set version 0.1.1 }] return diff --git a/src/bootsupport/modules/punk/console-0.1.0.tm b/src/bootsupport/modules/punk/console-0.1.1.tm similarity index 83% rename from src/bootsupport/modules/punk/console-0.1.0.tm rename to src/bootsupport/modules/punk/console-0.1.1.tm index 701f42af..944f818c 100644 --- a/src/bootsupport/modules/punk/console-0.1.0.tm +++ b/src/bootsupport/modules/punk/console-0.1.1.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::console 0.1.0 +# Application punk::console 0.1.1 # Meta platform tcl # Meta license # @@ Meta End @@ -31,6 +31,11 @@ if {"windows" eq $::tcl_platform(platform)} { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::console { variable has_twapi 0 + variable previous_stty_state_stdin "" + variable previous_stty_state_stdout "" + variable previous_stty_state_stderr "" + + variable is_raw 0 #punk::console namespace - contains *directly* acting functions - some based on ansi escapes from the 'ansi' sub namespace, some on local system calls or executable calls wrapped in the 'local' sub namespace #directly acting means they write to stdout to cause the console to peform the action, or they perform the action immediately via other means. @@ -56,6 +61,7 @@ namespace eval punk::console { internal::abort_if_loop tailcall enableAnsi } + #review what raw mode means with regard to a specific channel vs terminal as a whole proc enableRaw {{channel stdin}} { #loopavoidancetoken (don't remove) internal::define_windows_procs @@ -68,17 +74,42 @@ namespace eval punk::console { internal::abort_if_loop tailcall disableRaw $channel } + proc enableVirtualTerminal {} { + #loopavoidancetoken (don't remove) + internal::define_windows_procs + internal::abort_if_loop + tailcall enableVirtualTerminal + } } else { proc enableAnsi {} { #todo? } + + #todo - something better - the 'channel' concept may not really apply on unix, as raw mode is for input and output modes proc enableRaw {{channel stdin}} { + variable is_raw + variable previous_stty_state_$channel set sttycmd [auto_execok stty] + if {[set previous_stty_state_$channel] eq ""} { + set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel] + } + exec {*}$sttycmd raw -echo <@$channel + set is_raw 1 + return [dict create previous [set previous_stty_state_$channel]] } proc disableRaw {{channel stdin}} { + variable is_raw + variable previous_stty_state_$channel set sttycmd [auto_execok stty] - exec {*}$sttycmd raw echo <@$channel + if {[set previous_stty_state_$channel] ne ""} { + exec {*}$sttycmd [set previous_stty_state_$channel] + set previous_stty_state_$channel "" + return restored + } + exec {*}$sttycmd -raw echo <@$channel + set is_raw 0 + return done } } @@ -167,6 +198,7 @@ namespace eval punk::console { set h_in [twapi::get_console_handle stdin] set oldmode_in [twapi::GetConsoleMode $h_in] set newmode_in [expr {$oldmode_in | 8}] + #set newmode_in [expr {$oldmode_in | 0x208}] twapi::SetConsoleMode $h_in $newmode_in @@ -188,6 +220,19 @@ namespace eval punk::console { return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] } + proc [namespace parent]::enableVirtualTerminal {} { + set h_out [twapi::get_console_handle stdout] + set oldmode_out [twapi::GetConsoleMode $h_out] + set newmode_out [expr {$oldmode_out | 4}] + twapi::SetConsoleMode $h_out $newmode_out + + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in | 0x200}] + twapi::SetConsoleMode $h_in $newmode_in + return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] + } + proc [namespace parent]::enableProcessedInput {} { set h_in [twapi::get_console_handle stdin] set oldmode_in [twapi::GetConsoleMode $h_in] @@ -205,18 +250,24 @@ namespace eval punk::console { proc [namespace parent]::enableRaw {{channel stdin}} { + variable is_raw #review - change to modify_console_input_mode set console_handle [twapi::GetStdHandle -10] set oldmode [twapi::GetConsoleMode $console_handle] set newmode [expr {$oldmode & ~6}] ;# Turn off the echo and line-editing bits twapi::SetConsoleMode $console_handle $newmode + set is_raw 1 + #don't disable handler - it will detect is_raw + ### twapi::set_console_control_handler {} return [list stdin [list from $oldmode to $newmode]] } proc [namespace parent]::disableRaw {{channel stdin}} { + variable is_raw set console_handle [twapi::GetStdHandle -10] set oldmode [twapi::GetConsoleMode $console_handle] set newmode [expr {$oldmode | 6}] ;# Turn on the echo and line-editing bits twapi::SetConsoleMode $console_handle $newmode + set is_raw 0 return [list stdin [list from $oldmode to $newmode]] } @@ -238,6 +289,7 @@ namespace eval punk::console { } } + #review - 1 byte at a time seems inefficient.. proc ansi_response_handler {chan accumulatorvar waitvar} { set status [catch {read $chan 1} bytes] if { $status != 0 } { @@ -408,10 +460,24 @@ namespace eval punk::console { set existing_handler [fileevent stdin readable] set $waitvar "" #todo - test and save rawstate so we don't disableRaw if terminal was already raw - enableRaw + if {!$::punk::console::is_raw} { + set was_raw 0 + enableRaw + } else { + set was_raw 1 + } fconfigure stdin -blocking 0 + #review + #fconfigure stdin -blocking 0 -inputmode raw fileevent stdin readable [list ::punk::console::internal::ansi_response_handler stdin $accumulator $waitvar] - puts -nonewline stdout \033\[6n ;flush stdout + + # - stderr vs stdout + #It has to be same channel as used by functions such as test_char_width or erroneous results returned for those functions + #(presumably race conditions as to when data hits console?) + #review - experiment changing this and calling functions to stderr and see if it works + #review - Are there disadvantages to using stdout vs stderr? + + puts -nonewline stdout \033\[6n ;flush stdout after 0 {update idletasks} #e.g \033\[46;1R #todo - reset @@ -419,12 +485,25 @@ namespace eval punk::console { if {[set $waitvar] eq ""} { vwait $waitvar } - disableRaw + if {$was_raw == 0} { + disableRaw + } + #fconfigure stdin -inputmode normal if {[string length $existing_handler]} { fileevent stdin readable $existing_handler } + #response handler automatically removes it's own fileevent set info [set $accumulator] + set start [string first \x1b $info] + if {$start > 0} { + set other [string range $info 0 $start-1] + #!!!!! TODO + # Log this somehwere? Work out how to stop it happening? + #puts stderr "Warning - get_cursor_pos read extra data at start - '$other'" + set info [string range $info $start end] + } + #set punk::console::chunk "" set data [string range $info 2 end-1] return $data @@ -521,7 +600,12 @@ namespace eval punk::console { } proc test_cursor_pos {} { - enableRaw + if {!$::punk::terminal::is_raw} { + set was_raw 0 + enableRaw + } else { + set was_raw 1 + } puts -nonewline stdout \033\[6n ;flush stdout fconfigure stdin -blocking 0 set info [read stdin 20] ;# @@ -529,7 +613,9 @@ namespace eval punk::console { if {[string first "R" $info] <=0} { append info [read stdin 20] } - disableRaw + if {!$was_raw} { + disableRaw + } set data [string range [string trim $info] 2 end-1] return [split $data ";"] } @@ -538,17 +624,23 @@ namespace eval punk::console { proc move {row col} { puts -nonewline stdout [punk::ansi::move $row $col] } - proc move_forward {row col} { - puts -nonewline stdout [punk::ansi::move_forward $row $col] + proc move_forward {n} { + puts -nonewline stdout [punk::ansi::move_forward $n] + } + proc move_back {n} { + puts -nonewline stdout [punk::ansi::move_back $n] } - proc move_back {row col} { - puts -nonewline stdout [punk::ansi::move_back $row $col] + proc move_up {n} { + puts -nonewline stdout [punk::ansi::move_up $n] } - proc move_up {row col} { - puts -nonewline stdout [punk::ansi::move_up $row $col] + proc move_down {n} { + puts -nonewline stdout [punk::ansi::move_down $n] } - proc move_down {row col} { - puts -nonewline stdout [punk::ansi::move_down $row $col] + proc move_column {col} { + puts -nonewline stdout [punk::ansi::move_column $col] + } + proc move_row {row} { + puts -nonewline stdout [punk::ansi::move_row $col] } proc move_emit {row col data args} { puts -nonewline stdout [punk::ansi::move_emit $row $col $data {*}$args] @@ -562,6 +654,34 @@ namespace eval punk::console { } move $orig_row $orig_col } + proc save_cursor {} { + puts -nonewline stdout [punk::ansi::save_cursor] + } + proc restore_cursor {} { + puts -nonewline stdout [punk::ansi::restore_cursor] + } + proc scroll_up {n} { + puts -nonewline stdout [punk::ansi::scroll_up] + } + proc scroll_down {n} { + puts -nonewline stdout [punk::ansi::scroll_down] + } + #review - worth the extra microseconds to inline? might be + proc insert_spaces {count} { + puts -nonewline stdout \x1b\[${count}@ + } + proc delete_characters {count} { + puts -nonewline \x1b\[${count}P + } + proc erase_characters {count} { + puts -nonewline \x1b\[${count}X + } + proc insert_lines {count} { + puts -nonewline \x1b\[${count}L + } + proc delete_lines {count} { + puts -nonewline \x1b\[${count}M + } } namespace import ansi::move namespace import ansi::move_emit @@ -569,7 +689,32 @@ namespace eval punk::console { namespace import ansi::move_back namespace import ansi::move_up namespace import ansi::move_down - + namespace import ansi::move_column + namespace import ansi::move_row + namespace import ansi::save_cursor + namespace import ansi::restore_cursor + namespace import ansi::scroll_down + namespace import ansi::scroll_up + namespace import ansi::insert_spaces + namespace import ansi::delete_characters + namespace import ansi::erase_characters + namespace import ansi::insert_lines + namespace import ansi::delete_lines + + #experimental + proc rhs_prompt {col text} { + package require textblock + lassign [textblock::size $text] _w tw _h th + if {$th > 1} { + #move up first.. need to know current line? + } + #set blanks [string repeat " " [expr {$col + $tw}]] + #puts -nonewline [punk::ansi::erase_eol]$blanks;move_emit_return this $col $text + #puts -nonewline [move_emit_return this $col [punk::ansi::insert_spaces 150]$text] + save_cursor + move_emit_return this $col [punk::ansi::move_forward 50][punk::ansi::insert_spaces 150][punk::ansi::move_back 50][punk::ansi::move_forward $col]$text + restore_cursor + } proc move_emit_return {row col data args} { #todo detect if in raw mode or not? set is_in_raw 0 @@ -917,6 +1062,6 @@ namespace eval punk::console { ## Ready package provide punk::console [namespace eval punk::console { variable version - set version 0.1.0 + set version 0.1.1 }] return \ No newline at end of file diff --git a/src/bootsupport/modules/punk/lib-0.1.0.tm b/src/bootsupport/modules/punk/lib-0.1.0.tm index 59fdcde6..605c634e 100644 --- a/src/bootsupport/modules/punk/lib-0.1.0.tm +++ b/src/bootsupport/modules/punk/lib-0.1.0.tm @@ -561,7 +561,13 @@ namespace eval punk::lib { } proc lines_as_list {args} { - #The underlying function linelist has the validation code which gives nice usage errors. + #*** !doctools + #[call [fun lines_as_list] [opt {option value ...}] [arg text]] + #[para]Returns a list of possibly trimmed lines depeding on options + #[para]The concept of lines is raw lines from splitting on newline after crlf is mapped to lf + #[para]- not console lines which may be entirely different due to control characters such as vertical tabs or ANSI movements + + #The underlying function linelist has the validation code which gives nicer usage errors. #we can't use a dict merge here without either duplicating the underlying validation somewhat, or risking a default message from dict merge error #..because we don't know what to say if there are odd numbers of args #we can guess that it's ok to insert our default if no -block found in $args - but as a general principle this mightn't always work @@ -602,6 +608,8 @@ namespace eval punk::lib { error "linelist missing textchunk argument usage:$usage" } set text [lindex $args end] + set text [string map [list \r\n \n] $text] ;#review - option? + set arglist [lrange $args 0 end-1] set defaults [dict create\ -block {trimhead1 trimtail1}\ @@ -1210,6 +1218,8 @@ namespace eval punk::lib { return [dict create opts $opts values $values] } + + #*** !doctools #[list_end] [comment {--- end definitions namespace punk::lib ---}] } @@ -1297,7 +1307,139 @@ namespace eval punk::lib::system { return [concat $smallfactors [lreverse $largefactors] $x] } - + #important - used by punk::repl + proc incomplete {partial} { + #we can apparently get away without concatenating current innerpartial to previous in list - REVIEW. + if {[info complete $partial]} { + return [list] + } + set clist [split $partial ""] + #puts stderr "-->$clist<--" + set waiting [list ""] + set innerpartials [list ""] + set escaped 0 + foreach c $clist { + if {$c eq "\\"} { + set escaped [expr {!$escaped}] + continue + } ;# set escaped 0 at end + set p [lindex $innerpartials end] + if {$escaped == 0} { + if {$c eq {"}} { + if {![info complete ${p}]} { + lappend waiting {"} + lappend innerpartials "" + } else { + if {[lindex $waiting end] eq {"}} { + #this quote is endquote + set waiting [lrange $waiting 0 end-1] + set innerpartials [lrange $innerpartials 0 end-1] + } else { + if {![info complete ${p}$c]} { + lappend waiting {"} + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + } + } elseif {$c eq "\["} { + if {![info complete ${p}$c]} { + lappend waiting "\]" + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } elseif {$c eq "\{"} { + if {![info complete ${p}$c]} { + lappend waiting "\}" + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } else { + set waitingfor [lindex $waiting end] + if {$c eq "$waitingfor"} { + set waiting [lrange $waiting 0 end-1] + set innerpartials [lrange $innerpartials 0 end-1] + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + } else { + set p ${p}${c} + lset innerpartials end $p + } + set escaped 0 + } + set incomplete [list] + foreach w $waiting { + if {$w eq {"}} { + lappend incomplete $w + } elseif {$w eq "\]"} { + lappend incomplete "\[" + } elseif {$w eq "\}"} { + lappend incomplete "\{" + } + } + set debug 0 + if {$debug} { + foreach w $waiting p $innerpartials { + puts stderr "->'$w' partial: $p" + } + } + return $incomplete + } + #This only works for very simple cases will get confused with for example: + # {set x "a["""} + proc incomplete_naive {partial} { + if {[info complete $partial]} { + return [list] + } + set clist [split $partial ""] + set waiting [list] + set escaped 0 + foreach c $clist { + if {$c eq "\\"} { + set escaped [expr {!$escaped}] + continue + } + if {!$escaped} { + if {$c eq {"}} { + if {[lindex $waiting end] eq {"}} { + set waiting [lrange $waiting 0 end-1] + } else { + lappend waiting {"} + } + } elseif {$c eq "\["} { + lappend waiting "\]" + } elseif {$c eq "\{"} { + lappend waiting "\}" + } else { + set waitingfor [lindex $waiting end] + if {$c eq "$waitingfor"} { + set waiting [lrange $waiting 0 end-1] + } + } + } + } + set incomplete [list] + foreach w $waiting { + if {$w eq {"}} { + lappend incomplete $w + } elseif {$w eq "\]"} { + lappend incomplete "\[" + } elseif {$w eq "\}"} { + lappend incomplete "\{" + } + } + return $incomplete + } + #*** !doctools #[list_end] [comment {--- end definitions namespace punk::lib::system ---}] } diff --git a/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/bootsupport/modules/punk/repo-0.1.1.tm index 1a8ac6ec..b5752b56 100644 --- a/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -1144,7 +1144,7 @@ namespace eval punk::repo { try { #git describe will error with 'No names found' if repo has no tags #set v [::exec {*}[auto_execok git] describe] - set v [::exec {*}[auto_execok git] -remote -v] ;# consider 'git rev-parse --short HEAD' + set v [::exec {*}[auto_execok git] remote -v] ;# consider 'git rev-parse --short HEAD' } on error {e o} { set v [lindex [split [dict get $o -errorinfo] \n] 0] } diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index a29695c8..ffe16808 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -88,7 +88,11 @@ package require punk::mix::base namespace eval punk { interp alias {} purelist {} lreplace x 0 0 ;#required by pipe system - package require pattern + if {[catch { + package require pattern + } errpkg]} { + puts stderr "Failed to load package pattern error: $errpkg" + } package require shellfilter package require punkapp package require funcl @@ -6822,32 +6826,36 @@ namespace eval punk { append mascotblock [>punk . banner -title "Punk Shell" -left Tcl -right [package provide Tcl]] } + set topic [lindex $args end] + set argopts [lrange $args 0 end-1] set text "" - set known $::punk::config::known_punk_env_vars - append text $linesep\n - append text "punk environment vars:\n" - append text $linesep\n - set col1 [string repeat " " 25] - set col2 [string repeat " " 50] - foreach v $known { - set c1 [overtype::left $col1 $v] - if {[info exists ::env($v)]} { - set c2 [overtype::left $col2 [set ::env($v)] - } else { - set c2 [overtype::right $col2 "(NOT SET)"] + if {$topic in [list env environment]} { + set known $::punk::config::known_punk_env_vars + append text $linesep\n + append text "punk environment vars:\n" + append text $linesep\n + set col1 [string repeat " " 25] + set col2 [string repeat " " 50] + foreach v $known { + set c1 [overtype::left $col1 $v] + if {[info exists ::env($v)]} { + set c2 [overtype::left $col2 [set ::env($v)] + } else { + set c2 [overtype::right $col2 "(NOT SET)"] + } + append text "$c1 $c2\n" } - append text "$c1 $c2\n" + append text $linesep\n + lappend chunks [list stdout $text] } - append text $linesep\n - lappend chunks [list stdout $text] set text "" append text "Punk core navigation commands:\n" - append text " help\n" #todo - load from source code annotation? set cmdinfo [list] + lappend cmdinfo [list help "This help. To see available subitems type: help topics"] lappend cmdinfo [list deck "(ensemble command to make new projects/modules and to generate docs)"] lappend cmdinfo [list ./ "view/change directory"] lappend cmdinfo [list ../ "go up one directory"] @@ -6877,59 +6885,80 @@ namespace eval punk { } else { set introblock [textblock::join " " $mascotblock " " $text] } - #set introblock $text - if {[punk::repl::has_script_var_bug]} { - append warningblock \n "minor warning: punk::repl::has_script_var_bug returned true! (string rep for list variable in script generated when script changed)" + if {$topic in [list tcl]} { + if {[punk::repl::has_script_var_bug]} { + append warningblock \n "minor warning: punk::repl::has_script_var_bug returned true! (string rep for list variable in script generated when script changed)" + } } - lappend cstring_tests [dict create\ - type "PM "\ - msg "PRIVACY MESSAGE"\ - f7 punk::ansi::controlstring_PM\ - f7desc "7bit ESC ^"\ - f8 punk::ansi::controlstring_PM8\ - f8desc "8bit \\x9e"\ - ] - lappend cstring_tests [dict create\ - type SOS\ - msg "STRING"\ - f7 punk::ansi::controlstring_SOS\ - f7desc "7bit ESC X"\ - f8 punk::ansi::controlstring_SOS8\ - f8desc "8bit \\x98"\ - ] - lappend cstring_tests [dict create\ - type APC\ - msg "APPLICATION PROGRAM COMMAND"\ - f7 punk::ansi::controlstring_APC\ - f7desc "7bit ESC _"\ - f8 punk::ansi::controlstring_APC8\ - f8desc "8bit \\x9f"\ - ] + if {$topic in [list console terminal]} { + lappend cstring_tests [dict create\ + type "PM "\ + msg "PRIVACY MESSAGE"\ + f7 punk::ansi::controlstring_PM\ + f7desc "7bit ESC ^"\ + f8 punk::ansi::controlstring_PM8\ + f8desc "8bit \\x9e"\ + ] + lappend cstring_tests [dict create\ + type SOS\ + msg "STRING"\ + f7 punk::ansi::controlstring_SOS\ + f7desc "7bit ESC X"\ + f8 punk::ansi::controlstring_SOS8\ + f8desc "8bit \\x98"\ + ] + lappend cstring_tests [dict create\ + type APC\ + msg "APPLICATION PROGRAM COMMAND"\ + f7 punk::ansi::controlstring_APC\ + f7desc "7bit ESC _"\ + f8 punk::ansi::controlstring_APC8\ + f8desc "8bit \\x9f"\ + ] - foreach test $cstring_tests { - set m [[dict get $test f7] [dict get $test msg]] - set hidden_width_m [punk::console::test_char_width $m] - set m8 [[dict get $test f8] [dict get $test msg]] - set hidden_width_m8 [punk::console::test_char_width $m8] - if {$hidden_width_m != 0 || $hidden_width_m8 != 0} { - if {$hidden_width_m == 0} { - set d "[a+ green bold][dict get $test f7desc] [a red]${m}[a]" - } else { - set d "[a+ yellow bold][dict get $test f7desc] [a red]$m[a]" - } - if {$hidden_width_m8 == 0} { - set d8 "[a+ green ][dict get $test f8desc] [a red]$m8[a]" - } else { - set d8 "[a+ yellow bold][dict get $test f8desc] [a red]$m8[a]" + foreach test $cstring_tests { + set m [[dict get $test f7] [dict get $test msg]] + set hidden_width_m [punk::console::test_char_width $m] + set m8 [[dict get $test f8] [dict get $test msg]] + set hidden_width_m8 [punk::console::test_char_width $m8] + if {$hidden_width_m != 0 || $hidden_width_m8 != 0} { + if {$hidden_width_m == 0} { + set d "[a+ green bold][dict get $test f7desc] [a red]${m}[a]" + } else { + set d "[a+ yellow bold][dict get $test f7desc] [a red]$m[a]" + } + if {$hidden_width_m8 == 0} { + set d8 "[a+ green ][dict get $test f8desc] [a red]$m8[a]" + } else { + set d8 "[a+ yellow bold][dict get $test f8desc] [a red]$m8[a]" + } + append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8" } - append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8" } } lappend chunks [list stdout $introblock] lappend chunks [list stderr $warningblock] + if {$topic in [list topics help]} { + set text "" + set topics [dict create\ + "topic|help" "List help topics"\ + "tcl" "Tcl version warnings"\ + "env|environment" "punkshell environment vars"\ + "console|terminal" "Some console behaviour tests and warnings"\ + ] + set col1 [string repeat " " 20] + append text \n [string repeat - 20] + append text \n "Topic" + append text \n [string repeat - 20] + foreach {k v} $topics { + append text \n "[overtype::left $col1 $k] $v" + } + append text \n + lappend chunks [list stdout $text] + } return $chunks } @@ -6940,6 +6969,21 @@ namespace eval punk { puts -nonewline $chan $text } } + proc mode {raw_or_line} { + set raw_or_line [string tolower $raw_or_line] + if {$raw_or_line eq "raw"} { + punk::console::enableVirtualTerminal + punk::console::enableRaw + } elseif {$raw_or_line eq "line"} { + punk::console::disableRaw + #vt disable? + } else { + error "punk::mode expected 'raw' or 'line' + } + } + + #this hides cmds mode command - probably no big deal - anyone who needs it will know how to exec it. + interp alias {} mode {} punk::mode #NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed) @@ -7121,7 +7165,7 @@ namespace eval punk { #---------------------------------------------- interp alias {} linelistraw {} punk::linelistraw - interp alias {} linelist {} punk::linelist ;#critical for = assignment features + interp alias {} linelist {} punk::lib::linelist ;#critical for = assignment features interp alias {} linesort {} punk::lib::linesort # 'path' collides with kettle path in kettle::doc function - todo - patch kettle? @@ -7131,6 +7175,7 @@ namespace eval punk { #interp alias {} list_as_lines {} punk::list_as_lines interp alias {} list_as_lines {} punk::lib::list_as_lines interp alias {} lines_as_list {} punk::lib::lines_as_list + interp alias {} ansistrip {} punk::ansi::stripansi ;#review interp alias {} list_filter_cond {} punk::list_filter_cond interp alias {} is_list_all_in_list {} punk::is_list_all_in_list interp alias {} is_list_all_ni_list {} punk::is_list_all_ni_list diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index 8b63bdb6..064c146e 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -276,7 +276,7 @@ namespace eval punk::ansi { variable SGR_setting_map { bold 1 dim 2 blink 5 fastblink 6 noblink 25 hide 8 normal 22 underline 4 doubleunderline 21 nounderline 24 strike 9 nostrike 29 italic 3 noitalic 23 - reverse 7 noreverse 27 defaultfg 39 defaultbg 49 + reverse 7 noreverse 27 defaultfg 39 defaultbg 49 nohide 28 overline 53 nooverline 55 frame 51 framecircle 52 noframe 54 } variable SGR_colour_map { @@ -561,10 +561,18 @@ namespace eval punk::ansi { #[para]A string created by any move_emit_return for punk::ansi would not behave in an intuitive manner compared to other punk::ansi move functions - so is deliberately omitted. set out "" - append out \033\[${row}\;${col}H$data - foreach {row col data} $args { + if {$row eq "this"} { + append out \033\[\;${col}G$data + } else { append out \033\[${row}\;${col}H$data } + foreach {row col data} $args { + if {$row eq "this"} { + append out \033\[\;${col}G$data + } else { + append out \033\[${row}\;${col}H$data + } + } return $out } proc move_forward {{n 1}} { @@ -587,8 +595,28 @@ namespace eval punk::ansi { #[call [fun move_down] [arg n]] return \033\[${n}B } + proc move_column {col} { + #*** !doctools + #[call [fun move_column] [arg col]] + return \x1b\[${col}g + } + proc move_row {row} { + #*** !doctools + #[call [fun move_row] [arg row]] + return \x1b\[${row}G + } # -- --- --- --- --- + proc save_cursor {} { + #*** !doctools + #[call [fun save_cursor]] + return \x1b\[s + } + proc restore_cursor {} { + #*** !doctools + #[call [fun restore_cursor]] + return \x1b\[u + } # -- --- --- --- --- proc erase_line {} { @@ -610,6 +638,43 @@ namespace eval punk::ansi { #see also clear_above clear_below # -- --- --- --- --- + proc scroll_up {n} { + #*** !doctools + #[call [fun scroll_up] [arg n]] + return \x1b\[${n}S + } + proc scroll_down {n} { + #*** !doctools + #[call [fun scroll_down] [arg n]] + return \x1b\[${n}T + } + + proc insert_spaces {count} { + #*** !doctools + #[call [fun insert_spaces] [arg count]] + return \x1b\[${count}@ + } + proc delete_characters {count} { + #*** !doctools + #[call [fun delete_characters] [arg count]] + return \x1b\[${count}P + } + proc erase_characters {count} { + #*** !doctools + #[call [fun erase_characters] [arg count]] + return \x1b\[${count}X + } + proc insert_lines {count} { + #*** !doctools + #[call [fun insert_lines] [arg count]] + return \x1b\[${count}L + } + proc delete_lines {count} { + #*** !doctools + #[call [fun delete_lines] [arg count]] + return \x1b\[${count}M + } + proc cursor_pos {} { #*** !doctools #[call [fun cursor_pos]] @@ -650,6 +715,7 @@ namespace eval punk::ansi { if {[string first \n $line] >= 0} { error "line_print_length must not contain newline characters" } + #what if line has \v (vertical tab) ie more than one logical screen line? #review - set line [punk::ansi::stripansi $line] @@ -657,6 +723,7 @@ namespace eval punk::ansi { set line [punk::char::strip_nonprinting_ascii $line] ;#only strip nonprinting after stripansi - some like BEL are part of ansi #backspace 0x08 only erases* printing characters anyway - so presumably order of processing doesn't matter #(* more correctly - moves cursor back) + #Note some terminals process backspace before \v - which seems quite wrong #backspace will not move beyond a preceding newline - but we have disallowed newlines for this function already #leading backspaces will eat into any string (even prompt in non-standard tclsh shell) that is prepended to the line # - but for the purposes of overtype we wouldn't want that - so we strip it here in the length calculation and should strip leading backspaces in the actual data concatenation operations too. @@ -671,6 +738,7 @@ namespace eval punk::ansi { set bs [format %c 0x08] #set line [string map [list "\r${bs}" "\r"] $line] ;#backsp following a \r will have no effect set line [string trim $line $bs] + #counterintuitively "x\b" still shows the x ie length is still one. The backspace just moves the position. There must be a char following \b for it to affect the length. set n 0 set chars [split $line ""] @@ -1014,7 +1082,7 @@ namespace eval punk::ansi::ansistring { #\UFFFD - replacement char or \U2426 - #using ISO 2047 graphical representations of control characters + #using ISO 2047 graphical representations of control characters - probably obsolete? #00 NUL Null ⎕ U+2395 NU #01 TC1, SOH Start of Heading ⌈ U+2308 SH #02 TC2, STX Start of Text ⊥ U+22A5 SX @@ -1049,8 +1117,207 @@ namespace eval punk::ansi::ansistring { #1F IS1 US Unit Separator ◳ U+25F3 US #20 SP Space △ U+25B3 SP #7F DEL Delete ▨ —[d] DT - proc VIEW {string} { - return [string map [list \033 \U2296 \007 \U237E] $string] + + #C0 control code visual representations + # Code Val Name 2X Description + # 2400 00 NUL NU Symbol for Null + # 2401 01 SOH SH Symbol for Start of Heading + # 2402 02 STX SX Symbol for Start of Text + # 2403 03 ETX EX Symbol for End of Text + # 2404 04 EOT ET Symbol for End of Transmission + # 2405 05 ENQ EQ Symbol for Enquiry + # 2406 06 ACK AK Symbol for Acknowledge + # 2407 07 BEL BL Symbol for Bell + # 2409 09 BS BS Symbol for Backspace + # 2409 09 HT HT Symbol for Horizontal Tab (1) + # 240A 0A LF LF Symbol for Line Feed (1) + # 240B 0B VT VT Symbol for Vertical Tab (1) + # 240C 0C FF FF Symbol for Form Feed (2) + # 240D 0D CR CR Symbol for Carriage Return (1) + # 240E 0E SO SO Symbol for Shift Out + # 240F 0F SI SI Symbol for Shift In + # 2410 10 DLE DL Symbol for Data Link Escape + # 2411 11 DC1 D1 Symbol for Device Control 1 (2) + # 2412 12 DC2 D2 Symbol for Device Control 2 (2) + # 2413 13 DC3 D3 Symbol for Device Control 3 (2) + # 2414 14 DC4 D4 Symbol for Device Control 4 (2) + # 2415 15 NAK NK Symbol for Negative Acknowledge + # 2416 16 SYN SY Symbol for Synchronous Idle + # 2417 17 ETB EB Symbol for End of Transmission Block + # 2418 18 CAN CN Symbol for Cancel + # 2419 19 EM EM Symbol for End of Medium + # 241A 1A SUB SU Symbol for Substitute + # 241B 1B ESC EC Symbol for Escape + # 241C 1C FS FS Symbol for Field Separator (3) + # 241D 1D GS GS Symbol for Group Separator (3) + # 241E 1E RS RS Symbol for Record Separator (3) + # 241F 1F US US Symbol for Unit Separator (3) + # 2420 20 SP SP Symbol for Space (4) + # 2421 7F DEL DT Symbol for Delete (4) + + #C1 control code visual representations + #Code Val Name 2X Description + # 80 80 80 (1) + # 81 81 81 (1) + # E022 82 BPH 82 Symbol for Break Permitted Here (2) + # E023 83 NBH 83 Symbol for No Break Here (2) + # E024 84 IND IN Symbol for Index (3) + # E025 85 NEL NL Symbol for Next Line (4) + # E026 86 SSA SS Symbol for Start Selected Area + # E027 87 ESA ES Symbol for End Selected Area + # E028 88 HTS HS Symbol for Character Tabulation Set + # E029 89 HTJ HJ Symbol for Character Tabulation with Justification + # E02A 8A VTS VS Symbol for Line Tabulation Set + # E02B 8B PLD PD Symbol for Partial Line Forward + # E02C 8C PLU PU Symbol for Partial Line Backward + # E02D 8D RI RI Symbol for Reverse Line Feed + # E02E 8E SS2 S2 Symbol for Single Shift 2 + # E02F 8F SS3 S3 Symbol for Single Shift 3 + # E030 90 DCS DC Symbol for Device Control String + # E031 91 PU1 P1 Symbol for Private Use 1 + # E032 92 PU2 P2 Symbol for Private Use 2 + # E033 93 STS SE Symbol for Set Transmit State + # E034 94 CCH CC Symbol for Cancel Character + # E035 95 MW MW Symbol for Message Waiting + # E036 96 SPA SP Symbol for Start Protected (Guarded) Area + # E037 97 EPA EP Symbol for End Protected (Guarded) Area + # E038 98 SOS 98 Symbol for Start of String (2) + # 99 99 (1) + # E03A 9A SCI 9A Symbol for Single Character Introducer (2) + # E03B 9B CSI CS Symbol for Control Sequence Introducer (5) + # E03C 9C ST ST Symbol for String Terminator + # E03D 9D OSC OS Symbol for Operating System Command + # E03E 9E PM PM Symbol for Privacy Message + # E03F 9F APC AP Symbol for Application Program Command + + proc VIEW {args} { + #*** !doctools + #[call [fun VIEW] [arg string]] + #[para]Return a string with specific ANSI control characters substituted with visual equivalents frome the appropriate unicode C0 and C1 visualisation sets + #[para]For debugging purposes, certain other standard control characters are converted to visual representation, for example backspace (mapped to \\U2408 '\U2408') + #[para]Horizontal tab is mapped to \\U2409 '\U2409'. For many of the punk terminal text operations, tabs have already been mapped to the appropriate number of spaces using textutil::tabify functions + #[para]As punkshell uses linefeed where possible in preference to crlf even on windows, cr is mapped to \\U240D '\U240D' - but lf is left as is. + + if {![llength $args]} { + return "" + } + + set string [lindex $args end] + set defaults [dict create\ + -esc 1\ + -cr 1\ + -lf 0\ + -vt 0\ + -ht 1\ + -bs 1\ + -sp 1\ + ] + set argopts [lrange $args 0 end-1] + if {[llength $argopts] % 2 != 0} { + error "ansistring VIEW options must be option-value pairs, received '$argopts'. Known opts [dict keys $defaults]" + } + set opts [dict merge $defaults $argopts] + # -- --- --- --- --- + set opt_esc [dict get $opts -esc] + set opt_cr [dict get $opts -cr] + set opt_lf [dict get $opts -lf] + set opt_vt [dict get $opts -vt] + set opt_ht [dict get $opts -ht] + set opt_bs [dict get $opts -bs] + set opt_sp [dict get $opts -sp] + # -- --- --- --- --- + + + #modern (c0 seem to have more terminal/font support - C1 can show 8bit c1 codes - but also seems to be limited support) + + #Goal is not to map every control character? + #Map of which elements we want to convert - done this way so we can see names of control's that are included: - ease of maintenance compared to just creating the string map directly + #ETX -ctrl-c + #EOT ctrl-d (EOF?) + #SYN ctrl-v + #SUB ctrl-z + #CAN ctrl-x + #FS ctrl-\ (SIGQUIT) + set visuals_interesting [dict create\ + NUL [list \x00 \u2400]\ + ETX [list \x03 \u2403]\ + EOT [list \x04 \u2404]\ + BEL [list \x07 \u2407]\ + SYN [list \x16 \u2416]\ + CAN [list \x18 \u2418]\ + SUB [list \x1a \u241a]\ + FS [list \x1c \u241c]\ + SOS [list \x98 \ue038]\ + CSI [list \x9b \ue03b]\ + ST [list \x9c \ue03c]\ + PM [list \x9e \ue03e]\ + APC [list \x9f \ue03f]\ + ] + #it turns out we need pretty much everything for debugging + set visuals [dict create\ + NUL [list \x00 \u2400]\ + SOH [list \x01 \u2401]\ + STX [list \x02 \u2402]\ + ETX [list \x03 \u2403]\ + EOT [list \x04 \u2404]\ + ENQ [list \x05 \u2405]\ + ACK [list \x06 \u2406]\ + BEL [list \x07 \u2407]\ + FF [list \x0c \u240c]\ + SO [list \x0e \u240e]\ + SF [list \x0f \u240f]\ + DLE [list \x10 \u2410]\ + DC1 [list \x11 \u2411]\ + DC2 [list \x12 \u2412]\ + DC3 [list \x13 \u2413]\ + DC4 [list \x14 \u2414]\ + NAK [list \x15 \u2415]\ + SYN [list \x16 \u2416]\ + ETB [list \x17 \u2417]\ + CAN [list \x18 \u2418]\ + EM [list \x19 \u2419]\ + SUB [list \x1a \u241a]\ + FS [list \x1c \u241c]\ + GS [list \x1d \u241d]\ + RS [list \x1e \u241e]\ + US [list \x1f \u241f]\ + DEL [list \x7f \u2421]\ + SOS [list \x98 \ue038]\ + CSI [list \x9b \ue03b]\ + ST [list \x9c \ue03c]\ + PM [list \x9e \ue03e]\ + APC [list \x9f \ue03f]\ + ] + if {$opt_esc} { + dict set visuals VT [list \x1b \u241b] + } + if {$opt_cr} { + dict set visuals CR [list \x0d \u240d] + } + if {$opt_lf} { + dict set visuals LF [list \x0a \u240a] + } + if {$opt_vt} { + dict set visuals VT [list \x0b \u240b] + } + if {$opt_ht} { + dict set visuals HT [list \x09 \u2409] + } + if {$opt_bs} { + dict set visuals BS [list \x08 \u2408] + } + if {$opt_sp} { + dict set visuals SP [list \x20 \u2420] + } + + set charmap [list] + dict for {nm chars} $visuals { + lappend charmap {*}$chars + } + return [string map $charmap $string] + + #ISO2047 - 7bit - limited set, limited support + #return [string map [list \033 \U2296 \007 \U237E] $string] } proc length {string} { diff --git a/src/modules/punk/ansi-buildversion.txt b/src/modules/punk/ansi-buildversion.txt index f47d01c8..781c895b 100644 --- a/src/modules/punk/ansi-buildversion.txt +++ b/src/modules/punk/ansi-buildversion.txt @@ -1,3 +1,3 @@ -0.1.0 +0.1.1 #First line must be a semantic version number #all other lines are ignored. diff --git a/src/modules/punk/console-999999.0a1.0.tm b/src/modules/punk/console-999999.0a1.0.tm index f3a110a7..c7fe0db8 100644 --- a/src/modules/punk/console-999999.0a1.0.tm +++ b/src/modules/punk/console-999999.0a1.0.tm @@ -35,6 +35,8 @@ namespace eval punk::console { variable previous_stty_state_stdout "" variable previous_stty_state_stderr "" + variable is_raw 0 + #punk::console namespace - contains *directly* acting functions - some based on ansi escapes from the 'ansi' sub namespace, some on local system calls or executable calls wrapped in the 'local' sub namespace #directly acting means they write to stdout to cause the console to peform the action, or they perform the action immediately via other means. #punk::console::ansi contains a subset of punk::ansi, but with emission to stdout as opposed to simply returning the ansi sequence. @@ -72,6 +74,12 @@ namespace eval punk::console { internal::abort_if_loop tailcall disableRaw $channel } + proc enableVirtualTerminal {} { + #loopavoidancetoken (don't remove) + internal::define_windows_procs + internal::abort_if_loop + tailcall enableVirtualTerminal + } } else { proc enableAnsi {} { #todo? @@ -79,6 +87,7 @@ namespace eval punk::console { #todo - something better - the 'channel' concept may not really apply on unix, as raw mode is for input and output modes proc enableRaw {{channel stdin}} { + variable is_raw variable previous_stty_state_$channel set sttycmd [auto_execok stty] if {[set previous_stty_state_$channel] eq ""} { @@ -86,9 +95,11 @@ namespace eval punk::console { } exec {*}$sttycmd raw -echo <@$channel + set is_raw 1 return [dict create previous [set previous_stty_state_$channel]] } proc disableRaw {{channel stdin}} { + variable is_raw variable previous_stty_state_$channel set sttycmd [auto_execok stty] if {[set previous_stty_state_$channel] ne ""} { @@ -97,6 +108,7 @@ namespace eval punk::console { return restored } exec {*}$sttycmd -raw echo <@$channel + set is_raw 0 return done } } @@ -186,6 +198,7 @@ namespace eval punk::console { set h_in [twapi::get_console_handle stdin] set oldmode_in [twapi::GetConsoleMode $h_in] set newmode_in [expr {$oldmode_in | 8}] + #set newmode_in [expr {$oldmode_in | 0x208}] twapi::SetConsoleMode $h_in $newmode_in @@ -207,6 +220,19 @@ namespace eval punk::console { return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] } + proc [namespace parent]::enableVirtualTerminal {} { + set h_out [twapi::get_console_handle stdout] + set oldmode_out [twapi::GetConsoleMode $h_out] + set newmode_out [expr {$oldmode_out | 4}] + twapi::SetConsoleMode $h_out $newmode_out + + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in | 0x200}] + twapi::SetConsoleMode $h_in $newmode_in + return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] + } + proc [namespace parent]::enableProcessedInput {} { set h_in [twapi::get_console_handle stdin] set oldmode_in [twapi::GetConsoleMode $h_in] @@ -224,18 +250,24 @@ namespace eval punk::console { proc [namespace parent]::enableRaw {{channel stdin}} { + variable is_raw #review - change to modify_console_input_mode set console_handle [twapi::GetStdHandle -10] set oldmode [twapi::GetConsoleMode $console_handle] set newmode [expr {$oldmode & ~6}] ;# Turn off the echo and line-editing bits twapi::SetConsoleMode $console_handle $newmode + set is_raw 1 + #don't disable handler - it will detect is_raw + ### twapi::set_console_control_handler {} return [list stdin [list from $oldmode to $newmode]] } proc [namespace parent]::disableRaw {{channel stdin}} { + variable is_raw set console_handle [twapi::GetStdHandle -10] set oldmode [twapi::GetConsoleMode $console_handle] set newmode [expr {$oldmode | 6}] ;# Turn on the echo and line-editing bits twapi::SetConsoleMode $console_handle $newmode + set is_raw 0 return [list stdin [list from $oldmode to $newmode]] } @@ -257,6 +289,7 @@ namespace eval punk::console { } } + #review - 1 byte at a time seems inefficient.. proc ansi_response_handler {chan accumulatorvar waitvar} { set status [catch {read $chan 1} bytes] if { $status != 0 } { @@ -427,10 +460,24 @@ namespace eval punk::console { set existing_handler [fileevent stdin readable] set $waitvar "" #todo - test and save rawstate so we don't disableRaw if terminal was already raw - enableRaw + if {!$::punk::console::is_raw} { + set was_raw 0 + enableRaw + } else { + set was_raw 1 + } fconfigure stdin -blocking 0 + #review + #fconfigure stdin -blocking 0 -inputmode raw fileevent stdin readable [list ::punk::console::internal::ansi_response_handler stdin $accumulator $waitvar] - puts -nonewline stdout \033\[6n ;flush stdout + + # - stderr vs stdout + #It has to be same channel as used by functions such as test_char_width or erroneous results returned for those functions + #(presumably race conditions as to when data hits console?) + #review - experiment changing this and calling functions to stderr and see if it works + #review - Are there disadvantages to using stdout vs stderr? + + puts -nonewline stdout \033\[6n ;flush stdout after 0 {update idletasks} #e.g \033\[46;1R #todo - reset @@ -438,12 +485,25 @@ namespace eval punk::console { if {[set $waitvar] eq ""} { vwait $waitvar } - disableRaw + if {$was_raw == 0} { + disableRaw + } + #fconfigure stdin -inputmode normal if {[string length $existing_handler]} { fileevent stdin readable $existing_handler } + #response handler automatically removes it's own fileevent set info [set $accumulator] + set start [string first \x1b $info] + if {$start > 0} { + set other [string range $info 0 $start-1] + #!!!!! TODO + # Log this somehwere? Work out how to stop it happening? + #puts stderr "Warning - get_cursor_pos read extra data at start - '$other'" + set info [string range $info $start end] + } + #set punk::console::chunk "" set data [string range $info 2 end-1] return $data @@ -540,7 +600,12 @@ namespace eval punk::console { } proc test_cursor_pos {} { - enableRaw + if {!$::punk::terminal::is_raw} { + set was_raw 0 + enableRaw + } else { + set was_raw 1 + } puts -nonewline stdout \033\[6n ;flush stdout fconfigure stdin -blocking 0 set info [read stdin 20] ;# @@ -548,7 +613,9 @@ namespace eval punk::console { if {[string first "R" $info] <=0} { append info [read stdin 20] } - disableRaw + if {!$was_raw} { + disableRaw + } set data [string range [string trim $info] 2 end-1] return [split $data ";"] } @@ -557,17 +624,23 @@ namespace eval punk::console { proc move {row col} { puts -nonewline stdout [punk::ansi::move $row $col] } - proc move_forward {row col} { - puts -nonewline stdout [punk::ansi::move_forward $row $col] + proc move_forward {n} { + puts -nonewline stdout [punk::ansi::move_forward $n] + } + proc move_back {n} { + puts -nonewline stdout [punk::ansi::move_back $n] + } + proc move_up {n} { + puts -nonewline stdout [punk::ansi::move_up $n] } - proc move_back {row col} { - puts -nonewline stdout [punk::ansi::move_back $row $col] + proc move_down {n} { + puts -nonewline stdout [punk::ansi::move_down $n] } - proc move_up {row col} { - puts -nonewline stdout [punk::ansi::move_up $row $col] + proc move_column {col} { + puts -nonewline stdout [punk::ansi::move_column $col] } - proc move_down {row col} { - puts -nonewline stdout [punk::ansi::move_down $row $col] + proc move_row {row} { + puts -nonewline stdout [punk::ansi::move_row $col] } proc move_emit {row col data args} { puts -nonewline stdout [punk::ansi::move_emit $row $col $data {*}$args] @@ -581,6 +654,34 @@ namespace eval punk::console { } move $orig_row $orig_col } + proc save_cursor {} { + puts -nonewline stdout [punk::ansi::save_cursor] + } + proc restore_cursor {} { + puts -nonewline stdout [punk::ansi::restore_cursor] + } + proc scroll_up {n} { + puts -nonewline stdout [punk::ansi::scroll_up] + } + proc scroll_down {n} { + puts -nonewline stdout [punk::ansi::scroll_down] + } + #review - worth the extra microseconds to inline? might be + proc insert_spaces {count} { + puts -nonewline stdout \x1b\[${count}@ + } + proc delete_characters {count} { + puts -nonewline \x1b\[${count}P + } + proc erase_characters {count} { + puts -nonewline \x1b\[${count}X + } + proc insert_lines {count} { + puts -nonewline \x1b\[${count}L + } + proc delete_lines {count} { + puts -nonewline \x1b\[${count}M + } } namespace import ansi::move namespace import ansi::move_emit @@ -588,7 +689,32 @@ namespace eval punk::console { namespace import ansi::move_back namespace import ansi::move_up namespace import ansi::move_down - + namespace import ansi::move_column + namespace import ansi::move_row + namespace import ansi::save_cursor + namespace import ansi::restore_cursor + namespace import ansi::scroll_down + namespace import ansi::scroll_up + namespace import ansi::insert_spaces + namespace import ansi::delete_characters + namespace import ansi::erase_characters + namespace import ansi::insert_lines + namespace import ansi::delete_lines + + #experimental + proc rhs_prompt {col text} { + package require textblock + lassign [textblock::size $text] _w tw _h th + if {$th > 1} { + #move up first.. need to know current line? + } + #set blanks [string repeat " " [expr {$col + $tw}]] + #puts -nonewline [punk::ansi::erase_eol]$blanks;move_emit_return this $col $text + #puts -nonewline [move_emit_return this $col [punk::ansi::insert_spaces 150]$text] + save_cursor + move_emit_return this $col [punk::ansi::move_forward 50][punk::ansi::insert_spaces 150][punk::ansi::move_back 50][punk::ansi::move_forward $col]$text + restore_cursor + } proc move_emit_return {row col data args} { #todo detect if in raw mode or not? set is_in_raw 0 diff --git a/src/modules/punk/console-buildversion.txt b/src/modules/punk/console-buildversion.txt index f47d01c8..781c895b 100644 --- a/src/modules/punk/console-buildversion.txt +++ b/src/modules/punk/console-buildversion.txt @@ -1,3 +1,3 @@ -0.1.0 +0.1.1 #First line must be a semantic version number #all other lines are ignored. diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index 1779f161..56c9461b 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/src/modules/punk/lib-999999.0a1.0.tm @@ -561,7 +561,13 @@ namespace eval punk::lib { } proc lines_as_list {args} { - #The underlying function linelist has the validation code which gives nice usage errors. + #*** !doctools + #[call [fun lines_as_list] [opt {option value ...}] [arg text]] + #[para]Returns a list of possibly trimmed lines depeding on options + #[para]The concept of lines is raw lines from splitting on newline after crlf is mapped to lf + #[para]- not console lines which may be entirely different due to control characters such as vertical tabs or ANSI movements + + #The underlying function linelist has the validation code which gives nicer usage errors. #we can't use a dict merge here without either duplicating the underlying validation somewhat, or risking a default message from dict merge error #..because we don't know what to say if there are odd numbers of args #we can guess that it's ok to insert our default if no -block found in $args - but as a general principle this mightn't always work @@ -602,6 +608,8 @@ namespace eval punk::lib { error "linelist missing textchunk argument usage:$usage" } set text [lindex $args end] + set text [string map [list \r\n \n] $text] ;#review - option? + set arglist [lrange $args 0 end-1] set defaults [dict create\ -block {trimhead1 trimtail1}\ @@ -1210,6 +1218,8 @@ namespace eval punk::lib { return [dict create opts $opts values $values] } + + #*** !doctools #[list_end] [comment {--- end definitions namespace punk::lib ---}] } @@ -1297,7 +1307,139 @@ namespace eval punk::lib::system { return [concat $smallfactors [lreverse $largefactors] $x] } - + #important - used by punk::repl + proc incomplete {partial} { + #we can apparently get away without concatenating current innerpartial to previous in list - REVIEW. + if {[info complete $partial]} { + return [list] + } + set clist [split $partial ""] + #puts stderr "-->$clist<--" + set waiting [list ""] + set innerpartials [list ""] + set escaped 0 + foreach c $clist { + if {$c eq "\\"} { + set escaped [expr {!$escaped}] + continue + } ;# set escaped 0 at end + set p [lindex $innerpartials end] + if {$escaped == 0} { + if {$c eq {"}} { + if {![info complete ${p}]} { + lappend waiting {"} + lappend innerpartials "" + } else { + if {[lindex $waiting end] eq {"}} { + #this quote is endquote + set waiting [lrange $waiting 0 end-1] + set innerpartials [lrange $innerpartials 0 end-1] + } else { + if {![info complete ${p}$c]} { + lappend waiting {"} + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + } + } elseif {$c eq "\["} { + if {![info complete ${p}$c]} { + lappend waiting "\]" + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } elseif {$c eq "\{"} { + if {![info complete ${p}$c]} { + lappend waiting "\}" + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } else { + set waitingfor [lindex $waiting end] + if {$c eq "$waitingfor"} { + set waiting [lrange $waiting 0 end-1] + set innerpartials [lrange $innerpartials 0 end-1] + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + } else { + set p ${p}${c} + lset innerpartials end $p + } + set escaped 0 + } + set incomplete [list] + foreach w $waiting { + if {$w eq {"}} { + lappend incomplete $w + } elseif {$w eq "\]"} { + lappend incomplete "\[" + } elseif {$w eq "\}"} { + lappend incomplete "\{" + } + } + set debug 0 + if {$debug} { + foreach w $waiting p $innerpartials { + puts stderr "->'$w' partial: $p" + } + } + return $incomplete + } + #This only works for very simple cases will get confused with for example: + # {set x "a["""} + proc incomplete_naive {partial} { + if {[info complete $partial]} { + return [list] + } + set clist [split $partial ""] + set waiting [list] + set escaped 0 + foreach c $clist { + if {$c eq "\\"} { + set escaped [expr {!$escaped}] + continue + } + if {!$escaped} { + if {$c eq {"}} { + if {[lindex $waiting end] eq {"}} { + set waiting [lrange $waiting 0 end-1] + } else { + lappend waiting {"} + } + } elseif {$c eq "\["} { + lappend waiting "\]" + } elseif {$c eq "\{"} { + lappend waiting "\}" + } else { + set waitingfor [lindex $waiting end] + if {$c eq "$waitingfor"} { + set waiting [lrange $waiting 0 end-1] + } + } + } + } + set incomplete [list] + foreach w $waiting { + if {$w eq {"}} { + lappend incomplete $w + } elseif {$w eq "\]"} { + lappend incomplete "\[" + } elseif {$w eq "\}"} { + lappend incomplete "\{" + } + } + return $incomplete + } + #*** !doctools #[list_end] [comment {--- end definitions namespace punk::lib::system ---}] } diff --git a/src/modules/punk/repl-0.1.tm b/src/modules/punk/repl-0.1.tm index 842390a0..4aabc028 100644 --- a/src/modules/punk/repl-0.1.tm +++ b/src/modules/punk/repl-0.1.tm @@ -141,11 +141,15 @@ if {$::tcl_platform(platform) eq "windows"} { if {![catch {package require twapi}]} { proc ::repl::term::handler_console_control {args} { - puts -nonewline stdout . - flush stdout + #puts -nonewline stdout . + #flush stdout incr ::repl::signal_control_c #rputs stderr "* console_control: $args" - #return 0 to fall through to default handler + if {$::punk::console::is_raw} { + #how to let rawmode loop handle it? It doesn't seem to get through + return 0 + } + #note - returning 0 means pass event to other handlers including OS default handler if {$::repl::signal_control_c <= 2} { set remaining [expr {3 - $::repl::signal_control_c}] puts stderr "ctrl-c (perform $remaining more to quit, enter to return to repl)" @@ -170,6 +174,7 @@ if {$::tcl_platform(platform) eq "windows"} { } else { puts stderr "ctrl-c $::repl::signal_control_c received" flush stderr + #return 0 to fall through to default handler return 0 } } @@ -626,19 +631,45 @@ proc repl::doprompt {prompt {col {green bold}}} { #prompt to stderr. #We can pipe commands into repl's stdin without the prompt interfering with the output. #Although all command output for each line goes to stdout - not just what is emmited with puts + if {$::tcl_interactive} { + set last_char_info [screen_last_char_getinfo] + if {![llength $last_char_info]} { + set needs_clearance 1 + } else { + lassign $last_char_info c what why + if {$why eq "prompt"} { + set needs_clearance 0 + } else { + set needs_clearance [screen_needs_clearance] + #puts -nonewline "-->$needs_clearance $last_char_info" + } + } + if {$needs_clearance == 1} { + set c \n + } else { + set c "" + } + + #this sort of works - but steals some of our stdin data ? review + #lassign [punk::console::get_cursor_pos_list] column row + #if {$row != 1} { + # set c "\n" + #} + set o [a= {*}$col] set r [a=] - puts -nonewline stderr $o$prompt$r + puts -nonewline stderr $c$o$prompt$r + screen_last_char_add " " "prompt-stderr" prompt flush stderr } } proc repl::get_prompt_config {} { if {$::tcl_interactive} { - set resultprompt "[a green bold]-[a] " - set nlprompt "[a green bold].[a] " - set infoprompt "[a green bold]*[a] " - set debugprompt "[a purple bold]~[a] " + set resultprompt "[a green bold]-[a] " + set nlprompt "[a green bold].[a] " + set infoprompt "[a green bold]*[a] " + set debugprompt "[a purple bold]~[a] " } else { set resultprompt "" set nlprompt "" @@ -649,6 +680,7 @@ proc repl::get_prompt_config {} { } proc repl::start {inchan args} { variable commandstr + variable readingchunk variable running variable reading variable done @@ -663,13 +695,15 @@ proc repl::start {inchan args} { set loopinstance 0 set running 1 set commandstr "" + set readingchunk "" set prompt_config [get_prompt_config] doprompt "P% " fileevent $inchan readable [list [namespace current]::repl_handler $inchan $prompt_config] set reading 1 vwait [namespace current]::done #todo - override exit? - after 0 ::repl::post_operations + #after 0 ::repl::post_operations + after idle ::repl::post_operations vwait repl::post_operations_done if {[namespace exists ::punkapp]} { #todo check and get punkapp::result array - but what key? @@ -698,6 +732,7 @@ proc repl::post_operations {} { proc repl::reopen_stdin {} { + #variable reopen_stdin_attempts if {$::tcl_platform(platform) eq "windows"} { puts stderr "|repl> Attempting reconnection of console to stdin by opening 'CON'" } else { @@ -705,7 +740,8 @@ proc repl::reopen_stdin {} { } #puts stderr "channels:[chan names]" #flush stderr - chan close stdin + catch {chan close stdin} + if {$::tcl_platform(platform) eq "windows"} { set s [open "CON" r] } else { @@ -798,7 +834,8 @@ proc repl::screen_last_char_add {c what {why ""}} { append screen_last_chars $c lappend screen_last_char_list [list $c $what $why] #return [string index $screen_last_chars end] - return [lindex $screen_last_char_list 0 0] + #return [lindex $screen_last_char_list 0 0] + return [lindex $screen_last_char_list end 0] } proc repl::screen_last_char_get {} { variable screen_last_char_list @@ -873,11 +910,12 @@ proc repl::rputs {args} { } set last_char_info_width 40 #review - string shouldn't be truncated prior to stripcodes - could chop ansi codes! - set summary "[::shellfilter::ansi::stripcodes [string range $out 0 $last_char_info_width]]" + #set summary "[::shellfilter::ansi::stripcodes [string range $out 0 $last_char_info_width]]" + set summary [punk::ansi::stripansi [string range $out 0 $last_char_info_width]] if {[string length $out] > $last_char_info_width} { append summary " ..." } - screen_last_char_add $this_tail repl-$rputschan" $summary + screen_last_char_add $this_tail repl-$rputschan $summary #tailcall? puts {*}$args } else { @@ -912,6 +950,9 @@ proc repl::rputs {args} { } } #whether we need a newline as clearance from previous output +#review - race with copy pasted data, hold-down of enter key +# and data from external process or background script that doesn't go through our stdout filter +#we probably can't use get_cursor_pos - as that needs to emit to stdout and read-loop on stdin which will possibly? make things worse proc repl::screen_needs_clearance {} { variable screen_last_chars @@ -944,6 +985,30 @@ proc repl::repl_handler {inputchan prompt_config} { variable loopinstance variable loopcomplete incr loopinstance + + if {$::repl::signal_control_c > 0 || [chan eof $inputchan]} { + + if {[lindex $::errorCode 0] eq "CHILDKILLED"} { + #rputs stderr "\n|repl> ctrl-c errorCode: $::errorCode" + #avoid spurious triggers after interrupting a command.. + #review - dodgy.. we just want to interrupt child processes but then still be able to interrupt repl + set ::repl::signal_control_c 0 + set preverr [string map [list "child killed" "child_killed"] $::errorInfo] + catch {error $preverr} ;#for errorInfo display + } else { + set ::repl::signal_control_c 0 + fileevent $inputchan readable {} + set reading 0 + set running 0 + if {$::tcl_interactive} { + rputs stderr "\n|repl> EOF on $inputchan." + } + set [namespace current]::done 1 + #test + tailcall repl::reopen_stdin + } + } + if {[catch { variable prompt_reset_flag #catch {puts stderr "xx--->[rep $::arglej]"} @@ -955,34 +1020,16 @@ proc repl::repl_handler {inputchan prompt_config} { variable lastoutchar "" variable lasterrchar "" variable commandstr + variable readingchunk variable running variable reading variable post_script variable id_outstack upvar ::punk::last_run_display last_run_display upvar ::punk::config::running running_config - if {$::repl::signal_control_c > 0} { - - if {[lindex $::errorCode 0] eq "CHILDKILLED"} { - #rputs stderr "\n|repl> ctrl-c errorCode: $::errorCode" - #avoid spurious triggers after interrupting a command.. - #review - dodgy.. we just want to interrupt child processes but then still be able to interrupt repl - set ::repl::signal_control_c 0 - set preverr [string map [list "child killed" "child_killed"] $::errorInfo] - catch {error $preverr} ;#for errorInfo display - } else { - set ::repl::signal_control_c 0 - fileevent $inputchan readable {} - set reading 0 - set running 0 - if {$::tcl_interactive} { - rputs stderr "\n|repl> EOF on $inputchan." - } - set [namespace current]::done 1 - #test - tailcall repl::reopen_stdin - } - } + + + if 0 { set chunksize [gets $inputchan line] if {$chunksize < 0} { if {[chan eof $inputchan]} { @@ -998,393 +1045,610 @@ proc repl::repl_handler {inputchan prompt_config} { #tailcall repl::reopen_stdin } } + } + set resultprompt [dict get $prompt_config resultprompt] set nlprompt [dict get $prompt_config nlprompt] set infoprompt [dict get $prompt_config infoprompt] set debugprompt [dict get $prompt_config debugprompt] + #JMN + #fileevent $inputchan readable {} + + #According to DKF - -buffering option doesn't affect input channels + + + set stdinlines [list] + chan configure stdin -blocking 0 + + set linemax 40 - set stdinconf [fconfigure stdin] - if {$::tcl_platform(platform) eq "windows" && [dict get $stdinconf -encoding] ni [list unicode utf-16]} { - puts "--stdin> [fconfigure stdin]" - append commandstr $line - puts "1=============>[string length $commandstr] bytes , [string map [list \r -r- \n -n-] $commandstr] , info complete:[info complete $line]" - set commandstr [string range $commandstr 0 end-3] - set commandstr [encoding convertfrom utf-16be $commandstr] - set commandstr [string trimright $commandstr] - puts "2=============>[string length $commandstr] bytes , [string map [list \r -r- \n -n-] $commandstr] , info complete:[info complete $line]" - append commandstr \n + #note -inputmode not available in Tcl 8.6! + set rawmode 0 + if {[dict exists [chan configure stdin] -inputmode]} { + if {[chan configure stdin -inputmode] eq "raw"} { + set rawmode 1 + } } else { - #append commandstr $line - #puts "0=============>[string length $commandstr] bytes , [string map [list \r -r- \n -n-] $commandstr] , info complete:[info complete $line]" - append commandstr $line\n + set rawmode [set ::punk::console::is_raw] } - #puts "=============>[string length $commandstr] bytes , [string map [list \r -r- \n -n-] $commandstr] , info complete:[info complete $line]" - set ::repl::last_repl_char "\n" ;#this is actually the eol from stdin - screen_last_char_add "\n" stdin $line - if {[info complete $commandstr]} { - set ::repl::output_stdout "" - set ::repl::output_stderr "" - set outstack [list] - set errstack [list] - - - #oneshot repl debug - set wordparts [regexp -inline -all {\S+} $commandstr] - lassign $wordparts cmd_firstword cmd_secondword - if {$cmd_firstword eq "debugrepl"} { - if {[string is integer -strict $cmd_secondword]} { - incr ::punk::repl::debug_repl $cmd_secondword - } else { - incr ::punk::repl::debug_repl + if {!$rawmode} { + set lc 0 + while {[set chunksize [gets $inputchan ln]] >= 0 && $lc < $linemax} { + lappend stdinlines $ln + incr lc + } + if {$chunksize < 0 && [chan eof $inputchan]} { + fileevent $inputchan readable {} + set reading 0 + set running 0 + if {$::tcl_interactive} { + rputs stderr "\n|repl> EOF on $inputchan." } - set commandstr "set ::punk::repl::debug_repl" + set [namespace current]::done 1 + #test + #JMN + #tailcall repl::reopen_stdin } - if {$::punk::repl::debug_repl > 0} { - proc debug_repl_emit {msg} [string map [list %p% [list $debugprompt]] { - set p %p% - #don't auto-append \n even if missing. - #we may want to use debug_repl_emit with multiple calls for one output line - #if {[string index $msg end] ne "\n"} { - # set msg "$msg\n" - #} - #set last_char [string index $::repl::screen_last_chars end] - set last_char [screen_last_char_get] - if {$last_char ne "\n"} { - set clearance "\n" + } else { + #raw + chan conf stdin -translation lf + #rputs stderr "-->chan conf stdin: [chan conf stdin]<--" + set lc 0 + set maxreads 4 + set numreads 0 + while {[string length [set chunk [read $inputchan 1024]]] >= 0 && $lc < $linemax & $numreads < $maxreads} { + set chunklen [string length $chunk] + if {$chunklen > 0} { + set info1 "chunk $chunklen bytes->[ansistring VIEW -lf 1 -vt 1 $chunk]" + #it's strange - but apparently terminals use a lone cr to represent enter + #You can insert an lf using ctrl-j - and of course stdin could have crlf or lf + #pasting from notepad++ with mixed line endings seems to paste everything ok + #we don't really know the source of input - and whether a read has potentially chopped a crl in half.. + #possibly no real way to determine that. We could wait a small time to see if there's more data coming.. and potentially impact performance. + #Instead we'll try to make sense of it here. + + if {$chunklen == 1} { + #presume it's a keypress from terminal + set chunk [string map [list \r \n] $chunk] } else { - set clearance "" + #maybe a paste? (or stdin to active shell loop - possibly with no terminal ? ) + #we'd better check for crlf and/or plain lf. If found - presume any lone CR is to be left as is. + if {[string first \n $chunk] < 0} { + set chunk [string map [list \r \n] $chunk] + } + #else - + #has lf - but what if last char is cr? + #It may require user to hit enter - probably ok. + #could be a sequence of cr's from holding enter key } - rputs stderr $clearance$p[string map [list \n \n$p] $msg] - }] - set info "" - append info "repl loopinstance: $loopinstance\n" - append info "last_run_info\n" - append info "length: [llength $::punk::last_run_display]\n" - append info "namespace: $punk::ns::ns_current" - debug_repl_emit $info - } else { - proc debug_repl_emit {msg} {return} - } - #----------------------------------------- - #review! - #work around weird behaviour in tcl 8.6 & 8.7a5 (at least) part1 - #https://wiki.tcl-lang.org/page/representation - #/scriptlib/tests/listrep_bug.tcl - #after the uplevel #0 $commandstr call - # vars within the script that were set to a list, and have no string-rep, will generate a string-rep once the script (commandstr) is unset, or set to another value - global run_command_string - set run_command_string "$commandstr\n" ;#add anything that won't affect script. - global run_command_cache - #----------------------------------------- - - set ::punk::last_run_display [list] - set ::repl::last_unknown "" - #*********************************************************** - #don't use puts,rputs or debug_repl_emit in this block - #*********************************************************** - - if {[string length [dict get $running_config color_stdout]] && [punk::console::colour]} { - lappend outstack [shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout]]] - } + #if we get just ctrl-c in one chunk + if {$chunk eq "\x03"} { + ::repl::term::handler_console_control "ctrl-c_via_rawloop" + return + } + #for now - exit with small delay for tidyup + if {$chunk eq "\x1a"} { + ::repl::term::handler_console_control "ctrl-z_via_rawloop" + after 1000 exit + return + } + #try to brutally terminate process + if {$chunk eq "\x1c"} { + exit 42 + } + append readingchunk $chunk - lappend outstack [shellfilter::stack::add stdout tee_to_var -settings {-varname ::repl::output_stdout}] - if {[string length [dict get $running_config color_stderr]] && [punk::console::colour]} { - lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]]] + #rputs stderr "$info1 readingchunk [string length $readingchunk] bytes ->[ansistring VIEW -lf 1 -vt 1 $readingchunk]" + punk::console::rhs_prompt 80 "$info1 readingchunk [string length $readingchunk] bytes ->[ansistring VIEW -lf 1 -vt 1 -bs 1 $readingchunk]" + puts -nonewline $chunk + flush stdout + + while {[set lep [string first \n $readingchunk]] >=0} { + set ln [string range $readingchunk 0 $lep-1] + lappend stdinlines $ln + set readingchunk [string range $readingchunk $lep+1 end] + incr lc + } + } else { + #rputs stderr "->0byte read stdin" + if {[chan eof $inputchan]} { + fileevent $inputchan readable {} + set reading 0 + set running 0 + if {$::tcl_interactive} { + rputs stderr "\n|repl> EOF on $inputchan." + } + set [namespace current]::done 1 + #test + #JMN + #tailcall repl::reopen_stdin + } + break + + } + incr numreads } - lappend errstack [shellfilter::stack::add stderr tee_to_var -settings {-varname ::repl::output_stderr}] - #chan configure stdout -buffering none - fileevent $inputchan readable {} - set reading 0 - #don't let unknown use 'args' to convert commandstr to list - #=============================================================================== - #Actual command call - #puts "____>[rep $commandstr]" - #=============================================================================== - if {[string equal -length [string length "repl_runraw "] "repl_runraw " $commandstr]} { - #pass unevaluated command to runraw - set status [catch {uplevel #0 [list runraw $commandstr]} raw_result] + } + set xinfo [chan pending input stdin] + + + + set maxlinenum [expr {[llength $stdinlines] -1}] + set linenum 0 + foreach line $stdinlines { + set last_repl_char "" ;#last char emitted by this handler to stdout/stderr + set lastoutchar "" + set lasterrchar "" + + set pad [string repeat " " [string length $line]] + set line [overtype::renderline $pad $line] + + set stdinconf [fconfigure stdin] + if {$::tcl_platform(platform) eq "windows" && [dict get $stdinconf -encoding] ni [list unicode utf-16]} { + #some long console inputs are split weirdly when -encoding and -translation are left at defaults - requiring extra enter-key to get repl to process. + #experiment to see if using binary and handling line endings manually gives insight. + # - do: chan conf stdin -encoding binary -translation lf + + #first command after configuring stdin this way seems to be interpreted with wrong encoding - subsequent commands work - review + + #this branch only works on tcl8.7+ + #It seems to fix the issue with holding down enter-key and getting extra blank lines, but + # it breaks copy-paste (encoding issue?) + + + #puts "--stdin> [fconfigure stdin]" + append commandstr $line + #puts "1=============>[string length $commandstr] bytes , [string map [list \r -r- \n -n-] $commandstr] , info complete:[info complete $line]" + set commandstr [string range $commandstr 0 end-3] + set commandstr [encoding convertfrom utf-16be $commandstr] ;#This is weird - but it seemt to be big endian! + set commandstr [string trimright $commandstr] + #puts "2=============>[string length $commandstr] bytes , [string map [list \r -r- \n -n-] $commandstr] , info complete:[info complete $line]" + append commandstr \n } else { - #puts stderr "repl uplevel 0 '$command'" - set status [catch { - #uplevel 1 $run_command_string - #uplevel 1 {namespace eval $punk::ns::ns_current $run_command_string} - set weirdns 0 - set parts [punk::ns::nsparts $punk::ns::ns_current] - foreach p $parts { - if {[string match :* $p] || [string match *: $p]} { - set weirdns 1 - break - } - } - - if {$weirdns} { - uplevel 1 {punk::ns::nseval $punk::ns::ns_current $run_command_string} - } else { - uplevel 1 {namespace inscope $punk::ns::ns_current $run_command_string} - } - } raw_result] + #append commandstr $line + #puts "0=============>[string length $commandstr] bytes , [string map [list \r -r- \n -n-] $commandstr] , info complete:[info complete $line]" + append commandstr $line\n } - #set result $raw_result - #append result ""; #copy on write - #copy on write - append result $raw_result "" - #=============================================================================== - flush stdout - flush stderr - foreach s [lreverse $outstack] { - shellfilter::stack::remove stdout $s + + #puts "=============>[string length $commandstr] bytes , [string map [list \r -r- \n -n-] $commandstr] , info complete:[info complete $line]" + set ::repl::last_repl_char "\n" ;#this is actually the eol from stdin + screen_last_char_add "\n" stdin $line + + #consider \x1b as text on console vs \x1b the character + #review - if we're getting these actual escape characters in line mode.. something is off - let's emit something instead of trying to interpret as a command and failing. + #This tends to happen when some sort of readline not avaialbe ie on unix or mintty in windows + #this only captures leading escape.. as an aid to diagnosis e.g won't be caught and the user will need to close the right bracket to complete the bogus command + #we may need to think about legitimate raw escapes in commands e.g from pipes or script files, vs via console? + if {$commandstr eq "\x1b\[C\n"} { + rputs stderr "${debugprompt}arrow-right C" + set commandstr "" } - foreach s [lreverse $errstack] { - shellfilter::stack::remove stderr $s + if {$commandstr eq "\x1b\[D\n"} { + #rputs stderr "${debugprompt}arrow-left D" + #set commandstr "" + punk::console::move_back 1 } - - #----------------------------------------- - #list/string-rep bug workaround part 2 - #todo - set flag based on punk::repl::has_script_var_bug - lappend run_command_cache $run_command_string - #puts stderr "run_command_string rep: [rep $run_command_string]" - if {[llength $run_command_cache] > 2000} { - set run_command_cache [lrange $run_command_cache 1750 end] + if {$commandstr eq "\x1b\[A\n"} { + rputs stderr "${debugprompt}arrow-up A" + set commandstr "" } - #----------------------------------------- - - set lastoutchar [string index [punk::ansi::stripansi $::repl::output_stdout] end] - set lasterrchar [string index [punk::ansi::stripansi $::repl::output_stderr] end] - - #to determine whether cursor is back at col0 of newline - screen_last_char_add [string index $lastoutchar$lasterrchar end] "stdout/stderr" - - set result_is_chunk_list 0 - #------ - #todo - fix. It doesn't make much sense to only detect if the unknown command occurred in first word. - #e.g set x [something arg] not detected vs something arg - #also - unknown commands aren't the only things that can write directly to the os handles stderr & stdout - if { - [string length $::repl::last_unknown] && \ - [string equal -length [string length $::repl::last_unknown] $::repl::last_unknown $line] - } { - #can't currently detect stdout/stderr writes from unknown's call to exec - #add a clearance newline for direct unknown calls for now - #there is usually output anyway - but we will get an extra blank line now even for a call that only had an exit code - # - # - set unknown_clearance "\n* repl newline" - screen_last_char_add "\uFFFF" clearance "clearance after direct unknown call" - if {[llength $last_run_display]} { - if {$status == 0} { - set result $last_run_display + if {$commandstr eq "\x1b\[B\n"} { + rputs stderr "arrow-down B" + } + if {[string match "\x1b*" $commandstr]} { + rputs stderr "${debugprompt}esc - '[punk::ansi::ansistring::VIEW $commandstr]'" + set commandstr [punk::ansi::stripansi $commandstr] + } + if {[info complete $commandstr]} { + set ::repl::output_stdout "" + set ::repl::output_stderr "" + set outstack [list] + set errstack [list] + + + #oneshot repl debug + set wordparts [regexp -inline -all {\S+} $commandstr] + lassign $wordparts cmd_firstword cmd_secondword + if {$cmd_firstword eq "debugrepl"} { + if {[string is integer -strict $cmd_secondword]} { + incr ::punk::repl::debug_repl $cmd_secondword } else { - + incr ::punk::repl::debug_repl } - set result_is_chunk_list 1 + set commandstr "set ::punk::repl::debug_repl" } - } - #------ - #ok to use repl::screen_needs_clearance from here down.. (code smell proc only valid use in narrow context) - #*********************************************************** - #rputs -nonewline stderr $unknown_clearance - set lastcharinfo "\n" - set whatcol [string repeat " " 12] - foreach cinfo $::repl::screen_last_char_list { - lassign $cinfo c whatinfo whyinfo - set cdisplay [string map [list \r "-r-" \n "-n-"] $c] - if {[string length $cdisplay] == 1} { - set cdisplay "$cdisplay " ;#make 3 wide to match -n- and -r- + if {$::punk::repl::debug_repl > 0} { + proc debug_repl_emit {msg} [string map [list %p% [list $debugprompt]] { + set p %p% + #don't auto-append \n even if missing. + #we may want to use debug_repl_emit with multiple calls for one output line + #if {[string index $msg end] ne "\n"} { + # set msg "$msg\n" + #} + #set last_char [string index $::repl::screen_last_chars end] + set last_char [screen_last_char_get] + if {$last_char ne "\n"} { + set clearance "\n" + } else { + set clearance "" + } + rputs stderr $clearance$p[string map [list \n \n$p] $msg] + }] + set info "" + append info "repl loopinstance: $loopinstance\n" + append info "commandstr: [punk::ansi::ansistring::VIEW $commandstr]\n" + append info "last_run_info\n" + append info "length: [llength $::punk::last_run_display]\n" + append info "namespace: $punk::ns::ns_current" + debug_repl_emit $info + } else { + proc debug_repl_emit {msg} {return} } - set whatinfo [string range $whatinfo$whatcol 0 [string length $whatcol]] - set whysummary [string map [list \n "-n-"] $whyinfo] - append lastcharinfo "$cdisplay $whatinfo $whysummary\n" - } - debug_repl_emit "screen_last_chars: $lastcharinfo" - debug_repl_emit "lastoutchar:'$lastoutchar' lasterrchar: '$lasterrchar'" - if {$status == 0} { - debug_repl_emit "command call status: $status OK" - } else { - debug_repl_emit "command call status: $status ERR" - } - - + #----------------------------------------- + #review! + #work around weird behaviour in tcl 8.6 & 8.7a5 (at least) part1 + #https://wiki.tcl-lang.org/page/representation + #/scriptlib/tests/listrep_bug.tcl + #after the uplevel #0 $commandstr call + # vars within the script that were set to a list, and have no string-rep, will generate a string-rep once the script (commandstr) is unset, or set to another value + global run_command_string + set run_command_string "$commandstr\n" ;#add anything that won't affect script. + global run_command_cache + #----------------------------------------- + + set ::punk::last_run_display [list] + set ::repl::last_unknown "" + #*********************************************************** + #don't use puts,rputs or debug_repl_emit in this block + #*********************************************************** + + if {[string length [dict get $running_config color_stdout]] && [punk::console::colour]} { + lappend outstack [shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout]]] + } - #puts stderr "'$::repl::output_stdout' lastoutchar:'$lastoutchar' result:'$result'" - #$command is an unevaluated script at this point - # so may not be a well formed list e.g 'set x [list a "b"]' - #- lindex will fail - #if {[lindex $command 0] eq "runx"} {} - + lappend outstack [shellfilter::stack::add stdout tee_to_var -settings {-varname ::repl::output_stdout}] + if {[string length [dict get $running_config color_stderr]] && [punk::console::colour]} { + lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]]] + } - if { - [string equal -length [string length "d/ "] "d/ " $commandstr] || \ - [string equal "d/\n" $commandstr] || \ - [string equal -length [string length "dd/ "] "dd/ " $commandstr] || \ - [string equal "dd/\n" $commandstr] || \ - [string equal -length [string length "./ "] "./ " $commandstr] || \ - [string equal "./\n" $commandstr] || \ - [string equal -length [string length "../ "] "../ " $commandstr] || \ - [string equal "../\n" $commandstr] || \ - [string equal -length [string length "runx "] "runx " $commandstr] || \ - [string equal -length [string length "sh_runx "] "sh_runx " $commandstr] || \ - [string equal -length [string length "runout "] "runout " $commandstr] || \ - [string equal -length [string length "sh_runout "] "sh_runout " $commandstr] || \ - [string equal -length [string length "runerr "] "runerr " $commandstr] || \ - [string equal -length [string length "sh_runerr "] "sh_runerr " $commandstr] + lappend errstack [shellfilter::stack::add stderr tee_to_var -settings {-varname ::repl::output_stderr}] + #chan configure stdout -buffering none + #JMN + fileevent $inputchan readable {} + set reading 0 + #don't let unknown use 'args' to convert commandstr to list + #=============================================================================== + #Actual command call + #puts "____>[rep $commandstr]" + #=============================================================================== + if {[string equal -length [string length "repl_runraw "] "repl_runraw " $commandstr]} { + #pass unevaluated command to runraw + set status [catch {uplevel #0 [list runraw $commandstr]} raw_result] + } else { + #puts stderr "repl uplevel 0 '$command'" + set status [catch { + #uplevel 1 $run_command_string + #uplevel 1 {namespace eval $punk::ns::ns_current $run_command_string} + set weirdns 0 + set parts [punk::ns::nsparts $punk::ns::ns_current] + foreach p $parts { + if {[string match :* $p] || [string match *: $p]} { + set weirdns 1 + break + } + } + + if {$weirdns} { + uplevel 1 {punk::ns::nseval $punk::ns::ns_current $run_command_string} + } else { + uplevel 1 {namespace inscope $punk::ns::ns_current $run_command_string} + } + } raw_result] + } + #set result $raw_result + #append result ""; #copy on write + #copy on write + append result $raw_result "" + #=============================================================================== + flush stdout + flush stderr + foreach s [lreverse $outstack] { + shellfilter::stack::remove stdout $s + } + foreach s [lreverse $errstack] { + shellfilter::stack::remove stderr $s + } + #----------------------------------------- + #list/string-rep bug workaround part 2 + #todo - set flag based on punk::repl::has_script_var_bug + lappend run_command_cache $run_command_string + #puts stderr "run_command_string rep: [rep $run_command_string]" + if {[llength $run_command_cache] > 2000} { + set run_command_cache [lrange $run_command_cache 1750 end] + } + #----------------------------------------- + + set lastoutchar [string index [punk::ansi::stripansi $::repl::output_stdout] end] + set lasterrchar [string index [punk::ansi::stripansi $::repl::output_stderr] end] + + #to determine whether cursor is back at col0 of newline + screen_last_char_add [string index $lastoutchar$lasterrchar end] "stdout/stderr" + + set result_is_chunk_list 0 + #------ + #todo - fix. It doesn't make much sense to only detect if the unknown command occurred in first word. + #e.g set x [something arg] not detected vs something arg + #also - unknown commands aren't the only things that can write directly to the os handles stderr & stdout + if { + [string length $::repl::last_unknown] && \ + [string equal -length [string length $::repl::last_unknown] $::repl::last_unknown $line] } { - if {[llength $last_run_display]} { - set result $last_run_display - set result_is_chunk_list 1 + #can't currently detect stdout/stderr writes from unknown's call to exec + #add a clearance newline for direct unknown calls for now + #there is usually output anyway - but we will get an extra blank line now even for a call that only had an exit code + # + # + set unknown_clearance "\n* repl newline" + screen_last_char_add "\uFFFF" clearance "clearance after direct unknown call" + if {[llength $last_run_display]} { + if {$status == 0} { + set result $last_run_display + } else { + + } + set result_is_chunk_list 1 + } + } + #------ + #ok to use repl::screen_needs_clearance from here down.. (code smell proc only valid use in narrow context) + #*********************************************************** + #rputs -nonewline stderr $unknown_clearance + set lastcharinfo "\n" + set whatcol [string repeat " " 12] + foreach cinfo $::repl::screen_last_char_list { + lassign $cinfo c whatinfo whyinfo + set cdisplay [string map [list \r "-r-" \n "-n-"] $c] + if {[string length $cdisplay] == 1} { + set cdisplay "$cdisplay " ;#make 3 wide to match -n- and -r- + } + set whatinfo [string range $whatinfo$whatcol 0 [string length $whatcol]] + set whysummary [string map [list \n "-n-"] $whyinfo] + append lastcharinfo "$cdisplay $whatinfo $whysummary\n" + } + debug_repl_emit "screen_last_chars: $lastcharinfo" + debug_repl_emit "lastoutchar:'$lastoutchar' lasterrchar: '$lasterrchar'" + if {$status == 0} { + debug_repl_emit "command call status: $status OK" + } else { + debug_repl_emit "command call status: $status ERR" } - } - # -- --- --- --- --- --- --- --- --- --- - ##an attempt to preserve underlying rep - ##this is not for performance - just to be less disruptive to underlying rep to aid in learning/debugging - # -- --- --- --- --- --- --- --- --- --- - # JN 2023 - The lrange operation is destructive to path intrep - # The lrange operation is destructive to strings with leading/trailing newlines - # -- --- --- --- --- --- --- --- --- --- - #set saved_errorCode $::errorCode - #set saved_errorInfo $::errorInfo - #if {[catch {lrange $result 0 end} result_as_list]} { - # set is_result_empty [expr {$result eq ""}] - # set ::errorCode $saved_errorCode - # set ::errorInfo $saved_errorInfo - #} else { - # set is_result_empty [expr {[llength $result_as_list] == 0}] - #} - # -- --- --- --- --- --- --- --- --- --- - #set resultrep [::tcl::unsupported::representation $result] - - set is_result_empty [expr {$result eq ""}] - - #catch {puts stderr "yy--->[rep $::arglej]"} + + + + #puts stderr "'$::repl::output_stdout' lastoutchar:'$lastoutchar' result:'$result'" + #$command is an unevaluated script at this point + # so may not be a well formed list e.g 'set x [list a "b"]' + #- lindex will fail + #if {[lindex $command 0] eq "runx"} {} - set reading 1 - if {!$is_result_empty} { - if {$status == 0} { - if {[screen_needs_clearance]} { - rputs -nonewline stderr \n + + if { + [string equal -length [string length "d/ "] "d/ " $commandstr] || \ + [string equal "d/\n" $commandstr] || \ + [string equal -length [string length "dd/ "] "dd/ " $commandstr] || \ + [string equal "dd/\n" $commandstr] || \ + [string equal -length [string length "./ "] "./ " $commandstr] || \ + [string equal "./\n" $commandstr] || \ + [string equal -length [string length "../ "] "../ " $commandstr] || \ + [string equal "../\n" $commandstr] || \ + [string equal -length [string length "runx "] "runx " $commandstr] || \ + [string equal -length [string length "sh_runx "] "sh_runx " $commandstr] || \ + [string equal -length [string length "runout "] "runout " $commandstr] || \ + [string equal -length [string length "sh_runout "] "sh_runout " $commandstr] || \ + [string equal -length [string length "runerr "] "runerr " $commandstr] || \ + [string equal -length [string length "sh_runerr "] "sh_runerr " $commandstr] + + } { + if {[llength $last_run_display]} { + set result $last_run_display + set result_is_chunk_list 1 } - if {$result_is_chunk_list} { - foreach c $result { - lassign $c termchan text - if {[string length $text]} { - if {$termchan eq "result"} { - rputs stdout $resultprompt[string map [list \n "\n$resultprompt"] $text] - #puts -nonewline stdout $text - } elseif {$termchan eq "resulterr"} { - rputs stderr $resultprompt[string map [list \n "\n$resultprompt"] $text] - } elseif {$termchan eq "info"} { - rputs stderr $infoprompt[string map [list \n "\n$infoprompt"] $text] - } else { - #rputs -nonewline $termchan $text - set chanprompt "_ " - rputs $termchan ${chanprompt}[string map [list \n "\n${chanprompt}"] $text] + } + + # -- --- --- --- --- --- --- --- --- --- + ##an attempt to preserve underlying rep + ##this is not for performance - just to be less disruptive to underlying rep to aid in learning/debugging + # -- --- --- --- --- --- --- --- --- --- + # JN 2023 - The lrange operation is destructive to path intrep + # The lrange operation is destructive to strings with leading/trailing newlines + # -- --- --- --- --- --- --- --- --- --- + #set saved_errorCode $::errorCode + #set saved_errorInfo $::errorInfo + #if {[catch {lrange $result 0 end} result_as_list]} { + # set is_result_empty [expr {$result eq ""}] + # set ::errorCode $saved_errorCode + # set ::errorInfo $saved_errorInfo + #} else { + # set is_result_empty [expr {[llength $result_as_list] == 0}] + #} + # -- --- --- --- --- --- --- --- --- --- + #set resultrep [::tcl::unsupported::representation $result] + + set is_result_empty [expr {$result eq ""}] + + #catch {puts stderr "yy--->[rep $::arglej]"} + + set reading 1 + if {!$is_result_empty} { + if {$status == 0} { + if {[screen_needs_clearance]} { + rputs -nonewline stderr \n + } + if {$result_is_chunk_list} { + foreach c $result { + lassign $c termchan text + if {[string length $text]} { + if {$termchan eq "result"} { + rputs stdout $resultprompt[string map [list \n "\n$resultprompt"] $text] + #puts -nonewline stdout $text + } elseif {$termchan eq "resulterr"} { + rputs stderr $resultprompt[string map [list \n "\n$resultprompt"] $text] + } elseif {$termchan eq "info"} { + rputs stderr $infoprompt[string map [list \n "\n$infoprompt"] $text] + } else { + #rputs -nonewline $termchan $text + set chanprompt "_ " + rputs $termchan ${chanprompt}[string map [list \n "\n${chanprompt}"] $text] + } } } - } - } else { - #----------------------------------------------------------- - # avoid repl forcing string rep of simple results. This is just to aid analysis using tcl::unsupported::representation - #set rparts [split $result {}] - #if {[lsearch $rparts \n] < 0} { - # #type of $result unaffected - # rputs "$resultprompt $result" - #} else { - # #$result will be a string due to use of string map - # rputs $resultprompt[string map [list \n "\n$resultprompt"] $result] - #} - #----------------------------------------------------------- - - #we have copied rawresult using append with empty string - so our string interaction with result var here shouldn't affect the returned value - #empty-string result handled in other branch - set flat [string map [list \r\n "" \n ""] $result] - if {[string length $flat] == [string length $result]} { - #no line-endings in data - rputs "$resultprompt$result" } else { - #if {[string index $result end] eq "\n"} { - # set result [string range $result 0 end-1] + #----------------------------------------------------------- + # avoid repl forcing string rep of simple results. This is just to aid analysis using tcl::unsupported::representation + #set rparts [split $result {}] + #if {[lsearch $rparts \n] < 0} { + # #type of $result unaffected + # rputs "$resultprompt $result" + #} else { + # #$result will be a string due to use of string map + # rputs $resultprompt[string map [list \n "\n$resultprompt"] $result] #} - if {[string length $flat] == 0} { - if {[string range $result end-1 end] eq "\r\n"} { - set result [string range $result 0 end-2] - } else { - set result [string range $result 0 end-1] + #----------------------------------------------------------- + + #we have copied rawresult using append with empty string - so our string interaction with result var here shouldn't affect the returned value + #empty-string result handled in other branch + set flat [string map [list \r\n "" \n ""] $result] + if {[string length $flat] == [string length $result]} { + #no line-endings in data + rputs "$resultprompt$result" + } else { + #if {[string index $result end] eq "\n"} { + # set result [string range $result 0 end-1] + #} + if {[string length $flat] == 0} { + if {[string range $result end-1 end] eq "\r\n"} { + set result [string range $result 0 end-2] + } else { + set result [string range $result 0 end-1] + } } + rputs $resultprompt[string map [list \r\n "\n$resultprompt" \n "\n$resultprompt"] $result] } - rputs $resultprompt[string map [list \r\n "\n$resultprompt" \n "\n$resultprompt"] $result] } - } - doprompt "P% " - } else { - #tcl err - if {$result_is_chunk_list} { - foreach c $last_run_display { - lassign $c termchan text - if {[string length $text]} { - if {$termchan eq "result"} { - rputs stdout $resultprompt[string map [list \n "\n$resultprompt"] $text] - #puts -nonewline stdout $text - } elseif {$termchan eq "resulterr"} { - rputs stderr $resultprompt[string map [list \n "\n$resultprompt"] $text] - } elseif {$termchan eq "info"} { - rputs stderr $infoprompt[string map [list \n "\n$infoprompt"] $text] - } else { - rputs -nonewline $termchan $text + doprompt "P% " + } else { + #tcl err + if {$result_is_chunk_list} { + foreach c $last_run_display { + lassign $c termchan text + if {[string length $text]} { + if {$termchan eq "result"} { + rputs stdout $resultprompt[string map [list \n "\n$resultprompt"] $text] + #puts -nonewline stdout $text + } elseif {$termchan eq "resulterr"} { + rputs stderr $resultprompt[string map [list \n "\n$resultprompt"] $text] + } elseif {$termchan eq "info"} { + rputs stderr $infoprompt[string map [list \n "\n$infoprompt"] $text] + } else { + rputs -nonewline $termchan $text + } } } } + + set c [a yellow bold] + set n [a] + rputs stderr $c$result$n + #tcl err hint prompt - lowercase + doprompt "p% " + } + } else { + #doprompt "P% " "green nobold" + if {$linenum == 0} { + #doprompt "$loopinstance,$linenum-$xinfo " "green nobold" + doprompt "P% " "green nobold" + screen_last_char_add " " empty empty + } else { + #doprompt "\n$loopinstance,$linenum-$xinfo " "green nobold" + doprompt "\nP% " "green nobold" + screen_last_char_add "\n" empty empty ;#add \n to indicate noclearance required } - - set c [a yellow bold] - set n [a] - rputs stderr $c$result$n - #tcl err hint prompt - lowercase - doprompt "p% " } + #catch {puts stderr "zz1--->[rep $::arglej]"} + #puts stderr "??? $commandstr" + if {$::punk::repl::debug_repl > 0} { + incr ::punk::repl::debug_repl -1 + } + set commandstr "" + #catch {puts stderr "zz2---->[rep $::arglej]"} } else { - if {[screen_needs_clearance]} { - doprompt "\nP% " + #append commandstr \n + if {$::repl::signal_control_c} { + set ::repl::signal_control_c 0 + fileevent $inputchan readable {} + rputs stderr "* console_control: control-c" + flush stderr + set c [a yellow bold] + set n [a] + rputs stderr "${c}repl interrupted$n" + #set commandstr [list error "repl interrupted"] + set commandstr "" + doprompt ">_ " + flush stdout + } else { - doprompt "P% " + #Incomplete command + # parse and determine outermost unclosed quote/bracket and include in prompt + if {$linenum == $maxlinenum} { + if {$rawmode} { + #review + #we haven't put the data following last le into commandstr - but we want to display proper completion status prior to enter being hit or more data coming in. + #this could give spurious results for large pastes where buffering chunks it in odd places.? + #it does however give sensible output for the common case of a small paste where the last line ending wasn't included + set waiting [punk::lib::system::incomplete $commandstr$readingchunk] + } else { + set waiting [punk::lib::system::incomplete $commandstr] + } + if {[llength $waiting]} { + set c [lindex $waiting end] + } else { + set c " " + } + doprompt ">$c " + } } } - #catch {puts stderr "zz1--->[rep $::arglej]"} - #puts stderr "??? $commandstr" - if {$::punk::repl::debug_repl > 0} { - incr ::punk::repl::debug_repl -1 - } - set commandstr "" - #catch {puts stderr "zz2---->[rep $::arglej]"} - } else { - #append commandstr \n - if {$::repl::signal_control_c} { - set ::repl::signal_control_c 0 - fileevent $inputchan readable {} - rputs stderr "* console_control: control-c" - flush stderr - set c [a yellow bold] - set n [a] - rputs stderr "${c}repl interrupted$n" - #set commandstr [list error "repl interrupted"] - set commandstr "" - doprompt ">_ " - flush stdout - } else { - doprompt "> " - } + incr linenum + } + + + if {$maxlinenum == -1} { + #when in raw mode - no linefeed yet received + #rputs stderr "repl: no complete input line: $commandstr" + #doprompt "$loopinstance-$xinfo " + #screen_last_char_add "\n" empty empty + + screen_last_char_add [string index $readingchunk end] stdinchunk stdinchunk } + fileevent $inputchan readable [list ::repl::repl_handler $inputchan $prompt_config] - update idletasks #fileevent $inputchan readable [list repl::repl_handler $inputchan $prompt_config] #catch {puts stderr "zend--->[rep $::arglej]"} + + + #flush stdout + #update idletasks + + } repl_error]} { puts stderr "error in repl_handler: $repl_error" set stdinreader [fileevent $inputchan readable] diff --git a/src/modules/punk/repo-999999.0a1.0.tm b/src/modules/punk/repo-999999.0a1.0.tm index f2bbce66..656ce478 100644 --- a/src/modules/punk/repo-999999.0a1.0.tm +++ b/src/modules/punk/repo-999999.0a1.0.tm @@ -1144,7 +1144,7 @@ namespace eval punk::repo { try { #git describe will error with 'No names found' if repo has no tags #set v [::exec {*}[auto_execok git] describe] - set v [::exec {*}[auto_execok git] -remote -v] ;# consider 'git rev-parse --short HEAD' + set v [::exec {*}[auto_execok git] remote -v] ;# consider 'git rev-parse --short HEAD' } on error {e o} { set v [lindex [split [dict get $o -errorinfo] \n] 0] } diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index 6adb152b..9ee31e3f 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -21,7 +21,7 @@ package require punk::args package require punk::char package require punk::lib -package require patternpunk +catch {package require patternpunk} package require overtype package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional? package require textutil @@ -70,19 +70,44 @@ namespace eval textblock { } } + #todo - consider 'elastic tabstops' for textblocks where tab acts as a column separator and adjacent lines with the same number of tabs form a sort of table proc width {textblock} { + #backspaces, vertical tabs,carriage returns + if {$textblock eq ""} { return 0 } - set textblock [textutil::tabify::untabify2 $textblock] + + #textutil::tabify is a reasonable hack when there are no ansi SGR codes - but probably not always what we want even then - review + set textblock [textutil::tabify::untabify2 $textblock] + + if {[string first \n $textblock] >= 0} { + return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::string_width [stripansi $v]}]] + } + return [punk::char::string_width [stripansi $textblock]] + } + proc width_naive {textblock} { + # doesn't deal with backspaces, vertical tabs,carriage returns, ansi movements + + if {$textblock eq ""} { + return 0 + } + + set textblock [textutil::tabify::untabify2 $textblock] ;#a reasonable hack - but probably not always what we want - review + if {[string first \n $textblock] >= 0} { return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::string_width [stripansi $v]}]] } return [punk::char::string_width [stripansi $textblock]] } proc height {textblock} { + #This is the height as it will/would-be rendered - not the number of input lines purely in terms of le #empty string still has height 1 (at least for left-right/right-left languages) - set num_le [expr {[string length $textblock]-[string length [string map [list \n {}] $textblock]]}] ;#faster than splitting into single-char list + + #vertical tab on a proper terminal should move directly down. + #Whether or not the terminal in use actually does this - we need to calculate as if it does. (there might not even be a terminal) + + set num_le [expr {[string length $textblock]-[string length [string map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list return [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le } #MAINTENANCE - same as overtype::blocksize? @@ -98,7 +123,7 @@ namespace eval textblock { } else { set width [punk::char::string_width $textblock] } - set num_le [expr {[string length $textblock]-[string length [string map [list \n {}] $textblock]]}] ;#faster than splitting into single-char list + set num_le [expr {[string length $textblock]-[string length [string map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list #our concept of block-height is likely to be different to other line-counting mechanisms set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le