diff --git a/src/bootsupport/modules/dictn-0.1.2.tm b/src/bootsupport/modules/dictn-0.1.2.tm index 2ed2b1ef..5a7de769 100644 --- a/src/bootsupport/modules/dictn-0.1.2.tm +++ b/src/bootsupport/modules/dictn-0.1.2.tm @@ -25,17 +25,46 @@ namespace eval dictn { namespace export {[a-z]*} namespace ensemble create + + namespace eval argdoc { + variable PUNKARGS + #non-colour SGR codes + set I "\x1b\[3m" ;# [a+ italic] + set NI "\x1b\[23m" ;# [a+ noitalic] + set B "\x1b\[1m" ;# [a+ bold] + set N "\x1b\[22m" ;# [a+ normal] + set T "\x1b\[1\;4m" ;# [a+ bold underline] + set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] + } } ## ::dictn::append -#This can of course 'ruin' a nested dict if applied to the wrong element -# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: -# %set list {a b {c d}} -# %append list x -# a b {c d}x -# IOW - don't do that unless you really know that's what you want. # +tcl::namespace::eval ::dictn::argdoc { + lappend PUNKARGS [list { + @id -id ::dictn::append + @cmd -name dictn::append\ + -summary\ + "Append a single string to the value at dict path."\ + -help\ + "Append a single string to the value at a given dictionary path. + + This can of course 'ruin' a nested dict if applied to the wrong element + - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: + %set list {a b {c d}} + %append list x + a b {c d}x + IOW - don't do that unless you really know that's what you want. + + Note than unlike dict append - only a single value is accepted for appending. + " + @values -min 2 -max 3 + dictvar -type string + path -type list + value -type any -default "" -optional 1 + }] +} proc ::dictn::append {dictvar path {value {}}} { if {[llength $path] == 1} { uplevel 1 [list dict append $dictvar $path $value] @@ -43,7 +72,7 @@ proc ::dictn::append {dictvar path {value {}}} { upvar 1 $dictvar dvar ::set str [dict get $dvar {*}$path] - append str $val + append str $value dict set dvar {*}$path $str } } @@ -73,6 +102,25 @@ proc ::dictn::for {keyvalvars dictval path body} { proc ::dictn::get {dictval {path {}}} { return [dict get $dictval {*}$path] } +tcl::namespace::eval ::dictn::argdoc { + lappend PUNKARGS [list { + @id -id ::dictn::getn + @cmd -name dictn::getn\ + -summary\ + "Get one or more paths in a dict simultaneously."\ + -help\ + "" + @values -min 1 -max -1 + dictvar -type string + path -type list -multiple 1 + }] +} +proc ::dictn::getn {dictval args} { + if {![llength $args]} { + return [::tcl::dict::get $dictval] + } + lmap path $args {::tcl::dict::get $dictval {*}$path} +} if {[info commands ::tcl::dict::getdef] ne ""} { @@ -85,10 +133,18 @@ if {[info commands ::tcl::dict::getdef] ne ""} { return [dict getdef $dictval {*}$path $default] } - proc ::dictn::incr {dictvar path {increment {}} } { - if {$increment eq ""} { - ::set increment 1 + proc ::dictn::incr {dictvar path {increment 1} } { + upvar 1 $dictvar dvar + if {[llength $path] == 1} { + return [::tcl::dict::incr dvar $path $increment] + } + if {[::tcl::info::exists dvar]} { + ::set increment [expr {[::tcl::dict::getdef $dvar {*}$path 0] + $increment}] } + return [::tcl::dict::set dvar {*}$path $increment] + } + #test - compare disassembly + proc ::dictn::incr2 {dictvar path {increment 1} } { if {[llength $path] == 1} { uplevel 1 [list dict incr $dictvar $path $increment] } else { @@ -233,6 +289,33 @@ proc ::dictn::set {dictvar path newval} { return [dict set dvar {*}$path $newval] } +tcl::namespace::eval ::dictn::argdoc { + lappend PUNKARGS [list { + @id -id ::dictn::setn + @cmd -name dictn::setn\ + -summary\ + "Set one or more paths in a dict to value(s)"\ + -help\ + "" + @values -min 3 -max -1 + dictvar -type string + path_newval -type {path newval} -multiple 1 + }] +} +proc ::dictn::setn {dictvar args} { + if {[llength $args] == 0} { + error "dictn::setn requires at least one pair" + } + if {[llength $args] % 2 != 0} { + error "dictn::setn requires trailing pairs" + } + upvar 1 $dictvar dvar + foreach {p v} $args { + ::tcl::dict::set dvar {*}$p $v + } + return $dvar +} + proc ::dictn::size {dictval {path {}}} { return [dict size [dict get $dictval {*}$path]] } @@ -312,6 +395,46 @@ proc ::dictn::values {dictval {path {}} {glob {}}} { } } +tcl::namespace::eval ::dictn::argdoc { + lappend PUNKARGS [list { + @id -id ::dictn::with + @cmd -name dictn::with\ + -summary\ + "Execute script for each key at dict path."\ + -help\ + "Execute the Tcl script in body with the value for each key within the + given key-path mapped to either variables or keys in a specified array. + + If the name of an array variable is not supplied for arrayvar, + dictn with behaves like dict with, except that it accepts a list + for the possibly nested key-path instead of separate arguments. + + The subkeys of the dict at the given key-path will create variables + in the calling scope. + + If an arrayvar is passed, an array of that name in the calling + scope will be populated with keys and values from the subkeys and + values of the dict at the given key-path." + @form -form standard + @values -min 3 -max 3 + dictvar -type string + path -type list + body -type string + + @form -form array + @values -min 4 -max 4 + dictvar -type string + path -type list + arrayvar -type string -help\ + "Name of array variable in which key values are + stored for the given dict path. + This prevents key values being used as variable + names in the calling scope, instead capturing them + as keys in the single specified array at the calling + scope." + body -type string + }] +} # Standard form: #'dictn with dictVariable path body' # @@ -351,7 +474,10 @@ proc ::dictn::with {dictvar path args} { - +::tcl::namespace::eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::dictn +} diff --git a/src/bootsupport/modules/punk/lib-0.1.5.tm b/src/bootsupport/modules/punk/lib-0.1.5.tm index 6b2dd8a9..390b34ae 100644 --- a/src/bootsupport/modules/punk/lib-0.1.5.tm +++ b/src/bootsupport/modules/punk/lib-0.1.5.tm @@ -751,6 +751,27 @@ namespace eval punk::lib { # -- --- + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lswap + @cmd -name punk::lib::lswap\ + -summary\ + "Swap list values in-place"\ + -help\ + "Similar to struct::list swap, except it fully supports basic + list index expressions such as 7-2 end-1 etc. + + struct::list swap doesn't support 'end' offsets, and only + sometimes appears to support basic expressions, depending on the + expression compared to the list length." + @values -min 1 -max 1 + lvar -type string -help\ + "name of list variable" + a -type indexexpression + z -type indexexpression + }] + } proc lswap {lvar a z} { upvar $lvar l set len [llength $l] @@ -955,181 +976,233 @@ namespace eval punk::lib { } } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lzip + @cmd -name punk::lib::lzip\ + -summary\ + "zip any number of lists together."\ + -help\ + "Conceptually equivalent to converting a list of rows + to a list of columns. + + The number of returned lists (columns) will be equal to + the length of the longest supplied list (row). + If lengths of supplied lists don't match, empty strings + will be inserted in the resulting lists. + + e.g lzip {a b c d e} {1 2 3 4} {x y z} + -> {a 1 x} {b 2 y} {c 3 z} {d 4 {}} {3 {} {}} + " + @values -min 1 -max 1 + lvar -type string -help\ + "name of list variable" + a -type indexexpression + z -type indexexpression + }] + } proc lzip {args} { switch -- [llength $args] { - 0 {return {}} - 1 {return [lindex $args 0]} - 2 {return [lzip2lists {*}$args]} - 3 {return [lzip3lists {*}$args]} - 4 {return [lzip4lists {*}$args]} - 5 {return [lzip5lists {*}$args]} - 6 {return [lzip6lists {*}$args]} - 7 {return [lzip7lists {*}$args]} - 8 {return [lzip8lists {*}$args]} - 9 {return [lzip9lists {*}$args]} - 10 {return [lzip10lists {*}$args]} + 0 {return {}} + 1 {return [lindex $args 0]} + 2 {return [::punk::lib::system::lzip2lists {*}$args]} + 3 {return [::punk::lib::system::lzip3lists {*}$args]} + 4 {return [::punk::lib::system::lzip4lists {*}$args]} + 5 {return [::punk::lib::system::lzip5lists {*}$args]} + 6 {return [::punk::lib::system::lzip6lists {*}$args]} + 7 {return [::punk::lib::system::lzip7lists {*}$args]} + 8 {return [::punk::lib::system::lzip8lists {*}$args]} + 9 {return [::punk::lib::system::lzip9lists {*}$args]} + 10 {return [::punk::lib::system::lzip10lists {*}$args]} 11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 { set n [llength $args] - if {[info commands ::punk::lib::lzip${n}lists] eq ""} { - puts "calling ::punk::lib::Build_lzipn $n" - ::punk::lib::Build_lzipn $n + if {[info commands ::punk::lib::system::lzip${n}lists] eq ""} { + #puts "calling ::punk::lib::system::Build_lzipn $n" + ::punk::lib::system::Build_lzipn $n } - return [lzip${n}lists {*}$args] + return [::punk::lib::system::lzip${n}lists {*}$args] } default { if {[llength $args] < 4000} { set n [llength $args] - if {[info commands ::punk::lib::lzip${n}lists] eq ""} { - puts "calling ::punk::lib::Build_lzipn $n" - ::punk::lib::Build_lzipn $n + if {[info commands ::punk::lib::system::lzip${n}lists] eq ""} { + #puts "calling ::punk::lib::system::Build_lzipn $n" + ::punk::lib::system::Build_lzipn $n } - return [lzip${n}lists {*}$args] + return [::punk::lib::system::lzip${n}lists {*}$args] } else { - return [lzipn {*}$args] + return [::punk::lib::lzipn {*}$args] } } } } - proc Build_lzipn {n} { - set arglist [list] - #use punk::lib::range which defers to lseq if available - set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) - set body "\nlmap " - for {set i 1} {$i <= $n} {incr i} { - lappend arglist l$i - append body "[lindex $vars $i] \$l$i " - } - append body "\{list " - for {set i 1} {$i <= $n} {incr i} { - append body "\$[lindex $vars $i] " + namespace eval system { + proc Build_lzipn {n} { + set arglist [list] + #use punk::lib::range which defers to lseq if available + set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) + set body "\nlmap " + for {set i 1} {$i <= $n} {incr i} { + lappend arglist l$i + append body "[lindex $vars $i] \$l$i " + } + append body "\{list " + for {set i 1} {$i <= $n} {incr i} { + append body "\$[lindex $vars $i] " + } + append body "\}" \n + #puts "proc punk::lib::system::lzip${n}lists {$arglist} \{" + #puts "$body" + #puts "\}" + proc ::punk::lib::system::lzip${n}lists $arglist $body } - append body "\}" \n - puts "proc punk::lib::lzip${n}lists {$arglist} \{" - puts "$body" - puts "\}" - proc ::punk::lib::lzip${n}lists $arglist $body - } - #fastest is to know the number of lists to be zipped - proc lzip2lists {l1 l2} { - lmap a $l1 b $l2 {list $a $b} - } - proc lzip3lists {l1 l2 l3} { - lmap a $l1 b $l2 c $l3 {list $a $b $c} - } - proc lzip4lists {l1 l2 l3 l4} { - lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} - } - proc lzip5lists {l1 l2 l3 l4 l5} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} - } - proc lzip6lists {l1 l2 l3 l4 l5 l6} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} - } - proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} - } - proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} - } - proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} - } - proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} - } + #fastest is to know the number of lists to be zipped + proc lzip2lists {l1 l2} { + lmap a $l1 b $l2 {list $a $b} + } + proc lzip3lists {l1 l2 l3} { + lmap a $l1 b $l2 c $l3 {list $a $b $c} + } + proc lzip4lists {l1 l2 l3 l4} { + lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} + } + proc lzip5lists {l1 l2 l3 l4 l5} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} + } + proc lzip6lists {l1 l2 l3 l4 l5 l6} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} + } + proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} + } + proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} + } + proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} + } + proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} + } - #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly - # review - - proc lzipn_alt args { - #stackoverflow - courtesy glenn jackman (modified) - foreach l $args { - lappend vars [incr n] - lappend lmap_args $n $l + #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly + # review - + proc lzipn_alt args { + #stackoverflow - courtesy glenn jackman (modified) + foreach l $args { + lappend vars [incr n] + lappend lmap_args $n $l + } + lmap {*}$lmap_args {lmap v $vars {set $v}} } - lmap {*}$lmap_args {lmap v $vars {set $v}} - } - #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) - proc lzipn_tcl8 {args} { - #wiki - courtesy JAL - set list_l $args - set zip_l [] - while {1} { - set cur [lmap a_l $list_l { lindex $a_l 0 }] - set list_l [lmap a_l $list_l { lrange $a_l 1 end }] + #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) + proc lzipn_tcl8 {args} { + #For tcl pre 9 (without lsearch -stride) + #wiki - courtesy JAL + set list_l $args + set zip_l [] + while {1} { + set cur [lmap a_l $list_l { lindex $a_l 0 }] + set list_l [lmap a_l $list_l { lrange $a_l 1 end }] - if {[join $cur {}] eq {}} { - break + if {[join $cur {}] eq {}} { + break + } + lappend zip_l $cur + } + return $zip_l + } + proc lzipn_tcl9a {args} { + #For Tcl 9+ (with lsearch -stride) + #compared to wiki version + #comparable for lists len <3 or number of args < 3 + #approx 2x faster for large lists or more lists + #needs -stride single index bug fix to use empty string instead of NULL + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] + set outlist [lrepeat $numcolumns {}] + set s 0 + foreach len $lens list $args { + #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] + ledit flatlist $s [expr {$s + $len - 1}] {*}$list + incr s $numcolumns + } + #needs single index lstride bugfix + for {set c 0} {$c < $numcolumns} {incr c} { + ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] + } + return $outlist + } + proc lzipn_tcl9b {args} { + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} + } + proc lzipn_tcl9c {args} { + #SLOW + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + set zip_l {} + set cols_remaining $numcolumns + for {set c 0} {$c < $numcolumns} {incr c} { + if {$cols_remaining == 1} { + return [list {*}$zip_l $flatlist] + } + lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] + set flen [llength $flatlist] + set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] + incr cols_remaining -1 } - lappend zip_l $cur + return $zip_l } - return $zip_l } - proc lzipn_tcl9a {args} { - #compared to wiki version - #comparable for lists len <3 or number of args < 3 - #approx 2x faster for large lists or more lists - #needs -stride single index bug fix to use empty string instead of NULL - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] - set outlist [lrepeat $numcolumns {}] - set s 0 - foreach len $lens list $args { - #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] - ledit flatlist $s [expr {$s + $len - 1}] {*}$list - incr s $numcolumns - } - #needs single index lstride bugfix - for {set c 0} {$c < $numcolumns} {incr c} { - ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] - } - return $outlist - } - proc lzipn_tcl9b {args} { - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [list] - foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] - } - lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} - } - proc lzipn_tcl9c {args} { - #SLOW - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [list] - foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] - } - set zip_l {} - set cols_remaining $numcolumns - for {set c 0} {$c < $numcolumns} {incr c} { - if {$cols_remaining == 1} { - return [list {*}$zip_l $flatlist] - } - lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] - set flen [llength $flatlist] - set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] - incr cols_remaining -1 - } - return $zip_l + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lzipn + @cmd -name punk::lib::lzipn\ + -summary\ + "zip any number of lists together (unoptimised)."\ + -help\ + "Conceptually equivalent to converting a list of rows + to a list of columns. + + See lzip which provides the same functionality but with + optimisations depending on the number of supplied lists. + " + @values -min 1 -max 1 + lvar -type string -help\ + "name of list variable" + a -type indexexpression + z -type indexexpression + }] } #keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible if {![package vsatisfies [package present Tcl] 9.0-] || [dict get [punk::lib::check::has_tclbug_lsearch_strideallinline] bug]} { #-stride either not available - or has bug preventing use of main algorithm below - proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] + proc lzipn {args} [info body ::punk::lib::system::lzipn_tcl8] } else { - proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] + proc lzipn {args} [info body ::punk::lib::system::lzipn_tcl9a] } + namespace import ::punk::args::lib::tstr namespace eval argdoc { @@ -2291,13 +2364,31 @@ namespace eval punk::lib { proc is_list_all_ni_list2 {a b} $body } - #somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist - #struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on, - # especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg) - proc ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::ldiff + @cmd -name punk::lib::ldiff\ + -summary\ + "Difference consisting of items with removeitems removed."\ + -help\ + "Somewhat like struct::set difference, but order preserving, and doesn't + treat as a 'set' so preserves any duplicates in items. + + struct::set difference may happen to preserve ordering when items are + integers, but order can't be relied on, especially as struct::set has + 2 differening implementations (tcl vs critcl) which return results with + different ordering to each other and different deduping behaviour in + some cases (e.g when 2nd arg is empty)" + @values -min 2 -max 2 + items -type list + removeitems -type list + }] + } + proc ldiff {items removeitems} { + if {[llength $removeitems] == 0} {return $items} set result {} - foreach item $fromlist { + foreach item $items { if {$item ni $removeitems} { lappend result $item } @@ -2361,6 +2452,28 @@ namespace eval punk::lib { return [array names tmp] } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lunique_unordered + @cmd -name punk::lib::lunique_unordered\ + -summary\ + "unique values in list"\ + -help\ + "Return unique values in provided list. + This removes duplicates but *may* rearrange the + order of the returned elements compared to the + original list. + + When struct::set is available this will be used + for the implementation, as it can be *slightly* + faster if acceleration is present. When struct::set + is not available it will fallback to lunique and + provide the same functionality with order preserved." + @values -min 1 -max 1 + list -type list + }] + } #default/fallback implementation proc lunique_unordered {list} { lunique $list @@ -2371,13 +2484,33 @@ namespace eval punk::lib { struct::set union $list {} } } else { - puts stderr "WARNING: struct::set union no longer dedupes!" + #struct::set union operates on a 'set' - so this probably won't change, and hopefully is + #consistent across unacelerated versions and those implemented in accelerators, + #but if it ever does change - be a little noisy about it. + puts stderr "punk::lib WARNING: struct::set union no longer dedupes!" #we could also test a sequence of: struct::set add } } - #order-preserving + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lunique + @cmd -name punk::lib::lunique\ + -summary\ + "Order-preserving unique values in list"\ + -help\ + "Return unique values in provided list. + This removes duplicates whilst preserving the + original order of the provided list. + + When struct::set is available with acceleration, + lunique_unordered may be slightly faster." + @values -min 1 -max 1 + list -type list + }] + } proc lunique {list} { set new {} foreach item $list { @@ -2569,18 +2702,21 @@ namespace eval punk::lib { To validate if an indexset is strictly within range, both the length of the data and the base would need to be considered. - The normal 'range' specifier is .. + The normal 'range' specifier is .. but can be of the form .x. where x is the step value. The range specifier can appear at the beginning, middle or end, or even alone to indicate the entire range of valid values. e.g the following are all valid ranges - 1.. - (index 1 to 'max') - ..10 - (index 'base' to 10) - 2..11 - (index 2 to 11) - .. - (all indices) + 1.. + (index 1 to 'max') + ..10 + (index 'base' to 10) + 2..11 + (index 2 to 11) + .. + (all indices) + .3. + (1st index and every 3rd index thereafter) + Common whitespace elements space,tab,newlines are ignored. Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands, e.g end-2 or 2+2. @@ -2670,20 +2806,19 @@ namespace eval punk::lib { .-1. would represent end to base with step -1 If start is omitted and only the end is supplied: - The default step is 1 indicating ascension and the missing end is equivalent to 'end' - indexset_resolve 5 2.. - -> 2 3 4 - The default end is the base if the step is negative - indexset_resolve 5 2.-1. - -> 2 1 0 - If end is omitted and onlthe start is supplied: The default step is 1 indicating ascension and the missing start is equivalent to the base. indexset_resolve 5 ..2 -> 0 1 2 The default start is 'end' if the step is negative indexset_resolve 5 .-1.2 -> 4 3 2 - + If end is omitted and only the start is supplied: + The default step is 1 indicating ascension and the missing end is equivalent to 'end' + indexset_resolve 5 2.. + -> 2 3 4 + The default end is the base if the step is negative + indexset_resolve 5 2.-1. + -> 2 1 0 Like the tcl9 lseq command - a step (by) value of zero produces no results. @@ -2703,7 +2838,7 @@ namespace eval punk::lib { indexset examples: - These assume the default 0-based indices (base == 0) + These assume the default 0-based indices (-base 0) 1,3.. output the index 1 (2nd item) followed by all from index 3 to the end. @@ -3604,7 +3739,7 @@ namespace eval punk::lib { @id -id ::punk::lib::gcd @cmd -name punk::lib::gcd\ -summary\ - "Gretest common divisor of m and n."\ + "Greatest common divisor of m and n."\ -help\ "Return the greatest common divisor of m and n. Straight from Lars Hellström's math::numtheory library in Tcllib @@ -3643,12 +3778,22 @@ namespace eval punk::lib { return $m } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lcm + @cmd -name punk::lib::lcm\ + -summary\ + "Lowest common multiple of m and n."\ + -help\ + "Return the lowest common multiple of m and n. + Straight from Lars Hellström's math::numtheory library in Tcllib" + @values -min 2 -max 2 + m -type integer + n -type integer + }] + } proc lcm {n m} { - #*** !doctools - #[call [fun gcd] [arg n] [arg m]] - #[para]Return the lowest common multiple of m and n - #[para]Straight from Lars Hellström's math::numtheory library in Tcllib - #[para] set gcd [gcd $n $m] return [expr {$n*$m/$gcd}] } diff --git a/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/bootsupport/modules/punk/repl-0.1.2.tm index 96f506b5..c0f2b7ba 100644 --- a/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/bootsupport/modules/punk/repl-0.1.2.tm @@ -1036,7 +1036,8 @@ namespace eval punk::repl::class { # set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""] # incr nextrow -1 #} - set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""] + #set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""] + ledit o_rendered_lines $cursor_row_idx $cursor_row_idx-1 "" set o_cursor_col 1 } diff --git a/src/bootsupport/modules/punkcheck-0.1.0.tm b/src/bootsupport/modules/punkcheck-0.1.0.tm index 9c44ea72..c610c667 100644 --- a/src/bootsupport/modules/punkcheck-0.1.0.tm +++ b/src/bootsupport/modules/punkcheck-0.1.0.tm @@ -323,7 +323,8 @@ namespace eval punkcheck { if {$isnew} { lappend record_list $o_fileset_record } else { - set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record] + #set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record] + ledit record_list $oldposition $oldposition-1 $o_fileset_record } if {$o_operation ne "QUERY"} { punkcheck::save_records_to_file $record_list $punkcheck_file @@ -536,7 +537,8 @@ namespace eval punkcheck { set existing_header_posn [dict get $resultinfo position] if {$existing_header_posn == -1} { set this_installer_record [punkcheck::recordlist::new_installer_record $o_name] - set o_record_list [linsert $o_record_list 0 $this_installer_record] + #set o_record_list [linsert $o_record_list 0 $this_installer_record] + ledit o_record_list -1 -1 $this_installer_record } else { set this_installer_record [dict get $resultinfo record] } @@ -616,7 +618,8 @@ namespace eval punkcheck { set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records] set existing_header_posn [dict get $persistedinfo position] if {$existing_header_posn == -1} { - set file_records [linsert $file_records 0 $this_installer_record] + #set file_records [linsert $file_records 0 $this_installer_record] + ledit file_records -1 -1 $this_installer_record } else { lset file_records $existing_header_posn $this_installer_record } @@ -710,7 +713,8 @@ namespace eval punkcheck { if {$existing_header_posn == -1} { #not found - prepend - set record_list [linsert $record_list 0 $this_installer_record] + #set record_list [linsert $record_list 0 $this_installer_record] + ledit record_list -1 -1 $this_installer_record } else { #replace lset record_list $existing_header_posn $this_installer_record @@ -791,7 +795,8 @@ namespace eval punkcheck { if {$isnew} { lappend record_list $file_record } else { - set record_list [linsert $record_list[unset record_list] $oldposition $file_record] + #set record_list [linsert $record_list[unset record_list] $oldposition $file_record] + ledit record_list $oldposition $oldposition-1 $file_record } save_records_to_file $record_list $punkcheck_file @@ -1191,7 +1196,8 @@ namespace eval punkcheck { # dst is: base/sub = sub while {$baselen > 0} { - set dst [linsert $dst 0 ..] + #set dst [linsert $dst 0 ..] + ledit dst -1 -1 .. incr baselen -1 } set dst [file join {*}$dst] diff --git a/src/bootsupport/modules/textblock-0.1.3.tm b/src/bootsupport/modules/textblock-0.1.3.tm index 93e4a41c..4079254e 100644 --- a/src/bootsupport/modules/textblock-0.1.3.tm +++ b/src/bootsupport/modules/textblock-0.1.3.tm @@ -4480,7 +4480,8 @@ tcl::namespace::eval textblock { set code_idx 3 foreach {pt code} [lrange $parts 2 end] { if {[punk::ansi::codetype::is_sgr_reset $code]} { - set parts [linsert $parts $code_idx+1 $base] + #set parts [linsert $parts $code_idx+1 $base] + ledit parts $code_idx+1 $code_idx $base } incr code_idx 2 } @@ -4504,12 +4505,14 @@ tcl::namespace::eval textblock { #first pt & code if {$pt ne ""} { #leading plaintext - set parts [linsert $parts 0 $base] + #set parts [linsert $parts 0 $base] + ledit parts -1 -1 $base incr offset } } if {[punk::ansi::codetype::is_sgr_reset $code]} { set parts [linsert $parts [expr {$code_idx+1+$offset}] $base] + #ledit parts [expr {$code_idx+1+$offset}] $code_idx+$offset $base incr offset } incr code_idx 2 @@ -5371,6 +5374,9 @@ tcl::namespace::eval textblock { r-1 { if {[lindex $line_chunks end] eq ""} { set line_chunks [linsert $line_chunks end-2 $pad] + #breaks layout e.g subtables in: i i + #why? + #ledit line_chunks end-2 end-3 $pad } else { lappend line_chunks $pad } @@ -5379,13 +5385,16 @@ tcl::namespace::eval textblock { lappend line_chunks $pad } l-0 { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } l-1 { if {[lindex $line_chunks 0] eq ""} { - set line_chunks [linsert $line_chunks 2 $pad] + #set line_chunks [linsert $line_chunks 2 $pad] + ledit line_chunks 2 1 $pad } else { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } } l-2 { @@ -5393,10 +5402,12 @@ tcl::namespace::eval textblock { if {[lindex $line_chunks 0] eq ""} { set line_chunks [linsert $line_chunks 2 $pad] } else { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } } else { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } } } @@ -5466,14 +5477,17 @@ tcl::namespace::eval textblock { #} else { # set line_chunks [linsert $line_chunks 0 $pad] #} - set line_chunks [linsert $line_chunks 0 $pad] + + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } l-1 { #set line_chunks [linsert $line_chunks 0 $pad] set line_chunks [_insert_before_text_or_last_ansi $pad $line_chunks] } l-2 { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } } } diff --git a/src/modules/overtype-999999.0a1.0.tm b/src/modules/overtype-999999.0a1.0.tm index c3fca6d9..1555a5fa 100644 --- a/src/modules/overtype-999999.0a1.0.tm +++ b/src/modules/overtype-999999.0a1.0.tm @@ -493,13 +493,14 @@ tcl::namespace::eval overtype { switch -- $scheme { 0 { #one big chunk - set inputchunks [list $overblock] + set inputchunks [list mixed $overblock] } 1 { + #todo set inputchunks [punk::ansi::ta::split_codes $overblock] } 2 { - + #todo #split into lines if possible first - then into plaintext/ansi-sequence chunks ? set inputchunks [list ""] ;#put an empty plaintext split in for starters set i 1 @@ -516,6 +517,7 @@ tcl::namespace::eval overtype { } } 3 { + #todo #it turns out line based chunks are faster than the above.. probably because some of those end up doing the regex splitting twice set lflines [list] set inputchunks [split $overblock \n] @@ -533,10 +535,10 @@ tcl::namespace::eval overtype { 4 { set inputchunks [list] foreach ln [split $overblock \n] { - lappend inputchunks $ln\n + lappend inputchunks [list mixed $ln\n] } if {[llength $inputchunks]} { - lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] + lset inputchunks end 1 [tcl::string::range [lindex $inputchunks end 1] 0 end-1] } } } @@ -567,23 +569,54 @@ tcl::namespace::eval overtype { set loop 0 #while {$overidx < [llength $inputchunks]} { } - + set renderedrow "" while {[llength $inputchunks]} { - #set overtext [lindex $inputchunks $overidx]; lset inputchunks $overidx "" - set overtext [lpop inputchunks 0] - if {![tcl::string::length $overtext]} { + #set overtext [lpop inputchunks 0] ;#could be a list 'ansisplit' or text 'plain|mixed' + lassign [lpop inputchunks 0] overtext_type overtext + + #use eq test with emptystring instead of 'string length' - test for emptiness shouldn't cause shimmering if popped inputchunks member if an 'ansisplit' list + if {$overtext eq ""} { incr loop continue } #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" set undertext [lindex $outputlines [expr {$row -1}]] - set renderedrow $row #renderline pads each underaly line to width with spaces and should track where end of data is + switch -- $overtext_type { + mixed { + set overtext $replay_codes_overlay$overtext + } + ansisplit { + ledit overtext -1 -1 "" $replay_codes_overlay + } + default { + error "renderspace unsupported overtext type: $overtext_type overtext: $overtext" + } + } + + + ###################### + #debug + #set partinfo "" + #if {$overtext_type eq "ansisplit"} { + # set partinfo [llength $overtext] + #} else { + # set partinfo [string length $overtext] + #} + #if {$renderedrow eq $row} { + # puts -nonewline stderr <$row>$overtext_type$partinfo + #} else { + # puts -nonewline stderr \n<$row>$overtext_type$partinfo + #} + #if {$overtext_type eq "mixed"} { + # puts -nonewline stderr "\n[ansistring VIEW $overtext]\n" + #} + ###################### + + set renderedrow $row - #set overtext [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext] - set overtext $replay_codes_overlay$overtext if {[tcl::dict::exists $replay_codes_underlay $row]} { set undertext [tcl::dict::get $replay_codes_underlay $row]$undertext } @@ -604,6 +637,7 @@ tcl::namespace::eval overtype { -expand_right $opt_expand_right\ -cursor_column $col\ -cursor_row $row\ + -overtext_type $overtext_type\ ] set rinfo [renderline {*}$renderopts $undertext $overtext] @@ -623,6 +657,7 @@ tcl::namespace::eval overtype { set overflow_right_column [tcl::dict::get $rinfo overflow_right_column] set unapplied [tcl::dict::get $rinfo unapplied] set unapplied_list [tcl::dict::get $rinfo unapplied_list] + set unapplied_ansisplit [tcl::dict::get $rinfo unapplied_ansisplit] set post_render_col [tcl::dict::get $rinfo cursor_column] set post_render_row [tcl::dict::get $rinfo cursor_row] set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position] @@ -685,568 +720,644 @@ tcl::namespace::eval overtype { - set nextprefix "" + set nextprefix_list [list] - #todo - handle potential insertion mode as above for cursor restore? - #keeping separate branches for debugging - review and merge as appropriate when stable - set instruction_type [lindex $instruction 0] ;#some instructions have params - tcl::dict::incr instruction_stats $instruction_type - switch -- $instruction_type { - reset { - #reset the 'renderspace terminal' (not underlying terminal) - set row 1 - set col 1 - set vtstate [tcl::dict::merge $vtstate $initial_state] - #todo - clear screen + #todo - handle potential insertion mode as above for cursor restore? + #keeping separate branches for debugging - review and merge as appropriate when stable + set instruction_type [lindex $instruction 0] ;#some instructions have params + tcl::dict::incr instruction_stats $instruction_type + switch -- $instruction_type { + reset { + #reset the 'renderspace terminal' (not underlying terminal) + set row 1 + set col 1 + set vtstate [tcl::dict::merge $vtstate $initial_state] + #todo - clear screen + } + {} { + #end of supplied line input + #lf included in data + set row $post_render_row + set col $post_render_col + if {![llength $unapplied_list]} { + if {$overflow_right ne ""} { + incr row + } + } else { + puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)" } - {} { - #end of supplied line input - #lf included in data - set row $post_render_row + set col $opt_startcolumn + } + up { + + #renderline knows it's own line number, and knows not to go above row l + #it knows that a move whilst 1-beyond the width conflicts with the linefeed and reduces the move by one accordingly. + #row returned should be correct. + #column may be the overflow column - as it likes to report that to the caller. + + #Note that an ansi up sequence after last column going up to a previous line and also beyond the last column, will result in the next grapheme going onto the following line. + #this seems correct - as the column remains beyond the right margin so subsequent chars wrap (?) review + #puts stderr "up $post_render_row" + #puts stderr "$rinfo" + + #puts stdout "1 row:$row col $col" + set row $post_render_row + #data_mode (naming?) determines if we move to end of existing data or not. + #data_mode 0 means ignore existing line length and go to exact column + #set by -experimental flag + if {$data_mode == 0} { set col $post_render_col - if {![llength $unapplied_list]} { - if {$overflow_right ne ""} { - incr row - } + } else { + #This doesn't really work if columns are pre-filled with spaces..we can't distinguish them from data + #we need renderline to return the number of the maximum column filled (or min if we ever do r-to-l) + set existingdata [lindex $outputlines [expr {$post_render_row -1}]] + set lastdatacol [punk::ansi::printing_length $existingdata] + if {$lastdatacol < $renderwidth} { + set col [expr {$lastdatacol+1}] } else { - puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)" + set col $renderwidth } - set col $opt_startcolumn } - up { - - #renderline knows it's own line number, and knows not to go above row l - #it knows that a move whilst 1-beyond the width conflicts with the linefeed and reduces the move by one accordingly. - #row returned should be correct. - #column may be the overflow column - as it likes to report that to the caller. - - #Note that an ansi up sequence after last column going up to a previous line and also beyond the last column, will result in the next grapheme going onto the following line. - #this seems correct - as the column remains beyond the right margin so subsequent chars wrap (?) review - #puts stderr "up $post_render_row" - #puts stderr "$rinfo" - #puts stdout "1 row:$row col $col" - set row $post_render_row - #data_mode (naming?) determines if we move to end of existing data or not. - #data_mode 0 means ignore existing line length and go to exact column - #set by -experimental flag - if {$data_mode == 0} { - set col $post_render_col - } else { - #This doesn't really work if columns are pre-filled with spaces..we can't distinguish them from data - #we need renderline to return the number of the maximum column filled (or min if we ever do r-to-l) - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - } - - #puts stdout "2 row:$row col $col" - #puts stdout "-----------------------" - #puts stdout $rinfo - #flush stdout - } - down { - if {$data_mode == 0} { - #renderline doesn't know how far down we can go.. - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" + #puts stdout "2 row:$row col $col" + #puts stdout "-----------------------" + #puts stdout $rinfo + #flush stdout + } + down { + if {$data_mode == 0} { + #renderline doesn't know how far down we can go.. + if {$post_render_row > [llength $outputlines]} { + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] } + lappend outputlines "" } - set row $post_render_row - set col $post_render_col - } else { - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" + } + set row $post_render_row + set col $post_render_col + } else { + if {$post_render_row > [llength $outputlines]} { + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] } + lappend outputlines "" } - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - } - } - restore_cursor { - #testfile belinda.ans uses this - - #puts stdout "[a+ blue bold]CURSOR_RESTORE[a]" - if {[tcl::dict::exists $cursor_saved_position row]} { - set row [tcl::dict::get $cursor_saved_position row] - set col [tcl::dict::get $cursor_saved_position column] - #puts stdout "restoring: row $row col $col [ansistring VIEW $cursor_saved_attributes] [a] unapplied [ansistring VIEWCODES $unapplied]" - #set nextprefix $cursor_saved_attributes - #lset replay_codes_overlay [expr $overidx+1] $cursor_saved_attributes - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]$cursor_saved_attributes - #set replay_codes_overlay $cursor_saved_attributes - set cursor_saved_position [tcl::dict::create] - set cursor_saved_attributes "" - } else { - #TODO - #?restore without save? - #should move to home position and reset ansi SGR? - #puts stderr "overtype::renderspace cursor_restore without save data available" - } - #If we were inserting prior to hitting the cursor_restore - there could be overflow_right data - generally the overtype functions aren't for inserting - but ansi can enable it - #if we were already in overflow when cursor_restore was hit - it shouldn't have been processed as an action - just stored. - if {!$overflow_handled && $overflow_right ne ""} { - #wrap before restore? - possible effect on saved cursor position - #this overflow data has previously been rendered so has no cursor movements or further save/restore operations etc - #we can just insert another call to renderline to solve this.. ? - #It would perhaps be more properly handled as a queue of instructions from our initial renderline call - #we don't need to worry about overflow next call (?)- but we should carry forward our gx and ansi stacks - - puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" - - set sub_info [overtype::renderline\ - -info 1\ - -width [tcl::dict::get $vtstate renderwidth]\ - -insert_mode [tcl::dict::get $vtstate insert_mode]\ - -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ - -expand_right [tcl::dict::get $opts -expand_right]\ - ""\ - $overflow_right\ - ] - set foldline [tcl::dict::get $sub_info result] - tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..? - tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this.. - linsert outputlines $renderedrow $foldline - #review - row & col set by restore - but not if there was no save.. - } - set overflow_handled 1 + # ---- + # review + set col $post_render_col + #just because it's out of range of the renderwidth - doesn't mean a move down should jump to witin the range - 2025 + #---- + + #set existingdata [lindex $outputlines [expr {$post_render_row -1}]] + #set lastdatacol [punk::ansi::printing_length $existingdata] + + #set col [expr {$lastdatacol+1}] + + #if {$lastdatacol < $renderwidth} { + # set col [expr {$lastdatacol+1}] + #} else { + # set col $renderwidth + #} } - move { - ######## - if {$post_render_row > [llength $outputlines]} { - #Ansi moves need to create new lines ? - #if {$opt_appendlines} { - # set diff [expr {$post_render_row - [llength $outputlines]}] - # if {$diff > 0} { - # lappend outputlines {*}[lrepeat $diff ""] - # } - # set row $post_render_row - #} else { - set row [llength $outputlines] - #} - } else { - set row $post_render_row - } - ####### - set col $post_render_col - #overflow + unapplied? + } + restore_cursor { + #testfile belinda.ans uses this + + #puts stdout "[a+ blue bold]CURSOR_RESTORE[a]" + if {[tcl::dict::exists $cursor_saved_position row]} { + set row [tcl::dict::get $cursor_saved_position row] + set col [tcl::dict::get $cursor_saved_position column] + #puts stdout "restoring: row $row col $col [ansistring VIEW $cursor_saved_attributes] [a] unapplied [ansistring VIEWCODES $unapplied]" + #set nextprefix $cursor_saved_attributes + #lset replay_codes_overlay [expr $overidx+1] $cursor_saved_attributes + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]$cursor_saved_attributes + #set replay_codes_overlay $cursor_saved_attributes + set cursor_saved_position [tcl::dict::create] + set cursor_saved_attributes "" + } else { + #TODO + #?restore without save? + #should move to home position and reset ansi SGR? + #puts stderr "overtype::renderspace cursor_restore without save data available" } - clear_and_move { - #e.g 2J - if {$post_render_row > [llength $outputlines]} { + #If we were inserting prior to hitting the cursor_restore - there could be overflow_right data - generally the overtype functions aren't for inserting - but ansi can enable it + #if we were already in overflow when cursor_restore was hit - it shouldn't have been processed as an action - just stored. + if {!$overflow_handled && $overflow_right ne ""} { + #wrap before restore? - possible effect on saved cursor position + #this overflow data has previously been rendered so has no cursor movements or further save/restore operations etc + #we can just insert another call to renderline to solve this.. ? + #It would perhaps be more properly handled as a queue of instructions from our initial renderline call + #we don't need to worry about overflow next call (?)- but we should carry forward our gx and ansi stacks + + puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" + + set sub_info [overtype::renderline\ + -info 1\ + -width [tcl::dict::get $vtstate renderwidth]\ + -insert_mode [tcl::dict::get $vtstate insert_mode]\ + -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ + -expand_right [tcl::dict::get $opts -expand_right]\ + ""\ + $overflow_right\ + ] + set foldline [tcl::dict::get $sub_info result] + tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..? + tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this.. + + #todo!!! + # 2025 fix - this does nothing - so what uses it?? create a test! + linsert outputlines $renderedrow $foldline + #review - row & col set by restore - but not if there was no save.. + } + set overflow_handled 1 + + } + move { + ######## + if {$post_render_row > [llength $outputlines]} { + #Ansi moves need to create new lines ? + #if {$opt_appendlines} { + # set diff [expr {$post_render_row - [llength $outputlines]}] + # if {$diff > 0} { + # lappend outputlines {*}[lrepeat $diff ""] + # } + # set row $post_render_row + #} else { set row [llength $outputlines] - } else { - set row $post_render_row - } - set col $post_render_col - set overflow_right "" ;#if we're clearing - any overflow due to insert_mode is irrelevant - set clearedlines [list] - foreach ln $outputlines { - lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $renderwidth]\x1b\[0m - if 0 { - - set lineparts [punk::ansi::ta::split_codes $ln] - set numcells 0 - foreach {pt _code} $lineparts { - if {$pt ne ""} { - foreach grapheme [punk::char::grapheme_split $pt] { - switch -- $grapheme { - " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { + #} + } else { + set row $post_render_row + } + ####### + set col $post_render_col + #overflow + unapplied? + } + clear_and_move { + #e.g 2J + if {$post_render_row > [llength $outputlines]} { + set row [llength $outputlines] + } else { + set row $post_render_row + } + set col $post_render_col + set overflow_right "" ;#if we're clearing - any overflow due to insert_mode is irrelevant + set clearedlines [list] + foreach ln $outputlines { + lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $renderwidth]\x1b\[0m + if 0 { + + set lineparts [punk::ansi::ta::split_codes $ln] + set numcells 0 + foreach {pt _code} $lineparts { + if {$pt ne ""} { + foreach grapheme [punk::char::grapheme_split $pt] { + switch -- $grapheme { + " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - + z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { + incr numcells 1 + } + default { + if {$grapheme eq "\u0000"} { incr numcells 1 - } - default { - if {$grapheme eq "\u0000"} { - incr numcells 1 - } else { - incr numcells [grapheme_width_cached $grapheme] - } + } else { + incr numcells [grapheme_width_cached $grapheme] } } - } + } } - #replays/resets each line - lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $numcells]\x1b\[0m } + #replays/resets each line + lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $numcells]\x1b\[0m } - set outputlines $clearedlines - #todo - determine background/default to be in effect - DECECM ? - puts stderr "replay_codes_overlay: [ansistring VIEW $replay_codes_overlay]" - #lset outputlines 0 $replay_codes_overlay[lindex $outputlines 0] - } - lf_start { - #raw newlines - # ---------------------- - #test with fruit.ans - #test - treating as newline below... - #append rendered $overflow_right - #set overflow_right "" - set row $renderedrow - incr row - if {$row > [llength $outputlines]} { - lappend outputlines "" - } - set col $opt_startcolumn - # ---------------------- + set outputlines $clearedlines + #todo - determine background/default to be in effect - DECECM ? + puts stderr "replay_codes_overlay: [ansistring VIEW $replay_codes_overlay]" + #lset outputlines 0 $replay_codes_overlay[lindex $outputlines 0] + + } + lf_start { + #raw newlines + # ---------------------- + #test with fruit.ans + #test - treating as newline below... + #append rendered $overflow_right + #set overflow_right "" + set row $renderedrow + incr row + if {$row > [llength $outputlines]} { + lappend outputlines "" } - lf_mid { + set col $opt_startcolumn + # ---------------------- + } + lf_mid { - set edit_mode 0 - if {$edit_mode} { - set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] - set overflow_right "" - set unapplied "" - set row $post_render_row - #set col $post_render_col - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - if 1 { - if {$overflow_right ne ""} { - if {$opt_expand_right} { + set edit_mode 0 + if {$edit_mode} { + #set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] + #JMN + #ledit inputchunks -1 -1 $overflow_right$unapplied + + set pt_ansi_pt [punk::ansi::ta::split_codes_single $overflow_right] + #join the trailing and leading pt parts of the 2 lists + ledit pt_ansi_pt end end "[lindex $pt_ansi_pt end][lindex $unapplied_ansisplit 0]" + lappend pt_ansi_pt [lrange $unapplied_ansisplit 1 end] + + ledit inputchunks -1 -1 [list ansisplit $pt_ansi_pt] ;#combined overflow_right and unapplied - in ansisplit form + + set overflow_right "" + set unapplied "" + set unapplied_list [list] + set unapplied_ansisplit [list] + + set row $post_render_row + #set col $post_render_col + set col $opt_startcolumn + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + } else { + if 1 { + if {$overflow_right ne ""} { + if {$opt_expand_right} { + append rendered $overflow_right + set overflow_right "" + } else { + #review - we should really make renderline do the work...? + set overflow_width [punk::ansi::printing_length $overflow_right] + if {$visualwidth + $overflow_width <= $renderwidth} { append rendered $overflow_right set overflow_right "" } else { - #review - we should really make renderline do the work...? - set overflow_width [punk::ansi::printing_length $overflow_right] - if {$visualwidth + $overflow_width <= $renderwidth} { - append rendered $overflow_right + if {[tcl::dict::get $vtstate autowrap_mode]} { + set outputlines [linsert $outputlines $renderedrow $overflow_right] set overflow_right "" + set row [expr {$renderedrow + 2}] } else { - if {[tcl::dict::get $vtstate autowrap_mode]} { - set outputlines [linsert $outputlines $renderedrow $overflow_right] - set overflow_right "" - set row [expr {$renderedrow + 2}] - } else { - set overflow_right "" ;#abandon - } + set overflow_right "" ;#abandon + } - if {0 && $visualwidth < $renderwidth} { - puts stderr "visualwidth: $visualwidth < renderwidth:$renderwidth" - error "incomplete - abandon?" - set overflowparts [punk::ansi::ta::split_codes $overflow_right] - set remaining_overflow $overflowparts - set filled 0 - foreach {pt code} $overflowparts { - lpop remaining_overflow 0 - if {$pt ne ""} { - set graphemes [punk::char::grapheme_split $pt] - set add "" - set addlen $visualwidth - foreach g $graphemes { - set w [overtype::grapheme_width_cached $g] - if {$addlen + $w <= $renderwidth} { - append add $g - incr addlen $w - } else { - set filled 1 - break - } + if {0 && $visualwidth < $renderwidth} { + puts stderr "visualwidth: $visualwidth < renderwidth:$renderwidth" + error "incomplete - abandon?" + set overflowparts [punk::ansi::ta::split_codes $overflow_right] + set remaining_overflow $overflowparts + set filled 0 + foreach {pt code} $overflowparts { + lpop remaining_overflow 0 + if {$pt ne ""} { + set graphemes [punk::char::grapheme_split $pt] + set add "" + set addlen $visualwidth + foreach g $graphemes { + set w [overtype::grapheme_width_cached $g] + if {$addlen + $w <= $renderwidth} { + append add $g + incr addlen $w + } else { + set filled 1 + break } - append rendered $add - } - if {!$filled} { - lpop remaining_overflow 0 ;#pop code } + append rendered $add + } + if {!$filled} { + lpop remaining_overflow 0 ;#pop code } - set overflow_right [join $remaining_overflow ""] } + set overflow_right [join $remaining_overflow ""] } } } - set row $post_render_row - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - #old version - known to work with various ansi graphics - e.g fruit.ans - # - but fails to limit lines to renderwidth when expand_right == 0 - append rendered $overflow_right - set overflow_right "" - set row $post_render_row - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } + } + set row $post_render_row + set col $opt_startcolumn + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + } else { + #old version - known to work with various ansi graphics - e.g fruit.ans + # - but fails to limit lines to renderwidth when expand_right == 0 + append rendered $overflow_right + set overflow_right "" + set row $post_render_row + set col $opt_startcolumn + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] } } - } - lf_overflow { - #linefeed after renderwidth e.g at column 81 for an 80 col width - #we may also have other control sequences that came after col 80 e.g cursor save + } + } + lf_overflow { + #linefeed after renderwidth e.g at column 81 for an 80 col width + #we may also have other control sequences that came after col 80 e.g cursor save - if 0 { - set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]] - set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs] - set rhs "" + if 0 { + set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]] + set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs] + set rhs "" - #assertion - there should be no overflow.. - puts $lhs - } - if {![tcl::dict::get $vtstate insert_mode]} { - assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode - } + #assertion - there should be no overflow.. + puts $lhs + } + if {![tcl::dict::get $vtstate insert_mode]} { + assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode + } - set row $post_render_row - #set row $renderedrow - #incr row - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - set col $opt_startcolumn + set row $post_render_row + #set row $renderedrow + #incr row + #only add newline if we're at the bottom + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + set col $opt_startcolumn + } + newlines_above { + #we get a newlines_above instruction when received at column 1 + #In some cases we want to treat that as request to insert a new blank line above, and move our row 1 down (staying with the data) + #in other cases - we want to treat at column 1 the same as any other + + puts "--->newlines_above" + puts "rinfo: $rinfo" + #renderline doesn't advance the row for us - the caller has the choice to implement or not + set row $post_render_row + set col $post_render_col + if {$insert_lines_above > 0} { + set row $renderedrow + #set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]] + ledit outputlines $renderedrow-1 $renderedrow-2 {*}[lrepeat $insert_lines_above ""] + incr row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above + #? set row $post_render_row #can renderline tell us? } - newlines_above { - #we get a newlines_above instruction when received at column 1 - #In some cases we want to treat that as request to insert a new blank line above, and move our row 1 down (staying with the data) - #in other cases - we want to treat at column 1 the same as any other - - puts "--->newlines_above" - puts "rinfo: $rinfo" - #renderline doesn't advance the row for us - the caller has the choice to implement or not + } + newlines_below { + #obsolete? - use for ANSI insert lines sequence + if {$data_mode == 0} { + puts --->nl_below set row $post_render_row set col $post_render_col - if {$insert_lines_above > 0} { - set row $renderedrow - set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]] - incr row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above - #? set row $post_render_row #can renderline tell us? - } - } - newlines_below { - #obsolete? - use for ANSI insert lines sequence - if {$data_mode == 0} { - puts --->nl_below - set row $post_render_row - set col $post_render_col - if {$insert_lines_below == 1} { - #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] - #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] - #set rhs "" - #if {$overflow_right ne ""} { - # set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]] - # set rhs [textblock::frame -title overflow_right $rhs] - #} - #puts [textblock::join $lhs $rhs] - - #rendered - append rendered $overflow_right - # + if {$insert_lines_below == 1} { + #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] + #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] + #set rhs "" + #if {$overflow_right ne ""} { + # set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]] + # set rhs [textblock::frame -title overflow_right $rhs] + #} + #puts [textblock::join $lhs $rhs] + #rendered + append rendered $overflow_right + # - set overflow_right "" - set row $renderedrow - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat $insert_lines_below ""] + + set overflow_right "" + set row $renderedrow + #only add newline if we're at the bottom + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat $insert_lines_below ""] + } + incr row $insert_lines_below + set col $opt_startcolumn + } + } else { + set row $post_render_row + if {$post_render_row > [llength $outputlines]} { + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] } - incr row $insert_lines_below - set col $opt_startcolumn + lappend outputlines "" } } else { - set row $post_render_row - if {$post_render_row > [llength $outputlines]} { + set existingdata [lindex $outputlines [expr {$post_render_row -1}]] + set lastdatacol [punk::ansi::printing_length $existingdata] + if {$lastdatacol < $renderwidth} { + set col [expr {$lastdatacol+1}] + } else { + set col $renderwidth + } + } + } + } + wrapmoveforward { + #doesn't seem to be used by fruit.ans testfile + #used by dzds.ans + #note that cursor_forward may move deep into the next line - or even span multiple lines !TODO + set c $renderwidth + set r $post_render_row + if {$post_render_col > $renderwidth} { + set i $c + while {$i <= $post_render_col} { + if {$c == $renderwidth+1} { + incr r if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] + if {$r < [llength $outputlines]} { + lappend outputlines "" } - lappend outputlines "" } + set c $opt_startcolumn } else { - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } + incr c } + incr i } + set col $c + } else { + #why are we getting this instruction then? + puts stderr "wrapmoveforward - test" + set r [expr {$post_render_row +1}] + set c $post_render_col } - wrapmoveforward { - #doesn't seem to be used by fruit.ans testfile - #used by dzds.ans - #note that cursor_forward may move deep into the next line - or even span multiple lines !TODO - set c $renderwidth - set r $post_render_row - if {$post_render_col > $renderwidth} { - set i $c - while {$i <= $post_render_col} { - if {$c == $renderwidth+1} { - incr r - if {$opt_appendlines} { - if {$r < [llength $outputlines]} { - lappend outputlines "" - } - } - set c $opt_startcolumn + set row $r + set col $c + } + wrapmovebackward { + set c $renderwidth + set r $post_render_row + if {$post_render_col < 1} { + set c 1 + set i $c + while {$i >= $post_render_col} { + if {$c == 0} { + if {$r > 1} { + incr r -1 + set c $renderwidth } else { - incr c + #leave r at 1 set c 1 + #testfile besthpav.ans first line top left border alignment + set c 1 + break } - incr i + } else { + incr c -1 } - set col $c - } else { - #why are we getting this instruction then? - puts stderr "wrapmoveforward - test" - set r [expr {$post_render_row +1}] - set c $post_render_col + incr i -1 } - set row $r set col $c + } else { + puts stderr "Wrapmovebackward - but postrendercol >= 1???" } - wrapmovebackward { - set c $renderwidth - set r $post_render_row - if {$post_render_col < 1} { - set c 1 - set i $c - while {$i >= $post_render_col} { - if {$c == 0} { - if {$r > 1} { - incr r -1 - set c $renderwidth - } else { - #leave r at 1 set c 1 - #testfile besthpav.ans first line top left border alignment - set c 1 - break - } + set row $r + set col $c + } + overflow { + #normal single-width grapheme overflow + #puts stderr "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]" + + + #renderspace gives us an overflow when there is a grapheme followed by a non-grapheme + #This gives us some possible(probable) leading ANSI (which is probably SGR, or it would have triggered something else) + #followed by a sequence of 1 or more graphemes and some more unprocessed ANSI (which could be anything: SGR,movement etc) + #we want to strip out this leading run of graphemes + #NOTE: 2025 - comment is obsolete/inaccurate. We only ever get 1 grapheme - as prior were consumed/ignored by renderline + #REVIEW!!! + + #example trigger: textblock::frame -width 80 [ansicat us-pump_up_the_jam-355.ans 355x100] + + set row $post_render_row ;#renderline will not advance row when reporting overflow char + if {[tcl::dict::get $vtstate autowrap_mode]} { + incr row + set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? + } else { + set col $post_render_col + #The overflow can only be triggered by a grapheme (todo cluster?) - but our unapplied could contain SGR codes prior to the grapheme that triggered overflow - so we need to skip beyond any SGRs + #There may be more than one, because although the stack leading up to overflow may have been merged - codes between the last column and the overflowing grapheme will remain separate + #We don't expect any movement or other ANSI codes - as if they came before the grapheme, they would have triggered a different instruction to 'overflow' + + set drop_graphemes [list] ;#list of contiguous grapheme indices + set new_unapplied_list [list] + set unapplied_ansisplit [list ""] + set idx 0 + + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + #puts stderr "g$idx:$u" + if {![llength $drop_graphemes] || $idx == [lindex $drop_graphemes end]+1} { + #we are in the first run of uninterrupted graphemes + #drop by doing nothing with it here + lappend drop_graphemes $idx } else { - incr c -1 + lappend new_unapplied_list $u + ledit unapplied_ansisplit end end "[lindex $unapplied_ansisplit end]$u" } - incr i -1 + } else { + lappend new_unapplied_list $u + lappend unapplied_ansisplit $u "" } - set col $c - } else { - puts stderr "Wrapmovebackward - but postrendercol >= 1???" + incr idx } - set row $r - set col $c + #debug + if {[llength $drop_graphemes]} { + set idx0 [lindex $drop_graphemes 0] + set dbg "" + if {$idx0 > 0} { + for {set i 0} {$i < $idx0} {incr i} { + #leading SGR + append dbg [lindex $unapplied_list $i] + } + } + foreach idx $drop_graphemes { + append dbg [lindex $unapplied_list $idx] + } + puts stderr "dropped[llength $drop_graphemes]:$dbg\x1b\[m" + } + set unapplied [join $new_unapplied_list ""] + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } + set unapplied_list $new_unapplied_list + + #we need to run the reduced unapplied on the same line - further graphemes will just overflow again, but codes or control chars could trigger jumps to other lines + + set overflow_handled 1 + #handled by dropping overflow if any } - overflow { - #normal single-width grapheme overflow - #puts "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]" - set row $post_render_row ;#renderline will not advance row when reporting overflow char - if {[tcl::dict::get $vtstate autowrap_mode]} { - incr row - set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? - } else { - set col $post_render_col - #set unapplied "" ;#this seems wrong? - #set unapplied [tcl::string::range $unapplied 1 end] - #The overflow can only be triggered by a grapheme (todo cluster?) - but our unapplied could contain SGR codes prior to the grapheme that triggered overflow - so we need to skip beyond any SGRs - #There may be more than one, because although the stack leading up to overflow may have been merged - codes between the last column and the overflowing grapheme will remain separate - #We don't expect any movement or other ANSI codes - as if they came before the grapheme, they would have triggered a different instruction to 'overflow' + } + overflow_splitchar { + set row $post_render_row ;#renderline will not advance row when reporting overflow char + + #2nd half of grapheme would overflow - treggering grapheme is returned in unapplied. There may also be overflow_right from earlier inserts + #todo - consider various options .. re-render a single trailing space or placeholder on same output line, etc + if {[tcl::dict::get $vtstate autowrap_mode]} { + if {$renderwidth < 2} { + #edge case of rendering to a single column output - any 2w char will just cause a loop if we don't substitute with something, or drop the character set idx 0 - set next_grapheme_index -1 + set triggering_grapheme_index -1 foreach u $unapplied_list { if {![punk::ansi::ta::detect $u]} { - set next_grapheme_index $idx + set triggering_grapheme_index $idx break } incr idx } - assert {$next_grapheme_index >= 0} - #drop the overflow grapheme - keeping all codes in place. - set unapplied [join [lreplace $unapplied_list $next_grapheme_index $next_grapheme_index] ""] - #we need to run the reduced unapplied on the same line - further graphemes will just overflow again, but codes or control chars could trigger jumps to other lines - - set overflow_handled 1 - #handled by dropping overflow if any - } - } - overflow_splitchar { - set row $post_render_row ;#renderline will not advance row when reporting overflow char - - #2nd half of grapheme would overflow - treggering grapheme is returned in unapplied. There may also be overflow_right from earlier inserts - #todo - consider various options .. re-render a single trailing space or placeholder on same output line, etc - if {[tcl::dict::get $vtstate autowrap_mode]} { - if {$renderwidth < 2} { - #edge case of rendering to a single column output - any 2w char will just cause a loop if we don't substitute with something, or drop the character - set idx 0 - set triggering_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set triggering_grapheme_index $idx - break - } - incr idx - } - set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] - } else { - set col $opt_startcolumn - incr row - } + #set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] + ledit unapplied_list $triggering_grapheme_index $triggering_grapheme_index + set unapplied [join $unapplied_list ""] + #review - inefficient to re-split (return unapplied_tagged instead of unapplied_ansisplit?) + set unapplied_ansisplit [punk::ansi::ta::split_codes_single $unapplied] } else { - set overflow_handled 1 - #handled by dropping entire overflow if any - if {$renderwidth < 2} { - set idx 0 - set triggering_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set triggering_grapheme_index $idx - break - } - incr idx + set col $opt_startcolumn + incr row + } + } else { + set overflow_handled 1 + #handled by dropping entire overflow if any + if {$renderwidth < 2} { + set idx 0 + set triggering_grapheme_index -1 + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + set triggering_grapheme_index $idx + break } - set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] + incr idx } + #set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] + ledit unapplied_list $triggering_grapheme_index $triggering_grapheme_index + set unapplied [join $unapplied_list ""] + #review - inefficient + puts -nonewline stderr . + set unapplied_ansisplit [punk::ansi::ta::split_codes_single $unapplied] } - } - vt { - #can vt add a line like a linefeed can? - set row $post_render_row - set col $post_render_col - } - set_window_title { - set newtitle [lindex $instruction 1] - puts stderr "overtype::renderspace set_window_title [ansistring VIEW $newtitle] instruction '$instruction'" - # - } - reset_colour_palette { - puts stderr "overtype::renderspace instruction '$instruction' unimplemented" - } - default { - puts stderr "overtype::renderspace unhandled renderline instruction '$instruction'" - } + } + vt { + #can vt add a line like a linefeed can? + set row $post_render_row + set col $post_render_col + } + set_window_title { + set newtitle [lindex $instruction 1] + puts stderr "overtype::renderspace set_window_title [ansistring VIEW $newtitle] instruction '$instruction'" + # + } + reset_colour_palette { + puts stderr "overtype::renderspace instruction '$instruction' unimplemented" + } + default { + puts stderr "overtype::renderspace unhandled renderline instruction '$instruction'" } + } + if {!$opt_expand_right && ![tcl::dict::get $vtstate autowrap_mode]} { #not allowed to overflow column or wrap therefore we get overflow data to truncate @@ -1293,10 +1404,25 @@ tcl::namespace::eval overtype { } if {!$overflow_handled} { - append nextprefix $overflow_right + #append nextprefix $overflow_right + set overflow_right_pt_code_pt [punk::ansi::ta::split_codes_single $overflow_right] + if {![llength $nextprefix_list]} { + set nextprefix_list $overflow_right_pt_code_pt + } else { + #merge tail and head + ledit nextprefix_list end end "[lindex $nextprefix_list end][lindex $overflow_right_pt_code_pt 0]" + lappend nextprefix_list {*}[lrange $overflow_right_pt_code_pt 1 end] + } } - append nextprefix $unapplied + #append nextprefix $unapplied + if {![llength $nextprefix_list]} { + set nextprefix_list $unapplied_ansisplit + } else { + #merge tail and head + ledit nextprefix_list end end "[lindex $nextprefix_list end][lindex $unapplied_ansisplit 0]" + lappend nextprefix_list {*}[lrange $unapplied_ansisplit 1 end] + } if 0 { if {$nextprefix ne ""} { @@ -1310,8 +1436,10 @@ tcl::namespace::eval overtype { } } - if {$nextprefix ne ""} { - set inputchunks [linsert $inputchunks 0 $nextprefix] + if {[llength $nextprefix_list]} { + #set inputchunks [linsert $inputchunks 0 $nextprefix] + #JMN - assume backwards compat ledit available from punk::lib (for tcl <9) + ledit inputchunks -1 -1 [list ansisplit $nextprefix_list] } @@ -1854,7 +1982,8 @@ tcl::namespace::eval overtype { return [join $outputlines \n] } - variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches + #variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches + variable optimise_ptruns 5 @@ -1931,7 +2060,7 @@ tcl::namespace::eval overtype { -cursor_restore_attributes -default "" -cp437 -default 0 -type boolean -experimental -default {} - + -overtext_type -type string -choices {mixed plain ansisplit} -default mixed @values -min 2 -max 2 undertext -type string -help\ "A single line of text which may contain pre-rendered ANSI. @@ -2026,7 +2155,10 @@ tcl::namespace::eval overtype { -cursor_restore_attributes ""\ -cp437 0\ -experimental {}\ + -overtext_type mixed\ ] + #-overtext_type plain|mixed|ansisplit + #-cursor_restore_attributes only - for replay stack - position and actual setting/restoring handled by throwback to caller #cursor_row, when numeric will allow detection of certain row moves that are still within our row - allowing us to avoid an early return @@ -2040,7 +2172,7 @@ tcl::namespace::eval overtype { switch -- $k { -experimental - -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row - -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode - - -info - -exposed1 - -exposed2 - -cursor_restore_attributes { + - -info - -exposed1 - -exposed2 - -cursor_restore_attributes - -overtext_type { tcl::dict::set opts $k $v } default { @@ -2055,6 +2187,7 @@ tcl::namespace::eval overtype { set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay set opt_colcursor [tcl::dict::get $opts -cursor_column];#start cursor column relative to overlay set opt_row_context [tcl::dict::get $opts -cursor_row] + set opt_overtext_type [tcl::dict::get $opts -overtext_type] if {[string length $opt_row_context]} { if {![tcl::string::is integer -strict $opt_row_context] || $opt_row_context <1 } { error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'" @@ -2128,9 +2261,16 @@ tcl::namespace::eval overtype { #set under [textutil::tabify::untabify2 $under] set under [textutil::tabify::untabifyLine $under $tw] } - if {[string first \t $over] >= 0} { - #set overdata [textutil::tabify::untabify2 $over] - set overdata [textutil::tabify::untabifyLine $over $tw] + + #review - is untabifying sensible at this point?? + if {$opt_overtext_type eq "ansisplit"} { + #todo - something for each pt part? + } else { + #plain|mixed + if {[string first \t $over] >= 0} { + #set overdata [textutil::tabify::untabify2 $over] + set overdata [textutil::tabify::untabifyLine $over $tw] + } } } } @@ -2178,25 +2318,9 @@ tcl::namespace::eval overtype { set is_ptrun [regexp $re $pt] } if {$is_ptrun} { - #switch -- $p1 { - # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - # a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - # z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - # set width 1 - # } - # default { - # if {$p1 eq "\u0000"} { - # #use null as empty cell representation - review - # #use of this will probably collide with some application at some point - # #consider an option to set the empty cell character - # set width 1 - # } else { - # set width [grapheme_width_cached $p1] ;# when zero??? - # } - # } - #} set width [grapheme_width_cached $p1] ;# when zero??? set ptlen [string length $pt] + #puts -nonewline stderr !$ptlen! if {$width <= 1} { #review - 0 and 1? incr i_u $ptlen @@ -2415,11 +2539,21 @@ tcl::namespace::eval overtype { set startpadding [string repeat " " [expr {$opt_colstart -1}]] #overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency if {$startpadding ne "" || $overdata ne ""} { - if {[punk::ansi::ta::detect $overdata]} { - set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] + if {$opt_overtext_type eq "ansisplit"} { + set overmap $overdata + lset overmap 0 "$startpadding[lindex $overmap 0]" } else { - #single plaintext part - set overmap [list $startpadding$overdata] + if {[punk::ansi::ta::detect $overdata]} { + #TODO!! rework this. + #e.g 200K+ input file with no newlines - we are wastefully calling split_codes_single repeatedly on mostly the same data. + #set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] + set overmap [punk::ansi::ta::split_codes_single $overdata] + lset overmap 0 "$startpadding[lindex $overmap 0]" + + } else { + #single plaintext part + set overmap [list $startpadding$overdata] + } } } else { set overmap [list] @@ -2452,9 +2586,13 @@ tcl::namespace::eval overtype { set o_gxstack [list] set pt_overchars "" set i_o 0 + set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use - #experiment set overlay_grapheme_control_stacks [list] + #REVIEW - even if we pass in a pre-split overtext (-overtext_type ansisplit) + #we are re-generating the overlay_grapheme_control_stacks list each time + #this is a big issue when overtext is not broken into lines, but is just a big long ansi and/or plain text string. + #todo - return also the unapplied portion of the overlay_grapheme_control_stacks list?? foreach {pt code} $overmap { if {$pt ne ""} { #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) @@ -2482,6 +2620,7 @@ tcl::namespace::eval overtype { #could be edge cases for runs at line end? (should be ok as we include trailing \n in our data) set len [string length $pt] set g_element [list g $p1] + #puts -nonewline stderr "!$len!" #lappend overstacks {*}[lrepeat $len $o_codestack] #lappend overstacks_gx {*}[lrepeat $len $o_gxstack] @@ -2665,6 +2804,7 @@ tcl::namespace::eval overtype { set unapplied "" ;#if we break for move row (but not for /v ?) set unapplied_list [list] + set unapplied_ansisplit [list ""] ;#pt code ... pt set insert_lines_above 0 ;#return key set insert_lines_below 0 @@ -2723,10 +2863,14 @@ tcl::namespace::eval overtype { set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $ch] set chars [string map [list \n "\x1b\[00001E"] $chars] if {[llength [split $chars ""]] > 1} { - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci #prefix the unapplied controls with the string version of this control - set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + #set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + #JMN - backwards compat ledit from punk::lib for tcl <9 + ledit unapplied_list -1 -1 {*}[split $chars ""] set unapplied [join $unapplied_list ""] + lset unapplied_ansisplit 0 $chars ;#no existing ? + #incr idx_over break } else { @@ -2758,7 +2902,7 @@ tcl::namespace::eval overtype { #linefeed at column 1 #leave the overflow_idx ;#? review set instruction lf_start ;#specific instruction for newline at column 1 - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci break } elseif {$overflow_idx != -1 && $idx == $overflow_idx} { #linefeed after final column @@ -2766,7 +2910,7 @@ tcl::namespace::eval overtype { incr cursor_row set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 set instruction lf_overflow ;#only special treatment is to give it it's own instruction in case caller needs to handle differently - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci break } else { #linefeed occurred in middle or at end of text @@ -2778,12 +2922,12 @@ tcl::namespace::eval overtype { set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 } set instruction lf_mid - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci break } else { incr cursor_row #don't adjust the overflow_idx - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction lf_mid break ;# could have overdata following the \n - don't keep processing } @@ -2811,7 +2955,7 @@ tcl::namespace::eval overtype { set flag 0 if $flag { #review - conflicting requirements? Need a different sequence for destructive interactive backspace? - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction backspace_at_start break } @@ -2831,7 +2975,7 @@ tcl::namespace::eval overtype { incr cursor_row set overflow_idx $idx #idx_over has already been incremented as this is both a movement-control and in some sense a grapheme - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction vt break } @@ -2853,7 +2997,7 @@ tcl::namespace::eval overtype { set overflow_idx $idx incr idx incr idx_over -1 ;#set overlay grapheme index back one so that sgr stack from previous overlay grapheme used - priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#note $gci-1 instead of just gci + priv::render_to_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#note $gci-1 instead of just gci #throw back to caller's loop - add instruction to caller as this is not the usual case #caller may for example choose to render a single replacement char to this line and omit the grapheme, or wrap it to the next line set instruction overflow_splitchar @@ -2868,13 +3012,18 @@ tcl::namespace::eval overtype { #REVIEW set next_gc [lindex $overlay_grapheme_control_list $gci+1] ;#next grapheme or control lassign $next_gc next_type next_item - if {$autowrap_mode || $next_type ne "g"} { + if {$autowrap_mode} { set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci-1]] #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] #don't incr idx beyond the overflow_idx #idx_over already incremented - decrement so current overlay grapheme stacks go to unapplied incr idx_over -1 - #priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#back one index here too + #priv::render_to_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#back one index here too + priv::render_this_unapplied $overlay_grapheme_control_list $gci ;# + set instruction overflow + break + } elseif {0 && $next_type ne "g"} { + incr idx_over -1 priv::render_this_unapplied $overlay_grapheme_control_list $gci ;# set instruction overflow break @@ -3083,10 +3232,14 @@ tcl::namespace::eval overtype { #set within_undercols [expr {$idx <= $renderwidth-1}] #set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $item] set chars [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $item] - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci #prefix the unapplied controls with the string version of this control - set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + #set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + #JMN + ledit unapplied_list -1 -1 {*}[split $chars ""] set unapplied [join $unapplied_list ""] + #ledit unapplied_ansisplit -1 -1 $chars + lset unapplied_ansisplit 0 $chars ;#?? break } @@ -3151,7 +3304,17 @@ tcl::namespace::eval overtype { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] } default { - puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #JMN + puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. leadernorm: [ansistring VIEW -lf 1 $leadernorm] code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + puts stderr "ARGS:" + foreach a $args { + puts stderr " $a" + } + puts stderr ----- + foreach {xpt ycode} $overmap { + puts stderr "t:'$xpt'" + puts stderr "c:[ansistring VIEW $ycode]" + } #we haven't made a mapping for this #could in theory be 1,2 or 3 in len #although we shouldn't be getting here if the regexp for ansi codes is kept in sync with our switch branches @@ -3222,7 +3385,7 @@ tcl::namespace::eval overtype { #ensure rest of *overlay* is emitted to remainder incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction up #retain cursor_column break @@ -3241,7 +3404,7 @@ tcl::namespace::eval overtype { incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction down #retain cursor_column break @@ -3295,7 +3458,7 @@ tcl::namespace::eval overtype { incr cursor_column $num ;#give our caller the necessary info as columns from start of row #incr idx_over #should be gci following last one applied - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction wrapmoveforward break } else { @@ -3379,7 +3542,7 @@ tcl::namespace::eval overtype { } else { set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] incr cursor_column -$num - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction wrapmovebackward break } @@ -3407,7 +3570,7 @@ tcl::namespace::eval overtype { set idx [expr {$cursor_column -1}] set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction move break @@ -3428,7 +3591,7 @@ tcl::namespace::eval overtype { set idx [expr {$cursor_column - 1}] set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction move break @@ -3508,7 +3671,7 @@ tcl::namespace::eval overtype { set idx [expr {$cursor_column -1}] set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction move break } @@ -3542,7 +3705,7 @@ tcl::namespace::eval overtype { if {[llength $outcols]} { priv::render_erasechar 0 [llength $outcols] } - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction clear_and_move break } @@ -3672,7 +3835,7 @@ tcl::namespace::eval overtype { set cursor_row 1 incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction move ;#own instruction? decstbm? break } @@ -3807,25 +3970,39 @@ tcl::namespace::eval overtype { set replay_codes_overlay "" #} - #like priv::render_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code + #like priv::render_to_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code incr idx_over - set unapplied "" - set unapplied_list [list] + set unapplied "" + set unapplied_list [list] + set unapplied_ansisplit [list ""] ;#remove below if nothing added foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { lassign $gc type item - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" + switch -- $type { + g { + lappend unapplied_list $item + ledit unapplied_ansisplit end end [string cat [lindex $unapplied_ansisplit end] $item] + } + gx0 { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" + } + } + default { + lappend unapplied_list $item + lappend unapplied_ansisplit $item "" } - } else { - lappend unapplied_list $item } #incr idx_over } set unapplied [join $unapplied_list ""] + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } #if the save occured within this line - that's ok - it's in the return value list and caller can prepend for the next loop. set instruction restore_cursor break @@ -4100,7 +4277,7 @@ tcl::namespace::eval overtype { c { #RIS - reset terminal to initial state - where 'terminal' in this case is the renderspace - not the underlying terminal! puts stderr "renderline reset" - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction reset break } @@ -4110,7 +4287,7 @@ tcl::namespace::eval overtype { #vt102-docs: "Moves cursor down one line in same column. If cursor is at bottom margin, screen performs a scroll-up" puts stderr "renderline ESC D not fully implemented" incr cursor_row - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction down #retain cursor_column break @@ -4144,7 +4321,7 @@ tcl::namespace::eval overtype { set cursor_row 1 } #ensure rest of *overlay* is emitted to remainder - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction up ;#need instruction for scroll-down? #retain cursor_column break @@ -4247,7 +4424,7 @@ tcl::namespace::eval overtype { switch -exact -- $osc_code { 2 { set newtitle [tcl::string::range $code_content 2 end] - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction [list set_window_title $newtitle] break } @@ -4307,7 +4484,7 @@ tcl::namespace::eval overtype { #reset colour palette #we want to do it for the current rendering context only (vvt) - not just pass through to underlying vt puts stderr "overtype::renderline OSC 104 reset colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction [list reset_colour_palette] break } @@ -4534,6 +4711,10 @@ tcl::namespace::eval overtype { } else { set overflow_right_column [expr {$overflow_idx+1}] } + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } + set result [tcl::dict::create\ result $outstring\ visualwidth [punk::ansi::printing_length $outstring]\ @@ -4542,13 +4723,14 @@ tcl::namespace::eval overtype { overflow_right_column $overflow_right_column\ overflow_right $overflow_right\ unapplied $unapplied\ - unapplied_list $unapplied_list\ - insert_mode $insert_mode\ - autowrap_mode $autowrap_mode\ - crm_mode $crm_mode\ - reverse_mode $reverse_mode\ - insert_lines_above $insert_lines_above\ - insert_lines_below $insert_lines_below\ + unapplied_list $unapplied_list\ + unapplied_ansisplit $unapplied_ansisplit\ + insert_mode $insert_mode\ + autowrap_mode $autowrap_mode\ + crm_mode $crm_mode\ + reverse_mode $reverse_mode\ + insert_lines_above $insert_lines_above\ + insert_lines_below $insert_lines_below\ cursor_saved_position $cursor_saved_position\ cursor_saved_attributes $cursor_saved_attributes\ cursor_column $cursor_column\ @@ -4574,14 +4756,15 @@ tcl::namespace::eval overtype { set viewop VIEWSTYLE ;#ansi colorise the characters within the output with preceding codes, stacking codes only within each dict value - may not be same SGR effect as the effect in-situ. } } - tcl::dict::set result result [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result result]] - tcl::dict::set result overflow_right [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result overflow_right]] - tcl::dict::set result unapplied [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied]] - tcl::dict::set result unapplied_list [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_list]] - tcl::dict::set result replay_codes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes]] - tcl::dict::set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_underlay]] - tcl::dict::set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_overlay]] - tcl::dict::set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result cursor_saved_attributes]] + tcl::dict::set result result [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result result]] + tcl::dict::set result overflow_right [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result overflow_right]] + tcl::dict::set result unapplied [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied]] + tcl::dict::set result unapplied_list [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_list]] + tcl::dict::set result unapplied_ansisplit [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_ansisplit]] + tcl::dict::set result replay_codes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes]] + tcl::dict::set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_underlay]] + tcl::dict::set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_overlay]] + tcl::dict::set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result cursor_saved_attributes]] return $result } } else { @@ -4713,54 +4896,83 @@ tcl::namespace::eval overtype::priv { tcl::dict::set cache_is_sgr $code $answer return $answer } - # better named render_to_unapplied? - proc render_unapplied {overlay_grapheme_control_list gci} { + proc render_to_unapplied {overlay_grapheme_control_list gci} { upvar idx_over idx_over - upvar unapplied unapplied - upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split + + #----------------------------------------- + #review - this is a lot of copies of the same thing. + # ultimately we want to reduce expensive things like redundant grapheme-splits + # perhaps unapplied_tagged of some sort e.g - {g g code pt } ?? + upvar unapplied unapplied + upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split + upvar unapplied_ansisplit unapplied_ansisplit ;# pt ?code pt...? + #----------------------------------------- + + upvar overstacks overstacks upvar overstacks_gx overstacks_gx upvar overlay_grapheme_control_stacks og_stacks #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] - set unapplied "" - set unapplied_list [list] + set unapplied "" + set unapplied_list [list] + set unapplied_ansisplit [list ""] #append unapplied [join [lindex $overstacks $idx_over] ""] #append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $overstacks $idx_over]] set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] if {$sgr_merged ne ""} { lappend unapplied_list $sgr_merged + lappend unapplied_ansisplit $sgr_merged "" } switch -- [lindex $overstacks_gx $idx_over] { "gx0_on" { - lappend unapplied_list "\x1b(0" + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" } "gx0_off" { - lappend unapplied_list "\x1b(B" + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" } } foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { lassign $gc type item #types g other sgr gx0 - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" + switch -- $type { + g { + lappend unapplied_list $item + lset unapplied_ansisplit end [string cat [lindex $unapplied_ansisplit end] $item] + } + gx0 { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" + } + } + default { + lappend unapplied_list $item + lappend unapplied_ansisplit $item "" } - } else { - lappend unapplied_list $item } } + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } set unapplied [join $unapplied_list ""] } #clearer - renders the specific gci forward as unapplied - prefixed with it's merged sgr stack proc render_this_unapplied {overlay_grapheme_control_list gci} { upvar idx_over idx_over + #-------------- upvar unapplied unapplied upvar unapplied_list unapplied_list + upvar unapplied_ansisplit unapplied_ansisplit + #-------------- + upvar overstacks overstacks upvar overstacks_gx overstacks_gx upvar overlay_grapheme_control_stacks og_stacks @@ -4768,33 +4980,50 @@ tcl::namespace::eval overtype::priv { #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] set unapplied "" set unapplied_list [list] + set unapplied_ansisplit [list ""] ;#remove empty entry at end if nothing added set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] if {$sgr_merged ne ""} { - lappend unapplied_list $sgr_merged + lappend unapplied_list $sgr_merged + lappend unapplied_ansisplit $sgr_merged "" } switch -- [lindex $overstacks_gx $idx_over] { "gx0_on" { - lappend unapplied_list "\x1b(0" + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" } "gx0_off" { - lappend unapplied_list "\x1b(B" + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" } } foreach gc [lrange $overlay_grapheme_control_list $gci end] { lassign $gc type item #types g other sgr gx0 - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" + switch -- $type { + g { + lappend unapplied_list $item + lset unapplied_ansisplit end [string cat [lindex $unapplied_ansisplit end] $item] + } + gx0 { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" + } + } + default { + lappend unapplied_list $item + lappend unapplied_ansisplit $item "" } - } else { - lappend unapplied_list $item } } + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } set unapplied [join $unapplied_list ""] } proc render_delchar {i} { @@ -4923,13 +5152,18 @@ tcl::namespace::eval overtype::priv { } else { #insert of single-width vs double-width when underlying is double-width? if {$i < $nxt} { - set o [linsert $o $i $c] + #set o [linsert $o $i $c] + #JMN insert via ledit + ledit o $i $i-1 $c } else { lappend o $c } if {$i < [llength $ustacks]} { - set ustacks [linsert $ustacks $i $sgrstack] - set gxstacks [linsert $gxstacks $i $gx0stack] + #set ustacks [linsert $ustacks $i $sgrstack] + #set gxstacks [linsert $gxstacks $i $gx0stack] + #insert via ledit + ledit ustacks $i $i-1 $sgrstack + ledit gxstacks $i $i-1 $gx0stack } else { lappend ustacks $sgrstack lappend gxstacks $gx0stack diff --git a/src/modules/overtype-buildversion.txt b/src/modules/overtype-buildversion.txt index 4c0b0ec6..39db589b 100644 --- a/src/modules/overtype-buildversion.txt +++ b/src/modules/overtype-buildversion.txt @@ -1,3 +1,3 @@ -1.7.3 +1.7.4 #First line must be a semantic version number #all other lines are ignored. diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index 31719b23..dc508a3c 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -4072,7 +4072,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu # \033 - octal. equivalently \x1b in hex which is more common in documentation # empty list [a] should do reset - same for [a nonexistant] # explicit reset at beginning of parameter list for a= (as opposed to a+) - set t [linsert $t[unset t] 0 0] + #set t [linsert $t[unset t] 0 0] + ledit t -1 -1 0 if {![llength $e]} { set result "\x1b\[[join $t {;}]m" } else { diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index dca9ae3b..796ad397 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/src/modules/punk/lib-999999.0a1.0.tm @@ -751,6 +751,27 @@ namespace eval punk::lib { # -- --- + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lswap + @cmd -name punk::lib::lswap\ + -summary\ + "Swap list values in-place"\ + -help\ + "Similar to struct::list swap, except it fully supports basic + list index expressions such as 7-2 end-1 etc. + + struct::list swap doesn't support 'end' offsets, and only + sometimes appears to support basic expressions, depending on the + expression compared to the list length." + @values -min 1 -max 1 + lvar -type string -help\ + "name of list variable" + a -type indexexpression + z -type indexexpression + }] + } proc lswap {lvar a z} { upvar $lvar l set len [llength $l] @@ -955,181 +976,233 @@ namespace eval punk::lib { } } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lzip + @cmd -name punk::lib::lzip\ + -summary\ + "zip any number of lists together."\ + -help\ + "Conceptually equivalent to converting a list of rows + to a list of columns. + + The number of returned lists (columns) will be equal to + the length of the longest supplied list (row). + If lengths of supplied lists don't match, empty strings + will be inserted in the resulting lists. + + e.g lzip {a b c d e} {1 2 3 4} {x y z} + -> {a 1 x} {b 2 y} {c 3 z} {d 4 {}} {3 {} {}} + " + @values -min 1 -max 1 + lvar -type string -help\ + "name of list variable" + a -type indexexpression + z -type indexexpression + }] + } proc lzip {args} { switch -- [llength $args] { - 0 {return {}} - 1 {return [lindex $args 0]} - 2 {return [lzip2lists {*}$args]} - 3 {return [lzip3lists {*}$args]} - 4 {return [lzip4lists {*}$args]} - 5 {return [lzip5lists {*}$args]} - 6 {return [lzip6lists {*}$args]} - 7 {return [lzip7lists {*}$args]} - 8 {return [lzip8lists {*}$args]} - 9 {return [lzip9lists {*}$args]} - 10 {return [lzip10lists {*}$args]} + 0 {return {}} + 1 {return [lindex $args 0]} + 2 {return [::punk::lib::system::lzip2lists {*}$args]} + 3 {return [::punk::lib::system::lzip3lists {*}$args]} + 4 {return [::punk::lib::system::lzip4lists {*}$args]} + 5 {return [::punk::lib::system::lzip5lists {*}$args]} + 6 {return [::punk::lib::system::lzip6lists {*}$args]} + 7 {return [::punk::lib::system::lzip7lists {*}$args]} + 8 {return [::punk::lib::system::lzip8lists {*}$args]} + 9 {return [::punk::lib::system::lzip9lists {*}$args]} + 10 {return [::punk::lib::system::lzip10lists {*}$args]} 11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 { set n [llength $args] - if {[info commands ::punk::lib::lzip${n}lists] eq ""} { - puts "calling ::punk::lib::Build_lzipn $n" - ::punk::lib::Build_lzipn $n + if {[info commands ::punk::lib::system::lzip${n}lists] eq ""} { + #puts "calling ::punk::lib::system::Build_lzipn $n" + ::punk::lib::system::Build_lzipn $n } - return [lzip${n}lists {*}$args] + return [::punk::lib::system::lzip${n}lists {*}$args] } default { if {[llength $args] < 4000} { set n [llength $args] - if {[info commands ::punk::lib::lzip${n}lists] eq ""} { - puts "calling ::punk::lib::Build_lzipn $n" - ::punk::lib::Build_lzipn $n + if {[info commands ::punk::lib::system::lzip${n}lists] eq ""} { + #puts "calling ::punk::lib::system::Build_lzipn $n" + ::punk::lib::system::Build_lzipn $n } - return [lzip${n}lists {*}$args] + return [::punk::lib::system::lzip${n}lists {*}$args] } else { - return [lzipn {*}$args] + return [::punk::lib::lzipn {*}$args] } } } } - proc Build_lzipn {n} { - set arglist [list] - #use punk::lib::range which defers to lseq if available - set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) - set body "\nlmap " - for {set i 1} {$i <= $n} {incr i} { - lappend arglist l$i - append body "[lindex $vars $i] \$l$i " - } - append body "\{list " - for {set i 1} {$i <= $n} {incr i} { - append body "\$[lindex $vars $i] " + namespace eval system { + proc Build_lzipn {n} { + set arglist [list] + #use punk::lib::range which defers to lseq if available + set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) + set body "\nlmap " + for {set i 1} {$i <= $n} {incr i} { + lappend arglist l$i + append body "[lindex $vars $i] \$l$i " + } + append body "\{list " + for {set i 1} {$i <= $n} {incr i} { + append body "\$[lindex $vars $i] " + } + append body "\}" \n + #puts "proc punk::lib::system::lzip${n}lists {$arglist} \{" + #puts "$body" + #puts "\}" + proc ::punk::lib::system::lzip${n}lists $arglist $body } - append body "\}" \n - puts "proc punk::lib::lzip${n}lists {$arglist} \{" - puts "$body" - puts "\}" - proc ::punk::lib::lzip${n}lists $arglist $body - } - #fastest is to know the number of lists to be zipped - proc lzip2lists {l1 l2} { - lmap a $l1 b $l2 {list $a $b} - } - proc lzip3lists {l1 l2 l3} { - lmap a $l1 b $l2 c $l3 {list $a $b $c} - } - proc lzip4lists {l1 l2 l3 l4} { - lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} - } - proc lzip5lists {l1 l2 l3 l4 l5} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} - } - proc lzip6lists {l1 l2 l3 l4 l5 l6} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} - } - proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} - } - proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} - } - proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} - } - proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} - } + #fastest is to know the number of lists to be zipped + proc lzip2lists {l1 l2} { + lmap a $l1 b $l2 {list $a $b} + } + proc lzip3lists {l1 l2 l3} { + lmap a $l1 b $l2 c $l3 {list $a $b $c} + } + proc lzip4lists {l1 l2 l3 l4} { + lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} + } + proc lzip5lists {l1 l2 l3 l4 l5} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} + } + proc lzip6lists {l1 l2 l3 l4 l5 l6} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} + } + proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} + } + proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} + } + proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} + } + proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} + } - #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly - # review - - proc lzipn_alt args { - #stackoverflow - courtesy glenn jackman (modified) - foreach l $args { - lappend vars [incr n] - lappend lmap_args $n $l + #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly + # review - + proc lzipn_alt args { + #stackoverflow - courtesy glenn jackman (modified) + foreach l $args { + lappend vars [incr n] + lappend lmap_args $n $l + } + lmap {*}$lmap_args {lmap v $vars {set $v}} } - lmap {*}$lmap_args {lmap v $vars {set $v}} - } - #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) - proc lzipn_tcl8 {args} { - #wiki - courtesy JAL - set list_l $args - set zip_l [] - while {1} { - set cur [lmap a_l $list_l { lindex $a_l 0 }] - set list_l [lmap a_l $list_l { lrange $a_l 1 end }] + #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) + proc lzipn_tcl8 {args} { + #For tcl pre 9 (without lsearch -stride) + #wiki - courtesy JAL + set list_l $args + set zip_l [] + while {1} { + set cur [lmap a_l $list_l { lindex $a_l 0 }] + set list_l [lmap a_l $list_l { lrange $a_l 1 end }] - if {[join $cur {}] eq {}} { - break + if {[join $cur {}] eq {}} { + break + } + lappend zip_l $cur + } + return $zip_l + } + proc lzipn_tcl9a {args} { + #For Tcl 9+ (with lsearch -stride) + #compared to wiki version + #comparable for lists len <3 or number of args < 3 + #approx 2x faster for large lists or more lists + #needs -stride single index bug fix to use empty string instead of NULL + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] + set outlist [lrepeat $numcolumns {}] + set s 0 + foreach len $lens list $args { + #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] + ledit flatlist $s [expr {$s + $len - 1}] {*}$list + incr s $numcolumns + } + #needs single index lstride bugfix + for {set c 0} {$c < $numcolumns} {incr c} { + ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] + } + return $outlist + } + proc lzipn_tcl9b {args} { + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} + } + proc lzipn_tcl9c {args} { + #SLOW + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + set zip_l {} + set cols_remaining $numcolumns + for {set c 0} {$c < $numcolumns} {incr c} { + if {$cols_remaining == 1} { + return [list {*}$zip_l $flatlist] + } + lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] + set flen [llength $flatlist] + set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] + incr cols_remaining -1 } - lappend zip_l $cur + return $zip_l } - return $zip_l } - proc lzipn_tcl9a {args} { - #compared to wiki version - #comparable for lists len <3 or number of args < 3 - #approx 2x faster for large lists or more lists - #needs -stride single index bug fix to use empty string instead of NULL - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] - set outlist [lrepeat $numcolumns {}] - set s 0 - foreach len $lens list $args { - #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] - ledit flatlist $s [expr {$s + $len - 1}] {*}$list - incr s $numcolumns - } - #needs single index lstride bugfix - for {set c 0} {$c < $numcolumns} {incr c} { - ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] - } - return $outlist - } - proc lzipn_tcl9b {args} { - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [list] - foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] - } - lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} - } - proc lzipn_tcl9c {args} { - #SLOW - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [list] - foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] - } - set zip_l {} - set cols_remaining $numcolumns - for {set c 0} {$c < $numcolumns} {incr c} { - if {$cols_remaining == 1} { - return [list {*}$zip_l $flatlist] - } - lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] - set flen [llength $flatlist] - set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] - incr cols_remaining -1 - } - return $zip_l + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lzipn + @cmd -name punk::lib::lzipn\ + -summary\ + "zip any number of lists together (unoptimised)."\ + -help\ + "Conceptually equivalent to converting a list of rows + to a list of columns. + + See lzip which provides the same functionality but with + optimisations depending on the number of supplied lists. + " + @values -min 1 -max 1 + lvar -type string -help\ + "name of list variable" + a -type indexexpression + z -type indexexpression + }] } #keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible if {![package vsatisfies [package present Tcl] 9.0-] || [dict get [punk::lib::check::has_tclbug_lsearch_strideallinline] bug]} { #-stride either not available - or has bug preventing use of main algorithm below - proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] + proc lzipn {args} [info body ::punk::lib::system::lzipn_tcl8] } else { - proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] + proc lzipn {args} [info body ::punk::lib::system::lzipn_tcl9a] } + namespace import ::punk::args::lib::tstr namespace eval argdoc { @@ -2291,13 +2364,31 @@ namespace eval punk::lib { proc is_list_all_ni_list2 {a b} $body } - #somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist - #struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on, - # especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg) - proc ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::ldiff + @cmd -name punk::lib::ldiff\ + -summary\ + "Difference consisting of items with removeitems removed."\ + -help\ + "Somewhat like struct::set difference, but order preserving, and doesn't + treat as a 'set' so preserves any duplicates in items. + + struct::set difference may happen to preserve ordering when items are + integers, but order can't be relied on, especially as struct::set has + 2 differening implementations (tcl vs critcl) which return results with + different ordering to each other and different deduping behaviour in + some cases (e.g when 2nd arg is empty)" + @values -min 2 -max 2 + items -type list + removeitems -type list + }] + } + proc ldiff {items removeitems} { + if {[llength $removeitems] == 0} {return $items} set result {} - foreach item $fromlist { + foreach item $items { if {$item ni $removeitems} { lappend result $item } @@ -2361,6 +2452,28 @@ namespace eval punk::lib { return [array names tmp] } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lunique_unordered + @cmd -name punk::lib::lunique_unordered\ + -summary\ + "unique values in list"\ + -help\ + "Return unique values in provided list. + This removes duplicates but *may* rearrange the + order of the returned elements compared to the + original list. + + When struct::set is available this will be used + for the implementation, as it can be *slightly* + faster if acceleration is present. When struct::set + is not available it will fallback to lunique and + provide the same functionality with order preserved." + @values -min 1 -max 1 + list -type list + }] + } #default/fallback implementation proc lunique_unordered {list} { lunique $list @@ -2371,13 +2484,33 @@ namespace eval punk::lib { struct::set union $list {} } } else { - puts stderr "WARNING: struct::set union no longer dedupes!" + #struct::set union operates on a 'set' - so this probably won't change, and hopefully is + #consistent across unacelerated versions and those implemented in accelerators, + #but if it ever does change - be a little noisy about it. + puts stderr "punk::lib WARNING: struct::set union no longer dedupes!" #we could also test a sequence of: struct::set add } } - #order-preserving + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lunique + @cmd -name punk::lib::lunique\ + -summary\ + "Order-preserving unique values in list"\ + -help\ + "Return unique values in provided list. + This removes duplicates whilst preserving the + original order of the provided list. + + When struct::set is available with acceleration, + lunique_unordered may be slightly faster." + @values -min 1 -max 1 + list -type list + }] + } proc lunique {list} { set new {} foreach item $list { @@ -2569,18 +2702,21 @@ namespace eval punk::lib { To validate if an indexset is strictly within range, both the length of the data and the base would need to be considered. - The normal 'range' specifier is .. + The normal 'range' specifier is .. but can be of the form .x. where x is the step value. The range specifier can appear at the beginning, middle or end, or even alone to indicate the entire range of valid values. e.g the following are all valid ranges - 1.. - (index 1 to 'max') - ..10 - (index 'base' to 10) - 2..11 - (index 2 to 11) - .. - (all indices) + 1.. + (index 1 to 'max') + ..10 + (index 'base' to 10) + 2..11 + (index 2 to 11) + .. + (all indices) + .3. + (1st index and every 3rd index thereafter) + Common whitespace elements space,tab,newlines are ignored. Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands, e.g end-2 or 2+2. @@ -2670,20 +2806,19 @@ namespace eval punk::lib { .-1. would represent end to base with step -1 If start is omitted and only the end is supplied: - The default step is 1 indicating ascension and the missing end is equivalent to 'end' - indexset_resolve 5 2.. - -> 2 3 4 - The default end is the base if the step is negative - indexset_resolve 5 2.-1. - -> 2 1 0 - If end is omitted and onlthe start is supplied: The default step is 1 indicating ascension and the missing start is equivalent to the base. indexset_resolve 5 ..2 -> 0 1 2 The default start is 'end' if the step is negative indexset_resolve 5 .-1.2 -> 4 3 2 - + If end is omitted and only the start is supplied: + The default step is 1 indicating ascension and the missing end is equivalent to 'end' + indexset_resolve 5 2.. + -> 2 3 4 + The default end is the base if the step is negative + indexset_resolve 5 2.-1. + -> 2 1 0 Like the tcl9 lseq command - a step (by) value of zero produces no results. @@ -2703,7 +2838,7 @@ namespace eval punk::lib { indexset examples: - These assume the default 0-based indices (base == 0) + These assume the default 0-based indices (-base 0) 1,3.. output the index 1 (2nd item) followed by all from index 3 to the end. @@ -3604,7 +3739,7 @@ namespace eval punk::lib { @id -id ::punk::lib::gcd @cmd -name punk::lib::gcd\ -summary\ - "Gretest common divisor of m and n."\ + "Greatest common divisor of m and n."\ -help\ "Return the greatest common divisor of m and n. Straight from Lars Hellström's math::numtheory library in Tcllib @@ -3643,12 +3778,22 @@ namespace eval punk::lib { return $m } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lcm + @cmd -name punk::lib::lcm\ + -summary\ + "Lowest common multiple of m and n."\ + -help\ + "Return the lowest common multiple of m and n. + Straight from Lars Hellström's math::numtheory library in Tcllib" + @values -min 2 -max 2 + m -type integer + n -type integer + }] + } proc lcm {n m} { - #*** !doctools - #[call [fun gcd] [arg n] [arg m]] - #[para]Return the lowest common multiple of m and n - #[para]Straight from Lars Hellström's math::numtheory library in Tcllib - #[para] set gcd [gcd $n $m] return [expr {$n*$m/$gcd}] } diff --git a/src/modules/punk/path-999999.0a1.0.tm b/src/modules/punk/path-999999.0a1.0.tm index 1887b738..c3da92d9 100644 --- a/src/modules/punk/path-999999.0a1.0.tm +++ b/src/modules/punk/path-999999.0a1.0.tm @@ -294,7 +294,8 @@ namespace eval punk::path { } } elseif {[lindex $parts 0] ne ""} { #relpath a/b/c - set parts [linsert $parts 0 .] + #set parts [linsert $parts 0 .] + ledit parts -1 -1 . set rootindex 0 #allow backtracking arbitrarily for leading .. entries - simplify where possible #also need to stop possible conversion to absolute path @@ -1091,7 +1092,8 @@ namespace eval punk::path { # loc is: ref/sub = sub while {$reference_len > 0} { - set location [linsert $location 0 ..] + #set location [linsert $location 0 ..] + ledit location -1 -1 .. incr reference_len -1 } set location [file join {*}$location] diff --git a/src/modules/punk/repl-999999.0a1.0.tm b/src/modules/punk/repl-999999.0a1.0.tm index 9782941f..34f009dc 100644 --- a/src/modules/punk/repl-999999.0a1.0.tm +++ b/src/modules/punk/repl-999999.0a1.0.tm @@ -1036,7 +1036,8 @@ namespace eval punk::repl::class { # set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""] # incr nextrow -1 #} - set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""] + #set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""] + ledit o_rendered_lines $cursor_row_idx $cursor_row_idx-1 "" set o_cursor_col 1 } diff --git a/src/modules/punk/safe-999999.0a1.0.tm b/src/modules/punk/safe-999999.0a1.0.tm index cc739edf..b969b5bd 100644 --- a/src/modules/punk/safe-999999.0a1.0.tm +++ b/src/modules/punk/safe-999999.0a1.0.tm @@ -922,14 +922,18 @@ tcl::namespace::eval punk::safe::system { set where [lsearch -exact $access_path [info library]] if {$where < 0} { # not found, add it. - set access_path [linsert $access_path 0 [info library]] + #set access_path [linsert $access_path 0 [info library]] + ledit access_path -1 -1 [info library] Log $child "tcl_library was not in auto_path,\ added it to child's access_path" NOTICE } elseif {$where != 0} { # not first, move it first - set access_path [linsert \ - [lreplace $access_path $where $where] \ - 0 [info library]] + #set access_path [linsert \ + # [lreplace $access_path $where $where] \ + # 0 [info library]] + ledit access_path $where $where + ledit access_path -1 -1 [info library] + Log $child "tcl_libray was not in first in auto_path,\ moved it to front of child's access_path" NOTICE } diff --git a/src/modules/punkcheck-0.1.0.tm b/src/modules/punkcheck-0.1.0.tm index 9c44ea72..c610c667 100644 --- a/src/modules/punkcheck-0.1.0.tm +++ b/src/modules/punkcheck-0.1.0.tm @@ -323,7 +323,8 @@ namespace eval punkcheck { if {$isnew} { lappend record_list $o_fileset_record } else { - set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record] + #set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record] + ledit record_list $oldposition $oldposition-1 $o_fileset_record } if {$o_operation ne "QUERY"} { punkcheck::save_records_to_file $record_list $punkcheck_file @@ -536,7 +537,8 @@ namespace eval punkcheck { set existing_header_posn [dict get $resultinfo position] if {$existing_header_posn == -1} { set this_installer_record [punkcheck::recordlist::new_installer_record $o_name] - set o_record_list [linsert $o_record_list 0 $this_installer_record] + #set o_record_list [linsert $o_record_list 0 $this_installer_record] + ledit o_record_list -1 -1 $this_installer_record } else { set this_installer_record [dict get $resultinfo record] } @@ -616,7 +618,8 @@ namespace eval punkcheck { set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records] set existing_header_posn [dict get $persistedinfo position] if {$existing_header_posn == -1} { - set file_records [linsert $file_records 0 $this_installer_record] + #set file_records [linsert $file_records 0 $this_installer_record] + ledit file_records -1 -1 $this_installer_record } else { lset file_records $existing_header_posn $this_installer_record } @@ -710,7 +713,8 @@ namespace eval punkcheck { if {$existing_header_posn == -1} { #not found - prepend - set record_list [linsert $record_list 0 $this_installer_record] + #set record_list [linsert $record_list 0 $this_installer_record] + ledit record_list -1 -1 $this_installer_record } else { #replace lset record_list $existing_header_posn $this_installer_record @@ -791,7 +795,8 @@ namespace eval punkcheck { if {$isnew} { lappend record_list $file_record } else { - set record_list [linsert $record_list[unset record_list] $oldposition $file_record] + #set record_list [linsert $record_list[unset record_list] $oldposition $file_record] + ledit record_list $oldposition $oldposition-1 $file_record } save_records_to_file $record_list $punkcheck_file @@ -1191,7 +1196,8 @@ namespace eval punkcheck { # dst is: base/sub = sub while {$baselen > 0} { - set dst [linsert $dst 0 ..] + #set dst [linsert $dst 0 ..] + ledit dst -1 -1 .. incr baselen -1 } set dst [file join {*}$dst] diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index 82461639..2090ccc5 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -4480,7 +4480,8 @@ tcl::namespace::eval textblock { set code_idx 3 foreach {pt code} [lrange $parts 2 end] { if {[punk::ansi::codetype::is_sgr_reset $code]} { - set parts [linsert $parts $code_idx+1 $base] + #set parts [linsert $parts $code_idx+1 $base] + ledit parts $code_idx+1 $code_idx $base } incr code_idx 2 } @@ -4504,12 +4505,14 @@ tcl::namespace::eval textblock { #first pt & code if {$pt ne ""} { #leading plaintext - set parts [linsert $parts 0 $base] + #set parts [linsert $parts 0 $base] + ledit parts -1 -1 $base incr offset } } if {[punk::ansi::codetype::is_sgr_reset $code]} { set parts [linsert $parts [expr {$code_idx+1+$offset}] $base] + #ledit parts [expr {$code_idx+1+$offset}] $code_idx+$offset $base incr offset } incr code_idx 2 @@ -5371,6 +5374,9 @@ tcl::namespace::eval textblock { r-1 { if {[lindex $line_chunks end] eq ""} { set line_chunks [linsert $line_chunks end-2 $pad] + #breaks layout e.g subtables in: i i + #why? + #ledit line_chunks end-2 end-3 $pad } else { lappend line_chunks $pad } @@ -5379,24 +5385,30 @@ tcl::namespace::eval textblock { lappend line_chunks $pad } l-0 { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } l-1 { if {[lindex $line_chunks 0] eq ""} { - set line_chunks [linsert $line_chunks 2 $pad] + #set line_chunks [linsert $line_chunks 2 $pad] + ledit line_chunks 2 1 $pad } else { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } } l-2 { if {$lnum == 0} { if {[lindex $line_chunks 0] eq ""} { - set line_chunks [linsert $line_chunks 2 $pad] + #set line_chunks [linsert $line_chunks 2 $pad] + ledit line_chunks 2 1 $pad } else { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } } else { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } } } @@ -5466,14 +5478,17 @@ tcl::namespace::eval textblock { #} else { # set line_chunks [linsert $line_chunks 0 $pad] #} - set line_chunks [linsert $line_chunks 0 $pad] + + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } l-1 { #set line_chunks [linsert $line_chunks 0 $pad] set line_chunks [_insert_before_text_or_last_ansi $pad $line_chunks] } l-2 { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } } } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/dictn-0.1.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/dictn-0.1.2.tm index 2ed2b1ef..5a7de769 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/dictn-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/dictn-0.1.2.tm @@ -25,17 +25,46 @@ namespace eval dictn { namespace export {[a-z]*} namespace ensemble create + + namespace eval argdoc { + variable PUNKARGS + #non-colour SGR codes + set I "\x1b\[3m" ;# [a+ italic] + set NI "\x1b\[23m" ;# [a+ noitalic] + set B "\x1b\[1m" ;# [a+ bold] + set N "\x1b\[22m" ;# [a+ normal] + set T "\x1b\[1\;4m" ;# [a+ bold underline] + set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] + } } ## ::dictn::append -#This can of course 'ruin' a nested dict if applied to the wrong element -# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: -# %set list {a b {c d}} -# %append list x -# a b {c d}x -# IOW - don't do that unless you really know that's what you want. # +tcl::namespace::eval ::dictn::argdoc { + lappend PUNKARGS [list { + @id -id ::dictn::append + @cmd -name dictn::append\ + -summary\ + "Append a single string to the value at dict path."\ + -help\ + "Append a single string to the value at a given dictionary path. + + This can of course 'ruin' a nested dict if applied to the wrong element + - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: + %set list {a b {c d}} + %append list x + a b {c d}x + IOW - don't do that unless you really know that's what you want. + + Note than unlike dict append - only a single value is accepted for appending. + " + @values -min 2 -max 3 + dictvar -type string + path -type list + value -type any -default "" -optional 1 + }] +} proc ::dictn::append {dictvar path {value {}}} { if {[llength $path] == 1} { uplevel 1 [list dict append $dictvar $path $value] @@ -43,7 +72,7 @@ proc ::dictn::append {dictvar path {value {}}} { upvar 1 $dictvar dvar ::set str [dict get $dvar {*}$path] - append str $val + append str $value dict set dvar {*}$path $str } } @@ -73,6 +102,25 @@ proc ::dictn::for {keyvalvars dictval path body} { proc ::dictn::get {dictval {path {}}} { return [dict get $dictval {*}$path] } +tcl::namespace::eval ::dictn::argdoc { + lappend PUNKARGS [list { + @id -id ::dictn::getn + @cmd -name dictn::getn\ + -summary\ + "Get one or more paths in a dict simultaneously."\ + -help\ + "" + @values -min 1 -max -1 + dictvar -type string + path -type list -multiple 1 + }] +} +proc ::dictn::getn {dictval args} { + if {![llength $args]} { + return [::tcl::dict::get $dictval] + } + lmap path $args {::tcl::dict::get $dictval {*}$path} +} if {[info commands ::tcl::dict::getdef] ne ""} { @@ -85,10 +133,18 @@ if {[info commands ::tcl::dict::getdef] ne ""} { return [dict getdef $dictval {*}$path $default] } - proc ::dictn::incr {dictvar path {increment {}} } { - if {$increment eq ""} { - ::set increment 1 + proc ::dictn::incr {dictvar path {increment 1} } { + upvar 1 $dictvar dvar + if {[llength $path] == 1} { + return [::tcl::dict::incr dvar $path $increment] + } + if {[::tcl::info::exists dvar]} { + ::set increment [expr {[::tcl::dict::getdef $dvar {*}$path 0] + $increment}] } + return [::tcl::dict::set dvar {*}$path $increment] + } + #test - compare disassembly + proc ::dictn::incr2 {dictvar path {increment 1} } { if {[llength $path] == 1} { uplevel 1 [list dict incr $dictvar $path $increment] } else { @@ -233,6 +289,33 @@ proc ::dictn::set {dictvar path newval} { return [dict set dvar {*}$path $newval] } +tcl::namespace::eval ::dictn::argdoc { + lappend PUNKARGS [list { + @id -id ::dictn::setn + @cmd -name dictn::setn\ + -summary\ + "Set one or more paths in a dict to value(s)"\ + -help\ + "" + @values -min 3 -max -1 + dictvar -type string + path_newval -type {path newval} -multiple 1 + }] +} +proc ::dictn::setn {dictvar args} { + if {[llength $args] == 0} { + error "dictn::setn requires at least one pair" + } + if {[llength $args] % 2 != 0} { + error "dictn::setn requires trailing pairs" + } + upvar 1 $dictvar dvar + foreach {p v} $args { + ::tcl::dict::set dvar {*}$p $v + } + return $dvar +} + proc ::dictn::size {dictval {path {}}} { return [dict size [dict get $dictval {*}$path]] } @@ -312,6 +395,46 @@ proc ::dictn::values {dictval {path {}} {glob {}}} { } } +tcl::namespace::eval ::dictn::argdoc { + lappend PUNKARGS [list { + @id -id ::dictn::with + @cmd -name dictn::with\ + -summary\ + "Execute script for each key at dict path."\ + -help\ + "Execute the Tcl script in body with the value for each key within the + given key-path mapped to either variables or keys in a specified array. + + If the name of an array variable is not supplied for arrayvar, + dictn with behaves like dict with, except that it accepts a list + for the possibly nested key-path instead of separate arguments. + + The subkeys of the dict at the given key-path will create variables + in the calling scope. + + If an arrayvar is passed, an array of that name in the calling + scope will be populated with keys and values from the subkeys and + values of the dict at the given key-path." + @form -form standard + @values -min 3 -max 3 + dictvar -type string + path -type list + body -type string + + @form -form array + @values -min 4 -max 4 + dictvar -type string + path -type list + arrayvar -type string -help\ + "Name of array variable in which key values are + stored for the given dict path. + This prevents key values being used as variable + names in the calling scope, instead capturing them + as keys in the single specified array at the calling + scope." + body -type string + }] +} # Standard form: #'dictn with dictVariable path body' # @@ -351,7 +474,10 @@ proc ::dictn::with {dictvar path args} { - +::tcl::namespace::eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::dictn +} diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm index 6b2dd8a9..390b34ae 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm @@ -751,6 +751,27 @@ namespace eval punk::lib { # -- --- + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lswap + @cmd -name punk::lib::lswap\ + -summary\ + "Swap list values in-place"\ + -help\ + "Similar to struct::list swap, except it fully supports basic + list index expressions such as 7-2 end-1 etc. + + struct::list swap doesn't support 'end' offsets, and only + sometimes appears to support basic expressions, depending on the + expression compared to the list length." + @values -min 1 -max 1 + lvar -type string -help\ + "name of list variable" + a -type indexexpression + z -type indexexpression + }] + } proc lswap {lvar a z} { upvar $lvar l set len [llength $l] @@ -955,181 +976,233 @@ namespace eval punk::lib { } } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lzip + @cmd -name punk::lib::lzip\ + -summary\ + "zip any number of lists together."\ + -help\ + "Conceptually equivalent to converting a list of rows + to a list of columns. + + The number of returned lists (columns) will be equal to + the length of the longest supplied list (row). + If lengths of supplied lists don't match, empty strings + will be inserted in the resulting lists. + + e.g lzip {a b c d e} {1 2 3 4} {x y z} + -> {a 1 x} {b 2 y} {c 3 z} {d 4 {}} {3 {} {}} + " + @values -min 1 -max 1 + lvar -type string -help\ + "name of list variable" + a -type indexexpression + z -type indexexpression + }] + } proc lzip {args} { switch -- [llength $args] { - 0 {return {}} - 1 {return [lindex $args 0]} - 2 {return [lzip2lists {*}$args]} - 3 {return [lzip3lists {*}$args]} - 4 {return [lzip4lists {*}$args]} - 5 {return [lzip5lists {*}$args]} - 6 {return [lzip6lists {*}$args]} - 7 {return [lzip7lists {*}$args]} - 8 {return [lzip8lists {*}$args]} - 9 {return [lzip9lists {*}$args]} - 10 {return [lzip10lists {*}$args]} + 0 {return {}} + 1 {return [lindex $args 0]} + 2 {return [::punk::lib::system::lzip2lists {*}$args]} + 3 {return [::punk::lib::system::lzip3lists {*}$args]} + 4 {return [::punk::lib::system::lzip4lists {*}$args]} + 5 {return [::punk::lib::system::lzip5lists {*}$args]} + 6 {return [::punk::lib::system::lzip6lists {*}$args]} + 7 {return [::punk::lib::system::lzip7lists {*}$args]} + 8 {return [::punk::lib::system::lzip8lists {*}$args]} + 9 {return [::punk::lib::system::lzip9lists {*}$args]} + 10 {return [::punk::lib::system::lzip10lists {*}$args]} 11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 { set n [llength $args] - if {[info commands ::punk::lib::lzip${n}lists] eq ""} { - puts "calling ::punk::lib::Build_lzipn $n" - ::punk::lib::Build_lzipn $n + if {[info commands ::punk::lib::system::lzip${n}lists] eq ""} { + #puts "calling ::punk::lib::system::Build_lzipn $n" + ::punk::lib::system::Build_lzipn $n } - return [lzip${n}lists {*}$args] + return [::punk::lib::system::lzip${n}lists {*}$args] } default { if {[llength $args] < 4000} { set n [llength $args] - if {[info commands ::punk::lib::lzip${n}lists] eq ""} { - puts "calling ::punk::lib::Build_lzipn $n" - ::punk::lib::Build_lzipn $n + if {[info commands ::punk::lib::system::lzip${n}lists] eq ""} { + #puts "calling ::punk::lib::system::Build_lzipn $n" + ::punk::lib::system::Build_lzipn $n } - return [lzip${n}lists {*}$args] + return [::punk::lib::system::lzip${n}lists {*}$args] } else { - return [lzipn {*}$args] + return [::punk::lib::lzipn {*}$args] } } } } - proc Build_lzipn {n} { - set arglist [list] - #use punk::lib::range which defers to lseq if available - set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) - set body "\nlmap " - for {set i 1} {$i <= $n} {incr i} { - lappend arglist l$i - append body "[lindex $vars $i] \$l$i " - } - append body "\{list " - for {set i 1} {$i <= $n} {incr i} { - append body "\$[lindex $vars $i] " + namespace eval system { + proc Build_lzipn {n} { + set arglist [list] + #use punk::lib::range which defers to lseq if available + set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) + set body "\nlmap " + for {set i 1} {$i <= $n} {incr i} { + lappend arglist l$i + append body "[lindex $vars $i] \$l$i " + } + append body "\{list " + for {set i 1} {$i <= $n} {incr i} { + append body "\$[lindex $vars $i] " + } + append body "\}" \n + #puts "proc punk::lib::system::lzip${n}lists {$arglist} \{" + #puts "$body" + #puts "\}" + proc ::punk::lib::system::lzip${n}lists $arglist $body } - append body "\}" \n - puts "proc punk::lib::lzip${n}lists {$arglist} \{" - puts "$body" - puts "\}" - proc ::punk::lib::lzip${n}lists $arglist $body - } - #fastest is to know the number of lists to be zipped - proc lzip2lists {l1 l2} { - lmap a $l1 b $l2 {list $a $b} - } - proc lzip3lists {l1 l2 l3} { - lmap a $l1 b $l2 c $l3 {list $a $b $c} - } - proc lzip4lists {l1 l2 l3 l4} { - lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} - } - proc lzip5lists {l1 l2 l3 l4 l5} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} - } - proc lzip6lists {l1 l2 l3 l4 l5 l6} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} - } - proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} - } - proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} - } - proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} - } - proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} - } + #fastest is to know the number of lists to be zipped + proc lzip2lists {l1 l2} { + lmap a $l1 b $l2 {list $a $b} + } + proc lzip3lists {l1 l2 l3} { + lmap a $l1 b $l2 c $l3 {list $a $b $c} + } + proc lzip4lists {l1 l2 l3 l4} { + lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} + } + proc lzip5lists {l1 l2 l3 l4 l5} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} + } + proc lzip6lists {l1 l2 l3 l4 l5 l6} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} + } + proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} + } + proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} + } + proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} + } + proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} + } - #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly - # review - - proc lzipn_alt args { - #stackoverflow - courtesy glenn jackman (modified) - foreach l $args { - lappend vars [incr n] - lappend lmap_args $n $l + #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly + # review - + proc lzipn_alt args { + #stackoverflow - courtesy glenn jackman (modified) + foreach l $args { + lappend vars [incr n] + lappend lmap_args $n $l + } + lmap {*}$lmap_args {lmap v $vars {set $v}} } - lmap {*}$lmap_args {lmap v $vars {set $v}} - } - #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) - proc lzipn_tcl8 {args} { - #wiki - courtesy JAL - set list_l $args - set zip_l [] - while {1} { - set cur [lmap a_l $list_l { lindex $a_l 0 }] - set list_l [lmap a_l $list_l { lrange $a_l 1 end }] + #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) + proc lzipn_tcl8 {args} { + #For tcl pre 9 (without lsearch -stride) + #wiki - courtesy JAL + set list_l $args + set zip_l [] + while {1} { + set cur [lmap a_l $list_l { lindex $a_l 0 }] + set list_l [lmap a_l $list_l { lrange $a_l 1 end }] - if {[join $cur {}] eq {}} { - break + if {[join $cur {}] eq {}} { + break + } + lappend zip_l $cur + } + return $zip_l + } + proc lzipn_tcl9a {args} { + #For Tcl 9+ (with lsearch -stride) + #compared to wiki version + #comparable for lists len <3 or number of args < 3 + #approx 2x faster for large lists or more lists + #needs -stride single index bug fix to use empty string instead of NULL + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] + set outlist [lrepeat $numcolumns {}] + set s 0 + foreach len $lens list $args { + #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] + ledit flatlist $s [expr {$s + $len - 1}] {*}$list + incr s $numcolumns + } + #needs single index lstride bugfix + for {set c 0} {$c < $numcolumns} {incr c} { + ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] + } + return $outlist + } + proc lzipn_tcl9b {args} { + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} + } + proc lzipn_tcl9c {args} { + #SLOW + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + set zip_l {} + set cols_remaining $numcolumns + for {set c 0} {$c < $numcolumns} {incr c} { + if {$cols_remaining == 1} { + return [list {*}$zip_l $flatlist] + } + lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] + set flen [llength $flatlist] + set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] + incr cols_remaining -1 } - lappend zip_l $cur + return $zip_l } - return $zip_l } - proc lzipn_tcl9a {args} { - #compared to wiki version - #comparable for lists len <3 or number of args < 3 - #approx 2x faster for large lists or more lists - #needs -stride single index bug fix to use empty string instead of NULL - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] - set outlist [lrepeat $numcolumns {}] - set s 0 - foreach len $lens list $args { - #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] - ledit flatlist $s [expr {$s + $len - 1}] {*}$list - incr s $numcolumns - } - #needs single index lstride bugfix - for {set c 0} {$c < $numcolumns} {incr c} { - ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] - } - return $outlist - } - proc lzipn_tcl9b {args} { - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [list] - foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] - } - lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} - } - proc lzipn_tcl9c {args} { - #SLOW - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [list] - foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] - } - set zip_l {} - set cols_remaining $numcolumns - for {set c 0} {$c < $numcolumns} {incr c} { - if {$cols_remaining == 1} { - return [list {*}$zip_l $flatlist] - } - lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] - set flen [llength $flatlist] - set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] - incr cols_remaining -1 - } - return $zip_l + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lzipn + @cmd -name punk::lib::lzipn\ + -summary\ + "zip any number of lists together (unoptimised)."\ + -help\ + "Conceptually equivalent to converting a list of rows + to a list of columns. + + See lzip which provides the same functionality but with + optimisations depending on the number of supplied lists. + " + @values -min 1 -max 1 + lvar -type string -help\ + "name of list variable" + a -type indexexpression + z -type indexexpression + }] } #keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible if {![package vsatisfies [package present Tcl] 9.0-] || [dict get [punk::lib::check::has_tclbug_lsearch_strideallinline] bug]} { #-stride either not available - or has bug preventing use of main algorithm below - proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] + proc lzipn {args} [info body ::punk::lib::system::lzipn_tcl8] } else { - proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] + proc lzipn {args} [info body ::punk::lib::system::lzipn_tcl9a] } + namespace import ::punk::args::lib::tstr namespace eval argdoc { @@ -2291,13 +2364,31 @@ namespace eval punk::lib { proc is_list_all_ni_list2 {a b} $body } - #somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist - #struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on, - # especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg) - proc ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::ldiff + @cmd -name punk::lib::ldiff\ + -summary\ + "Difference consisting of items with removeitems removed."\ + -help\ + "Somewhat like struct::set difference, but order preserving, and doesn't + treat as a 'set' so preserves any duplicates in items. + + struct::set difference may happen to preserve ordering when items are + integers, but order can't be relied on, especially as struct::set has + 2 differening implementations (tcl vs critcl) which return results with + different ordering to each other and different deduping behaviour in + some cases (e.g when 2nd arg is empty)" + @values -min 2 -max 2 + items -type list + removeitems -type list + }] + } + proc ldiff {items removeitems} { + if {[llength $removeitems] == 0} {return $items} set result {} - foreach item $fromlist { + foreach item $items { if {$item ni $removeitems} { lappend result $item } @@ -2361,6 +2452,28 @@ namespace eval punk::lib { return [array names tmp] } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lunique_unordered + @cmd -name punk::lib::lunique_unordered\ + -summary\ + "unique values in list"\ + -help\ + "Return unique values in provided list. + This removes duplicates but *may* rearrange the + order of the returned elements compared to the + original list. + + When struct::set is available this will be used + for the implementation, as it can be *slightly* + faster if acceleration is present. When struct::set + is not available it will fallback to lunique and + provide the same functionality with order preserved." + @values -min 1 -max 1 + list -type list + }] + } #default/fallback implementation proc lunique_unordered {list} { lunique $list @@ -2371,13 +2484,33 @@ namespace eval punk::lib { struct::set union $list {} } } else { - puts stderr "WARNING: struct::set union no longer dedupes!" + #struct::set union operates on a 'set' - so this probably won't change, and hopefully is + #consistent across unacelerated versions and those implemented in accelerators, + #but if it ever does change - be a little noisy about it. + puts stderr "punk::lib WARNING: struct::set union no longer dedupes!" #we could also test a sequence of: struct::set add } } - #order-preserving + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lunique + @cmd -name punk::lib::lunique\ + -summary\ + "Order-preserving unique values in list"\ + -help\ + "Return unique values in provided list. + This removes duplicates whilst preserving the + original order of the provided list. + + When struct::set is available with acceleration, + lunique_unordered may be slightly faster." + @values -min 1 -max 1 + list -type list + }] + } proc lunique {list} { set new {} foreach item $list { @@ -2569,18 +2702,21 @@ namespace eval punk::lib { To validate if an indexset is strictly within range, both the length of the data and the base would need to be considered. - The normal 'range' specifier is .. + The normal 'range' specifier is .. but can be of the form .x. where x is the step value. The range specifier can appear at the beginning, middle or end, or even alone to indicate the entire range of valid values. e.g the following are all valid ranges - 1.. - (index 1 to 'max') - ..10 - (index 'base' to 10) - 2..11 - (index 2 to 11) - .. - (all indices) + 1.. + (index 1 to 'max') + ..10 + (index 'base' to 10) + 2..11 + (index 2 to 11) + .. + (all indices) + .3. + (1st index and every 3rd index thereafter) + Common whitespace elements space,tab,newlines are ignored. Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands, e.g end-2 or 2+2. @@ -2670,20 +2806,19 @@ namespace eval punk::lib { .-1. would represent end to base with step -1 If start is omitted and only the end is supplied: - The default step is 1 indicating ascension and the missing end is equivalent to 'end' - indexset_resolve 5 2.. - -> 2 3 4 - The default end is the base if the step is negative - indexset_resolve 5 2.-1. - -> 2 1 0 - If end is omitted and onlthe start is supplied: The default step is 1 indicating ascension and the missing start is equivalent to the base. indexset_resolve 5 ..2 -> 0 1 2 The default start is 'end' if the step is negative indexset_resolve 5 .-1.2 -> 4 3 2 - + If end is omitted and only the start is supplied: + The default step is 1 indicating ascension and the missing end is equivalent to 'end' + indexset_resolve 5 2.. + -> 2 3 4 + The default end is the base if the step is negative + indexset_resolve 5 2.-1. + -> 2 1 0 Like the tcl9 lseq command - a step (by) value of zero produces no results. @@ -2703,7 +2838,7 @@ namespace eval punk::lib { indexset examples: - These assume the default 0-based indices (base == 0) + These assume the default 0-based indices (-base 0) 1,3.. output the index 1 (2nd item) followed by all from index 3 to the end. @@ -3604,7 +3739,7 @@ namespace eval punk::lib { @id -id ::punk::lib::gcd @cmd -name punk::lib::gcd\ -summary\ - "Gretest common divisor of m and n."\ + "Greatest common divisor of m and n."\ -help\ "Return the greatest common divisor of m and n. Straight from Lars Hellström's math::numtheory library in Tcllib @@ -3643,12 +3778,22 @@ namespace eval punk::lib { return $m } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lcm + @cmd -name punk::lib::lcm\ + -summary\ + "Lowest common multiple of m and n."\ + -help\ + "Return the lowest common multiple of m and n. + Straight from Lars Hellström's math::numtheory library in Tcllib" + @values -min 2 -max 2 + m -type integer + n -type integer + }] + } proc lcm {n m} { - #*** !doctools - #[call [fun gcd] [arg n] [arg m]] - #[para]Return the lowest common multiple of m and n - #[para]Straight from Lars Hellström's math::numtheory library in Tcllib - #[para] set gcd [gcd $n $m] return [expr {$n*$m/$gcd}] } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm index 96f506b5..c0f2b7ba 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm @@ -1036,7 +1036,8 @@ namespace eval punk::repl::class { # set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""] # incr nextrow -1 #} - set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""] + #set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""] + ledit o_rendered_lines $cursor_row_idx $cursor_row_idx-1 "" set o_cursor_col 1 } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm index 9c44ea72..c610c667 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm @@ -323,7 +323,8 @@ namespace eval punkcheck { if {$isnew} { lappend record_list $o_fileset_record } else { - set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record] + #set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record] + ledit record_list $oldposition $oldposition-1 $o_fileset_record } if {$o_operation ne "QUERY"} { punkcheck::save_records_to_file $record_list $punkcheck_file @@ -536,7 +537,8 @@ namespace eval punkcheck { set existing_header_posn [dict get $resultinfo position] if {$existing_header_posn == -1} { set this_installer_record [punkcheck::recordlist::new_installer_record $o_name] - set o_record_list [linsert $o_record_list 0 $this_installer_record] + #set o_record_list [linsert $o_record_list 0 $this_installer_record] + ledit o_record_list -1 -1 $this_installer_record } else { set this_installer_record [dict get $resultinfo record] } @@ -616,7 +618,8 @@ namespace eval punkcheck { set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records] set existing_header_posn [dict get $persistedinfo position] if {$existing_header_posn == -1} { - set file_records [linsert $file_records 0 $this_installer_record] + #set file_records [linsert $file_records 0 $this_installer_record] + ledit file_records -1 -1 $this_installer_record } else { lset file_records $existing_header_posn $this_installer_record } @@ -710,7 +713,8 @@ namespace eval punkcheck { if {$existing_header_posn == -1} { #not found - prepend - set record_list [linsert $record_list 0 $this_installer_record] + #set record_list [linsert $record_list 0 $this_installer_record] + ledit record_list -1 -1 $this_installer_record } else { #replace lset record_list $existing_header_posn $this_installer_record @@ -791,7 +795,8 @@ namespace eval punkcheck { if {$isnew} { lappend record_list $file_record } else { - set record_list [linsert $record_list[unset record_list] $oldposition $file_record] + #set record_list [linsert $record_list[unset record_list] $oldposition $file_record] + ledit record_list $oldposition $oldposition-1 $file_record } save_records_to_file $record_list $punkcheck_file @@ -1191,7 +1196,8 @@ namespace eval punkcheck { # dst is: base/sub = sub while {$baselen > 0} { - set dst [linsert $dst 0 ..] + #set dst [linsert $dst 0 ..] + ledit dst -1 -1 .. incr baselen -1 } set dst [file join {*}$dst] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm index 93e4a41c..4079254e 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm @@ -4480,7 +4480,8 @@ tcl::namespace::eval textblock { set code_idx 3 foreach {pt code} [lrange $parts 2 end] { if {[punk::ansi::codetype::is_sgr_reset $code]} { - set parts [linsert $parts $code_idx+1 $base] + #set parts [linsert $parts $code_idx+1 $base] + ledit parts $code_idx+1 $code_idx $base } incr code_idx 2 } @@ -4504,12 +4505,14 @@ tcl::namespace::eval textblock { #first pt & code if {$pt ne ""} { #leading plaintext - set parts [linsert $parts 0 $base] + #set parts [linsert $parts 0 $base] + ledit parts -1 -1 $base incr offset } } if {[punk::ansi::codetype::is_sgr_reset $code]} { set parts [linsert $parts [expr {$code_idx+1+$offset}] $base] + #ledit parts [expr {$code_idx+1+$offset}] $code_idx+$offset $base incr offset } incr code_idx 2 @@ -5371,6 +5374,9 @@ tcl::namespace::eval textblock { r-1 { if {[lindex $line_chunks end] eq ""} { set line_chunks [linsert $line_chunks end-2 $pad] + #breaks layout e.g subtables in: i i + #why? + #ledit line_chunks end-2 end-3 $pad } else { lappend line_chunks $pad } @@ -5379,13 +5385,16 @@ tcl::namespace::eval textblock { lappend line_chunks $pad } l-0 { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } l-1 { if {[lindex $line_chunks 0] eq ""} { - set line_chunks [linsert $line_chunks 2 $pad] + #set line_chunks [linsert $line_chunks 2 $pad] + ledit line_chunks 2 1 $pad } else { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } } l-2 { @@ -5393,10 +5402,12 @@ tcl::namespace::eval textblock { if {[lindex $line_chunks 0] eq ""} { set line_chunks [linsert $line_chunks 2 $pad] } else { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } } else { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } } } @@ -5466,14 +5477,17 @@ tcl::namespace::eval textblock { #} else { # set line_chunks [linsert $line_chunks 0 $pad] #} - set line_chunks [linsert $line_chunks 0 $pad] + + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } l-1 { #set line_chunks [linsert $line_chunks 0 $pad] set line_chunks [_insert_before_text_or_last_ansi $pad $line_chunks] } l-2 { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } } } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/dictn-0.1.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/dictn-0.1.2.tm index 2ed2b1ef..5a7de769 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/dictn-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/dictn-0.1.2.tm @@ -25,17 +25,46 @@ namespace eval dictn { namespace export {[a-z]*} namespace ensemble create + + namespace eval argdoc { + variable PUNKARGS + #non-colour SGR codes + set I "\x1b\[3m" ;# [a+ italic] + set NI "\x1b\[23m" ;# [a+ noitalic] + set B "\x1b\[1m" ;# [a+ bold] + set N "\x1b\[22m" ;# [a+ normal] + set T "\x1b\[1\;4m" ;# [a+ bold underline] + set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] + } } ## ::dictn::append -#This can of course 'ruin' a nested dict if applied to the wrong element -# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: -# %set list {a b {c d}} -# %append list x -# a b {c d}x -# IOW - don't do that unless you really know that's what you want. # +tcl::namespace::eval ::dictn::argdoc { + lappend PUNKARGS [list { + @id -id ::dictn::append + @cmd -name dictn::append\ + -summary\ + "Append a single string to the value at dict path."\ + -help\ + "Append a single string to the value at a given dictionary path. + + This can of course 'ruin' a nested dict if applied to the wrong element + - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: + %set list {a b {c d}} + %append list x + a b {c d}x + IOW - don't do that unless you really know that's what you want. + + Note than unlike dict append - only a single value is accepted for appending. + " + @values -min 2 -max 3 + dictvar -type string + path -type list + value -type any -default "" -optional 1 + }] +} proc ::dictn::append {dictvar path {value {}}} { if {[llength $path] == 1} { uplevel 1 [list dict append $dictvar $path $value] @@ -43,7 +72,7 @@ proc ::dictn::append {dictvar path {value {}}} { upvar 1 $dictvar dvar ::set str [dict get $dvar {*}$path] - append str $val + append str $value dict set dvar {*}$path $str } } @@ -73,6 +102,25 @@ proc ::dictn::for {keyvalvars dictval path body} { proc ::dictn::get {dictval {path {}}} { return [dict get $dictval {*}$path] } +tcl::namespace::eval ::dictn::argdoc { + lappend PUNKARGS [list { + @id -id ::dictn::getn + @cmd -name dictn::getn\ + -summary\ + "Get one or more paths in a dict simultaneously."\ + -help\ + "" + @values -min 1 -max -1 + dictvar -type string + path -type list -multiple 1 + }] +} +proc ::dictn::getn {dictval args} { + if {![llength $args]} { + return [::tcl::dict::get $dictval] + } + lmap path $args {::tcl::dict::get $dictval {*}$path} +} if {[info commands ::tcl::dict::getdef] ne ""} { @@ -85,10 +133,18 @@ if {[info commands ::tcl::dict::getdef] ne ""} { return [dict getdef $dictval {*}$path $default] } - proc ::dictn::incr {dictvar path {increment {}} } { - if {$increment eq ""} { - ::set increment 1 + proc ::dictn::incr {dictvar path {increment 1} } { + upvar 1 $dictvar dvar + if {[llength $path] == 1} { + return [::tcl::dict::incr dvar $path $increment] + } + if {[::tcl::info::exists dvar]} { + ::set increment [expr {[::tcl::dict::getdef $dvar {*}$path 0] + $increment}] } + return [::tcl::dict::set dvar {*}$path $increment] + } + #test - compare disassembly + proc ::dictn::incr2 {dictvar path {increment 1} } { if {[llength $path] == 1} { uplevel 1 [list dict incr $dictvar $path $increment] } else { @@ -233,6 +289,33 @@ proc ::dictn::set {dictvar path newval} { return [dict set dvar {*}$path $newval] } +tcl::namespace::eval ::dictn::argdoc { + lappend PUNKARGS [list { + @id -id ::dictn::setn + @cmd -name dictn::setn\ + -summary\ + "Set one or more paths in a dict to value(s)"\ + -help\ + "" + @values -min 3 -max -1 + dictvar -type string + path_newval -type {path newval} -multiple 1 + }] +} +proc ::dictn::setn {dictvar args} { + if {[llength $args] == 0} { + error "dictn::setn requires at least one pair" + } + if {[llength $args] % 2 != 0} { + error "dictn::setn requires trailing pairs" + } + upvar 1 $dictvar dvar + foreach {p v} $args { + ::tcl::dict::set dvar {*}$p $v + } + return $dvar +} + proc ::dictn::size {dictval {path {}}} { return [dict size [dict get $dictval {*}$path]] } @@ -312,6 +395,46 @@ proc ::dictn::values {dictval {path {}} {glob {}}} { } } +tcl::namespace::eval ::dictn::argdoc { + lappend PUNKARGS [list { + @id -id ::dictn::with + @cmd -name dictn::with\ + -summary\ + "Execute script for each key at dict path."\ + -help\ + "Execute the Tcl script in body with the value for each key within the + given key-path mapped to either variables or keys in a specified array. + + If the name of an array variable is not supplied for arrayvar, + dictn with behaves like dict with, except that it accepts a list + for the possibly nested key-path instead of separate arguments. + + The subkeys of the dict at the given key-path will create variables + in the calling scope. + + If an arrayvar is passed, an array of that name in the calling + scope will be populated with keys and values from the subkeys and + values of the dict at the given key-path." + @form -form standard + @values -min 3 -max 3 + dictvar -type string + path -type list + body -type string + + @form -form array + @values -min 4 -max 4 + dictvar -type string + path -type list + arrayvar -type string -help\ + "Name of array variable in which key values are + stored for the given dict path. + This prevents key values being used as variable + names in the calling scope, instead capturing them + as keys in the single specified array at the calling + scope." + body -type string + }] +} # Standard form: #'dictn with dictVariable path body' # @@ -351,7 +474,10 @@ proc ::dictn::with {dictvar path args} { - +::tcl::namespace::eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::dictn +} diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm index 6b2dd8a9..390b34ae 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm @@ -751,6 +751,27 @@ namespace eval punk::lib { # -- --- + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lswap + @cmd -name punk::lib::lswap\ + -summary\ + "Swap list values in-place"\ + -help\ + "Similar to struct::list swap, except it fully supports basic + list index expressions such as 7-2 end-1 etc. + + struct::list swap doesn't support 'end' offsets, and only + sometimes appears to support basic expressions, depending on the + expression compared to the list length." + @values -min 1 -max 1 + lvar -type string -help\ + "name of list variable" + a -type indexexpression + z -type indexexpression + }] + } proc lswap {lvar a z} { upvar $lvar l set len [llength $l] @@ -955,181 +976,233 @@ namespace eval punk::lib { } } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lzip + @cmd -name punk::lib::lzip\ + -summary\ + "zip any number of lists together."\ + -help\ + "Conceptually equivalent to converting a list of rows + to a list of columns. + + The number of returned lists (columns) will be equal to + the length of the longest supplied list (row). + If lengths of supplied lists don't match, empty strings + will be inserted in the resulting lists. + + e.g lzip {a b c d e} {1 2 3 4} {x y z} + -> {a 1 x} {b 2 y} {c 3 z} {d 4 {}} {3 {} {}} + " + @values -min 1 -max 1 + lvar -type string -help\ + "name of list variable" + a -type indexexpression + z -type indexexpression + }] + } proc lzip {args} { switch -- [llength $args] { - 0 {return {}} - 1 {return [lindex $args 0]} - 2 {return [lzip2lists {*}$args]} - 3 {return [lzip3lists {*}$args]} - 4 {return [lzip4lists {*}$args]} - 5 {return [lzip5lists {*}$args]} - 6 {return [lzip6lists {*}$args]} - 7 {return [lzip7lists {*}$args]} - 8 {return [lzip8lists {*}$args]} - 9 {return [lzip9lists {*}$args]} - 10 {return [lzip10lists {*}$args]} + 0 {return {}} + 1 {return [lindex $args 0]} + 2 {return [::punk::lib::system::lzip2lists {*}$args]} + 3 {return [::punk::lib::system::lzip3lists {*}$args]} + 4 {return [::punk::lib::system::lzip4lists {*}$args]} + 5 {return [::punk::lib::system::lzip5lists {*}$args]} + 6 {return [::punk::lib::system::lzip6lists {*}$args]} + 7 {return [::punk::lib::system::lzip7lists {*}$args]} + 8 {return [::punk::lib::system::lzip8lists {*}$args]} + 9 {return [::punk::lib::system::lzip9lists {*}$args]} + 10 {return [::punk::lib::system::lzip10lists {*}$args]} 11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 { set n [llength $args] - if {[info commands ::punk::lib::lzip${n}lists] eq ""} { - puts "calling ::punk::lib::Build_lzipn $n" - ::punk::lib::Build_lzipn $n + if {[info commands ::punk::lib::system::lzip${n}lists] eq ""} { + #puts "calling ::punk::lib::system::Build_lzipn $n" + ::punk::lib::system::Build_lzipn $n } - return [lzip${n}lists {*}$args] + return [::punk::lib::system::lzip${n}lists {*}$args] } default { if {[llength $args] < 4000} { set n [llength $args] - if {[info commands ::punk::lib::lzip${n}lists] eq ""} { - puts "calling ::punk::lib::Build_lzipn $n" - ::punk::lib::Build_lzipn $n + if {[info commands ::punk::lib::system::lzip${n}lists] eq ""} { + #puts "calling ::punk::lib::system::Build_lzipn $n" + ::punk::lib::system::Build_lzipn $n } - return [lzip${n}lists {*}$args] + return [::punk::lib::system::lzip${n}lists {*}$args] } else { - return [lzipn {*}$args] + return [::punk::lib::lzipn {*}$args] } } } } - proc Build_lzipn {n} { - set arglist [list] - #use punk::lib::range which defers to lseq if available - set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) - set body "\nlmap " - for {set i 1} {$i <= $n} {incr i} { - lappend arglist l$i - append body "[lindex $vars $i] \$l$i " - } - append body "\{list " - for {set i 1} {$i <= $n} {incr i} { - append body "\$[lindex $vars $i] " + namespace eval system { + proc Build_lzipn {n} { + set arglist [list] + #use punk::lib::range which defers to lseq if available + set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) + set body "\nlmap " + for {set i 1} {$i <= $n} {incr i} { + lappend arglist l$i + append body "[lindex $vars $i] \$l$i " + } + append body "\{list " + for {set i 1} {$i <= $n} {incr i} { + append body "\$[lindex $vars $i] " + } + append body "\}" \n + #puts "proc punk::lib::system::lzip${n}lists {$arglist} \{" + #puts "$body" + #puts "\}" + proc ::punk::lib::system::lzip${n}lists $arglist $body } - append body "\}" \n - puts "proc punk::lib::lzip${n}lists {$arglist} \{" - puts "$body" - puts "\}" - proc ::punk::lib::lzip${n}lists $arglist $body - } - #fastest is to know the number of lists to be zipped - proc lzip2lists {l1 l2} { - lmap a $l1 b $l2 {list $a $b} - } - proc lzip3lists {l1 l2 l3} { - lmap a $l1 b $l2 c $l3 {list $a $b $c} - } - proc lzip4lists {l1 l2 l3 l4} { - lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} - } - proc lzip5lists {l1 l2 l3 l4 l5} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} - } - proc lzip6lists {l1 l2 l3 l4 l5 l6} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} - } - proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} - } - proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} - } - proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} - } - proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} - } + #fastest is to know the number of lists to be zipped + proc lzip2lists {l1 l2} { + lmap a $l1 b $l2 {list $a $b} + } + proc lzip3lists {l1 l2 l3} { + lmap a $l1 b $l2 c $l3 {list $a $b $c} + } + proc lzip4lists {l1 l2 l3 l4} { + lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} + } + proc lzip5lists {l1 l2 l3 l4 l5} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} + } + proc lzip6lists {l1 l2 l3 l4 l5 l6} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} + } + proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} + } + proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} + } + proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} + } + proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} + } - #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly - # review - - proc lzipn_alt args { - #stackoverflow - courtesy glenn jackman (modified) - foreach l $args { - lappend vars [incr n] - lappend lmap_args $n $l + #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly + # review - + proc lzipn_alt args { + #stackoverflow - courtesy glenn jackman (modified) + foreach l $args { + lappend vars [incr n] + lappend lmap_args $n $l + } + lmap {*}$lmap_args {lmap v $vars {set $v}} } - lmap {*}$lmap_args {lmap v $vars {set $v}} - } - #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) - proc lzipn_tcl8 {args} { - #wiki - courtesy JAL - set list_l $args - set zip_l [] - while {1} { - set cur [lmap a_l $list_l { lindex $a_l 0 }] - set list_l [lmap a_l $list_l { lrange $a_l 1 end }] + #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) + proc lzipn_tcl8 {args} { + #For tcl pre 9 (without lsearch -stride) + #wiki - courtesy JAL + set list_l $args + set zip_l [] + while {1} { + set cur [lmap a_l $list_l { lindex $a_l 0 }] + set list_l [lmap a_l $list_l { lrange $a_l 1 end }] - if {[join $cur {}] eq {}} { - break + if {[join $cur {}] eq {}} { + break + } + lappend zip_l $cur + } + return $zip_l + } + proc lzipn_tcl9a {args} { + #For Tcl 9+ (with lsearch -stride) + #compared to wiki version + #comparable for lists len <3 or number of args < 3 + #approx 2x faster for large lists or more lists + #needs -stride single index bug fix to use empty string instead of NULL + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] + set outlist [lrepeat $numcolumns {}] + set s 0 + foreach len $lens list $args { + #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] + ledit flatlist $s [expr {$s + $len - 1}] {*}$list + incr s $numcolumns + } + #needs single index lstride bugfix + for {set c 0} {$c < $numcolumns} {incr c} { + ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] + } + return $outlist + } + proc lzipn_tcl9b {args} { + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} + } + proc lzipn_tcl9c {args} { + #SLOW + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + set zip_l {} + set cols_remaining $numcolumns + for {set c 0} {$c < $numcolumns} {incr c} { + if {$cols_remaining == 1} { + return [list {*}$zip_l $flatlist] + } + lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] + set flen [llength $flatlist] + set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] + incr cols_remaining -1 } - lappend zip_l $cur + return $zip_l } - return $zip_l } - proc lzipn_tcl9a {args} { - #compared to wiki version - #comparable for lists len <3 or number of args < 3 - #approx 2x faster for large lists or more lists - #needs -stride single index bug fix to use empty string instead of NULL - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] - set outlist [lrepeat $numcolumns {}] - set s 0 - foreach len $lens list $args { - #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] - ledit flatlist $s [expr {$s + $len - 1}] {*}$list - incr s $numcolumns - } - #needs single index lstride bugfix - for {set c 0} {$c < $numcolumns} {incr c} { - ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] - } - return $outlist - } - proc lzipn_tcl9b {args} { - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [list] - foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] - } - lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} - } - proc lzipn_tcl9c {args} { - #SLOW - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [list] - foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] - } - set zip_l {} - set cols_remaining $numcolumns - for {set c 0} {$c < $numcolumns} {incr c} { - if {$cols_remaining == 1} { - return [list {*}$zip_l $flatlist] - } - lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] - set flen [llength $flatlist] - set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] - incr cols_remaining -1 - } - return $zip_l + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lzipn + @cmd -name punk::lib::lzipn\ + -summary\ + "zip any number of lists together (unoptimised)."\ + -help\ + "Conceptually equivalent to converting a list of rows + to a list of columns. + + See lzip which provides the same functionality but with + optimisations depending on the number of supplied lists. + " + @values -min 1 -max 1 + lvar -type string -help\ + "name of list variable" + a -type indexexpression + z -type indexexpression + }] } #keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible if {![package vsatisfies [package present Tcl] 9.0-] || [dict get [punk::lib::check::has_tclbug_lsearch_strideallinline] bug]} { #-stride either not available - or has bug preventing use of main algorithm below - proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] + proc lzipn {args} [info body ::punk::lib::system::lzipn_tcl8] } else { - proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] + proc lzipn {args} [info body ::punk::lib::system::lzipn_tcl9a] } + namespace import ::punk::args::lib::tstr namespace eval argdoc { @@ -2291,13 +2364,31 @@ namespace eval punk::lib { proc is_list_all_ni_list2 {a b} $body } - #somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist - #struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on, - # especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg) - proc ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::ldiff + @cmd -name punk::lib::ldiff\ + -summary\ + "Difference consisting of items with removeitems removed."\ + -help\ + "Somewhat like struct::set difference, but order preserving, and doesn't + treat as a 'set' so preserves any duplicates in items. + + struct::set difference may happen to preserve ordering when items are + integers, but order can't be relied on, especially as struct::set has + 2 differening implementations (tcl vs critcl) which return results with + different ordering to each other and different deduping behaviour in + some cases (e.g when 2nd arg is empty)" + @values -min 2 -max 2 + items -type list + removeitems -type list + }] + } + proc ldiff {items removeitems} { + if {[llength $removeitems] == 0} {return $items} set result {} - foreach item $fromlist { + foreach item $items { if {$item ni $removeitems} { lappend result $item } @@ -2361,6 +2452,28 @@ namespace eval punk::lib { return [array names tmp] } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lunique_unordered + @cmd -name punk::lib::lunique_unordered\ + -summary\ + "unique values in list"\ + -help\ + "Return unique values in provided list. + This removes duplicates but *may* rearrange the + order of the returned elements compared to the + original list. + + When struct::set is available this will be used + for the implementation, as it can be *slightly* + faster if acceleration is present. When struct::set + is not available it will fallback to lunique and + provide the same functionality with order preserved." + @values -min 1 -max 1 + list -type list + }] + } #default/fallback implementation proc lunique_unordered {list} { lunique $list @@ -2371,13 +2484,33 @@ namespace eval punk::lib { struct::set union $list {} } } else { - puts stderr "WARNING: struct::set union no longer dedupes!" + #struct::set union operates on a 'set' - so this probably won't change, and hopefully is + #consistent across unacelerated versions and those implemented in accelerators, + #but if it ever does change - be a little noisy about it. + puts stderr "punk::lib WARNING: struct::set union no longer dedupes!" #we could also test a sequence of: struct::set add } } - #order-preserving + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lunique + @cmd -name punk::lib::lunique\ + -summary\ + "Order-preserving unique values in list"\ + -help\ + "Return unique values in provided list. + This removes duplicates whilst preserving the + original order of the provided list. + + When struct::set is available with acceleration, + lunique_unordered may be slightly faster." + @values -min 1 -max 1 + list -type list + }] + } proc lunique {list} { set new {} foreach item $list { @@ -2569,18 +2702,21 @@ namespace eval punk::lib { To validate if an indexset is strictly within range, both the length of the data and the base would need to be considered. - The normal 'range' specifier is .. + The normal 'range' specifier is .. but can be of the form .x. where x is the step value. The range specifier can appear at the beginning, middle or end, or even alone to indicate the entire range of valid values. e.g the following are all valid ranges - 1.. - (index 1 to 'max') - ..10 - (index 'base' to 10) - 2..11 - (index 2 to 11) - .. - (all indices) + 1.. + (index 1 to 'max') + ..10 + (index 'base' to 10) + 2..11 + (index 2 to 11) + .. + (all indices) + .3. + (1st index and every 3rd index thereafter) + Common whitespace elements space,tab,newlines are ignored. Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands, e.g end-2 or 2+2. @@ -2670,20 +2806,19 @@ namespace eval punk::lib { .-1. would represent end to base with step -1 If start is omitted and only the end is supplied: - The default step is 1 indicating ascension and the missing end is equivalent to 'end' - indexset_resolve 5 2.. - -> 2 3 4 - The default end is the base if the step is negative - indexset_resolve 5 2.-1. - -> 2 1 0 - If end is omitted and onlthe start is supplied: The default step is 1 indicating ascension and the missing start is equivalent to the base. indexset_resolve 5 ..2 -> 0 1 2 The default start is 'end' if the step is negative indexset_resolve 5 .-1.2 -> 4 3 2 - + If end is omitted and only the start is supplied: + The default step is 1 indicating ascension and the missing end is equivalent to 'end' + indexset_resolve 5 2.. + -> 2 3 4 + The default end is the base if the step is negative + indexset_resolve 5 2.-1. + -> 2 1 0 Like the tcl9 lseq command - a step (by) value of zero produces no results. @@ -2703,7 +2838,7 @@ namespace eval punk::lib { indexset examples: - These assume the default 0-based indices (base == 0) + These assume the default 0-based indices (-base 0) 1,3.. output the index 1 (2nd item) followed by all from index 3 to the end. @@ -3604,7 +3739,7 @@ namespace eval punk::lib { @id -id ::punk::lib::gcd @cmd -name punk::lib::gcd\ -summary\ - "Gretest common divisor of m and n."\ + "Greatest common divisor of m and n."\ -help\ "Return the greatest common divisor of m and n. Straight from Lars Hellström's math::numtheory library in Tcllib @@ -3643,12 +3778,22 @@ namespace eval punk::lib { return $m } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lcm + @cmd -name punk::lib::lcm\ + -summary\ + "Lowest common multiple of m and n."\ + -help\ + "Return the lowest common multiple of m and n. + Straight from Lars Hellström's math::numtheory library in Tcllib" + @values -min 2 -max 2 + m -type integer + n -type integer + }] + } proc lcm {n m} { - #*** !doctools - #[call [fun gcd] [arg n] [arg m]] - #[para]Return the lowest common multiple of m and n - #[para]Straight from Lars Hellström's math::numtheory library in Tcllib - #[para] set gcd [gcd $n $m] return [expr {$n*$m/$gcd}] } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm index 96f506b5..c0f2b7ba 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm @@ -1036,7 +1036,8 @@ namespace eval punk::repl::class { # set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""] # incr nextrow -1 #} - set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""] + #set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""] + ledit o_rendered_lines $cursor_row_idx $cursor_row_idx-1 "" set o_cursor_col 1 } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm index 9c44ea72..c610c667 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm @@ -323,7 +323,8 @@ namespace eval punkcheck { if {$isnew} { lappend record_list $o_fileset_record } else { - set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record] + #set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record] + ledit record_list $oldposition $oldposition-1 $o_fileset_record } if {$o_operation ne "QUERY"} { punkcheck::save_records_to_file $record_list $punkcheck_file @@ -536,7 +537,8 @@ namespace eval punkcheck { set existing_header_posn [dict get $resultinfo position] if {$existing_header_posn == -1} { set this_installer_record [punkcheck::recordlist::new_installer_record $o_name] - set o_record_list [linsert $o_record_list 0 $this_installer_record] + #set o_record_list [linsert $o_record_list 0 $this_installer_record] + ledit o_record_list -1 -1 $this_installer_record } else { set this_installer_record [dict get $resultinfo record] } @@ -616,7 +618,8 @@ namespace eval punkcheck { set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records] set existing_header_posn [dict get $persistedinfo position] if {$existing_header_posn == -1} { - set file_records [linsert $file_records 0 $this_installer_record] + #set file_records [linsert $file_records 0 $this_installer_record] + ledit file_records -1 -1 $this_installer_record } else { lset file_records $existing_header_posn $this_installer_record } @@ -710,7 +713,8 @@ namespace eval punkcheck { if {$existing_header_posn == -1} { #not found - prepend - set record_list [linsert $record_list 0 $this_installer_record] + #set record_list [linsert $record_list 0 $this_installer_record] + ledit record_list -1 -1 $this_installer_record } else { #replace lset record_list $existing_header_posn $this_installer_record @@ -791,7 +795,8 @@ namespace eval punkcheck { if {$isnew} { lappend record_list $file_record } else { - set record_list [linsert $record_list[unset record_list] $oldposition $file_record] + #set record_list [linsert $record_list[unset record_list] $oldposition $file_record] + ledit record_list $oldposition $oldposition-1 $file_record } save_records_to_file $record_list $punkcheck_file @@ -1191,7 +1196,8 @@ namespace eval punkcheck { # dst is: base/sub = sub while {$baselen > 0} { - set dst [linsert $dst 0 ..] + #set dst [linsert $dst 0 ..] + ledit dst -1 -1 .. incr baselen -1 } set dst [file join {*}$dst] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm index 93e4a41c..4079254e 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm @@ -4480,7 +4480,8 @@ tcl::namespace::eval textblock { set code_idx 3 foreach {pt code} [lrange $parts 2 end] { if {[punk::ansi::codetype::is_sgr_reset $code]} { - set parts [linsert $parts $code_idx+1 $base] + #set parts [linsert $parts $code_idx+1 $base] + ledit parts $code_idx+1 $code_idx $base } incr code_idx 2 } @@ -4504,12 +4505,14 @@ tcl::namespace::eval textblock { #first pt & code if {$pt ne ""} { #leading plaintext - set parts [linsert $parts 0 $base] + #set parts [linsert $parts 0 $base] + ledit parts -1 -1 $base incr offset } } if {[punk::ansi::codetype::is_sgr_reset $code]} { set parts [linsert $parts [expr {$code_idx+1+$offset}] $base] + #ledit parts [expr {$code_idx+1+$offset}] $code_idx+$offset $base incr offset } incr code_idx 2 @@ -5371,6 +5374,9 @@ tcl::namespace::eval textblock { r-1 { if {[lindex $line_chunks end] eq ""} { set line_chunks [linsert $line_chunks end-2 $pad] + #breaks layout e.g subtables in: i i + #why? + #ledit line_chunks end-2 end-3 $pad } else { lappend line_chunks $pad } @@ -5379,13 +5385,16 @@ tcl::namespace::eval textblock { lappend line_chunks $pad } l-0 { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } l-1 { if {[lindex $line_chunks 0] eq ""} { - set line_chunks [linsert $line_chunks 2 $pad] + #set line_chunks [linsert $line_chunks 2 $pad] + ledit line_chunks 2 1 $pad } else { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } } l-2 { @@ -5393,10 +5402,12 @@ tcl::namespace::eval textblock { if {[lindex $line_chunks 0] eq ""} { set line_chunks [linsert $line_chunks 2 $pad] } else { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } } else { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } } } @@ -5466,14 +5477,17 @@ tcl::namespace::eval textblock { #} else { # set line_chunks [linsert $line_chunks 0 $pad] #} - set line_chunks [linsert $line_chunks 0 $pad] + + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } l-1 { #set line_chunks [linsert $line_chunks 0 $pad] set line_chunks [_insert_before_text_or_last_ansi $pad $line_chunks] } l-2 { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } } } diff --git a/src/vfs/_vfscommon.vfs/modules/dictn-0.1.2.tm b/src/vfs/_vfscommon.vfs/modules/dictn-0.1.2.tm index 2ed2b1ef..5a7de769 100644 --- a/src/vfs/_vfscommon.vfs/modules/dictn-0.1.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/dictn-0.1.2.tm @@ -25,17 +25,46 @@ namespace eval dictn { namespace export {[a-z]*} namespace ensemble create + + namespace eval argdoc { + variable PUNKARGS + #non-colour SGR codes + set I "\x1b\[3m" ;# [a+ italic] + set NI "\x1b\[23m" ;# [a+ noitalic] + set B "\x1b\[1m" ;# [a+ bold] + set N "\x1b\[22m" ;# [a+ normal] + set T "\x1b\[1\;4m" ;# [a+ bold underline] + set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] + } } ## ::dictn::append -#This can of course 'ruin' a nested dict if applied to the wrong element -# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: -# %set list {a b {c d}} -# %append list x -# a b {c d}x -# IOW - don't do that unless you really know that's what you want. # +tcl::namespace::eval ::dictn::argdoc { + lappend PUNKARGS [list { + @id -id ::dictn::append + @cmd -name dictn::append\ + -summary\ + "Append a single string to the value at dict path."\ + -help\ + "Append a single string to the value at a given dictionary path. + + This can of course 'ruin' a nested dict if applied to the wrong element + - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: + %set list {a b {c d}} + %append list x + a b {c d}x + IOW - don't do that unless you really know that's what you want. + + Note than unlike dict append - only a single value is accepted for appending. + " + @values -min 2 -max 3 + dictvar -type string + path -type list + value -type any -default "" -optional 1 + }] +} proc ::dictn::append {dictvar path {value {}}} { if {[llength $path] == 1} { uplevel 1 [list dict append $dictvar $path $value] @@ -43,7 +72,7 @@ proc ::dictn::append {dictvar path {value {}}} { upvar 1 $dictvar dvar ::set str [dict get $dvar {*}$path] - append str $val + append str $value dict set dvar {*}$path $str } } @@ -73,6 +102,25 @@ proc ::dictn::for {keyvalvars dictval path body} { proc ::dictn::get {dictval {path {}}} { return [dict get $dictval {*}$path] } +tcl::namespace::eval ::dictn::argdoc { + lappend PUNKARGS [list { + @id -id ::dictn::getn + @cmd -name dictn::getn\ + -summary\ + "Get one or more paths in a dict simultaneously."\ + -help\ + "" + @values -min 1 -max -1 + dictvar -type string + path -type list -multiple 1 + }] +} +proc ::dictn::getn {dictval args} { + if {![llength $args]} { + return [::tcl::dict::get $dictval] + } + lmap path $args {::tcl::dict::get $dictval {*}$path} +} if {[info commands ::tcl::dict::getdef] ne ""} { @@ -85,10 +133,18 @@ if {[info commands ::tcl::dict::getdef] ne ""} { return [dict getdef $dictval {*}$path $default] } - proc ::dictn::incr {dictvar path {increment {}} } { - if {$increment eq ""} { - ::set increment 1 + proc ::dictn::incr {dictvar path {increment 1} } { + upvar 1 $dictvar dvar + if {[llength $path] == 1} { + return [::tcl::dict::incr dvar $path $increment] + } + if {[::tcl::info::exists dvar]} { + ::set increment [expr {[::tcl::dict::getdef $dvar {*}$path 0] + $increment}] } + return [::tcl::dict::set dvar {*}$path $increment] + } + #test - compare disassembly + proc ::dictn::incr2 {dictvar path {increment 1} } { if {[llength $path] == 1} { uplevel 1 [list dict incr $dictvar $path $increment] } else { @@ -233,6 +289,33 @@ proc ::dictn::set {dictvar path newval} { return [dict set dvar {*}$path $newval] } +tcl::namespace::eval ::dictn::argdoc { + lappend PUNKARGS [list { + @id -id ::dictn::setn + @cmd -name dictn::setn\ + -summary\ + "Set one or more paths in a dict to value(s)"\ + -help\ + "" + @values -min 3 -max -1 + dictvar -type string + path_newval -type {path newval} -multiple 1 + }] +} +proc ::dictn::setn {dictvar args} { + if {[llength $args] == 0} { + error "dictn::setn requires at least one pair" + } + if {[llength $args] % 2 != 0} { + error "dictn::setn requires trailing pairs" + } + upvar 1 $dictvar dvar + foreach {p v} $args { + ::tcl::dict::set dvar {*}$p $v + } + return $dvar +} + proc ::dictn::size {dictval {path {}}} { return [dict size [dict get $dictval {*}$path]] } @@ -312,6 +395,46 @@ proc ::dictn::values {dictval {path {}} {glob {}}} { } } +tcl::namespace::eval ::dictn::argdoc { + lappend PUNKARGS [list { + @id -id ::dictn::with + @cmd -name dictn::with\ + -summary\ + "Execute script for each key at dict path."\ + -help\ + "Execute the Tcl script in body with the value for each key within the + given key-path mapped to either variables or keys in a specified array. + + If the name of an array variable is not supplied for arrayvar, + dictn with behaves like dict with, except that it accepts a list + for the possibly nested key-path instead of separate arguments. + + The subkeys of the dict at the given key-path will create variables + in the calling scope. + + If an arrayvar is passed, an array of that name in the calling + scope will be populated with keys and values from the subkeys and + values of the dict at the given key-path." + @form -form standard + @values -min 3 -max 3 + dictvar -type string + path -type list + body -type string + + @form -form array + @values -min 4 -max 4 + dictvar -type string + path -type list + arrayvar -type string -help\ + "Name of array variable in which key values are + stored for the given dict path. + This prevents key values being used as variable + names in the calling scope, instead capturing them + as keys in the single specified array at the calling + scope." + body -type string + }] +} # Standard form: #'dictn with dictVariable path body' # @@ -351,7 +474,10 @@ proc ::dictn::with {dictvar path args} { - +::tcl::namespace::eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::dictn +} diff --git a/src/vfs/_vfscommon.vfs/modules/overtype-1.7.3.tm b/src/vfs/_vfscommon.vfs/modules/overtype-1.7.3.tm index ef774919..e6828473 100644 --- a/src/vfs/_vfscommon.vfs/modules/overtype-1.7.3.tm +++ b/src/vfs/_vfscommon.vfs/modules/overtype-1.7.3.tm @@ -569,9 +569,10 @@ tcl::namespace::eval overtype { #while {$overidx < [llength $inputchunks]} { } while {[llength $inputchunks]} { - #set overtext [lindex $inputchunks $overidx]; lset inputchunks $overidx "" - set overtext [lpop inputchunks 0] - if {![tcl::string::length $overtext]} { + set overtext [lpop inputchunks 0] ;#could be a list 'ansisplit' or text 'plain|mixed' + + #use eq test with emptystring instead of 'string length' - test for emptiness shouldn't cause shimmering if popped inputchunks member if an 'ansisplit' list + if {$overtext eq ""} { incr loop continue } @@ -582,7 +583,6 @@ tcl::namespace::eval overtype { #renderline pads each underaly line to width with spaces and should track where end of data is - #set overtext [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext] set overtext $replay_codes_overlay$overtext if {[tcl::dict::exists $replay_codes_underlay $row]} { set undertext [tcl::dict::get $replay_codes_underlay $row]$undertext @@ -827,6 +827,9 @@ tcl::namespace::eval overtype { set foldline [tcl::dict::get $sub_info result] tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..? tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this.. + + #todo!!! + # 2025 fix - this does nothing - so what uses it?? create a test! linsert outputlines $renderedrow $foldline #review - row & col set by restore - but not if there was no save.. } @@ -919,9 +922,23 @@ tcl::namespace::eval overtype { set edit_mode 0 if {$edit_mode} { - set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] + #set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] + #JMN + ledit inputchunks -1 -1 $overflow_right$unapplied + + set pt_ansi_pt [punk::ansi::ta::split_codes_single $overflow_right] + #join the trailing and leading pt parts of the 2 lists + ledit pt_ansi_pt end end "[lindex $pt_ansi_pt end][lindex $unapplied_list 0]" + lappend pt_ansi_pt [lrange $unapplied_list 1 end] + + ledit inputchunks -1 -1 $pt_ansi_pt ;#combined overflow_right and unapplied - in ansisplit form + #JMN 2025 + set overtext_type "ansisplit" + set overflow_right "" set unapplied "" + set unapplied_list [list] + set row $post_render_row #set col $post_render_col set col $opt_startcolumn @@ -1311,7 +1328,9 @@ tcl::namespace::eval overtype { } if {$nextprefix ne ""} { - set inputchunks [linsert $inputchunks 0 $nextprefix] + #set inputchunks [linsert $inputchunks 0 $nextprefix] + #JMN - assume backwards compat ledit available from punk::lib (for tcl <9) + ledit inputchunks -1 -1 $nextprefix } @@ -2026,7 +2045,10 @@ tcl::namespace::eval overtype { -cursor_restore_attributes ""\ -cp437 0\ -experimental {}\ + -overtext_type mixed\ ] + #-overtext_type plain|mixed|ansisplit + #-cursor_restore_attributes only - for replay stack - position and actual setting/restoring handled by throwback to caller #cursor_row, when numeric will allow detection of certain row moves that are still within our row - allowing us to avoid an early return @@ -2040,7 +2062,7 @@ tcl::namespace::eval overtype { switch -- $k { -experimental - -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row - -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode - - -info - -exposed1 - -exposed2 - -cursor_restore_attributes { + - -info - -exposed1 - -exposed2 - -cursor_restore_attributes - -overtext_type { tcl::dict::set opts $k $v } default { @@ -2055,6 +2077,7 @@ tcl::namespace::eval overtype { set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay set opt_colcursor [tcl::dict::get $opts -cursor_column];#start cursor column relative to overlay set opt_row_context [tcl::dict::get $opts -cursor_row] + set opt_overtext_type [tcl::dict::get $opts -overtext_type] if {[string length $opt_row_context]} { if {![tcl::string::is integer -strict $opt_row_context] || $opt_row_context <1 } { error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'" @@ -2128,9 +2151,16 @@ tcl::namespace::eval overtype { #set under [textutil::tabify::untabify2 $under] set under [textutil::tabify::untabifyLine $under $tw] } - if {[string first \t $over] >= 0} { - #set overdata [textutil::tabify::untabify2 $over] - set overdata [textutil::tabify::untabifyLine $over $tw] + + #review - is untabifying sensible at this point?? + if {$opt_overtext_type eq "ansisplit"} { + #todo - something for each pt part? + } else { + #plain|mixed + if {[string first \t $over] >= 0} { + #set overdata [textutil::tabify::untabify2 $over] + set overdata [textutil::tabify::untabifyLine $over $tw] + } } } } @@ -2415,11 +2445,21 @@ tcl::namespace::eval overtype { set startpadding [string repeat " " [expr {$opt_colstart -1}]] #overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency if {$startpadding ne "" || $overdata ne ""} { - if {[punk::ansi::ta::detect $overdata]} { - set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] + if {$opt_overtext_type eq "ansisplit"} { + set overmap $overdata + lset overmap 0 "$startpadding[lindex $overmap 0]" } else { - #single plaintext part - set overmap [list $startpadding$overdata] + if {[punk::ansi::ta::detect $overdata]} { + #TODO!! rework this. + #e.g 200K+ input file with no newlines - we are wastefully calling split_codes_single repeatedly on mostly the same data. + #set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] + set overmap [punk::ansi::ta::split_codes_single $overdata] + lset overmap 0 "$startpadding[lindex $overmap 0]" + + } else { + #single plaintext part + set overmap [list $startpadding$overdata] + } } } else { set overmap [list] @@ -2453,8 +2493,13 @@ tcl::namespace::eval overtype { set pt_overchars "" set i_o 0 set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use - #experiment + + set overlay_grapheme_control_stacks [list] + #REVIEW - even if we pass in a pre-split overtext (-overtext_type ansisplit) + #we are re-generating the overlay_grapheme_control_stacks list each time + #this is a big issue when overtext is not broken into lines, but is just a big long ansi and/or plain text string. + #todo - return also the unapplied portion of the overlay_grapheme_control_stacks list?? foreach {pt code} $overmap { if {$pt ne ""} { #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) @@ -2725,7 +2770,9 @@ tcl::namespace::eval overtype { if {[llength [split $chars ""]] > 1} { priv::render_unapplied $overlay_grapheme_control_list $gci #prefix the unapplied controls with the string version of this control - set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + #set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + #JMN - backwards compat ledit from punk::lib for tcl <9 + ledit unapplied_list -1 -1 {*}[split $chars ""] set unapplied [join $unapplied_list ""] #incr idx_over break @@ -3085,7 +3132,9 @@ tcl::namespace::eval overtype { set chars [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $item] priv::render_unapplied $overlay_grapheme_control_list $gci #prefix the unapplied controls with the string version of this control - set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + #set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + #JMN + ledit unapplied_list -1 -1 {*}[split $chars ""] set unapplied [join $unapplied_list ""] break @@ -4923,13 +4972,18 @@ tcl::namespace::eval overtype::priv { } else { #insert of single-width vs double-width when underlying is double-width? if {$i < $nxt} { - set o [linsert $o $i $c] + #set o [linsert $o $i $c] + #JMN insert via ledit + ledit o $i $i-1 $c } else { lappend o $c } if {$i < [llength $ustacks]} { - set ustacks [linsert $ustacks $i $sgrstack] - set gxstacks [linsert $gxstacks $i $gx0stack] + #set ustacks [linsert $ustacks $i $sgrstack] + #set gxstacks [linsert $gxstacks $i $gx0stack] + #insert via ledit + ledit ustacks $i $i-1 $sgrstack + ledit gxstacks $i $i-1 $gx0stack } else { lappend ustacks $sgrstack lappend gxstacks $gx0stack diff --git a/src/vfs/_vfscommon.vfs/modules/overtype-1.7.4.tm b/src/vfs/_vfscommon.vfs/modules/overtype-1.7.4.tm new file mode 100644 index 00000000..439fd3b1 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/overtype-1.7.4.tm @@ -0,0 +1,5199 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) Julian Noble 2003-2023 +# +# @@ Meta Begin +# Application overtype 1.7.4 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin overtype_module_overtype 0 1.7.4] +#[copyright "2024"] +#[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}] +#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}] +#[require overtype] +#[keywords module text ansi] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of overtype +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by overtype +#[list_begin itemized] + +package require Tcl 8.6- +package require textutil +package require punk::lib ;#required for lines_as_list +package require punk::ansi ;#required to detect, split, strip and calculate lengths +package require punk::char ;#box drawing - and also unicode character width determination for proper layout of text with double-column-width chars +package require punk::assertion +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package textutil] +#[item] [package punk::ansi] +#[para] - required to detect, split, strip and calculate lengths of text possibly containing ansi codes +#[item] [package punk::char] +#[para] - box drawing - and also unicode character width determination for proper layout of text with double-column-width chars + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +#PERFORMANCE notes +#overtype is very performance sensitive - used in ansi output all over the place ie needs to be optimised +#NOTE use of tcl::dict::for tcl::string::range etc instead of ensemble versions. This is for the many tcl 8.6/8.7 interps which don't compile ensemble commands when in safe interps +#similar for tcl::namespace::eval - but this is at least on some versions of Tcl - faster even in a normal interp. Review to see if that holds for Tcl 9. +#for string map: when there are exactly 2 elements - it is faster to use a literal which has a special case optimisation in the c code +#ie use tcl::string::map {\n ""} ... instead of tcl::string::map [list \n ""] ... +#note that we can use unicode (e.g \uFF31) and other escapes such as \t within these curly braces - we don't have to use double quotes +#generally using 'list' is preferred for the map as less error prone. +#can also use: tcl::string::map "token $var" .. but be careful regarding quoting and whitespace in var. This should be used sparingly if at all. + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section API] + + +#Julian Noble - 2003 +#Released under standard 'BSD license' conditions. +# +#todo - ellipsis truncation indicator for center,right + +#v1.4 2023-07 - naive ansi color handling - todo - fix tcl::string::range +# - need to extract and replace ansi codes? + +tcl::namespace::eval overtype { + namespace import ::punk::assertion::assert + punk::assertion::active true + + namespace path ::punk::lib + + namespace export * + variable default_ellipsis_horizontal "..." ;#fallback + variable default_ellipsis_vertical "..." + tcl::namespace::eval priv { + proc _init {} { + upvar ::overtype::default_ellipsis_horizontal e_h + upvar ::overtype::default_ellipsis_vertical e_v + set e_h [format %c 0x2026] ;#Unicode Horizontal Ellipsis + set e_v [format %c 0x22EE] + #The unicode ellipsis looks more natural than triple-dash which is centred vertically whereas ellipsis is at floorline of text + #Also - unicode ellipsis has semantic meaning that other processors can interpret + #unicode does also provide a midline horizontal ellipsis 0x22EF + + #set e [format %c 0x2504] ;#punk::char::charshort boxd_ltdshhz - Box Drawings Light Triple Dash Horizontal + #if {![catch {package require punk::char}]} { + # set e [punk::char::charshort boxd_ltdshhz] + #} + } + } + priv::_init +} +proc overtype::about {} { + return "ANSI capable text formatting. Author JMN. BSD-License" +} + +tcl::namespace::eval overtype { + variable grapheme_widths [tcl::dict::create] + + variable escape_terminals + #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). + tcl::dict::set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"] + #tcl::dict::set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic + tcl::dict::set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals + + #self-contained 2 byte ansi escape sequences - review more? + variable ansi_2byte_codes_dict + set ansi_2byte_codes_dict [tcl::dict::create\ + "reset_terminal" "\u001bc"\ + "save_cursor_posn" "\u001b7"\ + "restore_cursor_posn" "\u001b8"\ + "cursor_up_one" "\u001bM"\ + "NEL - Next Line" "\u001bE"\ + "IND - Down one line" "\u001bD"\ + "HTS - Set Tab Stop" "\u001bH"\ + ] + + #debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. + # "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ +} + + + + +proc overtype::string_columns {text} { + if {[punk::ansi::ta::detect $text]} { + #error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::ansistrip. Alternatively try punk::ansi::printing_length" + set text [punk::ansi::ansistrip $text] + } + return [punk::char::ansifreestring_width $text] +} + +#todo - consider a way to merge overtype::left/centre/right +#These have similar algorithms/requirements - and should be refactored to be argument-wrappers over a function called something like overtype::renderblock +#overtype::renderblock could render the input to a defined (possibly overflowing in x or y) rectangle overlapping the underlay. +#(i.e not even necessariy having it's top left within the underlay) +tcl::namespace::eval overtype::priv { +} + +#could return larger than renderwidth +proc _get_row_append_column {row} { + #obsolete? + upvar outputlines outputlines + set idx [expr {$row -1}] + if {$row <= 1 || $row > [llength $outputlines]} { + return 1 + } else { + upvar opt_expand_right expand_right + upvar renderwidth renderwidth + set existinglen [punk::ansi::printing_length [lindex $outputlines $idx]] + set endpos [expr {$existinglen +1}] + if {$expand_right} { + return $endpos + } else { + if {$endpos > $renderwidth} { + return [expr {$renderwidth + 1}] + } else { + return $endpos + } + } + } +} + +tcl::namespace::eval overtype { + #*** !doctools + #[subsection {Namespace overtype}] + #[para] Core API functions for overtype + #[list_begin definitions] + + namespace eval argdoc { + variable PUNKARGS + #non-colour SGR codes + set I "\x1b\[3m" ;# [a+ italic] + set NI "\x1b\[23m" ;# [a+ noitalic] + set B "\x1b\[1m" ;# [a+ bold] + set N "\x1b\[22m" ;# [a+ normal] + set T "\x1b\[1\;4m" ;# [a+ bold underline] + set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] + interp alias "" ::overtype::example "" ::punk::args::helpers::example + } + + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::overtype::renderspace + @cmd -name overtype::renderspace\ + -summary\ + {}\ + -help\ + {} + @opts + #because underblocks value is optional - restrict opts to flag pairs (no solos) + #We don't use punk::args::parse in the actual function to parse args - so keep it simpler. + -bias -default left -type string -choices {left right} -help ignored + -width -default \uFFEF -type integer + -height -default \uFFEF -type integer + -startcolumn -default 1 -type integer + -startrow -default 1 -type integer + -ellipsis -default 0 -type boolean + -ellipsistext -default ${$::overtype::default_ellipsis_horizontal} -type char + -ellipsiswhitespace -default 0 -type boolean + -expand_right -default 0 -type boolean + -appendlines -default 1 -type boolean + -transparent -default 0 -type {literal(0)|literal(1)|regexp} -help\ + "0 to disable transparency processing + 1 to enable space characters in the + overlay to be transparent, or a regex + to match the character(s) required to be + transparent in the overlay." + -exposed1 -default \uFFFD -type char -help\ + {A character of single terminal column width to use + as replacement when first-half of an underlying char + is exposed due to overlay positioning/transparency + which obscures the second-half of the char. May be ANSI + coloured as this doesn't affect the display width. + Default is \uFFFD - the unicode replacement char.} + -exposed2 -default \uFFFD -type char -help\ + {A character of single terminal column width to use + as replacement when second-half of an underlying char + is exposed due to overlay positioning/transparency + which obscures the first-half of the char. May be ANSI + coloured as this doesn't affect the display width. + Default is \uFFFD - the unicode replacement char.} + + -experimental -default 0 + -cp437 -default 0 -type boolean + -looplimit -default \uFFEF\ -type integer -help\ + "internal failsafe - experimental" + -crm_mode -default 0 -type boolean + -reverse_mode -default 0 -type boolean + -insert_mode -default 1 -type boolean + -wrap -default 0 -type boolean + -info -default 0 -type boolean -help\ + "When set to 1, return a dictionary (experimental)" + -console -default {stdin stdout stderr} -type list + + @values -min 1 -max 2 + underblock -type string -optional 1 + overblock -type string -optional 0 + }] + } + + + #tcl::string::range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r + #render onto an already-rendered (ansi already processed) 'underlay' string, a possibly ansi-laden 'overlay' string. + #The underlay and overlay can be multiline blocks of text of varying line lengths. + #The overlay may just be an ansi-colourised block - or may contain ansi cursor movements and cursor save/restore calls - in which case the apparent length and width of the overlay can't be determined as if it was a block of text. + #This is a single-shot rendering of strings - ie there is no way to chain another call containing a cursor-restore to previously rendered output and have it know about any cursor-saves in the first call. + # a cursor start position other than top-left is a possible addition to consider. + #see editbuf in punk::repl for a more stateful ansi-processor. Both systems use loops over overtype::renderline + proc renderspace {args} { + #*** !doctools + #[call [fun overtype::renderspace] [arg args] ] + #[para] usage: ?-transparent [lb]0|1[rb]? ?-expand_right [lb]1|0[rb]? ?-ellipsis [lb]1|0[rb]? ?-ellipsistext ...? undertext overtext + + # @c overtype starting at left (overstrike) + # @c can/should we use something like this?: 'format "%-*s" $len $overtext + variable default_ellipsis_horizontal + + if {[llength $args] < 1} { + error {usage: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-expand_right [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} + } + set optargs [lrange $args 0 end-2] + if {[llength $optargs] % 2 == 0} { + set overblock [lindex $args end] + set underblock [lindex $args end-1] + #lassign [lrange $args end-1 end] underblock overblock + set argsflags [lrange $args 0 end-2] + } else { + #no solo flags - so we assume only an overblock was supplied + set overblock [lindex $args end] + set underblock "" + set argsflags [lrange $args 0 end-1] + + #set optargs [lrange $args 0 end-1] + #if {[llength $optargs] %2 == 0} { + # set overblock [lindex $args end] + # set underblock "" + # set argsflags [lrange $args 0 end-1] + #} else { + # error "renderspace expects opt-val pairs followed by: or just " + #} + } + set opts [tcl::dict::create\ + -bias ignored\ + -width \uFFEF\ + -height \uFFEF\ + -startcolumn 1\ + -startrow 1\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -expand_right 0\ + -appendlines 1\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -experimental 0\ + -cp437 0\ + -looplimit \uFFEF\ + -crm_mode 0\ + -reverse_mode 0\ + -insert_mode 0\ + -wrap 0\ + -info 0\ + -console {stdin stdout stderr}\ + ] + #expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally.. + # it does not necessarily mean the viewport grows. (which further implies need for horizontal scrolling) + # - it does need to be within some concept of terminal width - as columns must be addressable by ansi sequences. + # - This implies the -width option value must grow if it is tied to the concept of renderspace terminal width! REVIEW. + # - further implication is that if expand_right grows the virtual renderspace terminal width - + # then some sort of reflow/rerender needs to be done for preceeding lines? + # possibly not - as expand_right is distinct from a normal terminal-width change event, + # expand_right being primarily to support other operations such as textblock::table + + #todo - viewport width/height as separate concept to terminal width/height? + #-ellipsis args not used if -wrap is true + foreach {k v} $argsflags { + switch -- $k { + -looplimit - -width - -height - -startcolumn - -startrow - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace + - -transparent - -exposed1 - -exposed2 - -experimental + - -expand_right - -appendlines + - -reverse_mode - -crm_mode - -insert_mode + - -cp437 + - -info - -console { + tcl::dict::set opts $k $v + } + -wrap - -autowrap_mode { + #temp alias -autowrap_mode for consistency with renderline + #todo - + tcl::dict::set opts -wrap $v + } + default { + error "overtype::renderspace unknown option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + #set opts [tcl::dict::merge $defaults $argsflags] + # -- --- --- --- --- --- + #review - expand_left for RTL text? + set opt_expand_right [tcl::dict::get $opts -expand_right] + #for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line. + set opt_width [tcl::dict::get $opts -width] + set opt_height [tcl::dict::get $opts -height] + set opt_startcolumn [tcl::dict::get $opts -startcolumn] + set opt_startrow [tcl::dict::get $opts -startrow] + set opt_appendlines [tcl::dict::get $opts -appendlines] + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_exposed1 [tcl::dict::get $opts -exposed1] ;#widechar_exposed_left - todo + set opt_exposed2 [tcl::dict::get $opts -exposed2] ;#widechar_exposed_right - todo + # -- --- --- --- --- --- + set opt_crm_mode [tcl::dict::get $opts -crm_mode] + set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] + set opt_insert_mode [tcl::dict::get $opts -insert_mode] + ##### + # review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?. + set opt_autowrap_mode [tcl::dict::get $opts -wrap] + #??? wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo) + ##### + # -- --- --- --- --- --- + set opt_cp437 [tcl::dict::get $opts -cp437] + set opt_info [tcl::dict::get $opts -info] + + + + # ---------------------------- + # -experimental dev flag to set flags etc + # ---------------------------- + set data_mode 0 + set edit_mode 0 + set opt_experimental [tcl::dict::get $opts -experimental] + foreach o $opt_experimental { + switch -- $o { + data_mode { + set data_mode 1 + } + edit_mode { + set edit_mode 1 + } + } + } + # ---------------------------- + + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] + if {$opt_startrow > 1} { + set down [expr {$opt_startrow -1}] + set overblock [punk::ansi::move_down $down]$overblock + } + + + #set underlines [split $underblock \n] + + #underblock is a 'rendered' block - so width height make sense + #only non-cursor affecting and non-width occupying ANSI codes should be present. + #ie SGR codes and perhaps things such as PM - although generally those should have been pushed to the application already + #renderwidth & renderheight were originally used with reference to rendering into a 'column' of output e.g a table column - before cursor row/col was implemented. + + if {$opt_width eq "\uFFEF" || $opt_height eq "\uFFEF"} { + lassign [blocksize $underblock] _w renderwidth _h renderheight + if {$opt_width ne "\uFFEF"} { + set renderwidth $opt_width + } + if {$opt_height ne "\uFFEF"} { + set renderheight $opt_height + } + } else { + set renderwidth $opt_width + set renderheight $opt_height + } + #initial state for renderspace 'terminal' reset + set initial_state [dict create\ + renderwidth $renderwidth\ + renderheight $renderheight\ + crm_mode $opt_crm_mode\ + reverse_mode $opt_reverse_mode\ + insert_mode $opt_insert_mode\ + autowrap_mode $opt_autowrap_mode\ + cp437 $opt_cp437\ + ] + #modes + #e.g insert_mode can be toggled by insert key or ansi IRM sequence CSI 4 h|l + #opt_startcolumn ?? - DECSLRM ? + set vtstate $initial_state + + # -- --- --- --- + #REVIEW - do we need ansi resets in the underblock? + if {$underblock eq ""} { + set underlines [lrepeat $renderheight ""] + } else { + set underblock [textblock::join_basic -- $underblock] ;#ensure properly rendered - ansi per-line resets & replays + set underlines [split $underblock \n] + } + #if {$underblock eq ""} { + # set blank "\x1b\[0m\x1b\[0m" + # #set underlines [list "\x1b\[0m\x1b\[0m"] + # set underlines [lrepeat $renderheight $blank] + #} else { + # #lines_as_list -ansiresets 1 will do nothing if -ansiresets 1 isn't specified - REVIEW + # set underlines [lines_as_list -ansiresets 1 $underblock] + #} + # -- --- --- --- + + #todo - reconsider the 'line' as the natural chunking mechanism for the overlay. + #In practice an overlay ANSI stream can be a single line with ansi moves/restores etc - or even have no moves or newlines, just relying on wrapping at the output renderwidth + #In such cases - we process the whole shebazzle for the first output line - only reducing by the applied amount at the head each time, reprocessing the long tail each time. + #(in cases where there are interline moves or cursor jumps anyway) + #This works - but doesn't seem efficient. + #On the other hand.. maybe it depends on the data. For simpler files it's more efficient than splitting first + + #a hack until we work out how to avoid infinite loops... + # + set looplimit [tcl::dict::get $opts -looplimit] + if {$looplimit eq "\uFFEF"} { + #looping for each char is worst case (all newlines?) - anything over that is an indication of something broken? + #do we need any margin above the length? (telnet mapscii.me test) + set looplimit [expr {[tcl::string::length $overblock] + 10}] + } + + #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height + #lassign [blocksize $overblock] _w overblock_width _h overblock_height + + set scheme 4 + switch -- $scheme { + 0 { + #one big chunk + set inputchunks [list mixed $overblock] + } + 1 { + #todo + set inputchunks [punk::ansi::ta::split_codes $overblock] + } + 2 { + #todo + #split into lines if possible first - then into plaintext/ansi-sequence chunks ? + set inputchunks [list ""] ;#put an empty plaintext split in for starters + set i 1 + set lines [split $overblock \n] + foreach ln $lines { + if {$i < [llength $lines]} { + append ln \n + } + set sequence_split [punk::ansi::ta::split_codes_single $ln] ;#use split_codes Not split_codes_single? + set lastpt [lindex $inputchunks end] + lset inputchunks end [tcl::string::cat $lastpt [lindex $sequence_split 0]] + lappend inputchunks {*}[lrange $sequence_split 1 end] + incr i + } + } + 3 { + #todo + #it turns out line based chunks are faster than the above.. probably because some of those end up doing the regex splitting twice + set lflines [list] + set inputchunks [split $overblock \n] + foreach ln $inputchunks { + append ln \n + lappend lflines $ln + } + if {[llength $lflines]} { + lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] + } + #set inputchunks $lflines[unset lflines] + set inputchunks [lindex [list $lflines [unset lflines]] 0] + + } + 4 { + set inputchunks [list] + foreach ln [split $overblock \n] { + lappend inputchunks [list mixed $ln\n] + } + if {[llength $inputchunks]} { + lset inputchunks end 1 [tcl::string::range [lindex $inputchunks end 1] 0 end-1] + } + } + } + + + + + set replay_codes_underlay [tcl::dict::create 1 ""] + #lappend replay_codes_overlay "" + set replay_codes_overlay "[punk::ansi::a]" + set unapplied "" + set cursor_saved_position [tcl::dict::create] + set cursor_saved_attributes "" + + + set outputlines $underlines + set overidx 0 + + #underlines are not necessarily processed in order - depending on cursor-moves applied from overtext + set row 1 + #if {$data_mode} { + # set col [_get_row_append_column $row] + #} else { + set col $opt_startcolumn + #} + + set instruction_stats [tcl::dict::create] + + set loop 0 + #while {$overidx < [llength $inputchunks]} { } + set renderedrow "" + while {[llength $inputchunks]} { + #set overtext [lpop inputchunks 0] ;#could be a list 'ansisplit' or text 'plain|mixed' + lassign [lpop inputchunks 0] overtext_type overtext + + #use eq test with emptystring instead of 'string length' - test for emptiness shouldn't cause shimmering if popped inputchunks member if an 'ansisplit' list + if {$overtext eq ""} { + incr loop + continue + } + #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" + set undertext [lindex $outputlines [expr {$row -1}]] + + #renderline pads each underaly line to width with spaces and should track where end of data is + + switch -- $overtext_type { + mixed { + set overtext $replay_codes_overlay$overtext + } + ansisplit { + ledit overtext -1 -1 "" $replay_codes_overlay + } + default { + error "renderspace unsupported overtext type: $overtext_type overtext: $overtext" + } + } + + + ###################### + #debug + #set partinfo "" + #if {$overtext_type eq "ansisplit"} { + # set partinfo [llength $overtext] + #} else { + # set partinfo [string length $overtext] + #} + #if {$renderedrow eq $row} { + # puts -nonewline stderr <$row>$overtext_type$partinfo + #} else { + # puts -nonewline stderr \n<$row>$overtext_type$partinfo + #} + #if {$overtext_type eq "mixed"} { + # puts -nonewline stderr "\n[ansistring VIEW $overtext]\n" + #} + ###################### + + set renderedrow $row + + if {[tcl::dict::exists $replay_codes_underlay $row]} { + set undertext [tcl::dict::get $replay_codes_underlay $row]$undertext + } + #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - + #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l + set renderopts [list -experimental $opt_experimental\ + -cp437 $opt_cp437\ + -info 1\ + -crm_mode [tcl::dict::get $vtstate crm_mode]\ + -insert_mode [tcl::dict::get $vtstate insert_mode]\ + -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ + -reverse_mode [tcl::dict::get $vtstate reverse_mode]\ + -cursor_restore_attributes $cursor_saved_attributes\ + -transparent $opt_transparent\ + -width [tcl::dict::get $vtstate renderwidth]\ + -exposed1 $opt_exposed1\ + -exposed2 $opt_exposed2\ + -expand_right $opt_expand_right\ + -cursor_column $col\ + -cursor_row $row\ + -overtext_type $overtext_type\ + ] + set rinfo [renderline {*}$renderopts $undertext $overtext] + + set instruction [tcl::dict::get $rinfo instruction] + tcl::dict::set vtstate crm_mode [tcl::dict::get $rinfo crm_mode] + tcl::dict::set vtstate insert_mode [tcl::dict::get $rinfo insert_mode] + tcl::dict::set vtstate autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;# + tcl::dict::set vtstate reverse_mode [tcl::dict::get $rinfo reverse_mode] + #how to support reverse_mode in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack? + # - review - the answer is probably that we don't need to - it is set/reset only during application of overtext + + #Note carefully the difference betw overflow_right and unapplied. + #overflow_right may need to be included in next run before the unapplied data + #overflow_right most commonly has data when in insert_mode + set rendered [tcl::dict::get $rinfo result] + set overflow_right [tcl::dict::get $rinfo overflow_right] + set overflow_right_column [tcl::dict::get $rinfo overflow_right_column] + set unapplied [tcl::dict::get $rinfo unapplied] + set unapplied_list [tcl::dict::get $rinfo unapplied_list] + set unapplied_ansisplit [tcl::dict::get $rinfo unapplied_ansisplit] + set post_render_col [tcl::dict::get $rinfo cursor_column] + set post_render_row [tcl::dict::get $rinfo cursor_row] + set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position] + set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes] + set visualwidth [tcl::dict::get $rinfo visualwidth] ;#column width of what is 'rendered' for the line + set insert_lines_above [tcl::dict::get $rinfo insert_lines_above] + set insert_lines_below [tcl::dict::get $rinfo insert_lines_below] + tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay] + + #lset replay_codes_overlay [expr $overidx+1] [tcl::dict::get $rinfo replay_codes_overlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + if {0 && [tcl::dict::get $vtstate reverse_mode]} { + #test branch - todo - prune + puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" + #review + #JMN3 + set existing_reverse_state 0 + #split_codes_single is single esc sequence - but could have multiple sgr codes within one esc sequence + #e.g \x1b\[0;31;7m has a reset,colour red and reverse + set codeinfo [punk::ansi::codetype::sgr_merge [list $replay_codes_overlay] -info 1] + set codestate_reverse [dict get $codeinfo codestate reverse] + switch -- $codestate_reverse { + 7 { + set existing_reverse_state 1 + } + 27 { + set existing_reverse_state 0 + } + "" { + } + } + if {$existing_reverse_state == 0} { + set rflip [a+ reverse] + } else { + #reverse of reverse + set rflip [a+ noreverse] + } + #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) + set replay_codes_overlay [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] + puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" + } + + + + #-- todo - detect looping properly + if {$row > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == $row && $instruction eq ""} { + puts stderr "overtype::renderspace loop?" + puts [ansistring VIEW $rinfo] + break + } + #-- + + if {[tcl::dict::size $c_saved_pos] >= 1} { + set cursor_saved_position $c_saved_pos + set cursor_saved_attributes $c_saved_attributes + } + + + set overflow_handled 0 + + + + set nextprefix_list [list] + + + #todo - handle potential insertion mode as above for cursor restore? + #keeping separate branches for debugging - review and merge as appropriate when stable + set instruction_type [lindex $instruction 0] ;#some instructions have params + tcl::dict::incr instruction_stats $instruction_type + switch -- $instruction_type { + reset { + #reset the 'renderspace terminal' (not underlying terminal) + set row 1 + set col 1 + set vtstate [tcl::dict::merge $vtstate $initial_state] + #todo - clear screen + } + {} { + #end of supplied line input + #lf included in data + set row $post_render_row + set col $post_render_col + if {![llength $unapplied_list]} { + if {$overflow_right ne ""} { + incr row + } + } else { + puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)" + } + set col $opt_startcolumn + } + up { + + #renderline knows it's own line number, and knows not to go above row l + #it knows that a move whilst 1-beyond the width conflicts with the linefeed and reduces the move by one accordingly. + #row returned should be correct. + #column may be the overflow column - as it likes to report that to the caller. + + #Note that an ansi up sequence after last column going up to a previous line and also beyond the last column, will result in the next grapheme going onto the following line. + #this seems correct - as the column remains beyond the right margin so subsequent chars wrap (?) review + #puts stderr "up $post_render_row" + #puts stderr "$rinfo" + + #puts stdout "1 row:$row col $col" + set row $post_render_row + #data_mode (naming?) determines if we move to end of existing data or not. + #data_mode 0 means ignore existing line length and go to exact column + #set by -experimental flag + if {$data_mode == 0} { + set col $post_render_col + } else { + #This doesn't really work if columns are pre-filled with spaces..we can't distinguish them from data + #we need renderline to return the number of the maximum column filled (or min if we ever do r-to-l) + set existingdata [lindex $outputlines [expr {$post_render_row -1}]] + set lastdatacol [punk::ansi::printing_length $existingdata] + if {$lastdatacol < $renderwidth} { + set col [expr {$lastdatacol+1}] + } else { + set col $renderwidth + } + } + + #puts stdout "2 row:$row col $col" + #puts stdout "-----------------------" + #puts stdout $rinfo + #flush stdout + } + down { + if {$data_mode == 0} { + #renderline doesn't know how far down we can go.. + if {$post_render_row > [llength $outputlines]} { + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] + } + lappend outputlines "" + } + } + set row $post_render_row + set col $post_render_col + } else { + if {$post_render_row > [llength $outputlines]} { + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] + } + lappend outputlines "" + } + } + # ---- + # review + set col $post_render_col + #just because it's out of range of the renderwidth - doesn't mean a move down should jump to witin the range - 2025 + #---- + + #set existingdata [lindex $outputlines [expr {$post_render_row -1}]] + #set lastdatacol [punk::ansi::printing_length $existingdata] + + #set col [expr {$lastdatacol+1}] + + #if {$lastdatacol < $renderwidth} { + # set col [expr {$lastdatacol+1}] + #} else { + # set col $renderwidth + #} + + } + } + restore_cursor { + #testfile belinda.ans uses this + + #puts stdout "[a+ blue bold]CURSOR_RESTORE[a]" + if {[tcl::dict::exists $cursor_saved_position row]} { + set row [tcl::dict::get $cursor_saved_position row] + set col [tcl::dict::get $cursor_saved_position column] + #puts stdout "restoring: row $row col $col [ansistring VIEW $cursor_saved_attributes] [a] unapplied [ansistring VIEWCODES $unapplied]" + #set nextprefix $cursor_saved_attributes + #lset replay_codes_overlay [expr $overidx+1] $cursor_saved_attributes + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]$cursor_saved_attributes + #set replay_codes_overlay $cursor_saved_attributes + set cursor_saved_position [tcl::dict::create] + set cursor_saved_attributes "" + } else { + #TODO + #?restore without save? + #should move to home position and reset ansi SGR? + #puts stderr "overtype::renderspace cursor_restore without save data available" + } + #If we were inserting prior to hitting the cursor_restore - there could be overflow_right data - generally the overtype functions aren't for inserting - but ansi can enable it + #if we were already in overflow when cursor_restore was hit - it shouldn't have been processed as an action - just stored. + if {!$overflow_handled && $overflow_right ne ""} { + #wrap before restore? - possible effect on saved cursor position + #this overflow data has previously been rendered so has no cursor movements or further save/restore operations etc + #we can just insert another call to renderline to solve this.. ? + #It would perhaps be more properly handled as a queue of instructions from our initial renderline call + #we don't need to worry about overflow next call (?)- but we should carry forward our gx and ansi stacks + + puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" + + set sub_info [overtype::renderline\ + -info 1\ + -width [tcl::dict::get $vtstate renderwidth]\ + -insert_mode [tcl::dict::get $vtstate insert_mode]\ + -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ + -expand_right [tcl::dict::get $opts -expand_right]\ + ""\ + $overflow_right\ + ] + set foldline [tcl::dict::get $sub_info result] + tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..? + tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this.. + + #todo!!! + # 2025 fix - this does nothing - so what uses it?? create a test! + linsert outputlines $renderedrow $foldline + #review - row & col set by restore - but not if there was no save.. + } + set overflow_handled 1 + + } + move { + ######## + if {$post_render_row > [llength $outputlines]} { + #Ansi moves need to create new lines ? + #if {$opt_appendlines} { + # set diff [expr {$post_render_row - [llength $outputlines]}] + # if {$diff > 0} { + # lappend outputlines {*}[lrepeat $diff ""] + # } + # set row $post_render_row + #} else { + set row [llength $outputlines] + #} + } else { + set row $post_render_row + } + ####### + set col $post_render_col + #overflow + unapplied? + } + clear_and_move { + #e.g 2J + if {$post_render_row > [llength $outputlines]} { + set row [llength $outputlines] + } else { + set row $post_render_row + } + set col $post_render_col + set overflow_right "" ;#if we're clearing - any overflow due to insert_mode is irrelevant + set clearedlines [list] + foreach ln $outputlines { + lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $renderwidth]\x1b\[0m + if 0 { + + set lineparts [punk::ansi::ta::split_codes $ln] + set numcells 0 + foreach {pt _code} $lineparts { + if {$pt ne ""} { + foreach grapheme [punk::char::grapheme_split $pt] { + switch -- $grapheme { + " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - + z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { + incr numcells 1 + } + default { + if {$grapheme eq "\u0000"} { + incr numcells 1 + } else { + incr numcells [grapheme_width_cached $grapheme] + } + } + } + + } + } + } + #replays/resets each line + lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $numcells]\x1b\[0m + } + } + set outputlines $clearedlines + #todo - determine background/default to be in effect - DECECM ? + puts stderr "replay_codes_overlay: [ansistring VIEW $replay_codes_overlay]" + #lset outputlines 0 $replay_codes_overlay[lindex $outputlines 0] + + } + lf_start { + #raw newlines + # ---------------------- + #test with fruit.ans + #test - treating as newline below... + #append rendered $overflow_right + #set overflow_right "" + set row $renderedrow + incr row + if {$row > [llength $outputlines]} { + lappend outputlines "" + } + set col $opt_startcolumn + # ---------------------- + } + lf_mid { + + set edit_mode 0 + if {$edit_mode} { + #set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] + #JMN + #ledit inputchunks -1 -1 $overflow_right$unapplied + + set pt_ansi_pt [punk::ansi::ta::split_codes_single $overflow_right] + #join the trailing and leading pt parts of the 2 lists + ledit pt_ansi_pt end end "[lindex $pt_ansi_pt end][lindex $unapplied_ansisplit 0]" + lappend pt_ansi_pt [lrange $unapplied_ansisplit 1 end] + + ledit inputchunks -1 -1 [list ansisplit $pt_ansi_pt] ;#combined overflow_right and unapplied - in ansisplit form + + set overflow_right "" + set unapplied "" + set unapplied_list [list] + set unapplied_ansisplit [list] + + set row $post_render_row + #set col $post_render_col + set col $opt_startcolumn + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + } else { + if 1 { + if {$overflow_right ne ""} { + if {$opt_expand_right} { + append rendered $overflow_right + set overflow_right "" + } else { + #review - we should really make renderline do the work...? + set overflow_width [punk::ansi::printing_length $overflow_right] + if {$visualwidth + $overflow_width <= $renderwidth} { + append rendered $overflow_right + set overflow_right "" + } else { + if {[tcl::dict::get $vtstate autowrap_mode]} { + set outputlines [linsert $outputlines $renderedrow $overflow_right] + set overflow_right "" + set row [expr {$renderedrow + 2}] + } else { + set overflow_right "" ;#abandon + } + + if {0 && $visualwidth < $renderwidth} { + puts stderr "visualwidth: $visualwidth < renderwidth:$renderwidth" + error "incomplete - abandon?" + set overflowparts [punk::ansi::ta::split_codes $overflow_right] + set remaining_overflow $overflowparts + set filled 0 + foreach {pt code} $overflowparts { + lpop remaining_overflow 0 + if {$pt ne ""} { + set graphemes [punk::char::grapheme_split $pt] + set add "" + set addlen $visualwidth + foreach g $graphemes { + set w [overtype::grapheme_width_cached $g] + if {$addlen + $w <= $renderwidth} { + append add $g + incr addlen $w + } else { + set filled 1 + break + } + } + append rendered $add + } + if {!$filled} { + lpop remaining_overflow 0 ;#pop code + } + } + set overflow_right [join $remaining_overflow ""] + } + } + } + } + set row $post_render_row + set col $opt_startcolumn + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + } else { + #old version - known to work with various ansi graphics - e.g fruit.ans + # - but fails to limit lines to renderwidth when expand_right == 0 + append rendered $overflow_right + set overflow_right "" + set row $post_render_row + set col $opt_startcolumn + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + } + } + } + lf_overflow { + #linefeed after renderwidth e.g at column 81 for an 80 col width + #we may also have other control sequences that came after col 80 e.g cursor save + + if 0 { + set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]] + set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs] + set rhs "" + + #assertion - there should be no overflow.. + puts $lhs + } + if {![tcl::dict::get $vtstate insert_mode]} { + assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode + } + + set row $post_render_row + #set row $renderedrow + #incr row + #only add newline if we're at the bottom + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + set col $opt_startcolumn + + } + newlines_above { + #we get a newlines_above instruction when received at column 1 + #In some cases we want to treat that as request to insert a new blank line above, and move our row 1 down (staying with the data) + #in other cases - we want to treat at column 1 the same as any other + + puts "--->newlines_above" + puts "rinfo: $rinfo" + #renderline doesn't advance the row for us - the caller has the choice to implement or not + set row $post_render_row + set col $post_render_col + if {$insert_lines_above > 0} { + set row $renderedrow + #set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]] + ledit outputlines $renderedrow-1 $renderedrow-2 {*}[lrepeat $insert_lines_above ""] + incr row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above + #? set row $post_render_row #can renderline tell us? + } + } + newlines_below { + #obsolete? - use for ANSI insert lines sequence + if {$data_mode == 0} { + puts --->nl_below + set row $post_render_row + set col $post_render_col + if {$insert_lines_below == 1} { + #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] + #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] + #set rhs "" + #if {$overflow_right ne ""} { + # set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]] + # set rhs [textblock::frame -title overflow_right $rhs] + #} + #puts [textblock::join $lhs $rhs] + + #rendered + append rendered $overflow_right + # + + + set overflow_right "" + set row $renderedrow + #only add newline if we're at the bottom + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat $insert_lines_below ""] + } + incr row $insert_lines_below + set col $opt_startcolumn + } + } else { + set row $post_render_row + if {$post_render_row > [llength $outputlines]} { + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] + } + lappend outputlines "" + } + } else { + set existingdata [lindex $outputlines [expr {$post_render_row -1}]] + set lastdatacol [punk::ansi::printing_length $existingdata] + if {$lastdatacol < $renderwidth} { + set col [expr {$lastdatacol+1}] + } else { + set col $renderwidth + } + } + } + } + wrapmoveforward { + #doesn't seem to be used by fruit.ans testfile + #used by dzds.ans + #note that cursor_forward may move deep into the next line - or even span multiple lines !TODO + set c $renderwidth + set r $post_render_row + if {$post_render_col > $renderwidth} { + set i $c + while {$i <= $post_render_col} { + if {$c == $renderwidth+1} { + incr r + if {$opt_appendlines} { + if {$r < [llength $outputlines]} { + lappend outputlines "" + } + } + set c $opt_startcolumn + } else { + incr c + } + incr i + } + set col $c + } else { + #why are we getting this instruction then? + puts stderr "wrapmoveforward - test" + set r [expr {$post_render_row +1}] + set c $post_render_col + } + set row $r + set col $c + } + wrapmovebackward { + set c $renderwidth + set r $post_render_row + if {$post_render_col < 1} { + set c 1 + set i $c + while {$i >= $post_render_col} { + if {$c == 0} { + if {$r > 1} { + incr r -1 + set c $renderwidth + } else { + #leave r at 1 set c 1 + #testfile besthpav.ans first line top left border alignment + set c 1 + break + } + } else { + incr c -1 + } + incr i -1 + } + set col $c + } else { + puts stderr "Wrapmovebackward - but postrendercol >= 1???" + } + set row $r + set col $c + } + overflow { + #normal single-width grapheme overflow + #puts stderr "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]" + + + #renderspace gives us an overflow when there is a grapheme followed by a non-grapheme + #This gives us some possible(probable) leading ANSI (which is probably SGR, or it would have triggered something else) + #followed by a sequence of 1 or more graphemes and some more unprocessed ANSI (which could be anything: SGR,movement etc) + #we want to strip out this leading run of graphemes + #NOTE: 2025 - comment is obsolete/inaccurate. We only ever get 1 grapheme - as prior were consumed/ignored by renderline + #REVIEW!!! + + #example trigger: textblock::frame -width 80 [ansicat us-pump_up_the_jam-355.ans 355x100] + + set row $post_render_row ;#renderline will not advance row when reporting overflow char + if {[tcl::dict::get $vtstate autowrap_mode]} { + incr row + set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? + } else { + set col $post_render_col + #The overflow can only be triggered by a grapheme (todo cluster?) - but our unapplied could contain SGR codes prior to the grapheme that triggered overflow - so we need to skip beyond any SGRs + #There may be more than one, because although the stack leading up to overflow may have been merged - codes between the last column and the overflowing grapheme will remain separate + #We don't expect any movement or other ANSI codes - as if they came before the grapheme, they would have triggered a different instruction to 'overflow' + + set drop_graphemes [list] ;#list of contiguous grapheme indices + set new_unapplied_list [list] + set unapplied_ansisplit [list ""] + set idx 0 + + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + #puts stderr "g$idx:$u" + if {![llength $drop_graphemes] || $idx == [lindex $drop_graphemes end]+1} { + #we are in the first run of uninterrupted graphemes + #drop by doing nothing with it here + lappend drop_graphemes $idx + } else { + lappend new_unapplied_list $u + ledit unapplied_ansisplit end end "[lindex $unapplied_ansisplit end]$u" + } + } else { + lappend new_unapplied_list $u + lappend unapplied_ansisplit $u "" + } + incr idx + } + #debug + if {[llength $drop_graphemes]} { + set idx0 [lindex $drop_graphemes 0] + set dbg "" + if {$idx0 > 0} { + for {set i 0} {$i < $idx0} {incr i} { + #leading SGR + append dbg [lindex $unapplied_list $i] + } + } + foreach idx $drop_graphemes { + append dbg [lindex $unapplied_list $idx] + } + puts stderr "dropped[llength $drop_graphemes]:$dbg\x1b\[m" + } + set unapplied [join $new_unapplied_list ""] + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } + set unapplied_list $new_unapplied_list + + #we need to run the reduced unapplied on the same line - further graphemes will just overflow again, but codes or control chars could trigger jumps to other lines + + set overflow_handled 1 + #handled by dropping overflow if any + } + } + overflow_splitchar { + set row $post_render_row ;#renderline will not advance row when reporting overflow char + + #2nd half of grapheme would overflow - treggering grapheme is returned in unapplied. There may also be overflow_right from earlier inserts + #todo - consider various options .. re-render a single trailing space or placeholder on same output line, etc + if {[tcl::dict::get $vtstate autowrap_mode]} { + if {$renderwidth < 2} { + #edge case of rendering to a single column output - any 2w char will just cause a loop if we don't substitute with something, or drop the character + set idx 0 + set triggering_grapheme_index -1 + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + set triggering_grapheme_index $idx + break + } + incr idx + } + #set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] + ledit unapplied_list $triggering_grapheme_index $triggering_grapheme_index + set unapplied [join $unapplied_list ""] + #review - inefficient to re-split (return unapplied_tagged instead of unapplied_ansisplit?) + set unapplied_ansisplit [punk::ansi::ta::split_codes_single $unapplied] + } else { + set col $opt_startcolumn + incr row + } + } else { + set overflow_handled 1 + #handled by dropping entire overflow if any + if {$renderwidth < 2} { + set idx 0 + set triggering_grapheme_index -1 + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + set triggering_grapheme_index $idx + break + } + incr idx + } + #set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] + ledit unapplied_list $triggering_grapheme_index $triggering_grapheme_index + set unapplied [join $unapplied_list ""] + #review - inefficient + puts -nonewline stderr . + set unapplied_ansisplit [punk::ansi::ta::split_codes_single $unapplied] + } + } + + } + vt { + + #can vt add a line like a linefeed can? + set row $post_render_row + set col $post_render_col + } + set_window_title { + set newtitle [lindex $instruction 1] + puts stderr "overtype::renderspace set_window_title [ansistring VIEW $newtitle] instruction '$instruction'" + # + } + reset_colour_palette { + puts stderr "overtype::renderspace instruction '$instruction' unimplemented" + } + default { + puts stderr "overtype::renderspace unhandled renderline instruction '$instruction'" + } + + } + + + if {!$opt_expand_right && ![tcl::dict::get $vtstate autowrap_mode]} { + #not allowed to overflow column or wrap therefore we get overflow data to truncate + if {[tcl::dict::get $opts -ellipsis]} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + set lostdata "" + if {$overflow_right ne ""} { + append lostdata $overflow_right + } + if {$unapplied ne ""} { + append lostdata $unapplied + } + if {[tcl::string::trim $lostdata] eq ""} { + set show_ellipsis 0 + } + #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + if {[tcl::string::trim [punk::ansi::ansistrip $lostdata]] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set rendered [overtype::right $rendered $opt_ellipsistext] + } + set overflow_handled 1 + } else { + #no wrap - no ellipsis - silently truncate + set overflow_handled 1 + } + } + + + + if {$renderedrow <= [llength $outputlines]} { + lset outputlines [expr {$renderedrow-1}] $rendered + } else { + if {$opt_appendlines} { + lappend outputlines $rendered + } else { + #? + lset outputlines [expr {$renderedrow-1}] $rendered + } + } + + if {!$overflow_handled} { + #append nextprefix $overflow_right + set overflow_right_pt_code_pt [punk::ansi::ta::split_codes_single $overflow_right] + if {![llength $nextprefix_list]} { + set nextprefix_list $overflow_right_pt_code_pt + } else { + #merge tail and head + ledit nextprefix_list end end "[lindex $nextprefix_list end][lindex $overflow_right_pt_code_pt 0]" + lappend nextprefix_list {*}[lrange $overflow_right_pt_code_pt 1 end] + } + } + + #append nextprefix $unapplied + if {![llength $nextprefix_list]} { + set nextprefix_list $unapplied_ansisplit + } else { + #merge tail and head + ledit nextprefix_list end end "[lindex $nextprefix_list end][lindex $unapplied_ansisplit 0]" + lappend nextprefix_list {*}[lrange $unapplied_ansisplit 1 end] + } + + if 0 { + if {$nextprefix ne ""} { + set nextoveridx [expr {$overidx+1}] + if {$nextoveridx >= [llength $inputchunks]} { + lappend inputchunks $nextprefix + } else { + #lset overlines $nextoveridx $nextprefix[lindex $overlines $nextoveridx] + set inputchunks [linsert $inputchunks $nextoveridx $nextprefix] + } + } + } + + if {[llength $nextprefix_list]} { + #set inputchunks [linsert $inputchunks 0 $nextprefix] + #JMN - assume backwards compat ledit available from punk::lib (for tcl <9) + ledit inputchunks -1 -1 [list ansisplit $nextprefix_list] + } + + + incr overidx + incr loop + if {$loop >= $looplimit} { + puts stderr "overtype::renderspace looplimit reached ($looplimit)" + lappend outputlines "[a+ red bold] - looplimit $looplimit reached[a]" + set Y [a+ yellow bold] + set RST [a] + set sep_header ----DEBUG----- + set debugmsg "" + append debugmsg "${Y}${sep_header}${RST}" \n + append debugmsg "looplimit $looplimit reached\n" + append debugmsg "data_mode:$data_mode\n" + append debugmsg "opt_appendlines:$opt_appendlines\n" + append debugmsg "prev_row :[tcl::dict::get $renderopts -cursor_row]\n" + append debugmsg "prev_col :[tcl::dict::get $renderopts -cursor_column]\n" + tcl::dict::for {k v} $rinfo { + append debugmsg "${Y}$k [ansistring VIEW -lf 1 -vt 1 $v]$RST" \n + } + append debugmsg "${Y}[string repeat - [string length $sep_header]]$RST" \n + + puts stdout $debugmsg + #todo - config regarding error dumps rather than just dumping in working dir + set fd [open [pwd]/error_overtype.txt w] + puts $fd $debugmsg + close $fd + error $debugmsg + break + } + } + + set result [join $outputlines \n] + if {!$opt_info} { + return $result + } else { + #emit to debug window like basictelnet does? make debug configurable as syslog or even a telnet server to allow on 2nd window? + #append result \n$instruction_stats\n + set inforesult [dict create\ + result $result\ + last_instruction $instruction\ + instruction_stats $instruction_stats\ + ] + if {$opt_info == 2} { + return [pdict -channel none inforesult] + } else { + return $inforesult + } + } + } + + #todo - left-right ellipsis ? + proc centre {args} { + variable default_ellipsis_horizontal + if {[llength $args] < 2} { + error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} + } + + foreach {underblock overblock} [lrange $args end-1 end] break + + #todo - vertical vs horizontal overflow for blocks + set opts [tcl::dict::create\ + -bias left\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + ] + set argsflags [lrange $args 0 end-2] + foreach {k v} $argsflags { + switch -- $k { + -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 { + tcl::dict::set opts $k $v + } + default { + set known_opts [tcl::dict::keys $opts] + error "overtype::centre unknown option '$k'. Known options: $known_opts" + } + } + } + #set opts [tcl::dict::merge $defaults $argsflags] + # -- --- --- --- --- --- + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + # -- --- --- --- --- --- + + + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] + + set underlines [split $underblock \n] + #set renderwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] + lassign [blocksize $underblock] _w renderwidth _h renderheight + set overlines [split $overblock \n] + lassign [blocksize $overblock] _w overblock_width _h overblock_height + set under_exposed_max [expr {$renderwidth - $overblock_width}] + if {$under_exposed_max > 0} { + #background block is wider + if {$under_exposed_max % 2 == 0} { + #even left/right exposure + set left_exposed [expr {$under_exposed_max / 2}] + } else { + set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division + if {[tcl::string::tolower [tcl::dict::get $opts -bias]] eq "left"} { + set left_exposed $beforehalf + } else { + #bias to the right + set left_exposed [expr {$beforehalf + 1}] + } + } + } else { + set left_exposed 0 + } + + set outputlines [list] + if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { + set replay_codes "[punk::ansi::a]" + } else { + set replay_codes "" + } + set replay_codes_underlay "" + set replay_codes_overlay "" + foreach undertext $underlines overtext $overlines { + set overtext_datalen [punk::ansi::printing_length $overtext] + set ulen [punk::ansi::printing_length $undertext] + if {$ulen < $renderwidth} { + set udiff [expr {$renderwidth - $ulen}] + set undertext "$undertext[string repeat { } $udiff]" + } + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext + + set overflowlength [expr {$overtext_datalen - $renderwidth}] + #review - right-to-left langs should elide on left! - extra option required + + if {$overflowlength > 0} { + #overlay line wider or equal + #review - we still expand_right for centred for now.. possibly should do something like -expand_leftright with ellipsis each end? + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + set rendered [tcl::dict::get $rinfo result] + set overflow_right [tcl::dict::get $rinfo overflow_right] + set unapplied [tcl::dict::get $rinfo unapplied] + #todo - get replay_codes from overflow_right instead of wherever it was truncated? + + #overlay line data is wider - trim if overflow not specified in opts - and overtype an ellipsis at right if it was specified + if {![tcl::dict::get $opts -overflow]} { + #lappend outputlines [tcl::string::range $overtext 0 [expr {$renderwidth - 1}]] + #set overtext [tcl::string::range $overtext 0 $renderwidth-1 ] + if {$opt_ellipsis} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + #don't use tcl::string::range on ANSI data + #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + set lostdata "" + if {$overflow_right ne ""} { + append lostdata $overflow_right + } + if {$unapplied ne ""} { + append lostdata $unapplied + } + if {[tcl::string::trim $lostdata] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set rendered [overtype::right $rendered $opt_ellipsistext] + } + } + } + lappend outputlines $rendered + #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent $undertext $overtext] + } else { + #background block is wider than or equal to data for this line + #lappend outputlines [renderline -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + set rinfo [renderline -info 1 -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + lappend outputlines [tcl::dict::get $rinfo result] + } + set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + } + return [join $outputlines \n] + } + + #overtype::right is for a rendered ragged underblock and a rendered ragged overblock + #ie we can determine the block width for bost by examining the lines and picking the longest. + # + proc right {args} { + #NOT the same as align-right - which should be done to the overblock first if required + variable default_ellipsis_horizontal + # @d !todo - implement overflow, length checks etc + + if {[llength $args] < 2} { + error {usage: ?-overflow [1|0]? ?-transparent 0|? undertext overtext} + } + foreach {underblock overblock} [lrange $args end-1 end] break + + set opts [tcl::dict::create\ + -bias ignored\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -align "left"\ + ] + set argsflags [lrange $args 0 end-2] + tcl::dict::for {k v} $argsflags { + switch -- $k { + -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -align { + tcl::dict::set opts $k $v + } + default { + set known_opts [tcl::dict::keys $opts] + error "overtype::centre unknown option '$k'. Known options: $known_opts" + } + } + } + #set opts [tcl::dict::merge $defaults $argsflags] + # -- --- --- --- --- --- + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_overflow [tcl::dict::get $opts -overflow] + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + set opt_align [tcl::dict::get $opts -align] + # -- --- --- --- --- --- + + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] + + set underlines [split $underblock \n] + lassign [blocksize $underblock] _w renderwidth _h renderheight + set overlines [split $overblock \n] + #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] + lassign [blocksize $overblock] _w overblock_width _h overblock_height + set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] + set left_exposed $under_exposed_max + + + + set outputlines [list] + if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { + set replay_codes "[punk::ansi::a]" + } else { + set replay_codes "" + } + set replay_codes_underlay "" + set replay_codes_overlay "" + foreach undertext $underlines overtext $overlines { + set overtext_datalen [punk::ansi::printing_length $overtext] + set ulen [punk::ansi::printing_length $undertext] + if {$ulen < $renderwidth} { + set udiff [expr {$renderwidth - $ulen}] + #puts xxx + append undertext [string repeat { } $udiff] + } + if {$overtext_datalen < $overblock_width} { + set odiff [expr {$overblock_width - $overtext_datalen}] + switch -- $opt_align { + left { + set startoffset 0 + } + right { + set startoffset $odiff + } + default { + set half [expr {$odiff / 2}] + #set lhs [string repeat { } $half] + #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left + #set rhs [string repeat { } $righthalf] + set startoffset $half + } + } + } else { + set startoffset 0 ;#negative? + } + + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext + + set overflowlength [expr {$overtext_datalen - $renderwidth}] + if {$overflowlength > 0} { + #raw overtext wider than undertext column + set rinfo [renderline\ + -info 1\ + -insert_mode 0\ + -transparent $opt_transparent\ + -exposed1 $opt_exposed1 -exposed2 $opt_exposed2\ + -overflow $opt_overflow\ + -startcolumn [expr {1 + $startoffset}]\ + $undertext $overtext] + set replay_codes [tcl::dict::get $rinfo replay_codes] + set rendered [tcl::dict::get $rinfo result] + if {!$opt_overflow} { + if {$opt_ellipsis} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + if {[tcl::string::trim $lostdata] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set ellipsis $replay_codes$opt_ellipsistext + #todo - overflow on left if allign = right?? + set rendered [overtype::right $rendered $ellipsis] + } + } + } + lappend outputlines $rendered + } else { + #padded overtext + #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] + #Note - we still need overflow(exapnd_right) here - as although the overtext is short - it may oveflow due to the startoffset + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] + lappend outputlines [tcl::dict::get $rinfo result] + } + set replay_codes [tcl::dict::get $rinfo replay_codes] + set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + } + + return [join $outputlines \n] + } + + proc left {args} { + overtype::block -blockalign left {*}$args + } + #overtype a (possibly ragged) underblock with a (possibly ragged) overblock + proc block {args} { + variable default_ellipsis_horizontal + # @d !todo - implement overflow, length checks etc + + if {[llength $args] < 2} { + error {usage: ?-blockalign left|centre|right? ?-textalign left|centre|right? ?-overflow [1|0]? ?-transparent 0|? undertext overtext} + } + #foreach {underblock overblock} [lrange $args end-1 end] break + lassign [lrange $args end-1 end] underblock overblock + + set opts [tcl::dict::create\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -textalign "left"\ + -textvertical "top"\ + -blockalign "left"\ + -blockalignbias left\ + -blockvertical "top"\ + ] + set argsflags [lrange $args 0 end-2] + tcl::dict::for {k v} $argsflags { + switch -- $k { + -blockalignbias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -textalign - -blockalign - -blockvertical { + tcl::dict::set opts $k $v + } + default { + error "overtype::block unknown option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + # -- --- --- --- --- --- + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_overflow [tcl::dict::get $opts -overflow] + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + set opt_textalign [tcl::dict::get $opts -textalign] + set opt_blockalign [tcl::dict::get $opts -blockalign] + if {$opt_blockalign eq "center"} { + set opt_blockalign "centre" + } + # -- --- --- --- --- --- + + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] + + set underlines [split $underblock \n] + lassign [blocksize $underblock] _w renderwidth _h renderheight + set overlines [split $overblock \n] + #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] + lassign [blocksize $overblock] _w overblock_width _h overblock_height + set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] + + switch -- $opt_blockalign { + left { + set left_exposed 0 + } + right { + set left_exposed $under_exposed_max + } + centre { + if {$under_exposed_max > 0} { + #background block is wider + if {$under_exposed_max % 2 == 0} { + #even left/right exposure + set left_exposed [expr {$under_exposed_max / 2}] + } else { + set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division + if {[tcl::string::tolower [tcl::dict::get $opts -blockalignbias]] eq "left"} { + set left_exposed $beforehalf + } else { + #bias to the right + set left_exposed [expr {$beforehalf + 1}] + } + } + } else { + set left_exposed 0 + } + } + default { + set left_exposed 0 + } + } + + + + set outputlines [list] + if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { + set replay_codes "[punk::ansi::a]" + } else { + set replay_codes "" + } + set replay_codes_underlay "" + set replay_codes_overlay "" + foreach undertext $underlines overtext $overlines { + set overtext_datalen [punk::ansi::printing_length $overtext] + set ulen [punk::ansi::printing_length $undertext] + if {$ulen < $renderwidth} { + set udiff [expr {$renderwidth - $ulen}] + #puts xxx + append undertext [string repeat { } $udiff] + } + if {$overtext_datalen < $overblock_width} { + set odiff [expr {$overblock_width - $overtext_datalen}] + switch -- $opt_textalign { + left { + set startoffset 0 + } + right { + set startoffset $odiff + } + default { + set half [expr {$odiff / 2}] + #set lhs [string repeat { } $half] + #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left + #set rhs [string repeat { } $righthalf] + set startoffset $half + } + } + } else { + set startoffset 0 ;#negative? + } + + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext + + set overflowlength [expr {$overtext_datalen - $renderwidth}] + if {$overflowlength > 0} { + #raw overtext wider than undertext column + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -expand_right $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] + set replay_codes [tcl::dict::get $rinfo replay_codes] + set rendered [tcl::dict::get $rinfo result] + set overflow_right [tcl::dict::get $rinfo overflow_right] + set unapplied [tcl::dict::get $rinfo unapplied] + if {!$opt_overflow} { + if {$opt_ellipsis} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + #don't use tcl::string::range on ANSI data + #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + set lostdata "" + if {$overflow_right ne ""} { + append lostdata $overflow_right + } + if {$unapplied ne ""} { + append lostdata $unapplied + } + if {[tcl::string::trim $lostdata] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set rendered [overtype::block -blockalign right $rendered $opt_ellipsistext] + } + } + + #if {$opt_ellipsis} { + # set show_ellipsis 1 + # if {!$opt_ellipsiswhitespace} { + # #we don't want ellipsis if only whitespace was lost + # set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + # if {[tcl::string::trim $lostdata] eq ""} { + # set show_ellipsis 0 + # } + # } + # if {$show_ellipsis} { + # set ellipsis [tcl::string::cat $replay_codes $opt_ellipsistext] + # #todo - overflow on left if allign = right?? + # set rendered [overtype::right $rendered $ellipsis] + # } + #} + } + lappend outputlines $rendered + } else { + #padded overtext + #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] + #Note - we still need expand_right here - as although the overtext is short - it may oveflow due to the startoffset + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] + #puts stderr "--> [ansistring VIEW -lf 1 -nul 1 $rinfo] <--" + set overflow_right [tcl::dict::get $rinfo overflow_right] + set unapplied [tcl::dict::get $rinfo unapplied] + lappend outputlines [tcl::dict::get $rinfo result] + } + set replay_codes [tcl::dict::get $rinfo replay_codes] + set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + } + + return [join $outputlines \n] + } + + #variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches + variable optimise_ptruns 5 + + + + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::overtype::renderline + @cmd -name overtype::renderline\ + -summary\ + {Render a line of text/ANSI input over a line of text.}\ + -help\ + {renderline is the core engine for overtype string processing (frames & textblocks), and the raw mode + commandline repl for the Tcl Punk Shell. + It is also a central part of an ansi (micro) virtual terminal-emulator of sorts. + This system does a half decent job at rendering 90's ANSI art to manipulable colour text blocks that + can be joined & framed for layout display within a unix or windows terminal. + Renderline helps maintain ANSI text styling reset/replay codes so that the styling of one block doesn't + affect another. + Calling on the punk::ansi library - it can coalesce codes to keep the size down. + + It is a giant mess of doing exactly what common wisdom says not to do... lots at once. + Renderline is part of the Unicode and ANSI aware Overtype system which 'renders' a block of text onto a + static underlay. + The underlay is generally expected to be an ordered set of lines or a rectangular text block analogous + to a terminal screen - but it can also be ragged in line length, or just blank. + The overlay couuld be similar - in which case it may often be used to overwrite a column or section of + the underlay. + The overlay could however be a sequence of ANSI-laden text that jumps all over the place. + + Renderline itself only deals with a single line - or sometimes a single character. It is generally + called from a loop that does further terminal-like or textblock processing. + By suppyling the ${$B}-info${$N} 1 option - it can return various fields indicating the state of the render. + The main 3 are: result, overflow_right, and unapplied. + Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the + aforementioned loop will need to be in place to manage the set of lines under manipulation. + } + @opts + -etabs -default 0 -type boolean + -width -default \uFFEF -type integer + -expand_right -default 0 -type boolean + -transparent -default 0 -type {literal(0)|literal(1)|regexp} -help\ + "0 to disable transparency processing + 1 to enable space characters in the + overlay to be transparent, or a regex + to match the character(s) required to be + transparent in the overlay." + -startcolumn -default 1 -type integer + -cursor_column -default 1 -type integer -help\ + {First column is 1. Cursor column can be zero or negative} + -cursor_row -default "" -type integer + -insert_mode -default 1 -type boolean + -crm_mode -default 0 -type boolean + -autowrap_mode -default 1 -type boolean + -reverse_mode -default 0 -type boolean + -info -default 0 -type boolean -help\ + "When set to 1, return a dictionary of settings useful for + processing ANSI input in a loop. When zero, the resulting + string will contain the updated line, but not all the + overtext may have been applied." + -exposed1 -default \uFFFD -help\ + {A character of single terminal column width to use + as replacement when first-half of an underlying char + is exposed due to overlay positioning/transparency + which obscures the second-half of the char. May be ANSI + coloured as this doesn't affect the display width. + Default is \uFFFD - the unicode replacement char.} + -exposed2 -default \uFFFD -help\ + {A character of single terminal column width to use + as replacement when second-half of an underlying char + is exposed due to overlay positioning/transparency + which obscures the first-half of the char. May be ANSI + coloured as this doesn't affect the display width. + Default is \uFFFD - the unicode replacement char.} + -cursor_restore_attributes -default "" + -cp437 -default 0 -type boolean + -experimental -default {} + -overtext_type -type string -choices {mixed plain ansisplit} -default mixed + @values -min 2 -max 2 + undertext -type string -help\ + "A single line of text which may contain pre-rendered ANSI. + 'pre-rendered' in this context means that it may contain + various static ANSI codes such as SGR colours and attributes + but not motion-control or more complex ANSI sequences. + It is an error to supply a newline (lf) character in the + undertext." + overtext -type string -help\ + "ANSI (or plain text) to overlay onto the undertext. + May contain ANSI movement codes even if they would move the + cursor to another line. If -info is zero, the output will + only display up to the point where the cursor moved off-line. + If -info is 1, the line moved to may be reflected in the + cursor_row element of the result. Overtext may contain an lf + which is effectively a form of 'movement control' to increment + the row. + Other ANSI codes may perform operations such as changing the + insert_mode or reverse_mode - and these are reflected in the + result dictionary when '-info 1' is used, so that the state + can then be applied to subsequent lines." + }] + } + + proc renderline {args} { + # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### + # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. + # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. + # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### + # + # + #-returnextra enables returning of overflow and length + #review - use punk::ansi::ta::detect to short-circuit processing and do simpler string calcs as an optimisation? + #review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements + #(could render it by faking it with sixels and a lot of work - find/make a sixel font and ensure it's exactly 2 cols per char? + # This would probably be impractical to support for different fonts) + #todo - review transparency issues with single/double width characters + #bidi - need a base direction and concept of directional runs for RTL vs LTR - may be best handled at another layer? + + + + #*** !doctools + #[call [fun overtype::renderline] [arg args] ] + #[para] renderline is the core engine for overtype string processing (frames & textblocks), and the raw mode commandline repl for the Tcl Punk Shell + #[para] It is also a central part of an ansi (micro) virtual terminal-emulator of sorts + #[para] This system does a half decent job at rendering 90's ANSI art to manipulable colour text blocks that can be joined & framed for layout display within a unix or windows terminal + #[para] Renderline helps maintain ANSI text styling reset/replay codes so that the styling of one block doesn't affect another. + #[para] Calling on the punk::ansi library - it can coalesce codes to keep the size down. + #[para] It is a giant mess of doing exactly what common wisdom says not to do... lots at once. + #[para] renderline is part of the Unicode and ANSI aware Overtype system which 'renders' a block of text onto a static underlay + #[para] The underlay is generally expected to be an ordered set of lines or a rectangular text block analogous to a terminal screen - but it can also be ragged in line length, or just blank. + #[para] The overlay couuld be similar - in which case it may often be used to overwrite a column or section of the underlay. + #[para] The overlay could however be a sequence of ANSI-laden text that jumps all over the place. + # + #[para] renderline itself only deals with a single line - or sometimes a single character. It is generally called from a loop that does further terminal-like or textblock processing. + #[para] By suppyling the -info 1 option - it can return various fields indicating the state of the render. + #[para] The main 3 are the result, overflow_right, and unapplied. + #[para] Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the aforementioned loop will need to be in place to manage the set of lines under manipulation. + + #puts stderr "renderline '$args'" + variable optimise_ptruns + + if {[llength $args] < 2} { + error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-expand_right [1|0]? undertext overtext} + } + set under [lindex $args end-1] + set over [lindex $args end] + #lassign [lrange $args end-1 end] under over + if {[string last \n $under] >= 0} { + error "overtype::renderline not allowed to contain newlines in undertext" + } + #if {[string first \n $over] >=0 || [string first \n $under] >= 0} { + # error "overtype::renderline not allowed to contain newlines" + #} + + #generally faster to create a new dict in the proc than to use a namespace variable to create dict once and link to variable (2024 8.6/8.7) + set opts [tcl::dict::create\ + -etabs 0\ + -width \uFFEF\ + -expand_right 0\ + -transparent 0\ + -startcolumn 1\ + -cursor_column 1\ + -cursor_row ""\ + -insert_mode 1\ + -crm_mode 0\ + -autowrap_mode 1\ + -reverse_mode 0\ + -info 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -cursor_restore_attributes ""\ + -cp437 0\ + -experimental {}\ + -overtext_type mixed\ + ] + #-overtext_type plain|mixed|ansisplit + + #-cursor_restore_attributes only - for replay stack - position and actual setting/restoring handled by throwback to caller + + #cursor_row, when numeric will allow detection of certain row moves that are still within our row - allowing us to avoid an early return + #An empty string for cursor_row tells us we have no info about our own row context, and to return with an unapplied string if any row move occurs + + #exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency, currsor movements to 2nd charcol, or overflow/expand_right + #todo - return info about such grapheme 'cuts' in -info structure and/or create option to raise an error + + set argsflags [lrange $args 0 end-2] + tcl::dict::for {k v} $argsflags { + switch -- $k { + -experimental - -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row + - -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode + - -info - -exposed1 - -exposed2 - -cursor_restore_attributes - -overtext_type { + tcl::dict::set opts $k $v + } + default { + error "overtype::renderline unknown option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_width [tcl::dict::get $opts -width] + set opt_etabs [tcl::dict::get $opts -etabs] + set opt_expand_right [tcl::dict::get $opts -expand_right] + set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay + set opt_colcursor [tcl::dict::get $opts -cursor_column];#start cursor column relative to overlay + set opt_row_context [tcl::dict::get $opts -cursor_row] + set opt_overtext_type [tcl::dict::get $opts -overtext_type] + if {[string length $opt_row_context]} { + if {![tcl::string::is integer -strict $opt_row_context] || $opt_row_context <1 } { + error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'" + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- + #The _mode flags correspond to terminal modes that can be set/reset via escape sequences (e.g DECAWM wraparound mode) + set opt_insert_mode [tcl::dict::get $opts -insert_mode];#should usually be 1 for each new line in editor mode but must be initialised to 1 externally (review) + #default is for overtype + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_autowrap_mode [tcl::dict::get $opts -autowrap_mode] ;#DECAWM - char or movement can go beyond leftmost/rightmost col to prev/next line + set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] ;#DECSNM + set opt_crm_mode [tcl::dict::get $opts -crm_mode];# CRM - show control character mode + # -- --- --- --- --- --- --- --- --- --- --- --- + set temp_cursor_saved [tcl::dict::get $opts -cursor_restore_attributes] + + set cp437_glyphs [tcl::dict::get $opts -cp437] + set cp437_map [tcl::dict::create] + if {$cp437_glyphs} { + set cp437_map [set ::punk::ansi::cp437_map] + #for cp437 images we need to map these *after* splitting ansi + #some old files might use newline for its glyph.. but we can't easily support that. + #Not sure how old files did it.. maybe cr lf in sequence was newline and any lone cr or lf were displayed as glyphs? + tcl::dict::unset cp437_map \n + } + + set opt_transparent [tcl::dict::get $opts -transparent] + if {$opt_transparent eq "0"} { + set do_transparency 0 + } else { + set do_transparency 1 + if {$opt_transparent eq "1"} { + set opt_transparent {[\s]} + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_returnextra [tcl::dict::get $opts -info] + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + # -- --- --- --- --- --- --- --- --- --- --- --- + + if {$opt_row_context eq ""} { + set cursor_row 1 + } else { + set cursor_row $opt_row_context + } + + set insert_mode $opt_insert_mode ;#default 1 + set autowrap_mode $opt_autowrap_mode ;#default 1 + set crm_mode $opt_crm_mode ;#default 0 (Show Control Character mode) + set reverse_mode $opt_reverse_mode + + #----- + # + if {[info exists punk::console::tabwidth]} { + #punk console is updated if punk::console::set_tabstop_width is used or rep is started/restarted + #It is way too slow to test the current width by querying the terminal here - so it could conceivably get out of sync + #todo - we also need to handle the new threaded repl where console config is in a different thread. + # - also - concept of sub-regions being mini-consoles with their own settings - 'id' for console, or use in/out channels as id? + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + + set overdata $over + if {!$cp437_glyphs} { + #REVIEW! tabify will give different answers for an ANSI colourised string vs plain text + if {!$opt_etabs} { + if {[string first \t $under] >= 0} { + #set under [textutil::tabify::untabify2 $under] + set under [textutil::tabify::untabifyLine $under $tw] + } + + #review - is untabifying sensible at this point?? + if {$opt_overtext_type eq "ansisplit"} { + #todo - something for each pt part? + } else { + #plain|mixed + if {[string first \t $over] >= 0} { + #set overdata [textutil::tabify::untabify2 $over] + set overdata [textutil::tabify::untabifyLine $over $tw] + } + } + } + } + #------- + + #ta_detect ansi and do simpler processing? + + #we repeat tests for grapheme width in different loops - rather than create another datastructure to store widths based on column, + #we'll use the grapheme_width_cached function as a lookup table of all graphemes encountered - as there will often be repeats in different positions anyway. + + # -- --- --- --- --- --- --- --- + if {$under ne ""} { + if {[punk::ansi::ta::detect $under]} { + set undermap [punk::ansi::ta::split_codes_single $under] + } else { + #single plaintext part + set undermap [list $under] + } + } else { + set undermap [list] + } + set understacks [list] + set understacks_gx [list] + set pm_list [list] + + set i_u -1 ;#underlay may legitimately be empty + set undercols [list] + set u_codestack [list] + #u_gx_stack probably isn't really a stack - I don't know if g0 g1 can stack or not - for now we support only g0 anyway + set u_gx_stack [list] ;#separate stack for g0 (g1 g2 g3?) graphics on and off (DEC special graphics) + #set pt_underchars "" ;#for string_columns length calculation for expand_right 0 truncation + set remainder [list] ;#for returnextra + foreach {pt code} $undermap { + #pt = plain text + #append pt_underchars $pt + if {$pt ne ""} { + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] + } + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set hex [format %x [scan $p1 %c]] ;#punk::char::char_hex + set re [tcl::string::cat {^[} \\U$hex {]+$}] + set is_ptrun [regexp $re $pt] + } + if {$is_ptrun} { + set width [grapheme_width_cached $p1] ;# when zero??? + set ptlen [string length $pt] + #puts -nonewline stderr !$ptlen! + if {$width <= 1} { + #review - 0 and 1? + incr i_u $ptlen + lappend understacks {*}[lrepeat $ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $ptlen $u_gx_stack] + lappend undercols {*}[lrepeat $ptlen $p1] + } else { + incr i_u $ptlen ;#2nd col empty str - so same as above + set 2ptlen [expr {$ptlen * 2}] + lappend understacks {*}[lrepeat $2ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $2ptlen $u_gx_stack] + set l [concat {*}[lrepeat $ptlen [list $p1 ""]]] + lappend undercols {*}$l + unset l + } + + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + #an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. + #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. + #todo - test decimal value instead, compare performance + switch -- $grapheme { + " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - + z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { + set width 1 + } + default { + if {$grapheme eq "\u0000"} { + #use null as empty cell representation - review + #use of this will probably collide with some application at some point + #consider an option to set the empty cell character + set width 1 + } else { + #zero width still acts as 1 below??? review what should happen + set width [grapheme_width_cached $grapheme] + #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length + #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI + #todo - default to off and add a flag (?) to enable this substitution + set sub_stray_escapes 0 + if {$sub_stray_escapes && $width == 0} { + if {$grapheme eq "\x1b"} { + set gvis [ansistring VIEW $grapheme] ;#can only use with graphemes that have a single replacement char.. + set grapheme $gvis + set width 1 + } + } + } + } + } + + #set width [grapheme_width_cached $grapheme] + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + + lappend undercols $grapheme + if {$width > 1} { + #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) + #but what about emoji combinations etc - can they be wider than 2? + #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + lappend undercols "" + } + } + + } + } + #underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here + + #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc + #keep any remaining PMs in place + if {$code ne ""} { + set c1c2 [tcl::string::range $code 0 1] + + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[ 7CSI\ + \x9b 8CSI\ + \x1b\( 7GFX\ + \x1b^ 7PMX\ + \x1bX 7SOS\ + ] $c1c2] 0 3];# leadernorm is 1st 2 chars mapped to normalised indicator - or is original 2 chars + + switch -- $leadernorm { + 7CSI - 8CSI { + #need to exclude certain leaders after the lb e.g < for SGR 1006 mouse + #REVIEW - what else could end in m but be mistaken as a normal SGR code here? + set maybemouse "" + if {[tcl::string::index $c1c2 0] eq "\x1b"} { + set maybemouse [tcl::string::index $code 2] + } + + if {$maybemouse ne "<" && [tcl::string::index $code end] eq "m"} { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set u_codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set u_codestack [list $code] + } else { + #basic simplification first.. straight dups + set dup_posns [lsearch -all -exact $u_codestack $code] ;#-exact because of square-bracket glob chars + set u_codestack [lremove $u_codestack {*}$dup_posns] + lappend u_codestack $code + } + } + } + 7GFX { + switch -- [tcl::string::index $code 2] { + "0" { + set u_gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess + } + B { + set u_gx_stack [list] + } + } + } + 7PMX - 7SOS { + #we can have PMs or SOS (start of string) in the underlay - though mostly the PMs should have been processed.. + #attach the PM/SOS (entire ANSI sequence) to the previous grapheme! + #It should not affect the size - but terminal display may get thrown out if terminal doesn't support them. + + #note that there may in theory already be ANSI stored - we don't assume it was a pure grapheme string + set graphemeplus [lindex $undercols end] + if {$graphemeplus ne "\0"} { + append graphemeplus $code + } else { + set graphemeplus $code + } + lset undercols end $graphemeplus + #The grapheme_width_cached function will be called on this later - and doesn't account for ansi. + #we need to manually cache the item with it's proper width + variable grapheme_widths + #stripped and plus version keys pointing to same length + dict set grapheme_widths $graphemeplus [grapheme_width_cached [::punk::ansi::ansistrip $graphemeplus]] + + } + default { + + } + + } + + #if {[punk::ansi::codetype::is_sgr_reset $code]} { + # #set u_codestack [list] + #} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + #} elseif {[punk::ansi::codetype::is_sgr $code]} { + #} else { + # #leave SGR stack as is + # if {[punk::ansi::codetype::is_gx_open $code]} { + # } elseif {[punk::ansi::codetype::is_gx_close $code]} { + # } + #} + } + #consider also if there are other codes that should be stacked..? + } + + #NULL empty cell indicator + if {$opt_width ne "\uFFEF"} { + if {[llength $understacks]} { + set cs $u_codestack + set gs $u_gx_stack + } else { + set cs [list] + set gs [list] + } + if {[llength $undercols]< $opt_width} { + set diff [expr {$opt_width- [llength $undercols]}] + if {$diff > 0} { + #set undercols [list {*}$undercols {*}[lrepeat $diff "\u0000"]] ;#2024 - much slower + lappend undercols {*}[lrepeat $diff "\u0000"] + lappend understacks {*}[lrepeat $diff $cs] + lappend understacks_gx {*}[lrepeat $diff $gs] + } + } + } + + if {$opt_width ne "\uFFEF"} { + set renderwidth $opt_width + } else { + set renderwidth [llength $undercols] + } + + + if 0 { + # ----------------- + # if we aren't extending understacks & understacks_gx each time we incr idx above the undercols length.. this doesn't really serve a purpose + # Review. + # ----------------- + #replay code for last overlay position in input line + # whether or not we get that far - we need to return it for possible replay on next line + if {[llength $understacks]} { + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + } else { + #in case overlay onto emptystring as underlay + lappend understacks [list] + lappend understacks_gx [list] + } + # ----------------- + } + + #trailing codes in effect for underlay + if {[llength $u_codestack]} { + #set replay_codes_underlay [join $u_codestack ""] + set replay_codes_underlay [punk::ansi::codetype::sgr_merge_list {*}$u_codestack] + } else { + set replay_codes_underlay "" + } + + + # -- --- --- --- --- --- --- --- + #### + #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left containing the right number of columns. + #this will be processed as transparent - and handle doublewidth underlay characters appropriately + set startpadding [string repeat " " [expr {$opt_colstart -1}]] + #overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency + if {$startpadding ne "" || $overdata ne ""} { + if {$opt_overtext_type eq "ansisplit"} { + set overmap $overdata + lset overmap 0 "$startpadding[lindex $overmap 0]" + } else { + if {[punk::ansi::ta::detect $overdata]} { + #TODO!! rework this. + #e.g 200K+ input file with no newlines - we are wastefully calling split_codes_single repeatedly on mostly the same data. + #set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] + set overmap [punk::ansi::ta::split_codes_single $overdata] + lset overmap 0 "$startpadding[lindex $overmap 0]" + + } else { + #single plaintext part + set overmap [list $startpadding$overdata] + } + } + } else { + set overmap [list] + } + #### + + + #todo - detect plain ascii no-ansi input line (aside from leading ansi reset) + #will that allow some optimisations? + + #todo - detect repeated transparent char in overlay + #regexp {^(.)\1+$} ;#backtracking regexp - relatively slow. + # - try set c [string index $data 0]; regexp [string map [list %c% $c] {^[%c%]+$}] $data + #we should be able to optimize to pass through the underlay?? + + #??? + set colcursor $opt_colstart + #TODO - make a little virtual column object + #we need to refer to column1 or columnmin? or columnmax without calculating offsets due to to startcolumn + #need to lock-down what start column means from perspective of ANSI codes moving around - the offset perspective is unclear and a mess. + + + #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + #as at 2024-02 punk::char::grapheme_split uses these - not aware of more complex graphemes + + set overstacks [list] + set overstacks_gx [list] + + set o_codestack [list]; #SGR codestack (not other codes such as movement,insert key etc) + set o_gxstack [list] + set pt_overchars "" + set i_o 0 + + set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use + set overlay_grapheme_control_stacks [list] + #REVIEW - even if we pass in a pre-split overtext (-overtext_type ansisplit) + #we are re-generating the overlay_grapheme_control_stacks list each time + #this is a big issue when overtext is not broken into lines, but is just a big long ansi and/or plain text string. + #todo - return also the unapplied portion of the overlay_grapheme_control_stacks list?? + foreach {pt code} $overmap { + if {$pt ne ""} { + #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] + } + append pt_overchars $pt + #will get empty pt between adjacent codes + if {!$crm_mode} { + + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+$}] + set is_ptrun [regexp $re $pt] + + #leading only? we would have to check for graphemes at the trailing boundary? + #set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+}] + #set is_ptrun [regexp -indices $re $pt runrange] + #if {$is_ptrun && 1} { + #} + } + if {$is_ptrun} { + #review - in theory a run over a certain length won't be part of some grapheme combo (graphemes can be long e.g 44?, but not as runs(?)) + #could be edge cases for runs at line end? (should be ok as we include trailing \n in our data) + set len [string length $pt] + set g_element [list g $p1] + #puts -nonewline stderr "!$len!" + + #lappend overstacks {*}[lrepeat $len $o_codestack] + #lappend overstacks_gx {*}[lrepeat $len $o_gxstack] + #incr i_o $len + #lappend overlay_grapheme_control_list {*}[lrepeat $len [list g $p1]] + #lappend overlay_grapheme_control_stacks {*}[lrepeat $len $o_codestack] + + set pi 0 + incr i_o $len + while {$pi < $len} { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + lappend overlay_grapheme_control_list $g_element + lappend overlay_grapheme_control_stacks $o_codestack + incr pi + } + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + } else { + set tsbegin [clock micros] + foreach grapheme_original [punk::char::grapheme_split $pt] { + set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] + #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" + foreach grapheme [punk::char::grapheme_split $pt_crm] { + if {$grapheme eq "\n"} { + lappend overlay_grapheme_control_stacks $o_codestack + lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"] + } else { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + } + set elapsed [expr {[clock micros] - $tsbegin}] + puts stderr "ptlen [string length $pt] elapsedus:$elapsed" + } + } + + #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc + #order of if-else based on assumptions: + # that pure resets are fairly common - more so than leading resets with other info + # that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all. + if {$code ne ""} { + #we need to immediately set crm_mode here if \x1b\[3h received + if {$code eq "\x1b\[3h"} { + set crm_mode 1 + } elseif {$code eq "\x1b\[3l"} { + set crm_mode 0 + } + #else crm_mode could be set either way from options + if {$crm_mode && $code ne "\x1b\[00001E"} { + #treat the code as type 'g' like above - only allow through codes to reset mode REVIEW for now just \x1b\[3l ? + #we need to somehow convert further \n in the graphical rep to an instruction for newline that will bypass further crm_mode processing or we would loop. + set code_as_pt [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $code] + #split using standard split for first foreach loop - grapheme based split when processing 2nd foreach loop + set chars [split $code_as_pt ""] + set codeparts [list] ;#list of 2-el lists each element {crmcontrol } or {g } + foreach c $chars { + if {$c eq "\n"} { + #use CNL (cursor next line) \x1b\[00001E ;#leading zeroes ok for this processor - used as debugging aid to distinguish + lappend codeparts [list crmcontrol "\x1b\[00001E"] + } else { + if {[llength $codeparts] > 0 && [lindex $codeparts end 0] eq "g"} { + set existing [lindex $codeparts end 1] + lset codeparts end [list g [string cat $existing $c]] + } else { + lappend codeparts [list g $c] + } + } + } + + set partidx 0 + foreach record $codeparts { + lassign $record rtype rval + switch -exact -- $rtype { + g { + append pt_overchars $rval + foreach grapheme [punk::char::grapheme_split $rval] { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + crmcontrol { + #leave o_codestack + lappend overlay_grapheme_control_stacks $o_codestack + lappend overlay_grapheme_control_list [list crmcontrol $rval] + } + } + } + } else { + lappend overlay_grapheme_control_stacks $o_codestack + #there will always be an empty code at end due to foreach on 2 vars with odd-sized list ending with pt (overmap coming from perlish split) + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set o_codestack [list "\x1b\[m"] ;#reset better than empty list - fixes some ansi art issues + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set o_codestack [list $code] + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[priv::is_sgr $code]} { + #basic simplification first - remove straight dupes + set dup_posns [lsearch -all -exact $o_codestack $code] ;#must be -exact because of square-bracket glob chars + set o_codestack [lremove $o_codestack {*}$dup_posns] + lappend o_codestack $code + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[regexp {\x1b7|\x1b\[s} $code]} { + #experiment + #cursor_save - for the replays review. + #jmn + #set temp_cursor_saved [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] + lappend overlay_grapheme_control_list [list other $code] + } elseif {[regexp {\x1b8|\x1b\[u} $code]} { + #experiment + #cursor_restore - for the replays + set o_codestack [list $temp_cursor_saved] + lappend overlay_grapheme_control_list [list other $code] + } else { + #review + if {[punk::ansi::codetype::is_gx_open $code]} { + set o_gxstack [list "gx0_on"] + lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets + } elseif {[punk::ansi::codetype::is_gx_close $code]} { + set o_gxstack [list] + lappend overlay_grapheme_control_list [list gx0 gx0_off] ;#don't store code - will complicate debugging if we spit it out and jump character sets + } else { + lappend overlay_grapheme_control_list [list other $code] + } + } + } + } + + } + #replay code for last overlay position in input line - should take account of possible trailing sgr code after last grapheme + set max_overlay_grapheme_index [expr {$i_o -1}] + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + + #set replay_codes_overlay [join $o_codestack ""] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] + + #if {[tcl::dict::exists $overstacks $max_overlay_grapheme_index]} { + # set replay_codes_overlay [join [tcl::dict::get $overstacks $max_overlay_grapheme_index] ""] + #} else { + # set replay_codes_overlay "" + #} + # -- --- --- --- --- --- --- --- + + + #potential problem - combinining diacritics directly following control chars like \r \b + + # -- --- --- + #we need to initialise overflow_idx before any potential row-movements - as they need to perform a loop break and force in_excess to 1 + if {$opt_expand_right} { + #expand_right true means we can have lines as long as we want, but either way there can be excess data that needs to be thrown back to the calling loop. + #we currently only support horizontal expansion to the right (review regarding RTL text!) + set overflow_idx -1 + } else { + #expand_right zero - we can't grow beyond our column width - so we get ellipsis or truncation + if {$opt_width ne "\uFFEF"} { + set overflow_idx [expr {$opt_width}] + } else { + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + } + } + # -- --- --- + + set outcols $undercols ;#leave undercols as is, outcols can potentially be appended to. + + set unapplied "" ;#if we break for move row (but not for /v ?) + set unapplied_list [list] + set unapplied_ansisplit [list ""] ;#pt code ... pt + + set insert_lines_above 0 ;#return key + set insert_lines_below 0 + set instruction "" + + # -- --- --- + #cursor_save_dec, cursor_restore_dec etc + set cursor_restore_required 0 + set cursor_saved_attributes "" + set cursor_saved_position "" + # -- --- --- + + #set idx 0 ;# line index (cursor - 1) + #set idx [expr {$opt_colstart + $opt_colcursor} -1] + + #idx is the per column output index + set idx [expr {$opt_colcursor -1}] ;#don't use opt_colstart here - we have padded and won't start emitting until idx reaches opt_colstart-1 + #cursor_column is usually one above idx - but we have opt_colstart which is like a margin - todo: remove cursor_column from the following loop and calculate it's offset when breaking or at end. + #(for now we are incrementing/decrementing both in sync - which is a bit silly) + set cursor_column $opt_colcursor + + #idx_over is the per grapheme overlay index + set idx_over -1 + + + #movements only occur within the overlay range. + #an underlay is however not necessary.. e.g + #renderline -expand_right 1 "" data + + #set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM + #set re_col_move {\x1b\[([0-9]*)(C|D|G)$} + #set re_row_move {\x1b\[([0-9]*)(A|B)$} + #set re_both_move {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)H$} ;# or "f" ? + #set re_vt_sequence {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)~$} + #set re_cursor_save {\x1b\[s$} ;#note probable incompatibility with DECSLRM (set left right margin)! + #set re_cursor_restore {\x1b\[u$} + #set re_cursor_save_dec {\x1b7$} + #set re_cursor_restore_dec {\x1b8$} + #set re_other_single {\x1b(D|M|E)$} + #set re_decstbm {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)r$} ;#DECSTBM set top and bottom margins + + #puts "-->$overlay_grapheme_control_list<--" + #puts "-->overflow_idx: $overflow_idx" + for {set gci 0} {$gci < [llength $overlay_grapheme_control_list]} {incr gci} { + set gc [lindex $overlay_grapheme_control_list $gci] + lassign $gc type item + + #emit plaintext chars first using existing SGR codes from under/over stack as appropriate + #then check if the following code is a cursor movement within the line and adjust index if so + #foreach ch $overlay_graphemes {} + switch -- $type { + g { + set ch $item + #crm_mode affects both graphic and control + if {0 && $crm_mode} { + set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $ch] + set chars [string map [list \n "\x1b\[00001E"] $chars] + if {[llength [split $chars ""]] > 1} { + priv::render_to_unapplied $overlay_grapheme_control_list $gci + #prefix the unapplied controls with the string version of this control + #set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + #JMN - backwards compat ledit from punk::lib for tcl <9 + ledit unapplied_list -1 -1 {*}[split $chars ""] + set unapplied [join $unapplied_list ""] + lset unapplied_ansisplit 0 $chars ;#no existing ? + + #incr idx_over + break + } else { + set ch $chars + } + } + incr idx_over; #idx_over (until unapplied reached anyway) is per *grapheme* in the overlay - not per col. + if {($idx < ($opt_colstart -1))} { + incr idx [grapheme_width_cached $ch] + continue + } + #set within_undercols [expr {$idx <= [llength $undercols]-1}] ;#within our active data width + set within_undercols [expr {$idx <= $renderwidth-1}] + + #https://www.enigma.com/resources/blog/the-secret-world-of-newline-characters + #\x85 NEL in the c1 control set is treated by some terminal emulators (e.g Hyper) as a newline, + #on some it's invisble but doesn't change the line, on some it's a visible glyph of width 1. + #This is hard to process in any standard manner - but I think the Hyper behaviour of doing what it was intended is perhaps most reasonable + #We will map it to the same behaviour as lf here for now... but we need also to consider the equivalent ANSI sequence: \x1bE + + set chtest [tcl::string::map [list \n \x85 \b \r \v \x7f ] $ch] + #puts --->chtest:$chtest + #specials - each shoud have it's own test of what to do if it happens after overflow_idx reached + switch -- $chtest { + "" { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + if {$idx == 0} { + #puts "---a at col 1" + #linefeed at column 1 + #leave the overflow_idx ;#? review + set instruction lf_start ;#specific instruction for newline at column 1 + priv::render_to_unapplied $overlay_grapheme_control_list $gci + break + } elseif {$overflow_idx != -1 && $idx == $overflow_idx} { + #linefeed after final column + #puts "---c at overflow_idx=$overflow_idx" + incr cursor_row + set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 + set instruction lf_overflow ;#only special treatment is to give it it's own instruction in case caller needs to handle differently + priv::render_to_unapplied $overlay_grapheme_control_list $gci + break + } else { + #linefeed occurred in middle or at end of text + #puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx" + if {$insert_mode == 0} { + incr cursor_row + if {$idx == -1 || $overflow_idx > $idx} { + #don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow + set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 + } + set instruction lf_mid + priv::render_to_unapplied $overlay_grapheme_control_list $gci + break + } else { + incr cursor_row + #don't adjust the overflow_idx + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction lf_mid + break ;# could have overdata following the \n - don't keep processing + } + } + + } + "" { + #will we want/need to use raw for keypresses in terminal? (terminal with LNM in standard reset mode means enter= this is the usual config for terminals) + #So far we are assuming the caller has translated to and handle above.. REVIEW. + + #consider also the old space-carriagereturn softwrap convention used in some terminals. + #In the context of rendering to a block of text - this works similarly in that the space gets eaten so programs emitting space-cr at the terminal width col will pretty much get what they expect. + set idx [expr {$opt_colstart -1}] + set cursor_column $opt_colstart ;#? + } + "" { + #literal backspace char - not necessarily from keyboard + #review - backspace effect on double-width chars - we are taking a column-editing perspective in overtype + #(important for -transparent option - hence replacement chars for half-exposed etc) + #review - overstrike support as per nroff/less (generally considered an old technology replaced by unicode mechanisms and/or ansi SGR) + if {$idx > ($opt_colstart -1)} { + incr idx -1 + incr cursor_column -1 + } else { + set flag 0 + if $flag { + #review - conflicting requirements? Need a different sequence for destructive interactive backspace? + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction backspace_at_start + break + } + } + } + "" { + #literal del character - some terminals send just this for what is generally expected to be a destructive backspace + #We instead treat this as a pure delete at current cursor position - it is up to the repl or terminal to remap backspace key to a sequence that has the desired effect. + priv::render_delchar $idx + } + "" { + #end processing this overline. rest of line is remainder. cursor for column as is. + #REVIEW - this theoretically depends on terminal's vertical tabulation setting (name?) + #e.g it could be configured to jump down 6 rows. + #On the other hand I've seen indications that some modern terminal emulators treat it pretty much as a linefeed. + #todo? + incr cursor_row + set overflow_idx $idx + #idx_over has already been incremented as this is both a movement-control and in some sense a grapheme + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction vt + break + } + default { + if {$overflow_idx != -1} { + #review - how to check arbitrary length item such as tab is going to overflow .. before we get to overflow_idx? + #call grapheme_width_cached on each ch, or look for tab specifically as it's currently the only known reason to have a grapheme width > 2? + #we need to decide what a tab spanning the overflow_idx means and how it affects wrap etc etc + if {$idx == $overflow_idx-1} { + set owidth [grapheme_width_cached $ch] + if {$owidth == 2} { + #review split 2w overflow? + #we don't want to make the decision here to split a 2w into replacement characters at end of line and beginning of next line + #better to consider the overlay char as unable to be applied to the line + #render empty column(?) - and reduce overlay grapheme index by one so that the current ch goes into unapplied + #throwing back to caller with instruction complicates its job - but is necessary to avoid making decsions for it here. + priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #change the overflow_idx + set overflow_idx $idx + incr idx + incr idx_over -1 ;#set overlay grapheme index back one so that sgr stack from previous overlay grapheme used + priv::render_to_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#note $gci-1 instead of just gci + #throw back to caller's loop - add instruction to caller as this is not the usual case + #caller may for example choose to render a single replacement char to this line and omit the grapheme, or wrap it to the next line + set instruction overflow_splitchar + break + } elseif {$owidth > 2} { + #? tab? + #TODO! + puts stderr "overtype::renderline long overtext grapheme '[ansistring VIEW -lf 1 -vt 1 $ch]' not handled" + #tab of some length dependent on tabstops/elastic tabstop settings? + } + } elseif {$idx >= $overflow_idx} { + #REVIEW + set next_gc [lindex $overlay_grapheme_control_list $gci+1] ;#next grapheme or control + lassign $next_gc next_type next_item + if {$autowrap_mode} { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci-1]] + #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #don't incr idx beyond the overflow_idx + #idx_over already incremented - decrement so current overlay grapheme stacks go to unapplied + incr idx_over -1 + #priv::render_to_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#back one index here too + priv::render_this_unapplied $overlay_grapheme_control_list $gci ;# + set instruction overflow + break + } elseif {0 && $next_type ne "g"} { + incr idx_over -1 + priv::render_this_unapplied $overlay_grapheme_control_list $gci ;# + set instruction overflow + break + } else { + #no point throwing back to caller for each grapheme that is overflowing + #without this branch - renderline would be called with overtext reducing only by one grapheme per call + #processing a potentially long overtext each time (ie - very slow) + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #JMN4 + + } + } + } else { + #review. + #overflow_idx = -1 + #This corresponds to expand_right being true (at least until overflow_idx is in some cases forced to a value when throwing back to calling loop) + } + + if {($do_transparency && [regexp $opt_transparent $ch])} { + #pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay) + if {$idx > [llength $outcols]-1} { + lappend outcols " " + #tcl::dict::set understacks $idx [list] ;#review - use idx-1 codestack? + #lset understacks $idx [list] ;#will get index $i out of range error + lappend understacks [list] ;#REVIEW + incr idx + incr cursor_column + } else { + #todo - punk::char::char_width + set g [lindex $outcols $idx] + #JMN + set uwidth [grapheme_width_cached $g] + if {[lindex $outcols $idx] eq ""} { + #2nd col of 2-wide char in underlay + incr idx + incr cursor_column + } elseif {$uwidth == 0} { + #e.g control char ? combining diacritic ? + incr idx + incr cursor_column + } elseif {$uwidth == 1} { + set owidth [grapheme_width_cached $ch] + incr idx + incr cursor_column + if {$owidth > 1} { + incr idx + incr cursor_column + } + } elseif {$uwidth > 1} { + if {[grapheme_width_cached $ch] == 1} { + if {!$insert_mode} { + #normal singlewide transparent overlay onto double-wide underlay + set next_pt_overchar [tcl::string::index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay + if {$next_pt_overchar eq ""} { + #special-case trailing transparent - no next_pt_overchar + incr idx + incr cursor_column + } else { + if {[regexp $opt_transparent $next_pt_overchar]} { + incr idx + incr cursor_column + } else { + #next overlay char is not transparent.. first-half of underlying 2wide char is exposed + #priv::render_addchar $idx $opt_exposed1 [tcl::dict::get $overstacks $idx_over] [tcl::dict::get $overstacks_gx $idx_over] $insert_mode + priv::render_addchar $idx $opt_exposed1 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column + } + } + } else { + #? todo - decide what transparency even means for insert mode + incr idx + incr cursor_column + } + } else { + #2wide transparency over 2wide in underlay - review + incr idx + incr cursor_column + } + } + } + } else { + + set idxchar [lindex $outcols $idx] + #non-transparent char in overlay or empty cell + if {$idxchar eq "\u0000"} { + #empty/erased cell indicator + set uwidth 1 + } else { + set uwidth [grapheme_width_cached $idxchar] + } + if {$within_undercols} { + if {$idxchar eq ""} { + #2nd col of 2wide char in underlay + if {!$insert_mode} { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 + #JMN - this has to expose if our startposn chopped an underlay - but not if we already overwrote the first half of the widechar underlay grapheme + #e.g renderline \uFF21\uFF21--- a\uFF23\uFF23 + #vs + # renderline -startcolumn 2 \uFF21---- \uFF23 + if {[lindex $outcols $idx-1] != ""} { + #verified it's an empty following a filled - so it's a legit underlay remnant (REVIEW - when would it not be??) + #reset previous to an exposed 1st-half - but leave understacks code as is + priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 + } + incr idx + } else { + set prevcolinfo [lindex $outcols $idx-1] + #for insert mode - first replace the empty 2ndhalf char with exposed2 before shifting it right + #REVIEW - this leaves a replacement character permanently in our columns.. but it is consistent regarding length (?) + #The alternative is to disallow insertion at a column cursor that is at 2nd half of 2wide char + #perhaps by inserting after the char - this may be worthwhile - but may cause other surprises + #It is perhaps best avoided at another level and try to make renderline do exactly as it's told + #the advantage of this 2w splitting method is that the inserted character ends up in exactly the column we expect. + priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 ;#replace not insert + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 1 ;#insert - same index + if {$prevcolinfo ne ""} { + #we've split the 2wide - it may already have been rendered as an exposed1 - but not for example if our startcolumn was current idx + priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 ;#replace not insert + } ;# else?? + incr idx + } + if {$cursor_column < [llength $outcols] || $overflow_idx == -1} { + incr cursor_column + } + } elseif {$uwidth == 0} { + #what if this is some other c0/c1 control we haven't handled specifically? + + #by emitting a preceding empty-string column - we associate whatever this char is with the preceeding non-zero-length character and any existing zero-lengths that follow it + #e.g combining diacritic - increment before over char REVIEW + #arguably the previous overchar should have done this - ie lookahead for combiners? + #if we can get a proper grapheme_split function - this should be easier to tidy up. + priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column 2 + + if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { + set cursor_column [llength $outcols] + } + } elseif {$uwidth == 1} { + #includes null empty cells + set owidth [grapheme_width_cached $ch] + if {$owidth == 1} { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + } else { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #if next column in underlay empty - we've overwritten first half of underlying 2wide grapheme + #replace with rhs exposure in case there are no more overlay graphemes coming - use underlay's stack + if {([llength $outcols] >= $idx +2) && [lindex $outcols $idx+1] eq ""} { + priv::render_addchar [expr {$idx+1}] $opt_exposed2 [lindex $understacks $idx+1] [lindex $understacks_gx $idx+1] $insert_mode + } + incr idx + } + if {($cursor_column < [llength $outcols]) || $overflow_idx == -1} { + incr cursor_column + } + } elseif {$uwidth > 1} { + set owidth [grapheme_width_cached $ch] + if {$owidth == 1} { + #1wide over 2wide in underlay + if {!$insert_mode} { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column + priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #don't incr idx - we are just putting a broken-indication in the underlay - which may get overwritten by next overlay char + } else { + #insert mode just pushes all to right - no exposition char here + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column + } + } else { + #2wide over 2wide + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx 2 + incr cursor_column 2 + } + + if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { + set cursor_column [llength $outcols] + } + } + } else { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column + } + } + } + } ;# end switch + + + } + other - crmcontrol { + if {$crm_mode && $type ne "crmcontrol" && $item ne "\x1b\[00001E"} { + if {$item eq "\x1b\[3l"} { + set crm_mode 0 + } else { + #When our initial overlay split was done - we weren't in crm_mode - so there are codes that weren't mapped to unicode control character representations + #set within_undercols [expr {$idx <= $renderwidth-1}] + #set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $item] + set chars [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $item] + priv::render_to_unapplied $overlay_grapheme_control_list $gci + #prefix the unapplied controls with the string version of this control + #set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + #JMN + ledit unapplied_list -1 -1 {*}[split $chars ""] + set unapplied [join $unapplied_list ""] + #ledit unapplied_ansisplit -1 -1 $chars + lset unapplied_ansisplit 0 $chars ;#?? + + break + } + } + + #todo - consider CSI s DECSLRM vs ansi.sys \x1b\[s - we need \x1b\[s for oldschool ansi art - but may have to enable only for that. + #we should possibly therefore reverse this mapping so that x1b7 x1b8 are the primary codes for save/restore? + set code [tcl::string::map [list \x1b7 \x1b\[s \x1b8 \x1b\[u ] $item] + #since this element isn't a grapheme - advance idx_over to next grapheme overlay when about to fill 'unapplied' + + + #remap of DEC cursor_save/cursor_restore from ESC sequence to equivalent CSI + #probably not ideal - consider putting cursor_save/cursor_restore in functions so they can be called from the appropriate switch branch instead of using this mapping + #review - cost/benefit of function calls within these switch-arms instead of inline code? + + set c1 [tcl::string::index $code 0] + set c1c2c3 [tcl::string::range $code 0 2] + #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} + #tcl 8.7 - faster to use inline list than to store it in a local var outside of loop. + #(somewhat surprising) + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[< 1006\ + \x1b\[ 7CSI\ + \x1bY 7MAP\ + \x1bP 7DCS\ + \x90 8DCS\ + \x9b 8CSI\ + \x1b\] 7OSC\ + \x9d 8OSC\ + \x1b 7ESC\ + ] $c1c2c3] 0 3] ;#leadernorm is 1st 1,2 or 3 chars mapped to 4char normalised indicator - or is original first chars (1,2 or 3 len) + + #we leave the tail of the code unmapped for now + switch -- $leadernorm { + 1006 { + #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html + #SGR (1006) CSI < followed by colon separated encoded-button-value,px,py ordinates and final M for button press m for button release + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 3 end]] + } + 7CSI - 7OSC { + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] + set codenorm $leadernorm[tcl::string::range $code 2 end] + } + 7DCS { + #ESC P + #Device Control String https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h4-Controls-beginning-with-ESC:ESC-F.C74 + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] + } + 8DCS { + #8-bit Device Control String + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + } + 7MAP { + #map to another type of code to share implementation branch + set codenorm $leadernorm[tcl::string::range $code 1 end] + } + 7ESC { + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + set codenorm $leadernorm[tcl::string::range $code 1 end] + } + 8CSI - 8OSC { + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + } + default { + #JMN + puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. leadernorm: [ansistring VIEW -lf 1 $leadernorm] code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + puts stderr "ARGS:" + foreach a $args { + puts stderr " $a" + } + puts stderr ----- + foreach {xpt ycode} $overmap { + puts stderr "t:'$xpt'" + puts stderr "c:[ansistring VIEW $ycode]" + } + #we haven't made a mapping for this + #could in theory be 1,2 or 3 in len + #although we shouldn't be getting here if the regexp for ansi codes is kept in sync with our switch branches + set codenorm $code + } + } + + switch -- $leadernorm { + 7MAP { + switch -- [lindex $codenorm 4] { + Y { + #vt52 movement. we expect 2 chars representing position (limited range) + set params [tcl::string::range $codenorm 5 end] + if {[tcl::string::length $params] != 2} { + #shouldn't really get here or need this branch if ansi splitting was done correctly + puts stderr "overtype::renderline ESC Y recognised as vt52 move, but incorrect parameters length ([string length $params] vs expected 2) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" + } + set line [tcl::string::index $params 5] + set column [tcl::string::index $params 1] + set r [expr {[scan $line %c] -31}] + set c [expr {[scan $column %c] -31}] + + #MAP to: + #CSI n;m H - CUP - Cursor Position + set leadernorm 7CSI + set codenorm "$leadernorm${r}\;${c}H" + } + } + } + } + + #we've mapped 7 and 8bit escapes to values we can handle as literals in switch statements to take advantange of jump tables. + switch -- $leadernorm { + 1006 { + #TODO + # + switch -- [tcl::string::index $codenorm end] { + M { + puts stderr "mousedown $codenorm" + } + m { + puts stderr "mouseup $codenorm" + } + } + + } + {7CSI} - {8CSI} { + set param [tcl::string::range $codenorm 4 end-1] + #puts stdout "--> CSI [tcl::string::index $leadernorm 0] bit param:$param" + set code_end [tcl::string::index $codenorm end] ;#used for e.g h|l set/unset mode + + switch -exact -- $code_end { + A { + #Row move - up + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #todo + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + + if {$num eq ""} {set num 1} + incr cursor_row -$num + + if {$cursor_row < 1} { + set cursor_row 1 + } + + #ensure rest of *overlay* is emitted to remainder + incr idx_over + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction up + #retain cursor_column + break + } + B { + #CUD - Cursor Down + #Row move - down + lassign [split $param {;}] num modifierkey + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #move down + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} + incr cursor_row $num + + + incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction down + #retain cursor_column + break + } + C { + #CUF - Cursor Forward + #Col move + #puts stdout "->forward" + #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. + #cursor forward + #right-arrow/move forward + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} + + #todo - retrict to moving 1 position past datalen? restrict to column width? + #should ideally wrap to next line when interactive and not on last row + #(some ansi art seems to expect this behaviour) + #This presumably depends on the terminal's wrap mode + #e.g DECAWM autowrap mode + # CSI ? 7 h - set: autowrap (also tput smam) + # CSI ? 7 l - reset: no autowrap (also tput rmam) + set version 2 + if {$version eq "2"} { + set max [llength $outcols] + if {$overflow_idx == -1} { + incr max + } + if {$cursor_column == $max+1} { + #move_forward while in overflow + incr cursor_column -1 + } + + if {($cursor_column + $num) <= $max} { + incr idx $num + incr cursor_column $num + } else { + if {$autowrap_mode} { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #jmn + if {$idx == $overflow_idx} { + incr num + } + + #horizontal movement beyond line extent needs to wrap - throw back to caller + #we may have both overflow_right and unapplied data + #(can have overflow_right if we were in insert_mode and processed chars prior to this movement) + #leave row as is - caller will need to determine how many rows the column-movement has consumed + incr cursor_column $num ;#give our caller the necessary info as columns from start of row + #incr idx_over + #should be gci following last one applied + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction wrapmoveforward + break + } else { + set cursor_column $max + set idx [expr {$cursor_column -1}] + } + } + } else { + #review - dead branch + if {!$expand_right || ($cursor_column + $num) <= [llength $outcols+1]} { + incr idx $num + incr cursor_column $num + } else { + if {!$insert_mode} { + #block editing style with arrow keys + #overtype mode + set idxstart $idx + set idxend [llength $outcols] + set moveend [expr {$idxend - $idxstart}] + if {$moveend < 0} {set moveend 0} ;#sanity? + #puts "idxstart:$idxstart idxend:$idxend outcols[llength $outcols] undercols:[llength $undercols]" + incr idx $moveend + incr cursor_column $moveend + #if {[tcl::dict::exists $understacks $idx]} { + # set stackinfo [tcl::dict::get $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext + #} else { + # set stackinfo [list] + #} + if {$idx < [llength $understacks]} { + set stackinfo [lindex $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext + } else { + set stackinfo [list] + } + if {$idx < [llength $understacks_gx]} { + #set gxstackinfo [tcl::dict::get $understacks_gx $idx] + set gxstackinfo [lindex $understacks_gx $idx] + } else { + set gxstackinfo [list] + } + #pad outcols + set movemore [expr {$num - $moveend}] + #assert movemore always at least 1 or we wouldn't be in this branch + for {set m 1} {$m <= $movemore} {incr m} { + incr idx + incr cursor_column + priv::render_addchar $idx " " $stackinfo $gxstackinfo $insert_mode + } + } else { + #normal - insert + incr idx $num + incr cursor_column $num + if {$idx > [llength $outcols]} { + set idx [llength $outcols];#allow one beyond - for adding character at end of line + set cursor_column [expr {[llength $outcols]+1}] + } + } + } + } + } + D { + #Col move + #puts stdout "<-back" + #cursor back + #left-arrow/move-back when ltr mode + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} + + set version 2 + if {$version eq "2"} { + #todo - startcolumn offset! + if {$cursor_column - $num >= 1} { + incr idx -$num + incr cursor_column -$num + } else { + if {!$autowrap_mode} { + set cursor_column 1 + set idx 0 + } else { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr cursor_column -$num + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction wrapmovebackward + break + } + } + } else { + incr idx -$num + incr cursor_column -$num + if {$idx < $opt_colstart-1} { + #wrap to previous line and position cursor at end of data + set idx [expr {$opt_colstart-1}] + set cursor_column $opt_colstart + } + } + } + E { + #CNL - Cursor Next Line + if {$param eq ""} { + set downmove 1 + } else { + set downmove [expr {$param}] + } + puts stderr "renderline CNL down-by-$downmove" + set cursor_column 1 + set cursor_row [expr {$cursor_row + $downmove}] + set idx [expr {$cursor_column -1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction move + break + + } + F { + #CPL - Cursor Previous Line + if {$param eq ""} { + set upmove 1 + } else { + set upmove [expr {$param}] + } + puts stderr "renderline CPL up-by-$upmove" + set cursor_column 1 + set cursor_row [expr {$cursor_row -$upmove}] + if {$cursor_row < 1} { + set cursor_row 1 + } + set idx [expr {$cursor_column - 1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction move + break + + } + G { + #CHA - Cursor Horizontal Absolute (move to absolute column no) + if {$param eq ""} { + set targetcol 1 + } else { + set targetcol $param + if {![string is integer -strict $targetcol]} { + puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Unrecognised parameter '$param'" + } + set targetcol [expr {$param}] + set max [llength $outcols] + if {$overflow_idx == -1} { + incr max + } + if {$targetcol > $max} { + puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Param '$param' > max: $max" + set targetcol $max + } + } + #adjust to colstart - as column 1 is within overlay + #??? REVIEW + set idx [expr {($targetcol -1) + $opt_colstart -1}] + + set cursor_column $targetcol + #puts stderr "renderline absolute col move ESC G (TEST)" + } + H - f { + #CSI n;m H - CUP - Cursor Position + + #CSI n;m f - HVP - Horizontal Vertical Position REVIEW - same as CUP with differences (what?) in some terminal modes + # - 'counts as effector format function (like CR or LF) rather than an editor function (like CUD or CNL)' + # - REVIEW + #see Annex A at: https://www.ecma-international.org/wp-content/uploads/ECMA-48_5th_edition_june_1991.pdf + + #test e.g ansicat face_2.ans + #$re_both_move + lassign [split $param {;}] paramrow paramcol + #missing defaults to 1 + #CSI ;5H = CSI 1;5H -> row 1 col 5 + #CSI 17;H = CSI 17H = CSI 17;1H -> row 17 col 1 + + if {$paramcol eq ""} {set paramcol 1} + if {$paramrow eq ""} {set paramrow 1} + if {![string is integer -strict $paramcol] || ![string is integer -strict $paramrow]} { + puts stderr "renderline CUP (CSI H) unrecognised param $param" + #ignore? + } else { + set max [llength $outcols] + if {$overflow_idx == -1} { + incr max + } + if {$paramcol > $max} { + set target_column $max + } else { + set target_column [expr {$paramcol}] + } + + + if {$paramrow < 1} { + puts stderr "renderline CUP (CSI H) bad row target 0. Assuming 1" + set target_row 1 + } else { + set target_row [expr {$paramrow}] + } + if {$target_row == $cursor_row} { + #col move only - no need for break and move + #puts stderr "renderline CUP col move only to col $target_column param:$param" + set cursor_column $target_column + set idx [expr {$cursor_column -1}] + } else { + set cursor_row $target_row + set cursor_column $target_column + set idx [expr {$cursor_column -1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction move + break + } + } + } + J { + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + switch -exact -- $modegroup { + ? { + #CSI ? Pn J - selective erase + puts stderr "overtype::renderline ED - SELECTIVE ERASE IN DISPLAY (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + default { + puts stderr "overtype::renderline ED - ERASE IN DISPLAY (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of screen + } + 1 { + #clear from cursor to beginning of screen + } + 2 { + #clear entire screen + #ansi.sys - move cursor to upper left REVIEW + set cursor_row 1 + set cursor_column 1 + set idx [expr {$cursor_column -1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + if {[llength $outcols]} { + priv::render_erasechar 0 [llength $outcols] + } + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction clear_and_move + break + } + 3 { + #clear entire screen. presumably cursor doesn't move - otherwise it would be same as 2J ? + + } + default { + } + } + + } + } + } + K { + #see DECECM regarding background colour + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + switch -exact -- $modegroup { + ? { + puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set param [string range $param 1 end] ;#chop qmark + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of line - depending on DECSCA + } + 1 { + #clear from cursor to beginning of line - depending on DECSCA + + } + 2 { + #clear entire line - depending on DECSCA + } + default { + puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + default { + puts stderr "overtype::renderline EL - ERASE IN LINE (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of line + } + 1 { + #clear from cursor to beginning of line + + } + 2 { + #clear entire line + } + default { + puts stderr "overtype::renderline EL - ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + } + } + } + L { + puts stderr "overtype::renderline IL - Insert Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + M { + #CSI Pn M - DL - Delete Line + puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + + } + T { + #CSI Pn T - SD Pan Up (empty lines introduced at top) + #CSI Pn+T - kitty extension (lines at top come from scrollback buffer) + #Pn new lines appear at top of the display, Pn old lines disappear at the bottom of the display + if {$param eq "" || $param eq "0"} {set param 1} + if {[string index $param end] eq "+"} { + puts stderr "overtype::renderline CSI Pn + T - kitty Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } else { + puts stderr "overtype::renderline CSI Pn T - SD Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + X { + puts stderr "overtype::renderline X ECH ERASE CHARACTER - $param" + #ECH - erase character + if {$param eq "" || $param eq "0"} {set param 1}; #param=count of chars to erase + priv::render_erasechar $idx $param + #cursor position doesn't change. + } + q { + set code_secondlast [tcl::string::index $codenorm end-1] + switch -exact -- $code_secondlast { + {"} { + #DECSCA - Select Character Protection Attribute + #(for use with selective erase: DECSED and DECSEL) + set param [tcl::string::range $codenorm 4 end-2] + if {$param eq ""} {set param 0} + #TODO - store like SGR in stacks - replays? + switch -exact -- $param { + 0 - 2 { + #canerase + puts stderr "overtype::renderline - DECSCA canerase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 1 { + #cannoterase + puts stderr "overtype::renderline - DECSCA cannoterase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + default { + puts stderr "overtype::renderline DECSCA param '$param' not understood [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + default { + puts stderr "overtype::renderline - CSI ... q not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + r { + #$re_decstbm + #https://www.vt100.net/docs/vt510-rm/DECSTBM.html + #This control function sets the top and bottom margins for the current page. You cannot perform scrolling outside the margins + lassign [split $param {;}] margin_top margin_bottom + + #todo - return these for the caller to process.. + puts stderr "overtype::renderline DECSTBM set top and bottom margin not implemented" + #Also moves the cursor to col 1 line 1 of the page + set cursor_column 1 + set cursor_row 1 + + incr idx_over + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction move ;#own instruction? decstbm? + break + } + s { + #code conflict between ansi emulation and DECSLRM - REVIEW + #ANSISYSSC (when no parameters) - like other terminals - essentially treat same as DECSC + # todo - when parameters - support DECSLRM instead + + if {$param ne ""} { + #DECSLRM - should only be recognised if DECLRMM is set (vertical split screen mode) + lassign [split $param {;}] margin_left margin_right + puts stderr "overtype DECSLRM not yet supported - got [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$margin_left eq ""} { + set margin_left 1 + } + set columns_per_page 80 ;#todo - set to 'page width (DECSCPP set columns per page)' - could be 132 or?? + if {$margin_right eq ""} { + set margin_right $columns_per_page + } + puts stderr "DECSLRM margin left: $margin_left margin right: $margin_right" + if {![string is integer -strict $margin_left] || $margin_left < 0} { + puts stderr "DECSLRM invalid margin_left" + } + if {![string is integer -strict $margin_right] || $margin_right < 0} { + puts stderr "DECSLRM invalid margin_right" + } + set scrolling_region_size [expr {$margin_right - $margin_left}] + if {$scrolling_region_size < 2 || $scrolling_region_size > $columns_per_page} { + puts stderr "DECSLRM region size '$scrolling_regsion_size' must be between 1 and $columns_per_page" + } + #todo + + + } else { + #DECSC + #//notes on expected behaviour: + #DECSC - saves following items in terminal's memory + #cursor position + #character attributes set by the SGR command + #character sets (G0,G1,G2 or G3) currently in GL and GR + #Wrap flag (autowrap or no autowrap) + #State of origin mode (DECOM) + #selective erase attribute + #any single shift 2 (SS2) or single shift 3(SSD) functions sent + + #$re_cursor_save + #cursor save could come after last column + if {$overflow_idx != -1 && $idx == $overflow_idx} { + #bartman2.ans test file - fixes misalignment at bottom of dialog bubble + #incr cursor_row + #set cursor_column 1 + #bwings1.ans test file - breaks if we actually incr cursor (has repeated saves) + set cursor_saved_position [list row [expr {$cursor_row+1}] column 1] + } else { + set cursor_saved_position [list row $cursor_row column $cursor_column] + } + #there may be overlay stackable codes emitted that aren't in the understacks because they come between the last emmited character and the cursor_save control. + #we need the SGR and gx overlay codes prior to the cursor_save + + #a real terminal would not be able to know the state of the underlay.. so we should probably ignore it. + #set sgr_stack [lindex $understacks $idx] + #set gx_stack [lindex $understacks_gx $idx] ;#not actually a stack - just a boolean state (for now?) + + set sgr_stack [list] + set gx_stack [list] + + #we shouldn't need to scan for intermediate cursor save/restores - as restores would throw-back to the calling loop - so our overlay 'line' is since those. + #The overlay_grapheme_control_list had leading resets from previous lines - so we go back to the beginning not just the first grapheme. + + foreach gc [lrange $overlay_grapheme_control_list 0 $gci-1] { + lassign $gc type code + #types g other sgr gx0 + switch -- $type { + gx0 { + #code is actually a stand-in for the graphics on/off code - not the raw code + #It is either gx0_on or gx0_off + set gx_stack [list $code] + } + sgr { + #code is the raw code + if {[punk::ansi::codetype::is_sgr_reset $code]} { + #jmn + set sgr_stack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set sgr_stack [list $code] + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[priv::is_sgr $code]} { + #often we don't get resets - and codes just pile up. + #as a first step to simplifying - at least remove earlier straight up dupes + set dup_posns [lsearch -all -exact $sgr_stack $code] ;#needs -exact - codes have square-brackets (glob chars) + set sgr_stack [lremove $sgr_stack {*}$dup_posns] + lappend sgr_stack $code + } + } + } + } + set cursor_saved_attributes "" + switch -- [lindex $gx_stack 0] { + gx0_on { + append cursor_saved_attributes "\x1b(0" + } + gx0_off { + append cursor_saved_attributes "\x1b(B" + } + } + #append cursor_saved_attributes [join $sgr_stack ""] + append cursor_saved_attributes [punk::ansi::codetype::sgr_merge_list {*}$sgr_stack] + + #as there is apparently only one cursor storage element we don't need to throw back to the calling loop for a save. + + #don't incr index - or the save will cause cursor to move to the right + #carry on + } + } + u { + #ANSISYSRC save cursor (when no parameters) (DECSC) + + #$re_cursor_restore + #we are going to jump somewhere.. for now we will assume another line, and process accordingly. + #The caller has the cursor_saved_position/cursor_saved_attributes if any (?review - if we always pass it back it, we could save some calls for moves in same line) + #don't set overflow at this point. The existing underlay to the right must be preserved. + #we only want to jump and render the unapplied at the new location. + + #lset overstacks $idx_over [list] + #set replay_codes_overlay "" + + #if {$cursor_saved_attributes ne ""} { + # set replay_codes_overlay $cursor_saved_attributes ;#empty - or last save if it happend in this input chunk + #} else { + #jj + #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + set replay_codes_overlay "" + #} + + #like priv::render_to_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code + incr idx_over + + set unapplied "" + set unapplied_list [list] + set unapplied_ansisplit [list ""] ;#remove below if nothing added + foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { + lassign $gc type item + switch -- $type { + g { + lappend unapplied_list $item + ledit unapplied_ansisplit end end [string cat [lindex $unapplied_ansisplit end] $item] + } + gx0 { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" + } + } + default { + lappend unapplied_list $item + lappend unapplied_ansisplit $item "" + } + } + #incr idx_over + } + set unapplied [join $unapplied_list ""] + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } + #if the save occured within this line - that's ok - it's in the return value list and caller can prepend for the next loop. + set instruction restore_cursor + break + } + "{" { + + puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + "}" { + set code_secondlast [tcl::string::index $codenorm end-1] + switch -exact -- $code_secondlast { + ' { + puts stderr "renderline warning - DECIC - Insert Column - CSI...' - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + default { + puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + } + } + ~ { + set code_secondlast [tcl::string::index $codenorm end-1] ;#used for e.g CSI x '~ + switch -exact -- $code_secondlast { + ' { + #DECDC - editing sequence - Delete Column + puts stderr "renderline warning - DECDC - unimplemented" + } + default { + #$re_vt_sequence + lassign [split $param {;}] key mod + + #Note that f1 to f4 show as ESCOP|Q|R|S (VT220?) but f5+ show as ESC\[15~ + # + #e.g esc \[2~ insert esc \[2;2~ shift-insert + #mod - subtract 1, and then use bitmask + #shift = 1, (left)Alt = 2, control=4, meta=8 (meta seems to do nothing on many terminals on windows? Intercepted by windows?) + #puts stderr "vt key:$key mod:$mod code:[ansistring VIEW $code]" + if {$key eq "1"} { + #home + } elseif {$key eq "2"} { + #Insert + if {$mod eq ""} { + #no modifier key + set insert_mode [expr {!$insert_mode}] + #rather than set the cursor - we return the insert mode state so the caller can decide + } + } elseif {$key eq "3"} { + #Delete - presumably this shifts other chars in the line, with empty cells coming in from the end + switch -- $mod { + "" { + priv::render_delchar $idx + } + "5" { + #ctrl-del - delete to end of word (pwsh) - possibly word on next line if current line empty(?) + } + } + } elseif {$key eq "4"} { + #End + } elseif {$key eq "5"} { + #pgup + } elseif {$key eq "6"} { + #pgDn + } elseif {$key eq "7"} { + #Home + #?? + set idx [expr {$opt_colstart -1}] + set cursor_column 1 + } elseif {$key eq "8"} { + #End + } elseif {$key eq "11"} { + #F1 - or ESCOP or e.g shift F1 ESC\[1;2P + } elseif {$key eq "12"} { + #F2 - or ESCOQ + } elseif {$key eq "13"} { + #F3 - or ESCOR + } elseif {$key eq "14"} { + #F4 - or ESCOS + } elseif {$key eq "15"} { + #F5 or shift F5 ESC\[15;2~ + } elseif {$key eq "17"} { + #F6 + } elseif {$key eq "18"} { + #F7 + } elseif {$key eq "19"} { + #F8 + } elseif {$key eq "20"} { + #F9 + } elseif {$key eq "21"} { + #F10 + } elseif {$key eq "23"} { + #F11 + } elseif {$key eq "24"} { + #F12 + } + + } + } + + } + h - l { + #set mode unset mode + #we are matching only last char to get to this arm - but are there other sequences ending in h|l we need to handle? + + #$re_mode if first after CSI is "?" + #some docs mention ESC=h|l - not seen on windows terminals.. review + #e.g https://www2.math.upenn.edu/~kazdan/210/computer/ansi.html + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? = + switch -exact -- $modegroup { + ? { + set smparams [tcl::string::range $codenorm 5 end-1] ;#params between ? and h|l + #one or more modes can be set + set smparam_list [split $smparams {;}] + foreach num $smparam_list { + switch -- $num { + "" { + #ignore empties e.g extra/trailing semicolon in params + } + 5 { + #DECSNM - reverse video + #How we simulate this to render within a block of text is an open question. + #track all SGR stacks and constantly flip based on the current SGR reverse state? + #It is the job of the calling loop to do this - so at this stage we'll just set the states + + if {$code_end eq "h"} { + #set (enable) + set reverse_mode 1 + } else { + #reset (disable) + set reverse_mode 0 + } + + } + 7 { + #DECAWM autowrap + if {$code_end eq "h"} { + #set (enable) + set autowrap_mode 1 + if {$opt_width ne "\uFFEF"} { + set overflow_idx $opt_width + } else { + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + } + #review - can idx ever be beyond overflow_idx limit when we change e.g with a width setting and cursor movements? + # presume not usually - but sanity check with warning for now. + if {$idx >= $overflow_idx} { + puts stderr "renderline warning - idx '$idx' >= overflow_idx '$overflow_idx' - unexpected" + } + } else { + #reset (disable) + set autowrap_mode 0 + #REVIEW! + set overflow_idx -1 + } + } + 25 { + if {$code_end eq "h"} { + #visible cursor + + } else { + #invisible cursor + + } + } + 117 { + #DECECM - Erase Color Mode + #https://invisible-island.net/ncurses/ncurses.faq.html + #The Erase color selection controls the background color used when text is erased or new + #text is scrolled on to the screen. Screen background causes newly erased areas or + #scrolled text to be written using color index zero, the screen background. This is VT + #and DECterm compatible. Text background causes erased areas or scrolled text to be + #written using the current text background color. This is PC console compatible and is + #the factory default. + + #see also: https://unix.stackexchange.com/questions/251726/clear-to-end-of-line-uses-the-wrong-background-color-in-screen + } + } + } + } + = { + set num [tcl::string::range $codenorm 5 end-1] ;#param between = and h|l + puts stderr "overtype::renderline CSI=...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + default { + #e.g CSI 4 h + set num [tcl::string::range $codenorm 4 end-1] ;#param before h|l + switch -exact -- $num { + 3 { + puts stderr "CRM MODE $code_end" + #CRM - Show control character mode + # 'No control functions are executed except LF,FF and VT which are represented in the CRM FONT before a CRLF(new line) is executed' + # + #use ansistring VIEW -nul 1 -lf 2 -ff 2 -vt 2 + #https://vt100.net/docs/vt510-rm/CRM.html + #NOTE - vt100 CRM always does auto-wrap at right margin. + #disabling auto-wrap in set-up or by sequence is disabled. + #We should default to turning off auto-wrap when crm_mode enabled.. but + #displaying truncated (on rhs) crm can still be very useful - and we have optimisation in overflow to avoid excess renderline calls (per grapheme) + #we therefore could reasonably put in an exception to allow auto_wrap to be disabled after crm_mode is engaged, + #although this would be potentially an annoying difference to some.. REVIEW + if {$code_end eq "h"} { + set crm_mode 1 + set autowrap_mode 1 + if {$opt_width ne "\uFFEF"} { + set overflow_idx $opt_width + } else { + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + } + } else { + set crm_mode 0 + } + } + 4 { + #IRM - Insert/Replace Mode + if {$code_end eq "h"} { + #CSI 4 h + set insert_mode 1 + } else { + #CSI 4 l + #replace mode + set insert_mode 0 + } + } + default { + puts stderr "overtype::renderline CSI...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + } + } + } + | { + switch -- [tcl::string::index $codenorm end-1] { + {$} { + #CSI ... $ | DECSCPP set columns per page- (recommended in vt510 docs as preferable to DECCOLM) + #real terminals generally only supported 80/132 + #some other virtuals support any where from 2 to 65,536? + #we will allow arbitrary widths >= 2 .. to some as yet undetermined limit. + #CSI $ | + #empty or 0 param is 80 for compatibility - other numbers > 2 accepted + set page_width -1 ;#flag as unset + if {$param eq ""} { + set page_width 80 + } elseif {[string is integer -strict $param] && $param >=2} { + set page_width [expr {$param}] ;#we should allow leading zeros in the number - but lets normalize using expr + } else { + puts stderr "overtype::renderline unacceptable DECSPP value '$param'" + } + + if {$page_width > 2} { + puts stderr "overtype::renderline DECSCPP - not implemented - but selected width '$page_width' looks ok" + #if cursor already beyond new page_width - will move to right colum - otherwise no cursor movement + + } + + } + default { + puts stderr "overtype::renderline unrecognised CSI code ending in pipe (|) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + } + default { + puts stderr "overtype::renderline CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + } + 7ESC { + # + #re_other_single {\x1b(D|M|E)$} + #also vt52 Y.. + #also PM \x1b^...(ST) + switch -- [tcl::string::index $codenorm 4] { + c { + #RIS - reset terminal to initial state - where 'terminal' in this case is the renderspace - not the underlying terminal! + puts stderr "renderline reset" + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction reset + break + } + D { + #\x84 + #index (IND) + #vt102-docs: "Moves cursor down one line in same column. If cursor is at bottom margin, screen performs a scroll-up" + puts stderr "renderline ESC D not fully implemented" + incr cursor_row + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction down + #retain cursor_column + break + } + E { + #\x85 + #review - is behaviour different to lf? + #todo - possibly(?) same logic as handling above. i.e return instruction depends on where column_cursor is at the time we get NEL + #leave implementation until logic for is set in stone... still under review + #It's arguable NEL is a pure cursor movement as opposed to the semantic meaning of crlf or lf in a file. + # + #Next Line (NEL) "Move the cursor to the left margin on the next line. If the cursor is at the bottom margin, scroll the page up" + puts stderr "overtype::renderline ESC E unimplemented" + + } + H { + #\x88 + #Tab Set + puts stderr "overtype::renderline ESC H tab set unimplemented" + } + M { + #\x8D + #Reverse Index (RI) + #vt102-docs: "Moves cursor up one line in same column. If cursor is at top margin, screen performs a scroll-down" + puts stderr "overtype::renderline ESC M not fully implemented" + + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #move up + incr cursor_row -1 + if {$cursor_row < 1} { + set cursor_row 1 + } + #ensure rest of *overlay* is emitted to remainder + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction up ;#need instruction for scroll-down? + #retain cursor_column + break + } + N { + #\x8e - affects next character only + puts stderr "overtype::renderline single shift select G2 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + O { + #\x8f - affects next character only + puts stderr "overtype::renderline single shift select G3 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + P { + #\x90 + #DCS - shouldn't get here - handled in 7DCS branch + #similarly \] OSC (\x9d) and \\ (\x9c) ST + } + V { + #\x96 + + } + W { + #\x97 + } + X { + #\x98 + #SOS + if {[string index $code end] eq "\007"} { + set sos_content [string range $code 2 end-1] ;#ST is \007 + } else { + set sos_content [string range $code 2 end-2] ;#ST is \x1b\\ + } + #return in some useful form to the caller + #TODO! + lappend sos_list [list string $sos_content row $cursor_row column $cursor_column] + puts stderr "overtype::renderline ESCX SOS UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + ^ { + #puts stderr "renderline PM" + #Privacy Message. + if {[string index $code end] eq "\007"} { + set pm_content [string range $code 2 end-1] ;#ST is \007 + } else { + set pm_content [string range $code 2 end-2] ;#ST is \x1b\\ + } + #We don't want to render it - but we need to make it available to the application + #see the textblock library in punk, for the exception we make here for single backspace. + #It is unlikely to be encountered as a useful PM - so we hack to pass it through as a fix + #for spacing issues on old terminals which miscalculate the single-width 'Symbols for Legacy Computing' + if {$pm_content eq "\b"} { + #puts stderr "renderline PM sole backspace special handling for \U1FB00 - \U1FBFF" + #esc^\b\007 or esc^\besc\\ + #HACKY pass-through - targeting terminals that both mis-space legacy symbols *and* don't support PMs + #The result is repair of the extra space. If the terminal is a modern one and does support PM - the \b should be hidden anyway. + #If the terminal has the space problem AND does support PMs - then this just won't fix it. + #The fix relies on the symbol-supplier to cooperate by appending esc^\b\esc\\ to the problematic symbols. + + #priv::render_addchar $idx $code [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #idx has been incremented after last grapheme added + priv::render_append_to_char [expr {$idx -1}] $code + } + #lappend to a dict element in the result for application-specific processing + lappend pm_list $pm_content + } + _ { + #APC Application Program Command + #just warn for now.. + puts stderr "overtype::renderline ESC_ APC command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + default { + puts stderr "overtype::renderline ESC code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" + } + } + + } + 7DCS - 8DCS { + puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #ST (string terminator) \x9c or \x1b\\ + if {[tcl::string::index $codenorm end] eq "\x9c"} { + set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is 8-bit 0x9c + } else { + set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ + } + + } + 7OSC - 8OSC { + # OSCs are terminated with ST of either \007 or \x1b\\ - we allow either whether code was 7 or 8 bit + if {[tcl::string::index $codenorm end] eq "\007"} { + set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is \007 + } else { + set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ + } + set first_colon [tcl::string::first {;} $code_content] + if {$first_colon == -1} { + #there probably should always be a colon - but we'll try to make sense of it without + set osc_code $code_content ;#e.g \x1b\]104\007 vs \x1b\]104\;\007 + } else { + set osc_code [tcl::string::range $code_content 0 $first_colon-1] + } + switch -exact -- $osc_code { + 2 { + set newtitle [tcl::string::range $code_content 2 end] + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction [list set_window_title $newtitle] + break + } + 4 { + #OSC 4 - set colour palette + #can take multiple params + #e.g \x1b\]4\;1\;red\;2\;green\x1b\\ + set params [tcl::string::range $code_content 2 end] ;#strip 4 and first semicolon + set cmap [dict create] + foreach {cnum spec} [split $params {;}] { + if {$cnum >= 0 && $cnum <= 255} { + #todo - parse spec from names like 'red' to RGB + #todo - accept rgb:ab/cd/ef as well as rgb:/a/b/c (as alias for aa/bb/cc) + #also - what about rgb:abcd/defg/hijk and 12-bit abc/def/ghi ? + dict set cmap $cnum $spec + } else { + #todo - log + puts stderr "overtype::renderline OSC 4 set colour palette - bad color number: $cnum must be from 0 to 255. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + + + } + 10 - 11 - 12 - 13 - 14 - 15 - 16 - 17 { + #OSC 10 through 17 - so called 'dynamic colours' + #can take multiple params - each successive parameter changes the next colour in the list + #- e.g if code started at 11 - next param is for 12. 17 takes only one param because there are no more + #10 change text foreground colour + #11 change text background colour + #12 change text cursor colour + #13 change mouse foreground colour + #14 change mouse background colour + #15 change tektronix foreground colour + #16 change tektronix background colour + #17 change highlight colour + set params [tcl::string::range $code_content 2 end] + + puts stderr "overtype::renderline OSC $osc_code set dynamic colours unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + + + } + 18 { + #why is this not considered one of the dynamic colours above? + #https://www.xfree86.org/current/ctlseqs.html + #tektronix cursor color + puts stderr "overtype::renderline OSC 18 - set tektronix cursor color unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 99 { + #kitty desktop notifications + #https://sw.kovidgoyal.net/kitty/desktop-notifications/ + # 99 ; metadata ; payload + puts stderr "overtype::renderline OSC 99 kitty desktop notification unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 104 { + #reset colour palette + #we want to do it for the current rendering context only (vvt) - not just pass through to underlying vt + puts stderr "overtype::renderline OSC 104 reset colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction [list reset_colour_palette] + break + } + 1337 { + #iterm2 graphics and file transfer + puts stderr "overtype::renderline OSC 1337 iterm2 graphics/file_transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" + } + 5113 { + puts stderr "overtype::renderline OSC 5113 kitty file transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" + } + default { + puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + default { + } + } + + + } + default { + #don't need to handle sgr or gx0 types + #we have our sgr gx0 codes already in stacks for each overlay grapheme + } + } + } + + #-------- + if {$opt_expand_right == 0} { + #need to truncate to the width of the original undertext + #review - string_width vs printing_length here. undertext requirement to be already rendered therefore punk::char::string_width ok? + #set num_under_columns [punk::char::string_width $pt_underchars] ;#plaintext underchars + } + if {$overflow_idx == -1} { + #overflow was initially unlimited and hasn't been overridden + } else { + + } + #-------- + + + #coalesce and replay codestacks for outcols grapheme list + set outstring "" ;#output prior to overflow + set overflow_right "" ;#remainder after overflow point reached + set i 0 + set cstack [list] + set prevstack [list] + set prev_g0 [list] + #note overflow_idx may already have been set lower if we had a row move above due to \v or ANSI moves + set in_overflow 0 ;#used to stop char-width scanning once in overflow + if {$overflow_idx == 0} { + #how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW + set in_overflow 1 + } + set trailing_nulls 0 + foreach ch [lreverse $outcols] { + if {$ch eq "\u0000"} { + incr trailing_nulls + } else { + break + } + } + if {$trailing_nulls} { + set first_tail_null_posn [expr {[llength $outcols] - $trailing_nulls}] + } else { + set first_tail_null_posn -1 + } + + #puts stderr "first_tail_null_posn: $first_tail_null_posn" + #puts stderr "colview: [ansistring VIEW $outcols]" + + foreach ch $outcols { + #puts "---- [ansistring VIEW $ch]" + + set gxleader "" + if {$i < [llength $understacks_gx]} { + #set g0 [tcl::dict::get $understacks_gx $i] + set g0 [lindex $understacks_gx $i] + if {$g0 ne $prev_g0} { + if {$g0 eq [list "gx0_on"]} { + set gxleader "\x1b(0" + } else { + set gxleader "\x1b(B" + } + } + set prev_g0 $g0 + } else { + set prev_g0 [list] + } + + set sgrleader "" + if {$i < [llength $understacks]} { + #set cstack [tcl::dict::get $understacks $i] + set cstack [lindex $understacks $i] + if {$cstack ne $prevstack} { + if {[llength $prevstack] && ![llength $cstack]} { + #This reset is important e.g testfile fruit.ans - we get overhang on rhs without it. But why is cstack empty? + append sgrleader \033\[m + } else { + append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] + } + } + set prevstack $cstack + } else { + set prevstack [list] + } + + + + if {$in_overflow} { + if {$i == $overflow_idx} { + set 0 [lindex $understacks_gx $i] + set gxleader "" + if {$g0 eq [list "gx0_on"]} { + set gxleader "\x1b(0" + } elseif {$g0 eq [list "gx0_off"]} { + set gxleader "\x1b(B" + } + append overflow_right $gxleader + set cstack [lindex $understacks $i] + set sgrleader "" + #whether cstack is same or differs from previous char's stack - we must have an output at the start of the overflow_right + #if {[llength $prevstack] && ![llength $cstack]} { + # append sgrleader \033\[m + #} + append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] + append overflow_right $sgrleader + append overflow_right $ch + } else { + append overflow_right $gxleader + append overflow_right $sgrleader + append overflow_right $ch + } + } else { + if {$overflow_idx != -1 && $i+1 == $overflow_idx} { + #one before overflow + #will be in overflow in next iteration + set in_overflow 1 + if {[grapheme_width_cached $ch]> 1} { + #we overflowed with second-half of a double-width char - replace first-half with user-supplied exposition char (should be 1 wide) + set ch $opt_exposed1 + } + } + append outstring $gxleader + append outstring $sgrleader + if {$ch eq "\u0000"} { + if {$cp437_glyphs} { + #map all nulls including at tail to space + append outstring " " + } else { + if {$trailing_nulls && $i < $first_tail_null_posn} { + append outstring " " ;#map inner nulls to space + } else { + append outstring \u0000 + } + } + } else { + append outstring $ch + } + } + incr i + } + #flower.ans good test for null handling - reverse line building + #review - presence of overflow_right doesn't indicate line's trailing nulls should remain. + #The cells could have been erased? + #if {!$cp437_glyphs} { + # #if {![ansistring length $overflow_right]} { + # # set outstring [tcl::string::trimright $outstring "\u0000"] + # #} + # set outstring [tcl::string::trimright $outstring "\u0000"] + # set outstring [tcl::string::map {\u0000 " "} $outstring] + #} + + + #REVIEW + #set overflow_right [tcl::string::trimright $overflow_right "\u0000"] + #set overflow_right [tcl::string::map {\u0000 " "} $overflow_right] + + set replay_codes "" + if {[llength $understacks] > 0} { + if {$overflow_idx == -1} { + #set tail_idx [tcl::dict::size $understacks] + set tail_idx [llength $understacks] + } else { + set tail_idx [llength $undercols] + } + if {$tail_idx-1 < [llength $understacks]} { + #set replay_codes [join [lindex $understacks $tail_idx-1] ""] ;#tail replay codes + set replay_codes [punk::ansi::codetype::sgr_merge_list {*}[lindex $understacks $tail_idx-1]] ;#tail replay codes + } + if {$tail_idx-1 < [llength $understacks_gx]} { + set gx0 [lindex $understacks_gx $tail_idx-1] + if {$gx0 eq [list "gx0_on"]} { + #if it was on, turn gx0 off at the point we stop processing overlay + append outstring "\x1b(B" + } + } + } + if {[string length $overflow_right]} { + #puts stderr "remainder:$overflow_right" + } + #pdict $understacks + + if {[punk::ansi::ta::detect_sgr $outstring]} { + append outstring [punk::ansi::a] ;#without this - we would get for example, trailing backgrounds after rightmost column + + #close off any open gx? + #probably should - and overflow_right reopen? + } + + if {$opt_returnextra} { + #replay_codes is the codestack at the boundary - used for ellipsis colouring to match elided text - review + #replay_codes_underlay is the set of codes in effect at the very end of the original underlay + + #review + #replay_codes_overlay is the set of codes in effect at the very end of the original overlay (even if not all overlay was applied) + #todo - replay_codes for gx0 mode + + #overflow_idx may change during ansi & character processing + if {$overflow_idx == -1} { + set overflow_right_column "" + } else { + set overflow_right_column [expr {$overflow_idx+1}] + } + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } + + set result [tcl::dict::create\ + result $outstring\ + visualwidth [punk::ansi::printing_length $outstring]\ + instruction $instruction\ + stringlen [string length $outstring]\ + overflow_right_column $overflow_right_column\ + overflow_right $overflow_right\ + unapplied $unapplied\ + unapplied_list $unapplied_list\ + unapplied_ansisplit $unapplied_ansisplit\ + insert_mode $insert_mode\ + autowrap_mode $autowrap_mode\ + crm_mode $crm_mode\ + reverse_mode $reverse_mode\ + insert_lines_above $insert_lines_above\ + insert_lines_below $insert_lines_below\ + cursor_saved_position $cursor_saved_position\ + cursor_saved_attributes $cursor_saved_attributes\ + cursor_column $cursor_column\ + cursor_row $cursor_row\ + expand_right $opt_expand_right\ + replay_codes $replay_codes\ + replay_codes_underlay $replay_codes_underlay\ + replay_codes_overlay $replay_codes_overlay\ + pm_list $pm_list\ + ] + if {$opt_returnextra == 1} { + #puts stderr "renderline: $result" + return $result + } else { + #human/debug - map special chars to visual glyphs + set viewop VIEW + switch -- $opt_returnextra { + 2 { + #codes and character data + set viewop VIEWCODES ;#ansi colorisation of codes - green for SGR, blue/blue reverse for cursor_save/cursor_restore, cyan for movements, orange for others + } + 3 { + set viewop VIEWSTYLE ;#ansi colorise the characters within the output with preceding codes, stacking codes only within each dict value - may not be same SGR effect as the effect in-situ. + } + } + tcl::dict::set result result [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result result]] + tcl::dict::set result overflow_right [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result overflow_right]] + tcl::dict::set result unapplied [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied]] + tcl::dict::set result unapplied_list [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_list]] + tcl::dict::set result unapplied_ansisplit [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_ansisplit]] + tcl::dict::set result replay_codes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes]] + tcl::dict::set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_underlay]] + tcl::dict::set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_overlay]] + tcl::dict::set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result cursor_saved_attributes]] + return $result + } + } else { + #puts stderr "renderline returning: result $outstring instruction $instruction unapplied $unapplied overflow_right $overflow_right" + return $outstring + } + #return [join $out ""] + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace overtype ---}] +} + +tcl::namespace::eval overtype::piper { + proc overcentre {args} { + if {[llength $args] < 2} { + error {usage: ?-bias left|right? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} + } + lassign [lrange $args end-1 end] over under + set argsflags [lrange $args 0 end-2] + tailcall overtype::centre {*}$argsflags $under $over + } + proc overleft {args} { + if {[llength $args] < 2} { + error {usage: ?-startcolumn ? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} + } + lassign [lrange $args end-1 end] over under + set argsflags [lrange $args 0 end-2] + tailcall overtype::left {*}$argsflags $under $over + } +} + + +# -- --- --- --- --- --- --- --- --- --- --- +proc overtype::renderline_transparent {args} { + foreach {under over} [lrange $args end-1 end] break + set argsflags [lrange $args 0 end-2] + set defaults [tcl::dict::create\ + -transparent 1\ + -exposed 1 " "\ + -exposed 2 " "\ + ] + set newargs [tcl::dict::merge $defaults $argsflags] + tailcall overtype::renderline {*}$newargs $under $over +} +#renderline may not make sense as it is in the long run for blocks of text - but is handy in the single-line-handling form anyway. +# We are trying to handle ansi codes in a block of text which is acting like a mini-terminal in some sense. +#We can process standard cursor moves such as \b \r - but no way to respond to other cursor movements e.g moving to other lines. +# +tcl::namespace::eval overtype::piper { + proc renderline {args} { + if {[llength $args] < 2} { + error {usage: ?-start ? ?-transparent [0|1|]? ?-overflow [1|0]? overtext pipelinedata} + } + foreach {over under} [lrange $args end-1 end] break + set argsflags [lrange $args 0 end-2] + tailcall overtype::renderline {*}$argsflags $under $over + } +} +interp alias "" piper_renderline "" overtype::piper::renderline + +#intended primarily for single grapheme - but will work for multiple +#WARNING: query CAN contain ansi or newlines - but if cache was not already set manually,the answer will be incorrect! +#We deliberately allow this for PM/SOS attached within a column +#(a cache of ansifreestring_width calls - as these are quite regex heavy) +proc overtype::grapheme_width_cached {ch} { + variable grapheme_widths + if {[tcl::dict::exists $grapheme_widths $ch]} { + return [tcl::dict::get $grapheme_widths $ch] + } + set width [punk::char::ansifreestring_width $ch] + tcl::dict::set grapheme_widths $ch $width + return $width +} + + + +proc overtype::test_renderline {} { + set t \uFF5E ;#2-wide tilde + set u \uFF3F ;#2-wide underscore + set missing \uFFFD + return [list $t $u A${t}B] +} + +#maintenance warning +#same as textblock::size - but we don't want that circular dependency +#block width and height can be tricky. e.g \v handled differently on different terminal emulators and can affect both +proc overtype::blocksize {textblock} { + if {$textblock eq ""} { + return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings + } + if {[tcl::string::first \t $textblock] >= 0} { + if {[info exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + set textblock [textutil::tabify::untabify2 $textblock $tw] + } + #ansistrip on entire block in one go rather than line by line - result should be the same - review - make tests + if {[punk::ansi::ta::detect $textblock]} { + set textblock [punk::ansi::ansistrip $textblock] + } + if {[tcl::string::last \n $textblock] >= 0} { + set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map {\n {}} $textblock]]}] ;#faster than splitting into single-char list + set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] + } else { + set num_le 0 + set width [punk::char::ansifreestring_width $textblock] + } + #our concept of block-height is likely to be different to other line-counting mechanisms + set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le + + return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [dict values [blocksize ]] width height +} + +tcl::namespace::eval overtype::priv { + variable cache_is_sgr [tcl::dict::create] + + #we are likely to be asking the same question of the same ansi codes repeatedly + #caching the answer saves some regex expense - possibly a few uS to lookup vs under 1uS + #todo - test if still worthwhile after a large cache is built up. (limit cache size?) + proc is_sgr {code} { + variable cache_is_sgr + if {[tcl::dict::exists $cache_is_sgr $code]} { + return [tcl::dict::get $cache_is_sgr $code] + } + set answer [punk::ansi::codetype::is_sgr $code] + tcl::dict::set cache_is_sgr $code $answer + return $answer + } + proc render_to_unapplied {overlay_grapheme_control_list gci} { + upvar idx_over idx_over + + #----------------------------------------- + #review - this is a lot of copies of the same thing. + # ultimately we want to reduce expensive things like redundant grapheme-splits + # perhaps unapplied_tagged of some sort e.g - {g g code pt } ?? + upvar unapplied unapplied + upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split + upvar unapplied_ansisplit unapplied_ansisplit ;# pt ?code pt...? + #----------------------------------------- + + + upvar overstacks overstacks + upvar overstacks_gx overstacks_gx + upvar overlay_grapheme_control_stacks og_stacks + + #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] + set unapplied "" + set unapplied_list [list] + set unapplied_ansisplit [list ""] + #append unapplied [join [lindex $overstacks $idx_over] ""] + #append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $overstacks $idx_over]] + set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] + if {$sgr_merged ne ""} { + lappend unapplied_list $sgr_merged + lappend unapplied_ansisplit $sgr_merged "" + } + switch -- [lindex $overstacks_gx $idx_over] { + "gx0_on" { + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" + } + "gx0_off" { + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" + } + } + + foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { + lassign $gc type item + #types g other sgr gx0 + switch -- $type { + g { + lappend unapplied_list $item + lset unapplied_ansisplit end [string cat [lindex $unapplied_ansisplit end] $item] + } + gx0 { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" + } + } + default { + lappend unapplied_list $item + lappend unapplied_ansisplit $item "" + } + } + } + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } + set unapplied [join $unapplied_list ""] + } + + #clearer - renders the specific gci forward as unapplied - prefixed with it's merged sgr stack + proc render_this_unapplied {overlay_grapheme_control_list gci} { + upvar idx_over idx_over + #-------------- + upvar unapplied unapplied + upvar unapplied_list unapplied_list + upvar unapplied_ansisplit unapplied_ansisplit + #-------------- + + upvar overstacks overstacks + upvar overstacks_gx overstacks_gx + upvar overlay_grapheme_control_stacks og_stacks + + #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] + set unapplied "" + set unapplied_list [list] + set unapplied_ansisplit [list ""] ;#remove empty entry at end if nothing added + + set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] + if {$sgr_merged ne ""} { + lappend unapplied_list $sgr_merged + lappend unapplied_ansisplit $sgr_merged "" + } + switch -- [lindex $overstacks_gx $idx_over] { + "gx0_on" { + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" + } + "gx0_off" { + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" + } + } + + foreach gc [lrange $overlay_grapheme_control_list $gci end] { + lassign $gc type item + #types g other sgr gx0 + switch -- $type { + g { + lappend unapplied_list $item + lset unapplied_ansisplit end [string cat [lindex $unapplied_ansisplit end] $item] + } + gx0 { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" + } + } + default { + lappend unapplied_list $item + lappend unapplied_ansisplit $item "" + } + } + } + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } + set unapplied [join $unapplied_list ""] + } + proc render_delchar {i} { + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + set nxt [llength $o] + if {$i < $nxt} { + set o [lreplace $o $i $i] + set ustacks [lreplace $ustacks $i $i] + set gxstacks [lreplace $gxstacks $i $i] + } elseif {$i == 0 || $i == $nxt} { + #nothing to do + } else { + puts stderr "render_delchar - attempt to delchar at index $i >= number of outcols $nxt - shouldn't happen" + } + } + proc render_erasechar {i count} { + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + upvar replay_codes_overlay replay + #ECH clears character attributes from erased character positions + #ECH accepts 0 or empty parameter, which is equivalent to 1. Caller of render_erasechar should do that mapping and only supply 1 or greater. + if {![tcl::string::is integer -strict $count] || $count < 1} { + error "render_erasechar count must be integer >= 1" + } + set start $i + set end [expr {$i + $count -1}] + #we restrict ECH to current line - as some terminals do - review - is that the only way it's implemented? + if {$i > [llength $o]-1} { + return + } + if {$end > [llength $o]-1} { + set end [expr {[llength $o]-1}] + } + set num [expr {$end - $start + 1}] + set o [lreplace $o $start $end {*}[lrepeat $num \u0000]] ;#or space? + #DECECM ??? + set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list $replay]]] + set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] ;# ??? review + return + } + proc render_setchar {i c } { + upvar outcols o + lset o $i $c + } + + #Initial usecase is for old-terminal hack to add PM-wrapped \b + #review - can be used for other multibyte sequences that occupy one column? + #combiners? diacritics? + proc render_append_to_char {i c} { + upvar outcols o + if {$i > [llength $o]-1} { + error "render_append_to_char cannot append [ansistring VIEW -lf 1 -nul 1 $c] to existing char at index $i while $i >= llength outcols [llength $o]" + } + set existing [lindex $o $i] + if {$existing eq "\0"} { + lset o $i $c + } else { + lset o $i $existing$c + } + } + #is actually addgrapheme? + proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + + # -- --- --- + #this is somewhat of a hack.. probably not really the equivalent of proper reverse video? review + #we should ideally be able to reverse the video of a sequence that already includes SGR reverse/noreverse attributes + upvar reverse_mode do_reverse + #if {$do_reverse} { + # lappend sgrstack [a+ reverse] + #} else { + # lappend sgrstack [a+ noreverse] + #} + + #JMN3 + if {$do_reverse} { + #note we can't just look for \x1b\[7m or \x1b\[27m + # it may be a more complex sequence like \x1b\[0\;\;7\;31m etc + + set existing_reverse_state 0 + set codeinfo [punk::ansi::codetype::sgr_merge $sgrstack -info 1] + set codestate_reverse [dict get $codeinfo codestate reverse] + switch -- $codestate_reverse { + 7 { + set existing_reverse_state 1 + } + 27 { + set existing_reverse_state 0 + } + "" { + } + } + if {$existing_reverse_state == 0} { + set rflip [a+ reverse] + } else { + #reverse of reverse + set rflip [a+ noreverse] + } + #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) + set sgrstack [list [dict get $codeinfo mergeresult] $rflip] + #set sgrstack [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] + } + + # -- --- --- + + set nxt [llength $o] + if {!$insert_mode} { + if {$i < $nxt} { + #These lists must always be in sync + lset o $i $c + } else { + lappend o $c + } + if {$i < [llength $ustacks]} { + lset ustacks $i $sgrstack + lset gxstacks $i $gx0stack + } else { + lappend ustacks $sgrstack + lappend gxstacks $gx0stack + } + } else { + #insert of single-width vs double-width when underlying is double-width? + if {$i < $nxt} { + #set o [linsert $o $i $c] + #JMN insert via ledit + ledit o $i $i-1 $c + } else { + lappend o $c + } + if {$i < [llength $ustacks]} { + #set ustacks [linsert $ustacks $i $sgrstack] + #set gxstacks [linsert $gxstacks $i $gx0stack] + #insert via ledit + ledit ustacks $i $i-1 $sgrstack + ledit gxstacks $i $i-1 $gx0stack + } else { + lappend ustacks $sgrstack + lappend gxstacks $gx0stack + } + } + } + +} + + + +# -- --- --- --- --- --- --- --- --- --- --- +tcl::namespace::eval overtype { + interp alias {} ::overtype::center {} ::overtype::centre +} + + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::overtype ::overtype::argdoc +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide overtype [tcl::namespace::eval overtype { + variable version + set version 1.7.4 +}] +return + +#*** !doctools +#[manpage_end] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.5.tm b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.5.tm index 6b2dd8a9..390b34ae 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.5.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.5.tm @@ -751,6 +751,27 @@ namespace eval punk::lib { # -- --- + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lswap + @cmd -name punk::lib::lswap\ + -summary\ + "Swap list values in-place"\ + -help\ + "Similar to struct::list swap, except it fully supports basic + list index expressions such as 7-2 end-1 etc. + + struct::list swap doesn't support 'end' offsets, and only + sometimes appears to support basic expressions, depending on the + expression compared to the list length." + @values -min 1 -max 1 + lvar -type string -help\ + "name of list variable" + a -type indexexpression + z -type indexexpression + }] + } proc lswap {lvar a z} { upvar $lvar l set len [llength $l] @@ -955,181 +976,233 @@ namespace eval punk::lib { } } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lzip + @cmd -name punk::lib::lzip\ + -summary\ + "zip any number of lists together."\ + -help\ + "Conceptually equivalent to converting a list of rows + to a list of columns. + + The number of returned lists (columns) will be equal to + the length of the longest supplied list (row). + If lengths of supplied lists don't match, empty strings + will be inserted in the resulting lists. + + e.g lzip {a b c d e} {1 2 3 4} {x y z} + -> {a 1 x} {b 2 y} {c 3 z} {d 4 {}} {3 {} {}} + " + @values -min 1 -max 1 + lvar -type string -help\ + "name of list variable" + a -type indexexpression + z -type indexexpression + }] + } proc lzip {args} { switch -- [llength $args] { - 0 {return {}} - 1 {return [lindex $args 0]} - 2 {return [lzip2lists {*}$args]} - 3 {return [lzip3lists {*}$args]} - 4 {return [lzip4lists {*}$args]} - 5 {return [lzip5lists {*}$args]} - 6 {return [lzip6lists {*}$args]} - 7 {return [lzip7lists {*}$args]} - 8 {return [lzip8lists {*}$args]} - 9 {return [lzip9lists {*}$args]} - 10 {return [lzip10lists {*}$args]} + 0 {return {}} + 1 {return [lindex $args 0]} + 2 {return [::punk::lib::system::lzip2lists {*}$args]} + 3 {return [::punk::lib::system::lzip3lists {*}$args]} + 4 {return [::punk::lib::system::lzip4lists {*}$args]} + 5 {return [::punk::lib::system::lzip5lists {*}$args]} + 6 {return [::punk::lib::system::lzip6lists {*}$args]} + 7 {return [::punk::lib::system::lzip7lists {*}$args]} + 8 {return [::punk::lib::system::lzip8lists {*}$args]} + 9 {return [::punk::lib::system::lzip9lists {*}$args]} + 10 {return [::punk::lib::system::lzip10lists {*}$args]} 11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 { set n [llength $args] - if {[info commands ::punk::lib::lzip${n}lists] eq ""} { - puts "calling ::punk::lib::Build_lzipn $n" - ::punk::lib::Build_lzipn $n + if {[info commands ::punk::lib::system::lzip${n}lists] eq ""} { + #puts "calling ::punk::lib::system::Build_lzipn $n" + ::punk::lib::system::Build_lzipn $n } - return [lzip${n}lists {*}$args] + return [::punk::lib::system::lzip${n}lists {*}$args] } default { if {[llength $args] < 4000} { set n [llength $args] - if {[info commands ::punk::lib::lzip${n}lists] eq ""} { - puts "calling ::punk::lib::Build_lzipn $n" - ::punk::lib::Build_lzipn $n + if {[info commands ::punk::lib::system::lzip${n}lists] eq ""} { + #puts "calling ::punk::lib::system::Build_lzipn $n" + ::punk::lib::system::Build_lzipn $n } - return [lzip${n}lists {*}$args] + return [::punk::lib::system::lzip${n}lists {*}$args] } else { - return [lzipn {*}$args] + return [::punk::lib::lzipn {*}$args] } } } } - proc Build_lzipn {n} { - set arglist [list] - #use punk::lib::range which defers to lseq if available - set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) - set body "\nlmap " - for {set i 1} {$i <= $n} {incr i} { - lappend arglist l$i - append body "[lindex $vars $i] \$l$i " - } - append body "\{list " - for {set i 1} {$i <= $n} {incr i} { - append body "\$[lindex $vars $i] " + namespace eval system { + proc Build_lzipn {n} { + set arglist [list] + #use punk::lib::range which defers to lseq if available + set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) + set body "\nlmap " + for {set i 1} {$i <= $n} {incr i} { + lappend arglist l$i + append body "[lindex $vars $i] \$l$i " + } + append body "\{list " + for {set i 1} {$i <= $n} {incr i} { + append body "\$[lindex $vars $i] " + } + append body "\}" \n + #puts "proc punk::lib::system::lzip${n}lists {$arglist} \{" + #puts "$body" + #puts "\}" + proc ::punk::lib::system::lzip${n}lists $arglist $body } - append body "\}" \n - puts "proc punk::lib::lzip${n}lists {$arglist} \{" - puts "$body" - puts "\}" - proc ::punk::lib::lzip${n}lists $arglist $body - } - #fastest is to know the number of lists to be zipped - proc lzip2lists {l1 l2} { - lmap a $l1 b $l2 {list $a $b} - } - proc lzip3lists {l1 l2 l3} { - lmap a $l1 b $l2 c $l3 {list $a $b $c} - } - proc lzip4lists {l1 l2 l3 l4} { - lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} - } - proc lzip5lists {l1 l2 l3 l4 l5} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} - } - proc lzip6lists {l1 l2 l3 l4 l5 l6} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} - } - proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} - } - proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} - } - proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} - } - proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} - } + #fastest is to know the number of lists to be zipped + proc lzip2lists {l1 l2} { + lmap a $l1 b $l2 {list $a $b} + } + proc lzip3lists {l1 l2 l3} { + lmap a $l1 b $l2 c $l3 {list $a $b $c} + } + proc lzip4lists {l1 l2 l3 l4} { + lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} + } + proc lzip5lists {l1 l2 l3 l4 l5} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} + } + proc lzip6lists {l1 l2 l3 l4 l5 l6} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} + } + proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} + } + proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} + } + proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} + } + proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} + } - #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly - # review - - proc lzipn_alt args { - #stackoverflow - courtesy glenn jackman (modified) - foreach l $args { - lappend vars [incr n] - lappend lmap_args $n $l + #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly + # review - + proc lzipn_alt args { + #stackoverflow - courtesy glenn jackman (modified) + foreach l $args { + lappend vars [incr n] + lappend lmap_args $n $l + } + lmap {*}$lmap_args {lmap v $vars {set $v}} } - lmap {*}$lmap_args {lmap v $vars {set $v}} - } - #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) - proc lzipn_tcl8 {args} { - #wiki - courtesy JAL - set list_l $args - set zip_l [] - while {1} { - set cur [lmap a_l $list_l { lindex $a_l 0 }] - set list_l [lmap a_l $list_l { lrange $a_l 1 end }] + #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) + proc lzipn_tcl8 {args} { + #For tcl pre 9 (without lsearch -stride) + #wiki - courtesy JAL + set list_l $args + set zip_l [] + while {1} { + set cur [lmap a_l $list_l { lindex $a_l 0 }] + set list_l [lmap a_l $list_l { lrange $a_l 1 end }] - if {[join $cur {}] eq {}} { - break + if {[join $cur {}] eq {}} { + break + } + lappend zip_l $cur + } + return $zip_l + } + proc lzipn_tcl9a {args} { + #For Tcl 9+ (with lsearch -stride) + #compared to wiki version + #comparable for lists len <3 or number of args < 3 + #approx 2x faster for large lists or more lists + #needs -stride single index bug fix to use empty string instead of NULL + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] + set outlist [lrepeat $numcolumns {}] + set s 0 + foreach len $lens list $args { + #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] + ledit flatlist $s [expr {$s + $len - 1}] {*}$list + incr s $numcolumns + } + #needs single index lstride bugfix + for {set c 0} {$c < $numcolumns} {incr c} { + ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] + } + return $outlist + } + proc lzipn_tcl9b {args} { + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} + } + proc lzipn_tcl9c {args} { + #SLOW + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + set zip_l {} + set cols_remaining $numcolumns + for {set c 0} {$c < $numcolumns} {incr c} { + if {$cols_remaining == 1} { + return [list {*}$zip_l $flatlist] + } + lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] + set flen [llength $flatlist] + set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] + incr cols_remaining -1 } - lappend zip_l $cur + return $zip_l } - return $zip_l } - proc lzipn_tcl9a {args} { - #compared to wiki version - #comparable for lists len <3 or number of args < 3 - #approx 2x faster for large lists or more lists - #needs -stride single index bug fix to use empty string instead of NULL - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] - set outlist [lrepeat $numcolumns {}] - set s 0 - foreach len $lens list $args { - #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] - ledit flatlist $s [expr {$s + $len - 1}] {*}$list - incr s $numcolumns - } - #needs single index lstride bugfix - for {set c 0} {$c < $numcolumns} {incr c} { - ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] - } - return $outlist - } - proc lzipn_tcl9b {args} { - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [list] - foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] - } - lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} - } - proc lzipn_tcl9c {args} { - #SLOW - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [list] - foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] - } - set zip_l {} - set cols_remaining $numcolumns - for {set c 0} {$c < $numcolumns} {incr c} { - if {$cols_remaining == 1} { - return [list {*}$zip_l $flatlist] - } - lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] - set flen [llength $flatlist] - set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] - incr cols_remaining -1 - } - return $zip_l + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lzipn + @cmd -name punk::lib::lzipn\ + -summary\ + "zip any number of lists together (unoptimised)."\ + -help\ + "Conceptually equivalent to converting a list of rows + to a list of columns. + + See lzip which provides the same functionality but with + optimisations depending on the number of supplied lists. + " + @values -min 1 -max 1 + lvar -type string -help\ + "name of list variable" + a -type indexexpression + z -type indexexpression + }] } #keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible if {![package vsatisfies [package present Tcl] 9.0-] || [dict get [punk::lib::check::has_tclbug_lsearch_strideallinline] bug]} { #-stride either not available - or has bug preventing use of main algorithm below - proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] + proc lzipn {args} [info body ::punk::lib::system::lzipn_tcl8] } else { - proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] + proc lzipn {args} [info body ::punk::lib::system::lzipn_tcl9a] } + namespace import ::punk::args::lib::tstr namespace eval argdoc { @@ -2291,13 +2364,31 @@ namespace eval punk::lib { proc is_list_all_ni_list2 {a b} $body } - #somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist - #struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on, - # especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg) - proc ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::ldiff + @cmd -name punk::lib::ldiff\ + -summary\ + "Difference consisting of items with removeitems removed."\ + -help\ + "Somewhat like struct::set difference, but order preserving, and doesn't + treat as a 'set' so preserves any duplicates in items. + + struct::set difference may happen to preserve ordering when items are + integers, but order can't be relied on, especially as struct::set has + 2 differening implementations (tcl vs critcl) which return results with + different ordering to each other and different deduping behaviour in + some cases (e.g when 2nd arg is empty)" + @values -min 2 -max 2 + items -type list + removeitems -type list + }] + } + proc ldiff {items removeitems} { + if {[llength $removeitems] == 0} {return $items} set result {} - foreach item $fromlist { + foreach item $items { if {$item ni $removeitems} { lappend result $item } @@ -2361,6 +2452,28 @@ namespace eval punk::lib { return [array names tmp] } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lunique_unordered + @cmd -name punk::lib::lunique_unordered\ + -summary\ + "unique values in list"\ + -help\ + "Return unique values in provided list. + This removes duplicates but *may* rearrange the + order of the returned elements compared to the + original list. + + When struct::set is available this will be used + for the implementation, as it can be *slightly* + faster if acceleration is present. When struct::set + is not available it will fallback to lunique and + provide the same functionality with order preserved." + @values -min 1 -max 1 + list -type list + }] + } #default/fallback implementation proc lunique_unordered {list} { lunique $list @@ -2371,13 +2484,33 @@ namespace eval punk::lib { struct::set union $list {} } } else { - puts stderr "WARNING: struct::set union no longer dedupes!" + #struct::set union operates on a 'set' - so this probably won't change, and hopefully is + #consistent across unacelerated versions and those implemented in accelerators, + #but if it ever does change - be a little noisy about it. + puts stderr "punk::lib WARNING: struct::set union no longer dedupes!" #we could also test a sequence of: struct::set add } } - #order-preserving + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lunique + @cmd -name punk::lib::lunique\ + -summary\ + "Order-preserving unique values in list"\ + -help\ + "Return unique values in provided list. + This removes duplicates whilst preserving the + original order of the provided list. + + When struct::set is available with acceleration, + lunique_unordered may be slightly faster." + @values -min 1 -max 1 + list -type list + }] + } proc lunique {list} { set new {} foreach item $list { @@ -2569,18 +2702,21 @@ namespace eval punk::lib { To validate if an indexset is strictly within range, both the length of the data and the base would need to be considered. - The normal 'range' specifier is .. + The normal 'range' specifier is .. but can be of the form .x. where x is the step value. The range specifier can appear at the beginning, middle or end, or even alone to indicate the entire range of valid values. e.g the following are all valid ranges - 1.. - (index 1 to 'max') - ..10 - (index 'base' to 10) - 2..11 - (index 2 to 11) - .. - (all indices) + 1.. + (index 1 to 'max') + ..10 + (index 'base' to 10) + 2..11 + (index 2 to 11) + .. + (all indices) + .3. + (1st index and every 3rd index thereafter) + Common whitespace elements space,tab,newlines are ignored. Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands, e.g end-2 or 2+2. @@ -2670,20 +2806,19 @@ namespace eval punk::lib { .-1. would represent end to base with step -1 If start is omitted and only the end is supplied: - The default step is 1 indicating ascension and the missing end is equivalent to 'end' - indexset_resolve 5 2.. - -> 2 3 4 - The default end is the base if the step is negative - indexset_resolve 5 2.-1. - -> 2 1 0 - If end is omitted and onlthe start is supplied: The default step is 1 indicating ascension and the missing start is equivalent to the base. indexset_resolve 5 ..2 -> 0 1 2 The default start is 'end' if the step is negative indexset_resolve 5 .-1.2 -> 4 3 2 - + If end is omitted and only the start is supplied: + The default step is 1 indicating ascension and the missing end is equivalent to 'end' + indexset_resolve 5 2.. + -> 2 3 4 + The default end is the base if the step is negative + indexset_resolve 5 2.-1. + -> 2 1 0 Like the tcl9 lseq command - a step (by) value of zero produces no results. @@ -2703,7 +2838,7 @@ namespace eval punk::lib { indexset examples: - These assume the default 0-based indices (base == 0) + These assume the default 0-based indices (-base 0) 1,3.. output the index 1 (2nd item) followed by all from index 3 to the end. @@ -3604,7 +3739,7 @@ namespace eval punk::lib { @id -id ::punk::lib::gcd @cmd -name punk::lib::gcd\ -summary\ - "Gretest common divisor of m and n."\ + "Greatest common divisor of m and n."\ -help\ "Return the greatest common divisor of m and n. Straight from Lars Hellström's math::numtheory library in Tcllib @@ -3643,12 +3778,22 @@ namespace eval punk::lib { return $m } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::lcm + @cmd -name punk::lib::lcm\ + -summary\ + "Lowest common multiple of m and n."\ + -help\ + "Return the lowest common multiple of m and n. + Straight from Lars Hellström's math::numtheory library in Tcllib" + @values -min 2 -max 2 + m -type integer + n -type integer + }] + } proc lcm {n m} { - #*** !doctools - #[call [fun gcd] [arg n] [arg m]] - #[para]Return the lowest common multiple of m and n - #[para]Straight from Lars Hellström's math::numtheory library in Tcllib - #[para] set gcd [gcd $n $m] return [expr {$n*$m/$gcd}] } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm index 96f506b5..c0f2b7ba 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm @@ -1036,7 +1036,8 @@ namespace eval punk::repl::class { # set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""] # incr nextrow -1 #} - set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""] + #set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""] + ledit o_rendered_lines $cursor_row_idx $cursor_row_idx-1 "" set o_cursor_col 1 } diff --git a/src/vfs/_vfscommon.vfs/modules/punkcheck-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punkcheck-0.1.0.tm index 9c44ea72..c610c667 100644 --- a/src/vfs/_vfscommon.vfs/modules/punkcheck-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punkcheck-0.1.0.tm @@ -323,7 +323,8 @@ namespace eval punkcheck { if {$isnew} { lappend record_list $o_fileset_record } else { - set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record] + #set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record] + ledit record_list $oldposition $oldposition-1 $o_fileset_record } if {$o_operation ne "QUERY"} { punkcheck::save_records_to_file $record_list $punkcheck_file @@ -536,7 +537,8 @@ namespace eval punkcheck { set existing_header_posn [dict get $resultinfo position] if {$existing_header_posn == -1} { set this_installer_record [punkcheck::recordlist::new_installer_record $o_name] - set o_record_list [linsert $o_record_list 0 $this_installer_record] + #set o_record_list [linsert $o_record_list 0 $this_installer_record] + ledit o_record_list -1 -1 $this_installer_record } else { set this_installer_record [dict get $resultinfo record] } @@ -616,7 +618,8 @@ namespace eval punkcheck { set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records] set existing_header_posn [dict get $persistedinfo position] if {$existing_header_posn == -1} { - set file_records [linsert $file_records 0 $this_installer_record] + #set file_records [linsert $file_records 0 $this_installer_record] + ledit file_records -1 -1 $this_installer_record } else { lset file_records $existing_header_posn $this_installer_record } @@ -710,7 +713,8 @@ namespace eval punkcheck { if {$existing_header_posn == -1} { #not found - prepend - set record_list [linsert $record_list 0 $this_installer_record] + #set record_list [linsert $record_list 0 $this_installer_record] + ledit record_list -1 -1 $this_installer_record } else { #replace lset record_list $existing_header_posn $this_installer_record @@ -791,7 +795,8 @@ namespace eval punkcheck { if {$isnew} { lappend record_list $file_record } else { - set record_list [linsert $record_list[unset record_list] $oldposition $file_record] + #set record_list [linsert $record_list[unset record_list] $oldposition $file_record] + ledit record_list $oldposition $oldposition-1 $file_record } save_records_to_file $record_list $punkcheck_file @@ -1191,7 +1196,8 @@ namespace eval punkcheck { # dst is: base/sub = sub while {$baselen > 0} { - set dst [linsert $dst 0 ..] + #set dst [linsert $dst 0 ..] + ledit dst -1 -1 .. incr baselen -1 } set dst [file join {*}$dst] diff --git a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm index 93e4a41c..4079254e 100644 --- a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm +++ b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm @@ -4480,7 +4480,8 @@ tcl::namespace::eval textblock { set code_idx 3 foreach {pt code} [lrange $parts 2 end] { if {[punk::ansi::codetype::is_sgr_reset $code]} { - set parts [linsert $parts $code_idx+1 $base] + #set parts [linsert $parts $code_idx+1 $base] + ledit parts $code_idx+1 $code_idx $base } incr code_idx 2 } @@ -4504,12 +4505,14 @@ tcl::namespace::eval textblock { #first pt & code if {$pt ne ""} { #leading plaintext - set parts [linsert $parts 0 $base] + #set parts [linsert $parts 0 $base] + ledit parts -1 -1 $base incr offset } } if {[punk::ansi::codetype::is_sgr_reset $code]} { set parts [linsert $parts [expr {$code_idx+1+$offset}] $base] + #ledit parts [expr {$code_idx+1+$offset}] $code_idx+$offset $base incr offset } incr code_idx 2 @@ -5371,6 +5374,9 @@ tcl::namespace::eval textblock { r-1 { if {[lindex $line_chunks end] eq ""} { set line_chunks [linsert $line_chunks end-2 $pad] + #breaks layout e.g subtables in: i i + #why? + #ledit line_chunks end-2 end-3 $pad } else { lappend line_chunks $pad } @@ -5379,13 +5385,16 @@ tcl::namespace::eval textblock { lappend line_chunks $pad } l-0 { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } l-1 { if {[lindex $line_chunks 0] eq ""} { - set line_chunks [linsert $line_chunks 2 $pad] + #set line_chunks [linsert $line_chunks 2 $pad] + ledit line_chunks 2 1 $pad } else { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } } l-2 { @@ -5393,10 +5402,12 @@ tcl::namespace::eval textblock { if {[lindex $line_chunks 0] eq ""} { set line_chunks [linsert $line_chunks 2 $pad] } else { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } } else { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } } } @@ -5466,14 +5477,17 @@ tcl::namespace::eval textblock { #} else { # set line_chunks [linsert $line_chunks 0 $pad] #} - set line_chunks [linsert $line_chunks 0 $pad] + + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } l-1 { #set line_chunks [linsert $line_chunks 0 $pad] set line_chunks [_insert_before_text_or_last_ansi $pad $line_chunks] } l-2 { - set line_chunks [linsert $line_chunks 0 $pad] + #set line_chunks [linsert $line_chunks 0 $pad] + ledit line_chunks -1 -1 $pad } } }