#! /bin/env tclsh
package require {ycl ns}
namespace import [yclprefix]::ns::normalize
package require {ycl proc}
variable proc [yclprefix]::proc
namespace eval doc {}
variable doc::existsor {
description {
given a list of keylists, return the first keylist that exists in $dict
}
args {
dict {
description {
the dictionary to search in
}
args {
a list of keylists. Each keylist is a list containing one or
more keys that constitute a candidate path into the dict.
}
}
}
}
proc existsm {dict args} {
foreach keylist $args {
if {[dict exists $dict {*}$keylist]} {
return $keylist
}
}
}
variable doc::getor {
description {
given a list of keys, get the first available value
}
args {
args {
description {
keys to try
}
}
}
}
proc getor {dict args} {
foreach key $args {
if {[dict exists $dict $key]} {
return [dict get $dict $key]
}
}
error [list {none of the keys exist} $args]
}
variable doc::request {
description
look up a value
if it exists
store the result in the variable named by the first item in
$varname
}
proc request {dict varname args} {
if {[string is list -strict $varname]} {
if {[llength $varname] > 1} {
lassign $varname[set varname {}] varname default
} else {
lassign $varname[set varname {}] varname
}
}
upvar 1 $varname res
if {[dict exists $dict {*}$args]} {
set res [dict get $dict {*}$args]
} elseif {[info exists default]} {
set res $default
}
return $res
}
variable doc::search {
description {
Like lsearch, but returns results for the matching keys, and returns
the results in reverse order
}
}
proc search {dict args} {
set indices [lsearch $dict {*}$args]
if {[llength $indices]} {
set indices [lmap i [lreverse $indices[set indices {}]] {
if {$i % 2} continue
lindex $i
}]
}
return $indices
}
proc setdefault {dictname keys default {result {}}} {
upvar $dictname dict
if {![dict exists $dict {*}$keys]} {
dict set dict {*}$keys $default
}
if {[llength [info level 0]] > 3} {
upvar $result result_
set result_ [dict get $dict {*}$keys]
}
return [dict get $dict {*}$keys]
}
apply [list {} {
variable doc::setl {
description {
like [dict set], but doesn't duplicate any keys
}
}
set innerblock {
set args [lassign $args[set args {}] key]
set indices {}
if {[info exists var]} {
# assumption [indices are in reverse order]
set indices [search -exact -all $var $key]
if {[llength $indices]} {
set indices [lassign $indices[set indices {}] idx]
set inner [lindex $var $idx+1]
} else {
set inner {}
}
} else {
lappend var $key {}
set idx 0
set inner {}
}
@doinner@
set var [lreplace $var[set var {}] $idx+1 $idx+1 $inner]
foreach idx $indices {
set var [lreplace $var[set var {}] $idx $idx+1]
}
}
proc setl {varname args} [string map [
list @innerblock@ [string map [
list @doinner@ {
setl inner {*}$args
}] $innerblock]] {
upvar 1 $varname var
if {[llength $args] > 2} {
@innerblock@
} else {
lassign $args[set args {}] key val
if {[info exists var]} {
# assumption [indices are in reverse order]
set indices [search -exact -all $var $key]
if {[llength $indices]} {
set indices [lassign [lreverse $indices[set indices {}]] idx]
set var [lreplace $var[set var {}] $idx+1 $idx+1 $val]
foreach idx $indices {
set var [lreplace $var[set var {}] $idx $idx+1]
}
} else {
lappend var $key $val
}
} else {
lappend var $key $val
}
}
return $var
}]
variable doc::unsetl {
description {
like [dict unset], but doesn't deduplicate other keys
}
}
proc unsetl {varname args} [string map [
list @doinner@ [string map [
list @doinner@ {
unsetl inner {*}$args
}] $innerblock]] {
upvar 1 $varname var
if {[llength $args] > 1} {
@inner@
} else {
lassign $args[set args {}] key
if {[info exists var]} {
# assumption [indices are in reverse order]
set indices [search -exact -all $var $key]
if {[llength $indices]} {
foreach idx [lrange $indices 0 end] {
set var [lreplace $var[set var {}] $idx $idx+1]
}
} else {
error [list {no such key} $key]
}
} else {
error [list {no such key} $key]
}
}
}]
} [namespace current]]
variable doc::freqencode {
description {
take a table of values and their frequencies, and construct a table of
replacement hex values, where the more frequent values get smaller
replacement hex values.
}
args {
dict {
a dictionary where each values is a count of the occurrances of the key in some other dataset
}
}
value {
a dictionary where each key is the original string, and the value is a
replacment hex value for it.
}
}
proc freqencode {dict} {
#sort groups from highest frequency to lowest
set dict [lsort -decreasing -integer -stride 2 -index 1 $dict[set dict {}]]
#iterate through values in groups, assigning the lowest numbers to the highest-frequency values
set i -1
foreach {value count} $dict[set dict {}] {
incr i
if {$count == 1} {
#leave values that only occur once out of the strings table --
#unless they conflict with a string code
#no brackets in second expression!
if {[string is xdigit $value] && [expr 0x$value <= 0x$i]} {
#conflict with existing code
dict set strings $value [format %x $i]
}
break
}
dict set strings $value [format %x $i]
}
return $strings
}
variable doc::var {
description
link a slot in a dictionary to a variable
when updated
updates the specified value in a dictionary
if $varname exists
its value is stored in the slot
otherwise if a value exists in the dictionary for the given keys
that value is stored in $varname
}
proc var {varname dictname args} {
set dictname2 [namespace current]::[info cmdcount]_dictname
upvar 1 $dictname $dictname2
upvar 1 $dictname2 dict
set varname2 [namespace current]::[info cmdcount]_varname2
upvar 1 $varname $varname2
upvar 1 $varname2 var
if {[info exists var]} {
dict set dict {*}$args $var
} elseif {[dict exists $dict {*}$args]} {
set var [dict get $dict {*}$args]
}
uplevel 1 [
list ::trace add variable $varname2 {write unset} [
list ::apply [list {varname dictname keys name1 name2 op} {
upvar 0 $dictname dict
upvar 0 $varname var
if {[info exists var]} {
::dict set dict {*}$keys $var
} elseif {[dict exists $dict {*}$keys]} {
dict unset dict {*}$keys
}
} [uplevel 1 {namespace current}]] $varname2 $dictname2 $args
]
]
uplevel 1 [
list ::trace add variable $dictname2 {unset write} [
list ::apply [list {varname dictname keys name1 name2 op} {
upvar 0 $dictname dict
upvar 0 $varname var
if {[dict exists $dict {*}$keys]} {
set var [dict get $dict {*}$keys]
} else {
catch {unset var}
}
} [uplevel 1 {namespace current}]] $varname2 $dictname2 $args
]
]
}