#not significantly different in performance over test of 100 elements - getting somewhere near 10% for 1k integers
proc ::lremove2 {list args} {
set data [lmap v $list {list data $v}]
foreach doomed_index $args {
if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"}
lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value
}
set keep [lsearch -all -inline -not -exact $data x]
return [lmap v $keep {lindex $v 1}]
}
#outside of lmap - don't know of any particularly nice ways to flatten to subindex 1 of each element..
#flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 - and even in 8.7 it doesn't seem to allow returning one index of the stridden 'group'
}
if {"::lpop" ne [info commands ::lpop]} {
puts stderr "Warning - no built-in lpop"
interp alias {} lpop {} ::punk::lpop
}
proc lpop {lvar args} {
upvar $lvar l
if {![llength $args]} {
set args [list end]
}
set v [lindex $l {*}$args]
set newlist $l
set path [list]
set subl $l
for {set i 0} {$i < [llength $args]} {incr i} {
set idx [lindex $args $i]
if {![llength [lrange $subl $idx $idx]]} {
error "tcl_lpop index \"$idx\" out of range"
}
#if {[list_index_get $subl $idx] == -1} {
# error "tcl_lpop index \"$idx\" out of range"
#}
lappend path [lindex $args $i]
set subl [lindex $l {*}$path]
}
set sublist_path [lrange $args 0 end-1]
set tailidx [lindex $args end]
if {![llength $sublist_path]} {
#set newlist [lremove $newlist $tailidx]
set newlist [lreplace $newlist $tailidx $tailidx]
} else {
set sublist [lindex $newlist {*}$sublist_path]
#set sublist [lremove $sublist $tailidx]
set sublist [lreplace $sublist $tailidx $tailidx]
lset newlist {*}$sublist_path $sublist
}
#puts "[set l] -> $newlist"
set l $newlist
return $v
}
proc list_index_resolve {list index} {
#Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr
if {![llength $list]} {
return -1
}
set index [string map [list _ ""] $index] ;#forward compatibility with integers such as 1_000
if {[string is integer -strict $index]} {
#can match +i -i
if {$index < 0} {
return -1
} elseif {$index >= [llength $list]} {
return -1
} else {
#integer may still have + sign - normalize with expr
return [expr {$index}]
}
} else {
if {[string match end* $index]} {
if {$index ne "end"} {
set op [string index $index 3]
set offset [string range $index 4 end]
if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"}
if {$op eq "+" && $offset != 0} {
return -1
}
} else {
set offset 0
}
#by now, if op = + then offset = 0 so we only need to handle the minus case
if {$offset == 0} {
set index [expr {[llength $list]-1}]
} else {
set index [expr {([llength $list]-1) - $offset}]
}
if {$index < 0} {
return -1
} else {
return $index
}
} else {
#plain +-<int> already handled above.
#we are trying to avoid evaluating unbraced expr of potentially insecure origin
if {[regexp {(.*)([+-])(.*)} $index _match a op b]} {
if {[string is integer -strict $a] && [string is integer -strict $b]} {
if {$op eq "-"} {
set index [expr {$a - $b}]
} else {
set index [expr {$a + $b}]
}
} else {
error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"
}
} else {
error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"
set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ but that's likely unavailable here.
for {set i 0} {$i < [llength $list]} {incr i} {
lappend indices $i
}
set idx [lindex $indices $index]
if {$idx eq ""} {
return -1
} else {
return $idx
}
}
proc list_index_get {list index} {
set resultlist [lrange $list $index $index]
if {![llength $resultlist]} {
return -1
} else {
#we still don't know the actual integer index for an index such as end-x or int-int without parsing and evaluating ourself.
#we can return the value - but only in a way that won't collide with our -1 out-of-range indicator
#[para] compatibility functions for features that may not be available in earlier Tcl versions
#[para] These are generally 'forward compatibility' functions ie allowing earlier versions to use later features/idioms by using a Tcl-only version of a missing builtin.
#[para] Such Tcl-only versions will inevitably be less performant - perhaps significantly so.
#*** !doctools
#[list_begin enumerated]
if {"::lremove" ne [info commands ::lremove]} {
#puts stderr "Warning - no built-in lremove"
interp alias {} lremove {} ::punk::lib::compat::lremove
#not significantly different in performance over test of 100 elements - getting somewhere near 10% for 1k integers
proc lremove2 {list args} {
set data [lmap v $list {list data $v}]
foreach doomed_index $args {
if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"}
lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value
}
set keep [lsearch -all -inline -not -exact $data x]
return [lmap v $keep {lindex $v 1}]
}
#outside of lmap - don't know of any particularly nice ways to flatten to subindex 1 of each element..
#flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 - and even in 8.7 it doesn't seem to allow returning one index of the stridden 'group'
if {"::lpop" ne [info commands ::lpop]} {
#puts stderr "Warning - no built-in lpop"
interp alias {} lpop {} ::punk::lib::compat::lpop
}
proc lpop {lvar args} {
#*** !doctools
#[call [fun lpop] [arg listvar] [opt {index}]]
#[para] Forwards compatible lpop for versions 8.6 or less to support equivalent 8.7 lpop
upvar $lvar l
if {![llength $args]} {
set args [list end]
}
set v [lindex $l {*}$args]
set newlist $l
set path [list]
set subl $l
for {set i 0} {$i < [llength $args]} {incr i} {
set idx [lindex $args $i]
if {![llength [lrange $subl $idx $idx]]} {
error "tcl_lpop index \"$idx\" out of range"
}
lappend path [lindex $args $i]
set subl [lindex $l {*}$path]
}
set sublist_path [lrange $args 0 end-1]
set tailidx [lindex $args end]
if {![llength $sublist_path]} {
#set newlist [lremove $newlist $tailidx]
set newlist [lreplace $newlist $tailidx $tailidx]
} else {
set sublist [lindex $newlist {*}$sublist_path]
#set sublist [lremove $sublist $tailidx]
set sublist [lreplace $sublist $tailidx $tailidx]
lset newlist {*}$sublist_path $sublist
}
#puts "[set l] -> $newlist"
set l $newlist
return $v
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::lib::compat ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
@ -122,6 +210,91 @@ namespace eval punk::lib {
# return "ok"
#}
proc list_index_resolve {list index} {
#Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr
if {![llength $list]} {
return -1
}
set index [string map [list _ ""] $index] ;#forward compatibility with integers such as 1_000
if {[string is integer -strict $index]} {
#can match +i -i
if {$index < 0} {
return -1
} elseif {$index >= [llength $list]} {
return -1
} else {
#integer may still have + sign - normalize with expr
return [expr {$index}]
}
} else {
if {[string match end* $index]} {
if {$index ne "end"} {
set op [string index $index 3]
set offset [string range $index 4 end]
if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"}
if {$op eq "+" && $offset != 0} {
return -1
}
} else {
set offset 0
}
#by now, if op = + then offset = 0 so we only need to handle the minus case
if {$offset == 0} {
set index [expr {[llength $list]-1}]
} else {
set index [expr {([llength $list]-1) - $offset}]
}
if {$index < 0} {
return -1
} else {
return $index
}
} else {
#plain +-<int> already handled above.
#we are trying to avoid evaluating unbraced expr of potentially insecure origin
if {[regexp {(.*)([+-])(.*)} $index _match a op b]} {
if {[string is integer -strict $a] && [string is integer -strict $b]} {
if {$op eq "-"} {
set index [expr {$a - $b}]
} else {
set index [expr {$a + $b}]
}
} else {
error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"
}
} else {
error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"
set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ but that's likely unavailable here.
for {set i 0} {$i < [llength $list]} {incr i} {
lappend indices $i
}
set idx [lindex $indices $index]
if {$idx eq ""} {
return -1
} else {
return $idx
}
}
proc list_index_get {list index} {
set resultlist [lrange $list $index $index]
if {![llength $resultlist]} {
return -1
} else {
#we still don't know the actual integer index for an index such as end-x or int-int without parsing and evaluating ourself.
#we can return the value - but only in a way that won't collide with our -1 out-of-range indicator
