AMG's [dict] edit
AMG: Here is a full Tcl 8.4 implementation of [dict] that preserves key ordering. This code passes 261 out of the 317 tests in Tcl's dict test suite that existed at time of writing (2014-05-22).A likely-faster implementation based on [array] is found below [1], but it doesn't implement as much of [dict] and does not preserve key ordering.I say "likely-faster" because even though my code hasn't been benchmarked yet, it's probably slower than Anton Kovalenko's code due to thorough error checking, the frequent need to canonicalize dicts (remove duplicate keys), and the linear-time algorithms necessitated by the lack of hash tables.# dict.tcl
# http://wiki.tcl.tk/10609
#
# Tcl 8.4-compatible implementation of the [dict] command.
#
# Known deficiencies:
# - In error messages, the variable name doesn't always appear correctly. This
# is due to use of [upvar] which renames the variable.
# - Tcl 8.4 offers no way for [return], [break], etc. inside the script to
# affect the caller. [uplevel] doesn't quite do everything that's needed.
# - Some usage error messages show different names for formal parameters.
# - Performance is reduced.
#
# Test failures (prefix each name with "dict-"):
# 3.12 4.5 5.7 9.7 9.8 11.15 12.7 12.8 12.10
# 13.7 13.8 13.9 14.1 14.2 14.3 14.4 14.12 14.13
# 14.22 15.9 15.10 15.11 16.8 16.9 16.17 16.18 17.13
# 17.16 17.18 21.1 21.2 21.3 21.4 21.13 21.14 21.15
# 22.1 22.2 22.3 22.10 22.14 22.15 23.1 23.2 24.1
# 24.2 24.3 24.4 24.12 24.13 24.20.1 24.21 24.24 24.25
# Only create [dict] command if it doesn't already exist.
if {[catch {dict get {}}]} {
# Tcl 8.4-style implementation of namespace ensembles.
namespace eval ::dict {}
proc ::dict {subcommand args} {
# Confirm $subcommand is a [dict] command or unambiguous prefix thereof.
if {[regexp {[][*?\\]} $subcommand]
|| [llength [set command [info commands ::dict::$subcommand*]]] != 1} {
set commands [string map {::dict:: {}}\
[lsort [info commands ::dict::*]]]
if {[llength $commands] > 1} {
lset commands end "or [lindex $commands end]"
}
if {[llength $commands] > 2} {
set commands [join $commands ", "]
} else {
set commands [join $commands]
}
return -code error "unknown or ambiguous subcommand\
\"$subcommand\": must be $commands"
}
# Invoke the command.
if {[catch {uplevel 1 [concat [list $command] $args]} msg]} {
# Rewrite the command name on error.
regsub {^(wrong # args: should be \")::(dict)::} $msg {\1\2 } msg
return -code error $msg
} else {
return $msg
}
}
# [dict append]
proc ::dict::append {varName key args} {
upvar 1 $varName var
# Locate the matching key. On match, append to the key's value.
if {[::info exists var]} {
::set var [get $var]
::for {::set i 0} {$i < [llength $var]} {::incr i 2} {
if {[lindex $var $i] eq $key} {
::incr i
return [lset var $i [lindex $var $i][join $args {}]]
}
}
}
# On search failure, add the key to the dict. This code also will
# create the dict if it doesn't already exist.
::lappend var $key [join $args {}]
}
# [dict create]
proc ::dict::create {args} {
if {[llength $args] & 1} {
return -code error "wrong # args: should be\
\"dict create ?key value ...?\""
}
get $args
}
# [dict exists]
proc ::dict::exists {dictionary key args} {
# Traverse through nested dicts searching for matches.
::set sub $dictionary
foreach key [concat [list $key] $args] {
if {[llength $sub] & 1} {
return 0
}
::set match 0
foreach {subkey sub} $sub {
if {$subkey eq $key} {
::set match 1
break
}
}
if {!$match} {
return 0
}
}
return $match
}
# [dict filter]
proc ::dict::filter {dictionary filterType args} {
# Invoke the correct filter handler.
::set result {}
switch $filterType {
k - ke - key {
# Filter on keys.
foreach {key val} [get $dictionary] {
foreach pattern $args {
if {[string match $pattern $key]} {
::lappend result $key $val
break
}
}
}
} v - va - val - valu - value {
# Filter on values.
foreach {key val} [get $dictionary] {
foreach pattern $args {
if {[string match $pattern $val]} {
::lappend result $key $val
break
}
}
}
} s - sc - scr - scri - scrip - script {
# Filter on script returning true.
if {[llength $args] != 2} {
return -code error "wrong # args: should be\
\"dict filter dictionary script\
{keyVarName valueVarName} filterScript\""
} elseif {[llength [lindex $args 0]] != 2} {
return -code error "must have exactly two variable names"
}
upvar 1 [lindex $args 0 0] key [lindex $args 0 1] val
foreach {key val} [get $dictionary] {
if {[uplevel 1 [lindex $args 1]]} {
::lappend result $key $val
}
}
} default {
return -code error "bad filterType \"$filterType\":\
must be key, script, or value"
}}
return $result
}
# [dict for]
proc ::dict::for {keyVarValueVar dictionary script} {
if {[llength $keyVarValueVar] != 2} {
return -code error "must have exactly two variable names"
}
# [foreach] does what's needed, mostly. Tcl 8.4 offers no way for
# [return], etc. inside the script to make the caller return.
uplevel 1 [list foreach $keyVarValueVar [get $dictionary] $script]
}
# [dict get]
proc ::dict::get {dictionary args} {
if {[llength $args]} {
# When given multiple arguments, traverse nested dicts to find the
# requested key. Fail if the key is not found.
::set sub $dictionary
foreach key $args {
if {[llength $sub] & 1} {
return -code error "missing value to go with key"
}
::for {::set i [expr {[llength $sub] - 2}]} {1} {::incr i -2} {
if {$i < 0} {
return -code error "key \"$key\" not known\
in dictionary"
} elseif {[lindex $sub $i] eq $key} {
break
}
}
::set sub [lindex $sub [expr {$i + 1}]]
}
return $sub
} else {
# With only one argument, convert that argument to a canonical dict.
if {[llength $dictionary] & 1} {
return -code error "missing value to go with key"
}
::for {::set i 0} {$i < [llength $dictionary]} {::incr i 2} {
if {[::info exists indexes([lindex $dictionary $i])]} {
lset dictionary $indexes([lindex $dictionary $i])\
[lindex $dictionary [expr {$i + 1}]]
::set dictionary [lreplace $dictionary $i [expr {$i + 1}]]
::incr i -2
} else {
::set indexes([lindex $dictionary $i]) [expr {$i + 1}]
}
}
return $dictionary
}
}
# [dict incr]
proc ::dict::incr {varName key {increment 1}} {
upvar 1 $varName var
# Disallow non-integer increments.
if {![string is integer -strict $increment]} {
return -code error "expected integer but got \"$increment\""
}
# Locate the matching key and increment its value.
if {[::info exists var]} {
::set var [get $var]
::for {::set i 0} {$i < [llength $var]} {::incr i 2} {
if {$key eq [lindex $var $i]} {
::incr i
# Disallow non-integer values.
if {![string is integer -strict [lindex $var $i]]} {
return -code error "expected integer but\
got \"[lindex $var $i]\""
}
# Increment the value in place.
return [lset var $i [expr {[lindex $var $i] + $increment}]]
}
}
}
# On search failure, add the key to the dict. This code also will
# create the dict if it doesn't already exist.
::lappend var $key $increment
}
# [dict info]
proc ::dict::info {dictionary} {
# Make sure the dictionary is valid.
if {[llength $dictionary] & 1} {
return -code error "missing value to go with key"
}
# No hash table.
return "dict is represented as plain list"
}
# [dict keys]
proc ::dict::keys {dictionary {pattern *}} {
# Build and return a list of matching keys.
::set result {}
foreach {key val} [get $dictionary] {
if {[string match $pattern $key]} {
::lappend result $key
}
}
return $result
}
# [dict lappend]
proc ::dict::lappend {varName key args} {
upvar 1 $varName var
# Locate the matching key and append a list element to its value.
if {[::info exists var]} {
::set var [get $var]
::for {::set i 0} {$i < [llength $var]} {::incr i 2} {
if {$key eq [lindex $var $i]} {
::incr i
# Disallow non-list values.
llength [lindex $var $i]
# Increment the value in place.
return [lset var $i [concat [lindex $var $i] $args]]
}
}
}
# On search failure, add the key to the dict. This code also will
# create the dict if it doesn't already exist.
::lappend var $key $args
}
# [dict map]
proc ::dict::map {keyVarValueVar dictionary script} {
# Confirm argument syntax.
if {[llength $keyVarValueVar] != 2} {
return -code error "must have exactly two variable names"
}
# Link to local variables which will be used as iterators.
upvar 1 [lindex $keyVarValueVar 0] key [lindex $keyVarValueVar 1] val
# Accumulate and return the result.
::set result {}
foreach {key val} [get $dictionary] {
::lappend result $key [uplevel 1 $script]
}
return $result
}
# [dict merge]
proc ::dict::merge {args} {
# Confirm each argument is a dict.
foreach dict $args {
if {[llength $dict] & 1} {
return -code error "missing value to go with key"
}
}
# Merge the dicts, then normalize.
get [eval [list concat] $args]
}
# [dict remove]
proc ::dict::remove {dictionary args} {
# Remove all dictionary keys matching any of the key arguments.
::set dictionary [get $dictionary]
::set args [lsort -unique $args]
::for {::set i 0} {$i < [llength $dictionary]} {::incr i 2} {
::set index [lsearch -exact -sorted $args [lindex $dictionary $i]]
if {$index >= 0} {
::set dictionary [lreplace $dictionary $i [expr {$i + 1}]]
::set args [lreplace $args $index $index]
if {![llength $args]} {
break
}
::incr i -2
}
}
return $dictionary
}
# [dict replace]
proc ::dict::replace {dictionary args} {
# Confirm correct argument parity.
if {[llength $args] & 1} {
return -code error "wrong # args:\
should be \"dict replace dictionary ?key value ...?\""
}
# Concatenate the dicts then use [get] to canonicalize the result.
get [eval [list concat $dictionary] $args]
}
# [dict set]
proc ::dict::set {varName key args} {
upvar 1 $varName var
# Confirm that a value argument was given.
if {![llength $args]} {
return -code error "wrong # args:\
should be \"dict set varName key ?key ...? value\""
}
# Default the dictionary to empty.
if {![::info exists var]} {
::set var {}
}
# Shuffle the arguments into the right variables.
::set keys [concat [list $key] [lrange $args 0 end-1]]
::set val [lindex $args end]
# Traverse through nested dicts to find the key to insert or replace.
::set path {}
::set sub $var
::for {::set i 0} {$i < [llength $keys]} {::incr i} {
# Canonicalize each level of nested dicts.
lset var $path [::set sub [get $sub]]
# Search the current level to see if any keys match.
::for {::set j 0} {1} {::incr j 2} {
if {$j >= [llength $sub]} {
# On match failure, move the remaining keys into the value,
# transforming it into a nested dict, then set that value.
::set j [expr {[llength $keys] - 1}]
::for {} {$j > $i} {::incr j -1} {
::set val [list [lindex $keys $j] $val]
}
lset var $path [concat $sub [list [lindex $keys $i] $val]]
return $var
} elseif {[lindex $sub $j] eq [lindex $keys $i]} {
# On match success, advance to the next level of nesting.
break
}
}
# Descend into the value associated with the matching key.
::incr j
::lappend path $j
::set sub [lindex $sub $j]
}
# Replace the value of the matched key.
lset var $path $val
}
# [dict size]
proc ::dict::size {dictionary} {
# Canonicalize the dict and return half its length.
expr {[llength [get $dictionary]] / 2}
}
# [dict unset]
proc ::dict::unset {varName key args} {
upvar 1 $varName var
# Handle the case of the dict not existing.
if {![::info exists var]} {
if {[llength $args]} {
# Fail when unsetting a nested key.
return -code error "key \"$key\" not known in dictionary"
} else {
# Create the dict when unsetting a non-nested key.
::set var {}
return
}
}
# Traverse through nested dicts to find the key to remove.
::set keys [concat [list $key] $args]
::set path {}
::set sub $var
::for {::set i 0} {1} {::incr i} {
# Canonicalize each level of nested dicts.
lset var $path [::set sub [get $sub]]
# Search the current level to see if any keys match.
::for {::set j 0} {$j < [llength $sub]} {::incr j 2} {
if {[lindex $sub $j] eq [lindex $keys $i]} {
break
}
}
# Handle outer and innermost nesting levels differently.
if {$i < [llength $keys] - 1} {
# In parent levels, search failure is an error.
if {$j >= [llength $sub]} {
return -code error "key \"[lindex $keys $i]\"\
not known in dictionary"
}
# Descend into the value associated with the matching key.
::incr j
::lappend path $j
::set sub [lindex $sub $j]
} else {
# In the innermost level, search failure is acceptable. On
# search success, remove the key, otherwise just ignore.
if {$j < [llength $sub]} {
lset var $path [lreplace $sub $j [expr {$j + 1}]]
}
# Return the updated dictionary.
return $var
}
}
}
# [dict update]
proc ::dict::update {varName key valVarName args} {
# Confirm argument parity.
if {!([llength $args] & 1)} {
return -code error "wrong # args: should be\
\"dict update varName key valVarName\
?key valVarName ...? script\""
}
::set script [lindex $args end]
# Convert the list of keys and variable names to an array.
array set names [concat [list $key $valVarName] [lrange $args 0 end-1]]
# Initially unset caller variables.
::set valVarNames {}
foreach {key valVarName} [array get names] {
lappend valVarNames $valVarName
}
uplevel 1 [list unset -nocomplain] $valVarNames
# Copy the dict values into the caller's variables.
upvar 1 $varName dict
foreach {key val} [get $dict] {
if {[::info exists names($key)]} {
upvar 1 $names($key) valVar
::set valVar $val
}
}
# Invoke the caller-supplied script.
::set result [uplevel 1 $script]
# If the dict is gone, let it stay gone. Otherwise update it.
if {[::info exists dict]} {
# Update the dict values from the caller's variables, and remove
# keys corresponding to unset variables.
::for {::set i 0} {$i < [llength $dict]} {::incr i 2} {
if {[::info exists names([lindex $dict $i])]} {
upvar 1 $names([lindex $dict $i]) valVar
::unset names([lindex $dict $i])
if {[::info exists valVar]} {
lset dict [expr {$i + 1}] $valVar
} else {
::set dict [lreplace $dict $i [expr {$i + 1}]]
::incr i -2
}
}
}
# Add keys back to the dict from the caller's variables, in case the
# caller removed some keys directly from the dict.
foreach {key valVarName} [array get names] {
upvar 1 $valVarName valVar
if {[::info exists valVar]} {
::lappend dict $key $valVar
}
}
}
# Return the result of the script.
return $result
}
# [dict values]
proc ::dict::values {dictionary {pattern *}} {
# Build and return a list of matching values.
::set result {}
foreach {key val} [get $dictionary] {
if {[string match $pattern $val]} {
::lappend result $val
}
}
return $result
}
# [dict with]
proc ::dict::with {varName args} {
upvar 1 $varName dict
# Confirm a script argument was supplied.
if {![llength $args]} {
return -code error "wrong # args:\
should be \"dict with varName ?key ...? script\""
}
::set script [lindex $args end]
::set args [lrange $args 0 end-1]
# Traverse through nested dicts to find the dict on which to operate.
::set path {}
::set sub [get $dict]
foreach key $args {
# Canonicalize each level of nested dicts.
lset dict $path $sub
# Search the current level to see if any keys match.
::for {::set i 0} {$i < [llength $sub]} {::incr i 2} {
if {[lindex $sub $i] eq $key} {
break
}
}
# Terminate on match failure.
if {$i >= [llength $sub]} {
return -code error "key \"$key\" not known in dictionary"
}
# Descend into the value associated with the matching key.
::incr i
::set sub [get [lindex $sub $i]]
::lappend path $i
}
# Copy the dict values into the caller's variables. Make an array to
# keep track of all the keys in the dict.
foreach {key val} $sub {
upvar 1 $key valVar
::set valVar $val
::set keys($key) {}
}
# Invoke the caller-supplied script.
::set result [uplevel 1 $script]
# If the dict is gone, let it stay gone. Otherwise update it.
if {[::info exists dict]} {
# Traverse through nested dicts again in case the caller-supplied
# script reorganized the dict.
::set path {}
::set sub [get $dict]
foreach key $args {
# Canonicalize each level of nested dicts.
lset dict $path $sub
# Search the current level to see if any keys match.
::for {::set i 0} {$i < [llength $sub]} {::incr i 2} {
if {[lindex $sub $i] eq $key} {
break
}
}
# Terminate on match failure.
if {$i >= [llength $sub]} {
return -code error "key \"$key\" not known in dictionary"
}
# Descend into the value associated with the matching key.
::incr i
::set sub [get [lindex $sub $i]]
::lappend path $i
}
# Update the dict values from the caller's variables, and remove
# keys corresponding to unset variables.
::for {::set i 0} {$i < [llength $sub]} {::incr i 2} {
if {[::info exists keys([lindex $sub $i])]} {
upvar 1 [lindex $sub $i] valVar
::unset keys([lindex $sub $i])
if {[::info exists valVar]} {
lset sub [expr {$i + 1}] $valVar
} else {
::set sub [lreplace $sub $i [expr {$i + 1}]]
::incr i -2
}
}
}
# Add keys back to the dict from the caller's variables, in case the
# caller removed some keys directly from the dict.
foreach key [array names keys] {
upvar 1 $key valVar
if {[::info exists valVar]} {
::lappend sub $key $valVar
}
}
# Save the updated nested dict back into the dict variable.
lset dict $path $sub
}
# Return the result of the script.
return $result
}
}
# vim: set sts=4 sw=4 tw=80 et ft=tcl:Anton Kovalenko's [dict] edit
Anton Kovalenko: As I like the new dict command very much, I want to use it in all my new projects. But I don't want my programs to need tcl 8.5!Here is a pure tcl emulation of dict command.Vince -- this is very useful indeed. Thanks!dict update, dict with, and dict map are not yet supported here. Any contributions?# Poor man's dict -- a pure tcl [dict] emulation
# Very slow, but complete.
#
# Not all error checks are implemented!
# e.g. [dict create odd arguments here] will work
#
# Implementation is based on lists, [array set/get]
# and recursion
if {![llength [info commands dict]]} {
proc dict {cmd args} {
uplevel 1 [linsert $args 0 _dict_$cmd]
}
proc _dict_get {dv args} {
if {![llength $args]} {return $dv} else {
array set dvx $dv
set key [lindex $args 0]
set dv $dvx($key)
set args [lrange $args 1 end]
return [eval [linsert $args 0 _dict_get $dv]]
}
}
proc _dict_exists {dv key args} {
array set dvx $dv
set r [info exists dvx($key)]
if {!$r} {return 0}
if {[llength $args]} {
return [eval [linsert $args 0 _dict_exists $dvx($key) ]]
} else {return 1}
}
proc _dict_set {dvar key value args } {
upvar 1 $dvar dv
if {![info exists dv]} {set dv [list]}
array set dvx $dv
if {![llength $args]} {
set dvx($key) $value
} else {
eval [linsert $args 0 _dict_set dvx($key) $value]
}
set dv [array get dvx]
}
proc _dict_unset {dvar key args} {
upvar 1 $dvar mydvar
if {![info exists mydvar]} {return}
array set dv $mydvar
if {![llength $args]} {
if {[info exists dv($key)]} {
unset dv($key)
}
} else {
eval [linsert $args 0 _dict_unset dv($key) ]
}
set mydvar [array get dv]
return {}
}
proc _dict_keys {dv {pat *}} {
array set dvx $dv
return [array names dvx $pat]
}
proc _dict_append {dvar key {args}} {
upvar 1 $dvar dv
if {![info exists dv]} {set dv [list]}
array set dvx $dv
eval [linsert $args 0 append dvx($key) ]
set dv [array get dvx]
}
proc _dict_create {args} {
return $args
}
proc _dict_filter {dv ftype args} {
set r [list]
foreach {globpattern} $args {break}
foreach {varlist script} $args {break}
switch $ftype {
key {
foreach {key value} $dv {
if {[string match $globpattern $key]} {
lappend r $key $value
}
}
}
value {
foreach {key value} $dv {
if {[string match $globpattern $value]} {
lappend r $key $value
}
}
}
script {
foreach {Pkey Pval} $varlist {break}
upvar 1 $Pkey key $Pval value
foreach {key value} $dv {
if {[uplevel 1 $script]} {
lappend r $key $value
}
}
}
default {
error "Wrong filter type"
}
}
return $r
}
proc _dict_for {kv dict body} {
uplevel 1 [list foreach $kv $dict $body]
}
proc _dict_incr {dvar key {incr 1}} {
upvar 1 $dvar dv
if {![info exists dv]} {set dv [list]}
array set dvx $dv
if {![info exists dvx($key)]} {set dvx($key) 0}
incr dvx($key) $incr
set dv [array get dvx]
}
proc _dict_info {dv} {
return "Dictionary is represented as plain list"
}
proc _dict_lappend {dvar key args} {
upvar 1 $dvar dv
if {![info exists dv]} {set dv [list]}
array set dvx $dv
eval [linsert $args 0 lappend dvx($key)]
set dv [array get dvx]
}
proc _dict_merge {args} {
foreach dv $args {
array set dvx $dv
}
array get dvx
}
proc _dict_replace {dv args} {
foreach {k v} $args {
_dict_set dv $k $v
}
return $dv
}
proc _dict_remove {dv args} {
foreach k $args {
_dict_unset dv $k
}
return $dv
}
proc _dict_size {dv} {
return [expr {[llength $dv]/2}]
}
proc _dict_values {dv {gp *}} {
set r [list]
foreach {k v} $dv {
if {[string match $gp $v]} {
lappend r $v
}
}
return $r
}
}AMG: This code has numerous issues and shortcomings, though many of them are due to being implemented in terms of [array]. However, some things just baffle me. For example, what's this code supposed to do?
foreach {globpattern} $args {break}Why not just say set globpattern [lindex $args 0]?28jan04 jcw - The "ihash" package in critlib [2] might be a way to get good performance (from C, i.e. with a Tcl extension, not a core change). See also the Adding a hashed datatype page where this extension is described in more detail.
RHS 20Sept2004 I included this code in the .tgz file for RHS's Bytecode Package. I wasn't sure who to ask about doing this, but I assumed it was ok, since its on the Wiki and my code is released open source (standard Tclish license). I made a note in the dict.tcl file that the code in that file is not copyrighted to me, and put a link to this page. If my including this file is an issue, let me know and I'll remove it.AMG: See Who owns the content on this Wiki for more discussion on this subject.
PS's [dict update] edit
PS I created a dict package based on the current (Nov2005) code of Tcl 8.5, which has all the features and most of the performance of the real thing. See the dict page, search for 'tclDict' Here's an ugly 'dict update' implementation. Any improvements?proc _dict_update {dvar args} {
set name [string map {: {} ( {} ) {}} $dvar]
upvar 1 $dvar dv
upvar 1 _my_dict_array$name local
array set local $dv
foreach {k v} [lrange $args 0 end-1] {
if {[info exists local($k)]} {
if {![uplevel 1 [list info exists $v]]} {
uplevel 1 [list upvar 0 _my_dict_array${name}($k) $v]
} else {
uplevel 1 [list set $v $local($k)]
}
}
}
set code [catch {uplevel 1 [lindex $args end]} res]
foreach {k v} [lrange $args 0 end-1] {
if {[uplevel 1 [list info exists $v]]} {
set local($k) [uplevel 1 [list set $v]]
} else {
unset -nocomplain local($k)
}
}
set dv [array get local]
unset local
return -code $code $res
}
