You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
2590 lines
68 KiB
2590 lines
68 KiB
#JMN 2004 |
|
#public domain |
|
|
|
|
|
package provide patternlib [namespace eval patternlib { |
|
|
|
variable version |
|
set version 1.2.6 |
|
}] |
|
|
|
|
|
|
|
#Change History |
|
#------------------------------------------------------------------------------- |
|
#2022-05 |
|
# added . search and . itemKeys methods to >collection to enable lookups by value |
|
#2021-09 |
|
# Add >keyvalprotector - an object to overload various collection methods such as 'remove' to stop deletion of specific items. |
|
# |
|
#2006-05 |
|
# deprecate 'del' in favour of 'remove' - 'del' still there but delegated to 'remove'. todo - emit deprecation warnings. |
|
# |
|
#2005-04 |
|
# remove 'name' method - incorporate indexed retrieval into 'names' method |
|
# !todo? - adjust key/keys methods for consistency? |
|
# |
|
#2004-10 |
|
# initial key aliases support |
|
# fix negative index support on some methods e.g remove |
|
#2004-08 |
|
# separated >collection predicate methods out onto separate 'mixin' object >predicatedCollection |
|
# added $posn $result variables to predicate methods, changed varnames from $k $v to $key $value |
|
# |
|
#2004-06-05 |
|
# added 'sort' method to sort on values. |
|
# fixed 'keySort' method to accept multiple sort options |
|
# added predicate methods 'all' 'allKeys' 'collectAll' |
|
#2004-06-01 |
|
# '>collection . names' method now accepts optional 'glob' parameter to filter result |
|
#2004-05-19 |
|
#fix '>collection . clear' method so consecutive calls don't raise an error |
|
#------------------------------------------------------------------------------- |
|
|
|
namespace eval ::patternlib::util { |
|
proc package_require_min {pkg minver} { |
|
if {[package vsatisfies [lindex [set available [lsort -increasing [package versions $pkg]]] end] $minver-]} { |
|
package require $pkg |
|
} else { |
|
error "Package pattern requires package $pkg of at least version $minver. Available: $available" |
|
} |
|
} |
|
|
|
#bloom filter experiment https://wiki.tcl-lang.org/page/A+Simple+Bloom+Filter |
|
# k-hashes |
|
# m-bits |
|
# n-elements |
|
# optimal value of k: (m/n)ln(2) |
|
#proc bloom_optimalNumHashes {capacity_n bitsize_m} { |
|
# expr { round((double($bitsize_m) / $capacity_n) * log(2))} |
|
#} |
|
#proc bloom_optimalNumBits {capacity fpp} { |
|
# expr {entier(-$capacity * log($fpp) / (log(2) * log(2)))} |
|
#} |
|
|
|
} |
|
::patternlib::util::package_require_min pattern 1.2.4 |
|
#package require pattern |
|
::pattern::init ;# initialises (if not already) |
|
|
|
|
|
namespace eval ::patternlib {namespace export {[a-z]*} |
|
namespace export {[>]*} |
|
|
|
variable keyCounter 0 ;#form part of unique keys for collections when items added without any key specified |
|
proc uniqueKey {} { |
|
return [incr ::patternlib::keyCounter] |
|
} |
|
|
|
#!todo - multidimensional collection |
|
# - o_list as nested list |
|
# - o_array with compound keys(?) how will we unambiguously delimit dimensions in a concatenated key? |
|
# - perhaps a key is always a list length n where n is the number of dimensions? |
|
# - therefore we'll need an extra level of nesting for the current base case n=1 |
|
# |
|
# - how about a nested dict for each key-structure (o_list & o_array) ? |
|
|
|
#COLLECTION |
|
# |
|
#!todo? - consider putting the actual array & list vars in the objects namespace, and using the instancevars to hold their names |
|
# - consider array-style access using traced var named same as collection. |
|
# would this defeat the purpose ? if it was faster, would users always use array syntax in preference.. in which case they may as well just use arrays..? |
|
#!todo - add boolean property to force unique values as well as keys |
|
|
|
|
|
#::pattern::create >collection |
|
|
|
|
|
|
|
|
|
::>pattern .. Create >collection |
|
set COL >collection |
|
#process_pattern_aliases [namespace origin >collection] |
|
#process_pattern_aliases ::patternlib::>collection |
|
$COL .. Property version 1.0 |
|
$COL .. PatternDefaultMethod item |
|
|
|
set PV [$COL .. PatternVariable .] |
|
|
|
$PV o_data |
|
#$PV o_array |
|
#$PV o_list |
|
$PV o_alias |
|
$PV this |
|
|
|
#for invert method |
|
$PV o_dupes 0 |
|
|
|
|
|
$COL .. PatternProperty bgEnum |
|
|
|
|
|
#PV o_ns |
|
|
|
$PV m_i_filteredCollection |
|
|
|
#set ID [lindex [set >collection] 0 0] ;#context ID |
|
#set IID [lindex [set >collection] 1 0] ;#level 1 base-interface ID |
|
|
|
$COL .. Constructor {args} { |
|
var o_data m_i_filteredCollection o_count o_bgEnum |
|
|
|
var this |
|
set this @this@ |
|
|
|
set m_i_filteredCollection 0 |
|
if {![llength $args]} { |
|
set o_data [dict create] |
|
#array set o_array [list] |
|
#set o_list [list] |
|
set o_count 0 |
|
} elseif {[llength $args] == 1} { |
|
set o_data [dict create] |
|
set pairs [lindex $args 0] |
|
if {[llength $pairs] % 2} { |
|
error "patternllib::>collection - if an argument given to constructor, it must have an even number of elements. Bad args: $args" |
|
} |
|
set keys_seen [list] |
|
foreach key [dict keys $pairs] { |
|
if {[string is integer -strict $key] } { |
|
error ">collection key must be non-integer. Bad key: $key. No items added." |
|
} |
|
if {$key in $keys_seen} { |
|
error "key '$key' already exists in this collection. No items added." |
|
} |
|
lappend keys_seen $key |
|
} |
|
unset keys_seen |
|
#rely on dict ordering guarantees (post 8.5? preserves order?) |
|
set o_data [dict merge $o_data[set o_data {}] $pairs] |
|
set o_count [dict size $o_data] |
|
} else { |
|
error "patternlib::>collection constructor did not understand arguments supplied. Try a dict as a single argument." |
|
} |
|
array set o_alias [list] |
|
|
|
array set o_bgEnum [list] |
|
@next@ |
|
} |
|
#comment block snipped from collection Constructor |
|
#--------------------------------------------- |
|
#set o_selfID [lindex [set $o_this] 0] ;#object id always available in methods as $_ID_ anyway |
|
# |
|
#### OBSOLETE - left as example of an approach |
|
#make count property traceable (e.g so property ref can be bound to Tk widgets) |
|
#!todo - manually update o_count in relevant methods faster?? |
|
# should avoid trace calls for addList methods, shuffle etc |
|
# |
|
#set handler ::p::${_ID_}::___count_TraceHandler |
|
#proc $handler {_ID_ vname vidx op} { |
|
# #foreach {vname vidx op} [lrange $args end-2 end] {break} |
|
# #! we shouldn't trust this vname - it may be that we are being accessed via upvar so it is a different name |
|
# |
|
# #this is only a 'write' handler |
|
# set ::p::[lindex ${_ID_} 0 0]::o_count [llength [set ::p::[lindex ${_ID_} 0 0]::o_list]] |
|
# return |
|
#} |
|
#trace add variable o_list {write} [list $handler $_ID_] |
|
#### |
|
# |
|
# |
|
#puts "--->collection constructor id: $_ID_" |
|
|
|
|
|
|
|
|
|
set PM [$COL .. PatternMethod .] |
|
|
|
|
|
#!review - why do we need the count method as well as the property? |
|
#if needed - document why. |
|
# read traces on count property can be bypassed by method call... shouldn't we avoid that? |
|
#2018 - in theory write traces on the . count property are very useful from an application-writer's perpective. |
|
# |
|
$COL .. PatternMethod count {} { |
|
#we don't require any instance vars to be upvar'ed - argless [var] stops them automatically being added. |
|
#we directly refer to the ::O:: var if only accessing a few times rather than upvar'ing. |
|
var o_data |
|
dict size $o_data |
|
} |
|
|
|
$COL .. PatternProperty count |
|
$COL .. PatternPropertyWrite count {_val} { |
|
var |
|
error "count property is read-only" |
|
} |
|
|
|
$COL .. PatternPropertyUnset count {} { |
|
var |
|
} ;#cannot raise error's in unset trace handlers - simply fail to unset silently |
|
|
|
$COL .. PatternMethod isEmpty {} { |
|
#var o_list |
|
#return [expr {[llength $o_list] == 0}] |
|
var o_data |
|
expr {[dict size $o_data] == 0} |
|
} |
|
|
|
$COL .. PatternProperty inverted 0 |
|
|
|
|
|
|
|
###### |
|
# item |
|
###### |
|
#defaults to fifo when no idx supplied (same as 'pair' method). !review? is lifo more logical/intuitive/useful? |
|
# i.e [>obj . item] returns the 1st element in the list |
|
#[>obj . item -1] returns the last element (equiv to "end" keyword used by Tcl list commands) |
|
#[>obj . item -2] returns 2nd last element (equiv to "end-1") |
|
|
|
|
|
$COL .. PatternMethod item {{idx 0}} { |
|
#with pattern::0::$OID access.. was measured faster than item2 : approx 110us vs 140us for 26element collection accessed via string (time {>col $key} 10000) |
|
# (still at least 20 times slower than a plain array... at <5us) |
|
var o_data o_alias |
|
|
|
#!todo - review 'string is digit' vs 'string is integer' ?? |
|
if {[string is integer -strict $idx]} { |
|
if {$idx < 0} { |
|
set idx "end-[expr {abs($idx + 1)}]" |
|
} |
|
set keys [dict keys $o_data] |
|
if {[catch {dict get $o_data [lindex $keys $idx]} result]} { |
|
var this |
|
error "no such index : '$idx' in collection: $this" |
|
} else { |
|
return $result |
|
} |
|
} else { |
|
if {[catch {dict get $o_data $idx} result]} { |
|
if {[catch {set o_alias($idx)} nextIdx ]} { |
|
var this |
|
error "no such index: '$idx' in collection: $this" |
|
} else { |
|
#try again |
|
#return $o_array($nextIdx) |
|
#tailcall? |
|
#item $_ID_ $nextIdx |
|
#puts stdout "\n\n\n !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! about to call tailcall item $_ID_ $nextIdx \n\n\n" |
|
tailcall item $_ID_ $nextIdx |
|
} |
|
} else { |
|
return $result |
|
} |
|
} |
|
} |
|
|
|
|
|
|
|
if {0} { |
|
#leave this here for comparison. |
|
$COL .. PatternMethod item2 {{idx 0}} { |
|
var o_array o_list o_alias this |
|
|
|
if {[string is integer -strict $idx]} { |
|
if {$idx < 0} { |
|
set idx "end-[expr {abs($idx + 1)}]" |
|
} |
|
|
|
if {[catch {set o_array([lindex $o_list $idx])} result]} { |
|
error "no such index : '$idx' in collection: $this" |
|
} else { |
|
return $result |
|
} |
|
} else { |
|
if {[catch {set o_array($idx)} result]} { |
|
|
|
if {[catch {set o_alias($idx)} nextIdx ]} { |
|
error "no such index: '$idx' in collection: $this" |
|
} else { |
|
#try again |
|
#return $o_array($nextIdx) |
|
item $_ID_ $nextIdx |
|
} |
|
} else { |
|
return $result |
|
} |
|
} |
|
|
|
} |
|
} |
|
|
|
#simple no-frills access for speed.. (timed at 43us vs 63us for item (depending on dispatch method!)) |
|
$COL .. PatternMethod itemNamed {idx} { |
|
var o_data |
|
dict get $o_data $idx |
|
} |
|
$COL .. PatternMethod in {idx} { |
|
var o_data |
|
dict get $o_data $idx |
|
} |
|
|
|
$COL .. PatternMethod itemAt {idx} { |
|
var o_data |
|
dict get $o_data [lindex [dict keys $o_data] $idx] |
|
} |
|
|
|
$COL .. PatternMethod replace {idx val} { |
|
var o_data o_alias this |
|
|
|
if {[string is integer -strict $idx]} { |
|
if {$idx < 0} { |
|
set idx "end-[expr {abs($idx + 1)}]" |
|
} |
|
|
|
if {[catch {dict set o_data [lindex [dict keys $o_data] $idx] $val}]} { |
|
error "no such index: '$idx' in collection: $this" |
|
} else { |
|
return $val |
|
} |
|
} else { |
|
if {[catch {dict set o_data $idx $val}]} { |
|
if {[catch {set o_alias($idx)} nextIdx ]} { |
|
error "no such index: '$idx' in collection: $this" |
|
} else { |
|
#try again |
|
tailcall replace $_ID_ $nextIdx $val |
|
} |
|
|
|
} else { |
|
return $val |
|
} |
|
} |
|
} |
|
|
|
#if the supplied index is an alias, return the underlying key; else return the index supplied. |
|
$COL .. PatternMethod realKey {idx} { |
|
var o_alias |
|
|
|
if {[catch {set o_alias($idx)} key]} { |
|
return $idx |
|
} else { |
|
return $key |
|
} |
|
} |
|
|
|
#note alias feature is possibly ill-considered. |
|
#if we delete an item - should we delete corresponding alias? If not - we then would need to allow adding under an alias only if the corresponding key is missing. |
|
$COL .. PatternMethod alias {newAlias existingKeyOrAlias} { |
|
var o_alias |
|
|
|
#set existingKey [realKey $_ID_ $existingKeyOrAlias] |
|
#alias to the supplied KeyOrAlias - not the underlying key |
|
|
|
if {[string is integer -strict $newAlias]} { |
|
error "collection key alias cannot be integer" |
|
} |
|
|
|
if {[string length $existingKeyOrAlias]} { |
|
set o_alias($newAlias) $existingKeyOrAlias |
|
} else { |
|
unset o_alias($newAlias) |
|
} |
|
} |
|
$COL .. PatternMethod aliases {{key ""}} { |
|
var o_alias |
|
|
|
if {[string length $key]} { |
|
set result [list] |
|
#lsearch -stride? |
|
foreach {n v} [array get o_alias] { |
|
if {$v eq $key} { |
|
lappend result $n $v |
|
} |
|
} |
|
|
|
return $result |
|
} else { |
|
return [array get o_alias] |
|
} |
|
} |
|
|
|
#'pop' & 'unshift' methods !todo - optimize so lsearch not called when numerical idx/posn already supplied |
|
|
|
#default to removing item from the end, otherwise from supplied index (position or key) |
|
#!todo - accept alias indices |
|
#!todo - review.. should any corresponding alias be destroyed when the corresponding item is popped (or removed in any way?) |
|
#!todo - review.. for performance.. shouldn't pop NOT accept an index? |
|
#if we need to pop from other than the end.. this could be a separate function. Do other langs use pop with an index?? |
|
$COL .. PatternMethod pop {{idx ""}} { |
|
var o_data o_count |
|
|
|
if {$idx eq ""} { |
|
set key [lindex [dict keys $o_data] end] |
|
} else { |
|
if {[string is integer -strict $idx]} { |
|
set key [lindex [dict keys $o_data] $idx] |
|
} else { |
|
set key $idx |
|
} |
|
} |
|
set posn [lsearch -exact [dict keys $o_data] $key] |
|
|
|
if {($posn >= 0) && ($posn < [dict size $o_data])} { |
|
set result [dict get $o_data $key] |
|
dict unset o_data $key |
|
set o_count [dict size $o_data] |
|
return $result |
|
} else { |
|
error "no such index: '$idx'" |
|
} |
|
} |
|
$COL .. PatternMethod poppair {} { |
|
var o_data o_count |
|
set key [lindex [dict keys $o_data] end] |
|
set val [dict get $o_data $key] |
|
dict unset o_data $key |
|
set o_count [dict size $o_data] |
|
return [list $key $val] |
|
} |
|
|
|
|
|
|
|
#!todo - add 'push' method... (basically specialized versions of 'add') |
|
#push - add at end (effectively an alias for add) |
|
#shift - add at start ???bad name? this is completely at odds with for example the common Perl shift function, which returns and removes the first element of an array. |
|
#add - add at end |
|
|
|
#ordered |
|
$COL .. PatternMethod items {} { |
|
var o_data |
|
|
|
dict values $o_data |
|
} |
|
|
|
|
|
|
|
|
|
#### |
|
#pair |
|
#### |
|
#fifo-style accesss when no idx supplied (likewise with 'add' method) |
|
$COL .. PatternMethod pair {{idx 0}} { |
|
var o_data |
|
|
|
if {[string is integer -strict $idx]} { |
|
set key [lindex [dict keys $o_data] $idx] |
|
} else { |
|
set key $idx |
|
} |
|
|
|
if {[catch {dict get $o_data $key} val]} { |
|
error "no such index: '$idx'" |
|
} else { |
|
return [list $key $val] |
|
} |
|
} |
|
$COL .. PatternMethod pairs {} { |
|
var o_data |
|
set o_data |
|
} |
|
|
|
$COL .. PatternMethod get {} { |
|
var o_data |
|
set o_data |
|
} |
|
#todo - fix >pattern so that methods don't collide with builtins |
|
#may require change to use oo - or copy 'my' mechanism to call own methods |
|
$COL .. PatternMethod Info {} { |
|
var o_data |
|
return [dict info $o_data] |
|
} |
|
#2006-05-21.. args to add really should be in key, value order? |
|
# - this the natural order in array-like lists |
|
# - however.. key should be optional. |
|
|
|
$COL .. PatternMethod add {val args} { |
|
#(using args instead of {key ""} enables use of empty string as a key ) |
|
|
|
var o_data o_alias o_count this |
|
|
|
if {![llength $args]} { |
|
set key "_[::patternlib::uniqueKey]_" |
|
} else { |
|
#!todo - could we handle multiple val,key pairs without impacting performance of the common case? |
|
if {[llength $args] > 1} { |
|
error "add method expected 'val' and optional 'key' - got: $val $args" |
|
|
|
} |
|
|
|
set key [lindex $args 0] |
|
if {[string is integer -strict $key]} { |
|
error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys" |
|
} |
|
} |
|
|
|
if {[dict exists $o_data $key]} { |
|
#error "key $key already exists in collection [set ::p::[lindex ${_ID_} 0 0]::this]" |
|
error "key '$key' already exists in collection $this" |
|
} |
|
if {[info exists o_alias($key)]} { |
|
if {[dict exists $o_data $o_alias($key)]} { |
|
#only disallow adding via the alias if there is an existing o_data element for the key pointed to by the alias |
|
error "key '$key' already exists as an alias for $o_alias($key) in collection $this" |
|
} |
|
} |
|
|
|
dict set o_data $key $val |
|
|
|
|
|
set posn $o_count |
|
incr o_count |
|
|
|
return $posn |
|
} |
|
|
|
|
|
#should the 'stack' methods such as shift,push,pop,peek actually be on a separate interface? |
|
#what then of methods like 'count' which apply equally well to collections and stacks? |
|
|
|
#Alias for 'add' - is there a way to alias this to add implementation with zero overhead?? |
|
$COL .. PatternMethod push {val args} { |
|
#(using args instead of {key ""} enables use of empty string as a key ) |
|
|
|
var o_data o_alias o_count this |
|
|
|
if {![llength $args]} { |
|
set key "_[::patternlib::uniqueKey]_" |
|
} else { |
|
#!todo - could we handle multiple val,key pairs without impacting performance of the common case? |
|
if {[llength $args] > 1} { |
|
error "add method expected 'val' and optional 'key' - got: $val $args" |
|
|
|
} |
|
|
|
set key [lindex $args 0] |
|
if {[string is integer -strict $key]} { |
|
error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys" |
|
} |
|
} |
|
|
|
if {[dict exists $o_data $key]} { |
|
#error "key $key already exists in collection [set ::p::[lindex ${_ID_} 0 0]::this]" |
|
error "key '$key' already exists in collection $this" |
|
} |
|
if {[info exists o_alias($key)]} { |
|
if {[dict exists $o_data $o_alias($key)]} { |
|
#only disallow adding via the alias if there is an existing o_data element for the key pointed to by the alias |
|
error "key '$key' already exists as an alias for $o_alias($key) in collection $this" |
|
} |
|
} |
|
|
|
dict set o_data $key $val |
|
|
|
|
|
set posn $o_count |
|
incr o_count |
|
|
|
return $posn |
|
} |
|
|
|
|
|
#shift/unshift - roughly analogous to those found in Perl & PHP |
|
#unshift adds 1 or more values to the beginning of the collection. |
|
$COL .. PatternMethod unshift {values {keys ""}} { |
|
var o_data o_count |
|
|
|
if {![llength $keys]} { |
|
for {set i 0} {$i < [llength $values]} {incr i} { |
|
lappend keys "_[::patternlib::uniqueKey]_" |
|
} |
|
} else { |
|
#check keys before we insert any of them. |
|
foreach newkey $keys { |
|
if {[string is integer -strict $newkey]} { |
|
error "cannot accept key '$newkey', >collection keys must be non-numeric. Other structures such as >hashMap allow user specified integer keys" |
|
} |
|
} |
|
} |
|
if {[llength $values] != [llength $keys]} { |
|
error "unshift requires same number of keys as values. (or no keys for auto-generated keys) Received [llength $values] values, [llength $keys] keys" |
|
} |
|
|
|
#separate loop through keys because we want to fail the whole operation if any are invalid. |
|
|
|
set existing_keys [dict keys $o_data] |
|
foreach newkey $keys { |
|
if {$newkey in $exisint_keys} { |
|
#puts stderr "==============> key $key already exists in this collection" |
|
error "key '$newkey' already exists in this collection" |
|
} |
|
} |
|
|
|
|
|
#ok - looks like entire set can be inserted. |
|
set newpairs [list] |
|
foreach val $values key $keys { |
|
lappend newpairs $key $val |
|
} |
|
set o_data [concat $newpairs $o_data[set o_data {}]] |
|
set o_count [dict size $o_data] |
|
|
|
return [expr {$o_count - 1}] |
|
} |
|
|
|
#default to removing item from the beginning, otherwise from supplied index (position or key) |
|
#!todo - accept alias indices |
|
$COL .. PatternMethod shift {{idx ""}} { |
|
var o_data o_count |
|
|
|
if {$idx eq ""} { |
|
set key [lindex [dict keys $o_data] 0] |
|
} else { |
|
if {[string is integer -strict $idx]} { |
|
set key [lindex [dict keys $o_data] $idx] |
|
} else { |
|
set key $idx |
|
} |
|
} |
|
set posn [lsearch -exact [dict keys $o_data] $key] |
|
|
|
if {($posn >= 0) && (($posn/2) < [dict size $o_data])} { |
|
set result [dict get $o_data $key] |
|
dict unset o_data $key |
|
set o_count [dict size $o_data] |
|
return $result |
|
} else { |
|
error "no such index: '$idx'" |
|
} |
|
} |
|
|
|
|
|
$COL .. PatternMethod peek {} { |
|
var o_data |
|
|
|
#set o_array([lindex $o_list end]) |
|
|
|
#dict get $o_data [lindex [dict keys $o_data] end] |
|
lindex $o_data end |
|
} |
|
|
|
$COL .. PatternMethod peekKey {} { |
|
var o_data |
|
#lindex $o_list end |
|
lindex $o_data end-1 |
|
} |
|
|
|
|
|
$COL .. PatternMethod insert {val args} { |
|
var o_data o_count |
|
|
|
set idx 0 |
|
set key "" |
|
|
|
if {[llength $args] <= 2} { |
|
#standard arg (ordered) style: |
|
#>obj . insert $value $position $key |
|
|
|
lassign $args idx key |
|
} else { |
|
#allow for literate programming style: |
|
#e.g |
|
# >obj . insert $value at $listPosition as $key |
|
|
|
if {[catch {array set iargs $args}]} { |
|
error "insert did not understand argument list. |
|
usage: |
|
>obj . insert \$val \$position \$key |
|
>obj . insert \$val at \$position as \$key" |
|
} |
|
if {[info exists iargs(at)]} { |
|
set idx $iargs(at) |
|
} |
|
if {[info exists iargs(as)]} { |
|
set key $iargs(as) |
|
} |
|
} |
|
|
|
if {![string length $key]} { |
|
set key "_[::patternlib::uniqueKey]_" |
|
} |
|
|
|
if {[string is integer -strict $key]} { |
|
error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys" |
|
} |
|
|
|
|
|
if {[dict exists $o_data $key]} { |
|
#puts stderr "==============> key $key already exists in this collection" |
|
error "key '$key' already exists in this collection" |
|
} |
|
|
|
if {$idx eq "end"} { |
|
#lappend o_list $key |
|
#standard dict set will add it to the end anyway |
|
dict set o_data $key $val |
|
|
|
} else { |
|
#set o_list [linsert $o_list $idx $key] |
|
|
|
#treat dict as list |
|
set o_data [linsert $o_data[set o_data {}] [expr {$idx*2}] $key $val] |
|
} |
|
|
|
|
|
#set o_array($key) $val |
|
|
|
|
|
set o_count [dict size $o_data] |
|
|
|
return [expr {$o_count - 1}] |
|
} |
|
|
|
#!todo - deprecate and give it a better name! addDict addPairs ? |
|
$COL .. PatternMethod addArray {list} { |
|
var |
|
puts stderr "patternlib::>collection WARNING: addArray deprecated - call addPairs with same argument instead" |
|
tailcall addPairs $_ID_ $list |
|
} |
|
$COL .. PatternMethod addPairs {list} { |
|
var o_data o_alias o_count |
|
if {[llength $list] % 2} { |
|
error "must supply an even number of elements" |
|
} |
|
|
|
set aliaslist [array names o_alias] |
|
#set keylist [dict keys $o_data] |
|
foreach newkey [dict keys $list] { |
|
if {[string is integer -strict $newkey] } { |
|
error ">collection key must be non-integer. Bad key: $newkey. No items added." |
|
} |
|
|
|
#if {$newkey in $keylist} {} |
|
#for small to medium collections - testing for newkey in $keylist is probably faster, |
|
# but we optimise here for potentially large existing collections, where presumably a dict exists lookup will be more efficient. |
|
if {[dict exists $o_data $newkey]} { |
|
error "key '$newkey' already exists in this collection. No items added." |
|
} |
|
#The assumption is that there are in general relatively few aliases - so a list test is appropriate |
|
if {$newkey in $aliaslist} { |
|
if {[dict exists $o_data $o_alias($newkey)]} { |
|
error "key '$newkey' already exists as an alias for $o_alias($newkey) in collection. No items added " |
|
} |
|
} |
|
#! check if $list contains dups? |
|
#- slows method down - for little benefit? |
|
} |
|
#!todo - test? (but we need a loop to test for integer keys.. so what's the point?) |
|
#set intersection [struct::set intersect [dict keys $list] [dict keys $o_data]] |
|
#if {[llength $intersection]} { |
|
# error "keys '$intersection' already present in this collection. No items added." |
|
#} |
|
|
|
|
|
#rely on dict ordering guarantees (post 8.5? preserves order?) |
|
set o_data [dict merge $o_data[set o_data {}] $list] |
|
|
|
set o_count [dict size $o_data] |
|
|
|
return [expr {$o_count - 1}] |
|
} |
|
$COL .. PatternMethod addList {list} { |
|
var o_data o_count |
|
|
|
foreach val $list { |
|
dict set o_data "_[::patternlib::uniqueKey]_" $val |
|
#!todo - test. Presumably lappend faster because we don't need to check existing keys.. |
|
#..but.. is there shimmering involved in treating o_data as a list? |
|
#lappend o_data _[::patternlib::uniqueKey]_ $val |
|
|
|
#tested 2008-06 tcl8.6a0 lappend was slower as the gain is lost (and more!) during subsequent [dict size $o_data] |
|
} |
|
set o_count [dict size $o_data] |
|
|
|
return [expr {$o_count - 1}] |
|
} |
|
|
|
#'del' is not a very good name... as we're not really 'deleting' anything. |
|
# 'remove' seems better, and appears to be more consistent with other languages' collection implementations. |
|
#!todo - handle 'endRange' parameter for removing ranges of items. |
|
$COL .. PatternMethod del {idx {endRange ""}} { |
|
var |
|
#!todo - emit a deprecation warning for 'del' |
|
tailcall remove $_ID_ $idx $endRange |
|
} |
|
|
|
$COL .. PatternMethod remove {idx {endRange ""}} { |
|
var o_data o_count o_alias this |
|
|
|
if {[string length $endRange]} { |
|
error "ranged removal not yet implemented.. remove one item at a time." |
|
} |
|
|
|
|
|
if {[string is integer -strict $idx]} { |
|
if {$idx < 0} { |
|
set idx "end-[expr {abs($idx + 1)}]" |
|
} |
|
set key [lindex [dict keys $o_data] $idx] |
|
set posn $idx |
|
} else { |
|
set key $idx |
|
set posn [lsearch -exact [dict keys $o_data] $key] |
|
if {$posn < 0} { |
|
if {[catch {set o_alias($key)} nextKey]} { |
|
error "no such index: '$idx' in collection: $this" |
|
} else { |
|
#try with next key in alias chain... |
|
#return [remove $_ID_ $nextKey] |
|
tailcall remove $_ID_ $nextKey |
|
} |
|
} |
|
} |
|
|
|
dict unset o_data $key |
|
|
|
set o_count [dict size $o_data] |
|
return |
|
} |
|
|
|
#ordered |
|
$COL .. PatternMethod names {{globOrIdx {}}} { |
|
var o_data |
|
|
|
if {[llength $globOrIdx]} { |
|
if {[string is integer -strict $globOrIdx]} { |
|
#Idx |
|
set idx $globOrIdx |
|
|
|
if {$idx < 0} { |
|
set idx "end-[expr {abs($idx + 1)}]" |
|
} |
|
|
|
|
|
|
|
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
|
error "no such index : '$idx'" |
|
} else { |
|
return $result |
|
} |
|
|
|
} else { |
|
#glob |
|
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
|
} |
|
} else { |
|
return [dict keys $o_data] |
|
} |
|
} |
|
|
|
#ordered |
|
$COL .. PatternMethod keys {} { |
|
#like 'names' but without globbing |
|
var o_data |
|
dict keys $o_data |
|
} |
|
|
|
#Unfortunately the string 'name' is highly collidable when mixing in a collection over existing objects |
|
# - !todo - review. Is it worth adjusting the collection methodnames to avoid a few common collision cases? |
|
# - some sort of resolution order/interface-selection is clearly required anyway |
|
# so perhaps it's generally best not to bother being 'polite' here, and implement a robust understandable resolution mechanism. |
|
# In the mean time however... we'll at least avoid 'name'! |
|
# |
|
#$PM name {{posn 0}} { |
|
# var o_array o_list |
|
# |
|
# if {$posn < 0} { |
|
# set posn "end-[expr {abs($posn + 1)}]" |
|
# } |
|
# |
|
# if {[catch {lindex $o_list $posn} result]} { |
|
# error "no such index : '$posn'" |
|
# } else { |
|
# return $result |
|
# } |
|
#} |
|
|
|
$COL .. PatternMethod key {{posn 0}} { |
|
var o_data |
|
|
|
if {$posn < 0} { |
|
set posn "end-[expr {abs($posn + 1)}]" |
|
} |
|
|
|
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
|
error "no such index : '$posn'" |
|
} else { |
|
return $result |
|
} |
|
} |
|
|
|
|
|
#!todo - consider use of 'end-x' syntax for 'to', and implications re consistency with other commands. |
|
$COL .. PatternMethod setPosn {idx to} { |
|
var o_data |
|
|
|
if {![string is integer -strict $to]} { |
|
error "destination position must be numeric, consider reKey method if you are trying to change the string key under which this value is stored" |
|
} |
|
|
|
if {[string is integer -strict $idx]} { |
|
set idx [expr {$idx % [dict size $o_data]}] |
|
|
|
set key [lindex [dict keys $o_data] $idx] |
|
set posn $idx |
|
} else { |
|
set key $idx |
|
set posn [lsearch -exact [dict keys $o_data] $key] |
|
} |
|
|
|
set to [expr {$to % [dict size $o_data]}] |
|
|
|
|
|
set val [dict get $o_data $key] |
|
dict unset o_data $key |
|
|
|
#treat dict as list |
|
set o_data [linsert $o_data[set o_data {}] [expr {$posn*2}] $key $val] |
|
|
|
#set o_list [lreplace $o_list $posn $posn] |
|
#set o_list [linsert $o_list $to $key] |
|
|
|
return $to |
|
} |
|
#!todo - improve efficiency of calls to other functions on this object.. 'inline'?? |
|
#presumably the collection object functionality will be long-term stable because it's purpose is to be a core datastructure; therefore it should be reasonable to favour efficiency over maintainability. |
|
$COL .. PatternMethod incrPosn {idx {by 1}} { |
|
var o_data |
|
if {[string is integer -strict $idx]} { |
|
set idx [expr {$idx % [dict size $o_data]}] |
|
set key [lindex [dict keys $o_data] $idx] |
|
set posn $idx |
|
} else { |
|
set key $idx |
|
set posn [lsearch -exact [dict keys $o_data] $key] |
|
} |
|
|
|
set newPosn [expr {($posn + $by) % [dict size $o_data]}] |
|
|
|
setPosn $_ID_ $posn $newPosn |
|
return $newPosn |
|
} |
|
$COL .. PatternMethod decrPosn {idx {by 1}} { |
|
var |
|
return [incrPosn $_ID_ $idx [expr {- $by}]] |
|
} |
|
$COL .. PatternMethod move {idx to} { |
|
var |
|
return [setPosn $_ID_ $idx $to] |
|
} |
|
$COL .. PatternMethod posn {key} { |
|
var o_data |
|
return [lsearch -exact [dict keys $o_data] $key] |
|
} |
|
|
|
#!todo? - disallow numeric values for newKey so as to be consistent with add |
|
#!note! - item can be reKeyed out from under an alias such that the alias chain no longer points to anything |
|
# - this is ok. |
|
$COL .. PatternMethod reKey {idx newKey} { |
|
var o_data o_alias |
|
|
|
|
|
if {[dict exists $o_data $newKey]} { |
|
#puts stderr "==============> reKey collision, key $newKey already exists in this collection" |
|
error "reKey collision, key '$newKey' already exists in this collection" |
|
} |
|
if {[info exists o_alias($newKey)]} { |
|
if {[dict exists $o_data $o_alias($newKey)]} { |
|
error "reKey collision, key '$newKey' already present as an alias in this collection" |
|
} else { |
|
set newKey $o_alias($newKey) |
|
} |
|
} |
|
|
|
|
|
|
|
if {[string is integer -strict $idx]} { |
|
if {$idx < 0} { |
|
set idx "end-[expr {abs($idx + 1)}]" |
|
} |
|
set key [lindex [dict keys $o_data] $idx] |
|
set posn $idx |
|
} else { |
|
set key $idx |
|
set posn [lsearch -exact [dict keys $o_data] $key] |
|
if {$posn < 0} { |
|
if {[catch {set o_alias($key)} nextKey]} { |
|
error "no such index: '$idx'" |
|
} else { |
|
#try with next key in alias chain... |
|
#return [reKey $_ID_ $nextKey $newKey] |
|
tailcall reKey $_ID_ $nextKey $newKey |
|
} |
|
} |
|
} |
|
|
|
#set o_list [lreplace $o_list $posn $posn $newKey] |
|
##atomic? (traces on array?) |
|
#set o_array($newKey) $o_array($key) |
|
#unset o_array($key) |
|
|
|
dict set o_data $newKey [dict get $o_data $key] |
|
dict unset o_data $key |
|
|
|
return |
|
} |
|
$COL .. PatternMethod hasKey {key} { |
|
var o_data |
|
dict exists $o_data $key |
|
} |
|
$COL .. PatternMethod hasAlias {key} { |
|
var o_alias |
|
info exists o_alias($key) |
|
} |
|
|
|
#either key or alias |
|
$COL .. PatternMethod hasIndex {key} { |
|
var o_data o_alias |
|
if {[dict exists $o_data $key]} { |
|
return 1 |
|
} else { |
|
return [info exists o_alias($key)] |
|
} |
|
} |
|
|
|
|
|
#Shuffle methods from http://mini.net/tcl/941 |
|
$COL .. PatternMethod shuffleFast {} { |
|
#shuffle6 - fast, but some orders more likely than others. |
|
|
|
var o_data |
|
|
|
set keys [dict keys $o_data] |
|
|
|
set n [llength $keys] |
|
for { set i 1 } { $i < $n } { incr i } { |
|
set j [expr { int( rand() * $n ) }] |
|
set temp [lindex $keys $i] |
|
lset keys $i [lindex $keys $j] |
|
lset keys $j $temp |
|
} |
|
|
|
#rebuild dict in new order |
|
#!todo - can we do the above 'in place'? |
|
set newdata [dict create] |
|
foreach k $keys { |
|
dict set newdata $k [dict get $o_data $k] |
|
} |
|
set o_data $newdata |
|
|
|
return |
|
} |
|
$COL .. PatternMethod shuffle {} { |
|
#shuffle5a |
|
|
|
var o_data |
|
|
|
set n 1 |
|
set keys [list] ;#sorted list of keys |
|
foreach k [dict keys $o_data] { |
|
#set index [expr {int(rand()*$n)}] |
|
|
|
#set slist [linsert [::pattern::K $keys [set keys {}]] $index $k] |
|
|
|
#faster alternative.. 'inline K' [lindex [list a b] 0] ~ [K a b] |
|
set keys [linsert [lindex [list $keys [set keys {}]] 0] [expr {int(rand()*$n)}] $k] |
|
incr n |
|
} |
|
|
|
#rebuild dict in new order |
|
#!todo - can we do the above 'in place'? |
|
set newdata [dict create] |
|
foreach k $keys { |
|
dict set newdata $k [dict get $o_data $k] |
|
} |
|
set o_data $newdata |
|
|
|
return |
|
} |
|
|
|
|
|
#search is a somewhat specialised form of 'itemKeys' |
|
$COL .. PatternMethod search {value args} { |
|
var o_data |
|
#only search on values as it's possible for keys to match - especially with options such as -glob |
|
set matches [lsearch {*}$args [dict values $o_data] $value] |
|
|
|
if {"-inline" in $args} { |
|
return $matches |
|
} else { |
|
set keylist [list] |
|
foreach i $matches { |
|
set idx [expr {(($i + 1) * 2) -2}] |
|
lappend keylist [lindex $o_data $idx] |
|
} |
|
return $keylist |
|
} |
|
} |
|
|
|
#inverse lookup |
|
$COL .. PatternMethod itemKeys {value} { |
|
var o_data |
|
#only search on values as it's possible for keys to match |
|
set value_indices [lsearch -all [dict values $o_data] $value] |
|
|
|
set keylist [list] |
|
foreach i $value_indices { |
|
set idx [expr {(($i + 1) * 2) -2}] |
|
lappend keylist [lindex $o_data $idx] |
|
} |
|
return $keylist |
|
} |
|
|
|
#invert: |
|
#change collection to be indexed by its values with the old keys as new values. |
|
# - keys of duplicate values become a list keyed on the value. |
|
#e.g the array equivalent is: |
|
# arr(a) 1 |
|
# arr(b) 2 |
|
# arr(c) 2 |
|
#becomes |
|
# inv(1) a |
|
# inv(2) {b c} |
|
#where the order of duplicate-value keys is not defined. |
|
# |
|
#As the total number of keys may change on inversion - order is not preserved if there are ANY duplicates. |
|
# |
|
|
|
|
|
#!todo - try just [lreverse $o_data] ?? |
|
|
|
|
|
$COL .. PatternMethod invert {{splitvalues ""}} { |
|
|
|
var o_data o_count o_dupes o_inverted |
|
|
|
|
|
if {$splitvalues eq ""} { |
|
#not overridden - use o_dupes from last call to determine if values are actually keylists. |
|
if {$o_dupes > 0} { |
|
set splitvalues 1 |
|
} else { |
|
set splitvalues 0 |
|
} |
|
} |
|
|
|
|
|
#set data [array get o_array] |
|
set data $o_data |
|
|
|
if {$o_count > 500} { |
|
#an arbitrary optimisation for 'larger' collections. |
|
#- should theoretically keep the data size and save some reallocations. |
|
#!todo - test & review |
|
# |
|
foreach nm [dict keys $o_data] { |
|
dict unset o_data $nm |
|
} |
|
} else { |
|
set o_data [dict create] |
|
} |
|
|
|
if {!$splitvalues} { |
|
dict for {k v} $data { |
|
dict set o_data $v $k |
|
} |
|
} else { |
|
dict for {k v} $data { |
|
#we're splitting values because each value is a list of keys |
|
#therefore sub should be unique - no need for lappend in this branch. |
|
foreach sub $v { |
|
#if {[info exists o_array($sub)]} { |
|
# puts stderr "---here! v:$v sub:$sub k:$k" |
|
# lappend o_array($sub) $k |
|
#} else { |
|
dict set o_data $sub $k |
|
#} |
|
} |
|
} |
|
} |
|
|
|
|
|
if {[dict size $o_data] != $o_count} { |
|
#must have been some dupes |
|
|
|
set o_dupes [expr {$o_count - [dict size $o_data]}] |
|
#update count to match inverted collection |
|
set o_count [dict size $o_data] |
|
} else { |
|
set o_dupes 0 |
|
} |
|
|
|
set o_inverted [expr {!$o_inverted}] |
|
|
|
#'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes' |
|
return $o_dupes |
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
#NOTE: values are treated as lists and split into separate keys for inversion only if requested! |
|
# To treat values as keylists - set splitvalues 1 |
|
# To treat each value atomically - set splitvalues 0 |
|
# i.e only set splitvalues 1 if you know the values represent duplicate keys from a previous call to invert! |
|
# |
|
# |
|
#Initially call invert with splitvalues = 0 |
|
#To keep calling invert and get back where you started.. |
|
# The rule is... if the previous call to invert returned > 0... pass 1 on the next call. |
|
# |
|
$COL .. PatternMethod invert_manual {{splitvalues 0}} { |
|
#NOTE - the list nesting here is *tricky* - It probably isn't broken. |
|
|
|
var o_list o_array o_count |
|
|
|
set data [array get o_array] |
|
|
|
if {$o_count > 500} { |
|
#an arbitrary optimisation for 'large' collections. |
|
#- should theoretically keep the array size and save some reallocations. |
|
#!todo - test & review |
|
# |
|
foreach nm [array names o_array] { |
|
unset o_array($nm) |
|
} |
|
} else { |
|
array unset o_array |
|
} |
|
|
|
if {!$splitvalues} { |
|
foreach {k v} $data { |
|
lappend o_array($v) $k |
|
} |
|
} else { |
|
foreach {k v} $data { |
|
#we're splitting values because each value is a list of keys |
|
#therefore sub should be unique - no need for lappend in this branch. |
|
foreach sub $v { |
|
#if {[info exists o_array($sub)]} { |
|
# puts stderr "---here! v:$v sub:$sub k:$k" |
|
# lappend o_array($sub) $k |
|
#} else { |
|
set o_array($sub) $k |
|
#} |
|
} |
|
} |
|
} |
|
|
|
|
|
if {[array size o_array] != $o_count} { |
|
#must have been some dupes |
|
set o_list [array names o_array] |
|
|
|
|
|
set dupes [expr {$o_count - [array size o_array]}] |
|
#update count to match inverted collection |
|
set o_count [array size o_array] |
|
} else { |
|
#review - are these machinations worthwhile for order preservation? what speed penalty do we pay? |
|
array set prev $data |
|
set i -1 |
|
if {$splitvalues} { |
|
#values are lists of length one. Take lindex 0 so list values aren't overnested. |
|
foreach oldkey $o_list { |
|
lset o_list [incr i] [lindex $prev($oldkey) 0] |
|
} |
|
} else { |
|
foreach oldkey $o_list { |
|
lset o_list [incr i] $prev($oldkey) |
|
} |
|
} |
|
|
|
set dupes 0 |
|
} |
|
|
|
|
|
#'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes' |
|
return $dupes |
|
} |
|
|
|
|
|
|
|
#Note that collections cannot be inverted without loss of information if they have duplicates AND compound keys |
|
# (keys that are lists) |
|
$COL .. PatternMethod invert_lossy {{splitvalues 1}} { |
|
var o_list o_array o_count |
|
|
|
set data [array get o_array] |
|
|
|
if {$o_count > 500} { |
|
#an arbitrary optimisation for 'large' collections. |
|
#- should theoretically keep the array size and save some reallocations. |
|
#!todo - test & review |
|
# |
|
foreach nm [array names o_array] { |
|
unset o_array($nm) |
|
} |
|
} else { |
|
array unset o_array |
|
} |
|
|
|
if {!$splitvalues} { |
|
foreach {k v} $data { |
|
#note! we must check for existence and use 'set' for first case. |
|
#using 'lappend' only will result in deeper nestings on each invert! |
|
#If you don't understand this - don't change it! |
|
if {[info exists o_array($v)]} { |
|
lappend o_array($v) $k |
|
} else { |
|
set o_array($v) $k |
|
} |
|
} |
|
} else { |
|
foreach {k v} $data { |
|
#length test necessary to avoid incorrect 'un-nesting' |
|
#if {[llength $v] > 1} { |
|
foreach sub $v { |
|
if {[info exists o_array($sub)]} { |
|
lappend o_array($sub) $k |
|
} else { |
|
set o_array($sub) $k |
|
} |
|
} |
|
#} else { |
|
# if {[info exists o_array($v)]} { |
|
# lappend o_array($v) $k |
|
# } else { |
|
# set o_array($v) $k |
|
# } |
|
#} |
|
} |
|
} |
|
|
|
|
|
if {[array size o_array] != $o_count} { |
|
#must have been some dupes |
|
set o_list [array names o_array] |
|
|
|
|
|
set dupes [expr {$o_count - [array size o_array]}] |
|
#update count to match inverted collection |
|
set o_count [array size o_array] |
|
} else { |
|
#review - are these machinations worthwhile for order preservation? what speed penalty do we pay? |
|
array set prev $data |
|
set i -1 |
|
foreach oldkey $o_list { |
|
lset o_list [incr i] $prev($oldkey) |
|
} |
|
set dupes 0 |
|
} |
|
|
|
|
|
#'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes' |
|
return $dupes |
|
} |
|
|
|
$COL .. PatternMethod reverse {} { |
|
var o_data |
|
|
|
set dictnew [dict create] |
|
foreach k [lreverse [dict keys $o_data]] { |
|
dict set dictnew $k [dict get $o_data $k] |
|
} |
|
set o_data $dictnew |
|
return |
|
} |
|
|
|
$COL .. PatternMethod keySort {{options -ascii}} { |
|
var o_data |
|
|
|
set keys [lsort {*}$options [dict keys $o_data]] |
|
|
|
set dictnew [dict create] |
|
foreach k $keys { |
|
dict set dictnew $k [dict get $o_data $k] |
|
} |
|
set o_data $dictnew |
|
|
|
return |
|
} |
|
|
|
#!todo - allow simple options in combination with options such as -command and -object. Redo args handling completely for more complex sorting. |
|
$COL .. PatternMethod sort {args} { |
|
var o_data |
|
|
|
#defaults |
|
set options [dict create -index 1] ;#values always in subelement 1 of name-value pair list for sorting. |
|
|
|
set options_simple [list] |
|
|
|
|
|
for {set i 0} {$i < [llength $args]} {incr i} { |
|
set a [lindex $args $i] |
|
switch -- $a { |
|
-indices - |
|
-ascii - |
|
-dictionary - |
|
-integer - |
|
-real - |
|
-increasing - |
|
-decreasing { |
|
#dict set options $a 1 |
|
lappend options_simple $a |
|
} |
|
-unique { |
|
#not a valid option |
|
#this would stuff up the data... |
|
#!todo? - remove dups from collection if this option used? - alias the keys? |
|
} |
|
-object { |
|
#!todo - treat value as object and allow sorting by sub-values .eg >col1 . sort -object ". sub . property" -increasing |
|
#may be slow - but handy. Consider -indexed property to store/cache these values on first run |
|
} |
|
-command { |
|
dict set options $a [lindex $args [incr i]] |
|
} |
|
-index { |
|
#allow sorting on subindices of the value. |
|
dict set options -index [concat [dict get $options -index] [lindex $args [incr i]] ] |
|
} |
|
default { |
|
#unrecognised option - print usage? |
|
} |
|
} |
|
} |
|
|
|
|
|
|
|
if {[set posn [lsearch -exact $options_simple "-indices"]] >= 0} { |
|
|
|
var o_array |
|
|
|
set slist [list] |
|
foreach k [dict keys $o_data] { |
|
lappend slist [list $k [dict get $o_data $k]] |
|
} |
|
return [lsort {*}$options_simple {*}$options $slist] |
|
|
|
|
|
|
|
#set options_simple [lreplace $options_simple $posn $posn] ;# |
|
#set slist [list] |
|
#foreach {n v} [array get ::p::[lindex ${_ID_} 0 0]::o_array] { |
|
# lappend slist [list $n $v] |
|
#} |
|
#set slist [lsort {*}$options_simple {*}$options $slist] |
|
#foreach i $slist { |
|
# #determine the position in the collections list |
|
# lappend result {*}[lsearch -exact $o_list [lindex $i 0]] |
|
#} |
|
#return $result |
|
} else { |
|
set slist [list] |
|
dict for {k v} $o_data { |
|
lappend slist [list $k $v] |
|
} |
|
#set slist [lsort {*}$options_simple {*}$options $slist] |
|
set slist [lsort {*}$options_simple {*}$options $slist[set slist {}]] ;#K combinator for efficiency |
|
|
|
|
|
#set o_list [lsearch -all -inline -subindices -index 0 $slist *] |
|
|
|
set o_data [dict create] |
|
foreach pair $slist { |
|
dict set o_data [lindex $pair 0] [lindex $pair 1] |
|
} |
|
|
|
|
|
|
|
return |
|
} |
|
|
|
} |
|
|
|
|
|
$COL .. PatternMethod clear {} { |
|
var o_data o_count |
|
|
|
set o_data [dict create] |
|
set o_count 0 |
|
#aliases? |
|
return |
|
} |
|
|
|
#see http://wiki.tcl.tk/15271 - A generic collection traversal interface |
|
# |
|
#!todo - options: -progresscommand -errorcommand (-granularity ?) (-self ? (to convert to an iterator?)) |
|
#!todo? - lazy retrieval of items so that all changes to the collection are available to a running asynch enumeration? |
|
# - should this be an option? which mechanism should be the default? |
|
# - currently only the keylist is treated in 'snapshot' fashion |
|
# so values could be changed and the state could be invalidated by other code during an enumeration |
|
# |
|
$COL .. PatternMethod enumerate {args} { |
|
#---------- |
|
lassign [lrange $args end-1 end] cmd seed |
|
set optionlist [list] |
|
foreach a [lrange $args 0 end-2] { |
|
lappend optionlist $a |
|
} |
|
set opt(-direction) left |
|
set opt(-completioncommand) "" |
|
array set opt $optionlist |
|
#---------- |
|
var o_data |
|
|
|
if {[string tolower [string index $opt(-direction) 0]] eq "r"} { |
|
#'right' 'RIGHT' 'r' etc. |
|
set list [lreverse [dict keys $o_data]] |
|
} else { |
|
#normal left-right order |
|
set list [dict keys $o_data] |
|
} |
|
|
|
if {![string length $opt(-completioncommand)]} { |
|
#standard synchronous processing |
|
foreach k $list { |
|
set seed [uplevel #0 [list {*}$cmd $seed [dict get $o_data $k]]] |
|
} |
|
return $seed |
|
} else { |
|
#ASYNCHRONOUS enumeration |
|
var this o_bgEnum |
|
#!todo - make id unique |
|
#!todo - facility to abort running enumeration. |
|
set enumID enum[array size o_bgEnum] |
|
|
|
set seedvar [$this . bgEnum $enumID .] |
|
set $seedvar $seed |
|
|
|
after 0 [list $this . _doBackgroundEnum $enumID $list $cmd $seedvar $opt(-completioncommand)] |
|
return $enumID |
|
} |
|
} |
|
|
|
#!todo - make private? - put on a separate interface? |
|
$COL .. PatternMethod _doBackgroundEnum {enumID slice cmd seedvar completioncommand} { |
|
var this o_data |
|
|
|
|
|
#Note that we don't post to the eventqueue using 'foreach s $slice' |
|
# we only schedule another event after each item is processed |
|
# - otherwise we would be spamming the eventqueue with <collection . count> items. |
|
|
|
#!todo? - accept a -granularity option to allow handling of n list-items per event? |
|
|
|
if {[llength $slice]} { |
|
set slice [lassign $slice head] |
|
|
|
set script [string map [list %cmd% $cmd %seedvar% $seedvar %val% [dict get $o_data $head]] { |
|
%cmd% [set %seedvar%] %val% |
|
}] |
|
|
|
#post to eventqueue and re-enter _doBackgroundEnum |
|
# |
|
after idle [list after 0 [subst {set $seedvar \[uplevel #0 [list $script] \]; $this . _doBackgroundEnum $enumID [list $slice] [list $cmd] $seedvar [list $completioncommand]}]] |
|
|
|
} else { |
|
#done. |
|
|
|
set script [string map [list %cmd% $completioncommand %seedvar% $seedvar] { |
|
lindex [list [%cmd% [set %seedvar%]] [unset %seedvar%]] 0 |
|
}] |
|
|
|
after idle [list after 0 [list uplevel #0 $script]] |
|
} |
|
|
|
return |
|
} |
|
|
|
$COL .. PatternMethod enumeratorstate {} { |
|
var o_bgEnum |
|
parray o_bgEnum |
|
} |
|
|
|
#proc ::bgerror {args} { |
|
# puts stderr "=bgerror===>$args" |
|
#} |
|
|
|
|
|
#map could be done in terms of the generic 'enumerate' method.. but it's slower. |
|
# |
|
#$PM map2 {proc} { |
|
# var |
|
# enumerate $_ID_ [list ::map-helper $proc] [list] |
|
#} |
|
#proc ::map-helper {proc accum item} { |
|
# lappend accum [uplevel #0 [list {*}$proc $item]] |
|
#} |
|
|
|
$COL .. PatternMethod map {cmd} { |
|
var o_data |
|
set seed [list] |
|
dict for {k v} $o_data { |
|
lappend seed [uplevel #0 [list {*}$cmd $v]] |
|
} |
|
|
|
return $seed |
|
} |
|
$COL .. PatternMethod objectmap {cmd} { |
|
var o_data |
|
set seed [list] |
|
dict for {k v} $o_data { |
|
lappend seed [uplevel #0 [list $v {*}$cmd]] |
|
} |
|
|
|
return $seed |
|
} |
|
|
|
|
|
#End core collection functionality. |
|
#collection 'mixin' interfaces |
|
|
|
>pattern .. Create >keyvalprotector |
|
>keyvalprotector .. PatternVariable o_protectedkeys |
|
>keyvalprotector .. PatternVariable o_protectedvals |
|
|
|
#!todo - write test regarding errors in Constructors for mixins like this |
|
# - an error (e.g from bad args) can cause errors with vars after it's re-run with correct args |
|
>keyvalprotector .. Constructor {args} { |
|
var this o_protectedkeys o_protectedvals |
|
set this @this@ |
|
#---------------------------------------------------------------------------- |
|
set known_opts [list -keys -vals ] |
|
dict set default -keys [list] |
|
dict set default -vals [list] |
|
if {([llength $args] % 2) != 0} { |
|
error "(>keyvalprotector .. Constructor) ERROR: uneven options supplied - must be of form '-option value' " |
|
} |
|
foreach {k v} $args { |
|
if {$k ni $known_opts} { |
|
error "(>keyvalprotector .. Constructor) ERROR: option '$k' not in known options: '$known_opts'" |
|
} |
|
} |
|
set opts [dict merge $default $args] |
|
set o_protectedkeys [dict get $opts -keys] |
|
set o_protectedvals [dict get $opts -vals] |
|
#---------------------------------------------------------------------------- |
|
set protections [concat $o_protectedkeys $o_protectedvals] |
|
if {![llength $protections]} { |
|
error "(>keyvalprotector .. Constructor) ERROR: must supply at least one argument to -vals or -keys" |
|
} |
|
|
|
} |
|
>keyvalprotector .. PatternMethod clear {} { |
|
error "(>keyvalprotector . clear) ERROR: This collection is protected by a >keyvalprotector mixin. Cannot clear" |
|
} |
|
>keyvalprotector .. PatternMethod pop {{idx ""}} { |
|
var o_data o_count o_protectedkeys o_protectedvals |
|
|
|
if {$idx eq ""} { |
|
set key [lindex [dict keys $o_data] end] |
|
} else { |
|
if {[string is integer -strict $idx]} { |
|
set key [lindex [dict keys $o_data] $idx] |
|
} else { |
|
set key $idx |
|
} |
|
} |
|
|
|
if {$key in $o_protectedkeys} { |
|
error "(>keyvalprotector . pop) ERROR: Cannot pop object with index '$idx', key '$key' from collection." |
|
} |
|
set posn [lsearch -exact [dict keys $o_data] $key] |
|
if {($posn >= 0) && ($posn < [dict size $o_data])} { |
|
set result [dict get $o_data $key] |
|
if {$result in $o_protectedvals} { |
|
error "(>keyvalprotector . pop) ERROR: Cannot pop object '$result' with index '$idx', key '$key' from collection." |
|
} |
|
dict unset o_data $key |
|
set o_count [dict size $o_data] |
|
return $result |
|
} else { |
|
error "no such index: '$idx'" |
|
} |
|
|
|
} |
|
>keyvalprotector .. PatternMethod remove {idx {endRange ""}} { |
|
var this o_data o_count o_alias o_protectedkeys o_protectedvals |
|
|
|
if {[string length $endRange]} { |
|
error "ranged removal not yet implemented.. remove one item at a time." |
|
} |
|
|
|
if {[string is integer -strict $idx]} { |
|
if {$idx < 0} { |
|
set idx "end-[expr {abs($idx + 1)}]" |
|
} |
|
set key [lindex [dict keys $o_data] $idx] |
|
if {$key in $o_protectedkeys} { |
|
error "(>keyvalprotector . remove) ERROR: cannot remove item with index '$idx' key '$key' from collection" |
|
} |
|
set posn $idx |
|
} else { |
|
set key $idx |
|
set posn [lsearch -exact [dict keys $o_data] $key] |
|
if {$posn < 0} { |
|
if {[catch {set o_alias($key)} nextKey]} { |
|
error "no such index: '$idx' in collection: $this" |
|
} else { |
|
if {$key in $o_protectedkeys} { |
|
error "(>keyvalprotector . remove) ERROR: cannot remove item with index '$idx' from collection" |
|
} |
|
#try with next key in alias chain... |
|
#return [remove $_ID_ $nextKey] |
|
tailcall remove $_ID_ $nextKey |
|
} |
|
} |
|
} |
|
|
|
dict unset o_data $key |
|
|
|
set o_count [dict size $o_data] |
|
return |
|
} |
|
|
|
#1) |
|
#predicate methods (order preserving) |
|
#usage: |
|
# >collection .. Create >c1 |
|
# >predicatedCollection .. Create >c1 ;#overlay predicate methods on existing collection |
|
|
|
#e.g >col1 . all {$val > 14} |
|
#e.g >col1 . filterToCollection {$val > 19} . count |
|
#e.g >col1 . filter {[string match "x*" $key]} |
|
#!todo - fix. currying fails.. |
|
|
|
::>pattern .. Create >predicatedCollection |
|
#process_pattern_aliases ::patternlib::>predicatedCollection |
|
|
|
set PM [>predicatedCollection .. PatternMethod .] |
|
|
|
>predicatedCollection .. PatternMethod filter {predicate} { |
|
var this o_list o_array |
|
set result [list] |
|
|
|
#!note (jmn 2004) how could we do smart filtering based on $posn? |
|
#i.e it would make sense to lrange $o_list based on $posn... |
|
#but what about complicated expressions where $posn is a set of ranges and/or combined with tests on $key & $val ?? |
|
#Seems better to provide an alternative efficient means of generating subcolllections/ranges to perform predicate operations upon. |
|
#given this, is $posn even useful? |
|
|
|
set posn 0 |
|
foreach key $o_list { |
|
set val $o_array($key) |
|
if $predicate { |
|
lappend result $val |
|
} |
|
incr posn |
|
} |
|
set result |
|
} |
|
>predicatedCollection .. PatternMethod filterToKeys {predicate} { |
|
var this o_list o_array |
|
set result [list] |
|
|
|
set posn 0 |
|
foreach key $o_list { |
|
set val $o_array($key) |
|
if $predicate { |
|
lappend result $key |
|
} |
|
incr posn |
|
} |
|
set result |
|
} |
|
>predicatedCollection .. PatternMethod filterToCollection {predicate {destCollection {}}} { |
|
#!todo - collection not in subordinate namespace? -> if subordinate, should imply modification of sub's contents will be reflected in parent? |
|
#!todo - implement as 'view' on current collection object.. extra o_list variables? |
|
#!todo - review/document 'expected' key collision behaviour - source keys used as dest keys.. -autokey option required? |
|
var this o_list o_array m_i_filteredCollection |
|
|
|
incr m_i_filteredCollection |
|
if {![string length $destCollection]} { |
|
#!todo? - implement 'one-shot' object (similar to RaTcl) |
|
set result [::patternlib::>collection .. Create [$this .. Namespace]::>filteredCollection-$m_i_filteredCollection] |
|
} else { |
|
set result $destCollection |
|
} |
|
|
|
#### |
|
#externally manipulate new collection |
|
#set ADD [$c . add .] |
|
#foreach key $o_list { |
|
# set val $o_array($key) |
|
# if $predicate { |
|
# $ADD $val $key |
|
# } |
|
#} |
|
### |
|
|
|
#internal manipulation faster |
|
#set cID [lindex [set $result] 0] |
|
set cID [lindex [$result --] 0] |
|
|
|
#use list to get keys so as to preserve order |
|
set posn 0 |
|
upvar #0 ::p::${cID}::o_array cARRAY ::p::${cID}::o_list cLIST |
|
foreach key $o_list { |
|
set val $o_array($key) |
|
if $predicate { |
|
if {[info exists cARRAY($key)]} { |
|
error "key '$key' already exists in this collection" |
|
} |
|
lappend cLIST $key |
|
set cARRAY($key) $val |
|
} |
|
incr posn |
|
} |
|
|
|
return $result |
|
} |
|
|
|
#NOTE! unbraced expr/if statements. We want to evaluate the predicate. |
|
>predicatedCollection .. PatternMethod any {predicate} { |
|
var this o_list o_array |
|
set posn 0 |
|
foreach key $o_list { |
|
set val $o_array($key) |
|
if $predicate { |
|
return 1 |
|
} |
|
incr posn |
|
} |
|
return 0 |
|
} |
|
>predicatedCollection .. PatternMethod all {predicate} { |
|
var this o_list o_array |
|
set posn 0 |
|
foreach key $o_list { |
|
set val $o_array($key) |
|
if !($predicate) { |
|
return 0 |
|
} |
|
incr posn |
|
} |
|
return 1 |
|
} |
|
>predicatedCollection .. PatternMethod dropWhile {predicate} { |
|
var this o_list o_array |
|
set result [list] |
|
set _idx 0 |
|
set posn 0 |
|
foreach key $o_list { |
|
set val $o_array($key) |
|
if $predicate { |
|
incr _idx |
|
} else { |
|
break |
|
} |
|
incr posn |
|
} |
|
set remaining [lrange $o_list $_idx end] |
|
foreach key $remaining { |
|
set val $o_array($key) |
|
lappend result $val |
|
} |
|
return $result |
|
} |
|
>predicatedCollection .. PatternMethod takeWhile {predicate} { |
|
var this o_list o_array |
|
set result [list] |
|
set posn 0 |
|
foreach key $o_list { |
|
set val $o_array($key) |
|
if $predicate { |
|
lappend result $val |
|
} else { |
|
break |
|
} |
|
incr posn |
|
} |
|
set result |
|
} |
|
|
|
|
|
|
|
#end >collection mixins |
|
###################################### |
|
|
|
|
|
|
|
|
|
#----------------------------------------------------------- |
|
#!TODO - methods for converting an arrayHandle to & from a hashMap efficiently? |
|
# Why do we need both? apart from the size variable, what is the use of hashMap? |
|
#----------------------------------------------------------- |
|
#::pattern::create >hashMap |
|
::>pattern .. Create >hashMap |
|
|
|
>hashMap .. PatternVariable o_size |
|
>hashMap .. PatternVariable o_array |
|
|
|
>hashMap .. Constructor {args} { |
|
var o_array o_size |
|
array set o_array [list] |
|
set o_size 0 |
|
} |
|
>hashMap .. PatternDefaultMethod "item" |
|
>hashMap .. PatternMethod item {key} { |
|
var o_array |
|
set o_array($key) |
|
} |
|
>hashMap .. PatternMethod items {} { |
|
var o_array |
|
|
|
set result [list] |
|
foreach nm [array names o_array] { |
|
lappend result $o_array($nm) |
|
} |
|
return $result |
|
} |
|
>hashMap .. PatternMethod pairs {} { |
|
var o_array |
|
|
|
array get o_array |
|
} |
|
>hashMap .. PatternMethod add {val key} { |
|
var o_array o_size |
|
|
|
set o_array($key) $val |
|
incr o_size |
|
return $key |
|
} |
|
|
|
>hashMap .. PatternMethod del {key} { |
|
var |
|
puts stderr "warning: 'del' method of >hashMap deprecated. Use 'remove' instead." |
|
remove $_ID_ $key |
|
} |
|
>hashMap .. PatternMethod remove {key} { |
|
var o_array o_size |
|
unset o_array($key) |
|
incr o_size -1 |
|
return $key |
|
} |
|
>hashMap .. PatternMethod count {} { |
|
var o_size |
|
#array size o_array |
|
return $o_size |
|
} |
|
>hashMap .. PatternMethod count2 {} { |
|
var o_array |
|
#array size o_array ;#slow, at least for TCLv8.4.4 |
|
#even array statistics is faster than array size ! |
|
#e.g return [lindex [array statistics o_array] 0] |
|
#but.. apparently there are circumstances where array statistics doesn't report the correct size. |
|
return [array size o_array] |
|
} |
|
>hashMap .. PatternMethod names {} { |
|
var o_array |
|
array names o_array |
|
} |
|
>hashMap .. PatternMethod keys {} { |
|
#synonym for names |
|
var o_array |
|
array names o_array |
|
} |
|
>hashMap .. PatternMethod hasKey {key} { |
|
var o_array |
|
return [info exists o_array($key)] |
|
} |
|
>hashMap .. PatternMethod clear {} { |
|
var o_array o_size |
|
unset o_array |
|
set o_size 0 |
|
return |
|
} |
|
#>hashMap .. Ready 1 |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
#explicitly create metadata. Not required for user-defined patterns. |
|
# this is only done here because this object is used for the metadata of all objects |
|
# so the object must have all it's methods/props before its own metadata structure can be built. |
|
#uplevel 1 "::pattern::object ::pattern::>_nullMeta createMetadata >collection" |
|
#uplevel 1 "::patternlib::>collection .. CreateMetadata ::patternlib::>collection" |
|
|
|
|
|
|
|
|
|
if 0 { |
|
|
|
|
|
#----------------------------------------------------------- |
|
#::pattern::create >arrayHandle { |
|
# variable o_arrayName |
|
# variable this |
|
#} |
|
::>pattern .. Create >arrayHandle |
|
|
|
>arrayHandle .. PatternVariable o_arrayName |
|
>arrayHandle .. PatternVariable this |
|
|
|
>arrayHandle .. Constructor {args} { |
|
var o_arrayName this |
|
set this @this@ |
|
|
|
|
|
set o_arrayName [$this .. Namespace]::array |
|
|
|
upvar #0 $o_arrayName $this |
|
#? how to automatically update this after a namespace import? |
|
|
|
array set $o_arrayName [list] |
|
|
|
} |
|
>arrayHandle .. PatternMethod array {} { |
|
var o_arrayName |
|
return $o_arrayName |
|
} |
|
|
|
#------------------------------------------------------- |
|
#---- some experiments |
|
>arrayHandle .. PatternMethod up {varname} { |
|
var o_arrayName |
|
|
|
#is it dodgy to hard-code the calling depth? |
|
#will it be different for different object systems? |
|
#Will it even be consistent for the same object. |
|
# Is this method necessary anyway? - |
|
# - users can always instead do: |
|
# upvar #0 [>instance . array] var |
|
|
|
uplevel 3 [list upvar 0 $o_arrayName $varname] |
|
|
|
return |
|
} |
|
>arrayHandle .. PatternMethod global {varname} { |
|
var o_arrayName |
|
# upvar #0 [>instance . array] var |
|
|
|
if {![string match ::* $varname]} { |
|
set varname ::$varname |
|
} |
|
|
|
upvar #0 $o_arrayName $varname |
|
|
|
return |
|
} |
|
>arrayHandle .. PatternMethod depth {} { |
|
var o_arrayName |
|
# |
|
for {set i 0} {$i < [info level]} { |
|
puts "${i}: [uplevel $i [list namespace current] , [info level $i]]" |
|
} |
|
|
|
} |
|
# -------------------------------------------- |
|
|
|
|
|
>arrayHandle .. PatternMethod item {key} { |
|
var o_arrayName |
|
set ${o_arrayName}($key) |
|
} |
|
>arrayHandle .. PatternMethod items {} { |
|
var o_arrayName |
|
|
|
set result [list] |
|
foreach nm [array names $o_arrayName] { |
|
lappend result [set ${o_arrayName}($nm)] |
|
} |
|
return $result |
|
} |
|
>arrayHandle .. PatternMethod pairs {} { |
|
var o_arrayName |
|
|
|
array get $o_arrayName |
|
} |
|
>arrayHandle .. PatternMethod add {val key} { |
|
var o_arrayName |
|
|
|
set ${o_arrayName}($key) $val |
|
return $key |
|
} |
|
>arrayHandle .. PatternMethod del {key} { |
|
puts stderr "Warning: 'del' method of >arrayHandle deprecated. Use 'remove' instead." |
|
remove $_ID_ $key |
|
} |
|
>arrayHandle .. PatternMethod remove {key} { |
|
var o_arrayName |
|
unset ${o_arrayName}($key) |
|
return $key |
|
} |
|
>arrayHandle .. PatternMethod size {} { |
|
var o_arrayName |
|
return [array size $o_arrayName] |
|
} |
|
>arrayHandle .. PatternMethod count {} { |
|
#alias for size |
|
var o_arrayName |
|
return [array size $o_arrayName] |
|
} |
|
>arrayHandle .. PatternMethod statistics {} { |
|
var o_arrayName |
|
return [array statistics $o_arrayName] |
|
} |
|
>arrayHandle .. PatternMethod names {} { |
|
var o_arrayName |
|
array names $o_arrayName |
|
} |
|
>arrayHandle .. PatternMethod keys {} { |
|
#synonym for names |
|
var o_arrayName |
|
array names $o_arrayName |
|
} |
|
>arrayHandle .. PatternMethod hasKey {key} { |
|
var o_arrayName |
|
|
|
return [info exists ${o_arrayName}($key)] |
|
} |
|
>arrayHandle .. PatternMethod clear {} { |
|
var o_arrayName |
|
unset $o_arrayName |
|
array set $o_arrayName [list] |
|
|
|
return |
|
} |
|
#>arrayHandle .. Ready 1 |
|
|
|
|
|
|
|
|
|
::>pattern .. Create >matrix |
|
|
|
>matrix .. PatternVariable o_array |
|
>matrix .. PatternVariable o_size |
|
|
|
>matrix .. Constructor {args} { |
|
var o_array o_size |
|
|
|
array set o_array [list] |
|
set o_size 0 |
|
} |
|
|
|
|
|
#process_pattern_aliases ::patternlib::>matrix |
|
|
|
set PM [>matrix .. PatternMethod .] |
|
|
|
>matrix .. PatternMethod item {args} { |
|
var o_array |
|
|
|
if {![llength $args]} { |
|
error "indices required" |
|
} else { |
|
|
|
} |
|
if [info exists o_array($args)] { |
|
return $o_array($args) |
|
} else { |
|
error "no such index: '$args'" |
|
} |
|
} |
|
>matrix .. PatternMethod items {} { |
|
var o_array |
|
|
|
set result [list] |
|
foreach nm [array names o_array] { |
|
lappend result $o_array($nm) |
|
} |
|
return $result |
|
} |
|
>matrix .. PatternMethod pairs {} { |
|
var o_array |
|
|
|
array get o_array |
|
} |
|
>matrix .. PatternMethod slice {args} { |
|
var o_array |
|
|
|
if {"*" ni $args} { |
|
lappend args * |
|
} |
|
|
|
array get o_array $args |
|
} |
|
>matrix .. PatternMethod add {val args} { |
|
var o_array o_size |
|
|
|
if {![llength $args]} { |
|
error "indices required" |
|
} |
|
|
|
set o_array($args) $val |
|
incr o_size |
|
|
|
#return [array size o_array] |
|
return $o_size |
|
} |
|
>matrix .. PatternMethod names {} { |
|
var o_array |
|
array names o_array |
|
} |
|
>matrix .. PatternMethod keys {} { |
|
#synonym for names |
|
var o_array |
|
array names o_array |
|
} |
|
>matrix .. PatternMethod hasKey {args} { |
|
var o_array |
|
|
|
return [info exists o_array($args)] |
|
} |
|
>matrix .. PatternMethod clear {} { |
|
var o_array o_size |
|
unset o_array |
|
set o_size 0 |
|
return |
|
} |
|
>matrix .. PatternMethod count {} { |
|
var o_size |
|
return $o_size |
|
} |
|
>matrix .. PatternMethod count2 {} { |
|
var o_array |
|
#see comments for >hashMap count2 |
|
return [array size o_array] |
|
} |
|
#>matrix .. Ready 1 |
|
|
|
#-------------------------------------------------------- |
|
#tree data structure (based *loosely* on API at http://www.msen.com/%7Eclif/treeNobj.html - discussed in Clif Flynts book Tcl programming) |
|
#!todo - compare API to http://tcllib.sourceforge.net/doc/tree.html |
|
#!todo - create an >itree (inheritance tree) where node data is readable/writable on children unless overridden. |
|
::>pattern .. Create >tree |
|
|
|
set _NODE [::>pattern .. Create [>tree .. Namespace]::>node] |
|
set _TREE_NODE $_NODE |
|
#process_pattern_aliases $_TREE_NODE |
|
|
|
$_NODE .. PatternVariable o_treens ;#tree namespace |
|
$_NODE .. PatternVariable o_idref |
|
$_NODE .. PatternVariable o_nodePrototype |
|
|
|
#$_NODE .. PatternProperty data |
|
$_NODE .. PatternProperty info |
|
|
|
$_NODE .. PatternProperty tree |
|
$_NODE .. PatternProperty parent |
|
$_NODE .. PatternProperty children |
|
$_NODE .. PatternMethod addNode {} { |
|
set nd_id [incr $o_idref] |
|
set nd [$o_nodePrototype .. Create ${o_treens}::>n-$nd_id -tree $o_tree -parent @this@] |
|
@this@ . add $nd n-$nd_id |
|
|
|
return n-$nd_id |
|
} |
|
#flat list of all nodes below this |
|
#!todo - something else? ad-hoc collections? |
|
#!todo - non-recursive version? tail-call opt? |
|
$_NODE .. PatternMethod nodes {} { |
|
set result [list] |
|
|
|
#use(abuse?) our knowledge of >collection internals |
|
foreach n $o_list { |
|
#eval lappend result $n [$o_array($n) . nodes] |
|
#!todo - test |
|
lappend result $n {*}[$o_array($n) . nodes] |
|
} |
|
return $result |
|
} |
|
#count of number of descendants |
|
#!todo - non-recursive version? tail-call opt? |
|
$_NODE .. PatternMethod size {} { |
|
set result 0 |
|
#use(abuse?) our knowledge of >collection internals |
|
foreach n $o_list { |
|
incr result [expr {1 + [$o_array($n) . size]}] |
|
} |
|
return $result |
|
} |
|
$_NODE .. PatternMethod isLeaf {} { |
|
#!todo - way to stop unused vars being uplevelled? |
|
var o_tree |
|
|
|
#tailcall isEmpty $_ID_ ;#fails. because isEmpty is from >collection interface - so different ns? |
|
tailcall [@this@ . isEmpty .] |
|
} |
|
$_NODE .. Constructor {args} { |
|
array set A $args |
|
|
|
set o_tree $A(-tree) |
|
set o_parent $A(-parent) |
|
|
|
#array set o_data [list] |
|
array set o_info [list] |
|
|
|
set o_nodePrototype [::patternlib::>tree .. Namespace]::>node |
|
set o_idref [$o_tree . nodeID .] |
|
set o_treens [$o_tree .. Namespace] |
|
#set o_children [::patternlib::>collection .. Create [@this@ .. Namespace]::>children] |
|
|
|
#overlay children collection directly on the node |
|
set o_children [::patternlib::>collection .. Create @this@] |
|
|
|
return |
|
} |
|
|
|
>tree .. PatternProperty test blah |
|
>tree .. PatternProperty nodeID 0 ;#public only so node can access.. need 'friend' concept? |
|
>tree .. PatternVariable o_ns |
|
>tree .. Constructor {args} { |
|
set o_ns [@this@ .. Namespace] |
|
|
|
#>tree is itself also a node (root node) |
|
#overlay new 'root' node onto existing tree, pass tree to constructor |
|
[::patternlib::>tree .. Namespace]::>node .. Create @this@ -tree @this@ -parent "" |
|
} |
|
|
|
|
|
|
|
|
|
unset _NODE |
|
|
|
|
|
|
|
|
|
#-------------------------------------------------------- |
|
#a basic binary search tree experiment |
|
# - todo - 'scheme' property to change behaviour? e.g balanced tree |
|
::>pattern .. Create >bst |
|
#process_pattern_aliases ::patternlib::>bst |
|
>bst .. PatternVariable o_NS ;#namespace |
|
>bst .. PatternVariable o_this ;#namespace |
|
>bst .. PatternVariable o_nodeID |
|
|
|
>bst .. PatternProperty root "" |
|
>bst .. Constructor {args} { |
|
set o_this @this@ |
|
set o_NS [$o_this .. Namespace] |
|
namespace eval ${o_NS}::nodes {} |
|
puts stdout ">bst constructor" |
|
set o_nodeID 0 |
|
} |
|
>bst .. PatternMethod insert {key args} { |
|
set newnode [::patternlib::>bstnode .. Create ${o_NS}::nodes::>n-[incr o_nodeID]] |
|
set [$newnode . key .] $key |
|
if {[llength $args]} { |
|
set [$newnode . value .] $args |
|
} |
|
if {![string length $o_root]} { |
|
set o_root $newnode |
|
set [$newnode . parent .] $o_this |
|
} else { |
|
set ipoint {} ;#insertion point |
|
set tpoint $o_root ;#test point |
|
set side {} |
|
while {[string length $tpoint]} { |
|
set ipoint $tpoint |
|
if {[$newnode . key] < [$tpoint . key]} { |
|
set tpoint [$tpoint . left] |
|
set side left |
|
} else { |
|
set tpoint [$tpoint . right] |
|
set side right |
|
} |
|
} |
|
set [$newnode . parent .] $ipoint |
|
set [$ipoint . $side .] $newnode |
|
} |
|
return $newnode |
|
} |
|
>bst .. PatternMethod item {key} { |
|
if {![string length $o_root]} { |
|
error "item $key not found" |
|
} else { |
|
set tpoint $o_root |
|
while {[string length $tpoint]} { |
|
if {[$tpoint . key] eq $key} { |
|
return $tpoint |
|
} else { |
|
if {$key < [$tpoint . key]} { |
|
set tpoint [$tpoint . left] |
|
} else { |
|
set tpoint [$tpoint . right] |
|
} |
|
} |
|
} |
|
error "item $key not found" |
|
} |
|
} |
|
>bst .. PatternMethod inorder-walk {} { |
|
if {[string length $o_root]} { |
|
$o_root . inorder-walk |
|
} |
|
puts {} |
|
} |
|
>bst .. PatternMethod view {} { |
|
array set result [list] |
|
|
|
if {[string length $o_root]} { |
|
array set result [$o_root . view 0 [list]] |
|
} |
|
|
|
foreach depth [lsort [array names result]] { |
|
puts "$depth: $result($depth)" |
|
} |
|
|
|
} |
|
::>pattern .. Create >bstnode |
|
#process_pattern_aliases ::patternlib::>bstnode |
|
>bstnode .. PatternProperty parent |
|
>bstnode .. PatternProperty left "" |
|
>bstnode .. PatternProperty right "" |
|
>bstnode .. PatternProperty key |
|
>bstnode .. PatternProperty value |
|
|
|
>bstnode .. PatternMethod inorder-walk {} { |
|
if {[string length $o_left]} { |
|
$o_left . inorder-walk |
|
} |
|
|
|
puts -nonewline "$o_key " |
|
|
|
if {[string length $o_right]} { |
|
$o_right . inorder-walk |
|
} |
|
|
|
return |
|
} |
|
>bstnode .. PatternMethod view {depth state} { |
|
#!todo - show more useful representation of structure |
|
set lower [incr depth] |
|
|
|
if {[string length $o_left]} { |
|
set state [$o_left . view $lower $state] |
|
} |
|
|
|
if {[string length $o_right]} { |
|
set state [$o_right . view $lower $state] |
|
} |
|
|
|
|
|
array set s $state |
|
lappend s($depth) $o_key |
|
|
|
return [array get s] |
|
} |
|
|
|
|
|
#-------------------------------------------------------- |
|
#::pattern::create ::pattern::>metaObject |
|
#::pattern::>metaObject PatternProperty methods |
|
#::pattern::>metaObject PatternProperty properties |
|
#::pattern::>metaObject PatternProperty PatternMethods |
|
#::pattern::>metaObject PatternProperty patternProperties |
|
#::pattern::>metaObject Constructor args { |
|
# set this @this@ |
|
# |
|
# set [$this . methods .] [::>collection create [$this namespace]::methods] |
|
# set [$this . properties .] [::>collection create [$this namespace]::properties] |
|
# set [$this . PatternMethods .] [::>collection create [$this namespace]::PatternMethods] |
|
# set [$this . patternProperties .] [::>collection create [$this namespace]::patternProperties] |
|
# |
|
#} |
|
|
|
|
|
|
|
#tidy up |
|
unset PV |
|
unset PM |
|
|
|
|
|
|
|
#-------------------------------------------------------- |
|
::>pattern .. Create >enum |
|
#process_pattern_aliases ::patternlib::>enum |
|
>enum .. PatternMethod item {{idx 0}} { |
|
var o_array o_list |
|
|
|
if {[string is integer -strict $idx]} { |
|
if {$idx < 0} { |
|
set idx "end-[expr {abs($idx + 1)}]" |
|
} |
|
if {[catch {set o_array([lindex $o_list $idx])} result]} { |
|
error "no such index : '$idx'" |
|
} else { |
|
return $result |
|
} |
|
} else { |
|
if {[catch {set o_array($idx)} result]} { |
|
error "no such index: '$idx'" |
|
} else { |
|
return $result |
|
} |
|
} |
|
} |
|
|
|
|
|
|
|
#proc makeenum {type identifiers} { |
|
# #!!todo - make generated procs import into whatever current system context? |
|
# |
|
# upvar #0 wbpbenum_${type}_number a1 wbpbenum_number_${type} a2 |
|
# |
|
# #obliterate any previous enum for this type |
|
# catch {unset a1} |
|
# catch {unset a2} |
|
# |
|
# set n 0 |
|
# foreach id $identifiers { |
|
# set a1($id) $n |
|
# set a2($n) $id |
|
# incr n |
|
# } |
|
# proc ::${type}_to_number key [string map [list @type@ $type] { |
|
# upvar #0 wbpbenum_@type@_number ary |
|
# if {[catch {set ary($key)} num]} { |
|
# return -code error "unknown @type@ '$key'" |
|
# } |
|
# return $num |
|
# }] |
|
# |
|
# proc ::number_to_${type} {number} [string map [list @type@ $type] { |
|
# upvar #0 wbpbenum_number_@type@ ary |
|
# if {[catch {set ary($number)} @type@]} { |
|
# return -code error "no @type@ for '$number'" |
|
# } |
|
# return $@type@ |
|
# }] |
|
# |
|
# #eval "namespace eval ::sysnexus {namespace export number_to_${type}; namespace export ${type}_to_number}" |
|
# #eval "namespace eval :: {namespace import -force sysnexus::number_to_${type} sysnexus::${type}_to_number}" |
|
#} |
|
# |
|
#-------------------------------------------------------- |
|
::>pattern .. Create >nest |
|
>nest .. PatternVariable THIS |
|
>nest .. PatternProperty data -autoclone |
|
>nest .. Constructor {args} { |
|
var o_data |
|
var THIS |
|
set THIS @this@ |
|
array set o_data [list] |
|
} |
|
>nest .. PatternMethod item {args} { |
|
set THIS @this@ |
|
return [$THIS . data [join $args ,]] |
|
} |
|
|
|
# |
|
# e.g |
|
# set [>nest a , b . data c .] blah |
|
# >nest a , b , c |
|
# |
|
# set [>nest w x , y . data z .] etc |
|
# >nest w x , y , z |
|
#-------------------------------------------------------- |
|
|
|
} |
|
|
|
} |
|
|
|
|
|
#package require patternlibtemp
|
|
|