@ -1510,14 +1510,16 @@ tcl::namespace::eval textblock {
#check minheight and maxheight together
set opt_minh [tcl::dict::get $opts -minheight]
set opt_maxh [tcl::dict::get $opts -maxheight]
#todo - allow zero values to hide/collapse rows as is possible with columns
if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} {
error "[tcl::namespace::current]::table::add_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1"
error "[tcl::namespace::current]::table::configure _row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now) "
}
if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} {
error "[tcl::namespace::current]::table::add _row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater"
error "[tcl::namespace::current]::table::configure _row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now) "
}
if {$opt_maxh ne "" && $opt_maxh < $opt_minh} {
error "[tcl::namespace::current]::table::add _row error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'"
error "[tcl::namespace::current]::table::configure _row error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'"
}
tcl::dict::set o_rowstates $ridx -minheight $opt_minh
@ -1564,35 +1566,79 @@ tcl::namespace::eval textblock {
}
}
method Get_boxlimits_and_joins {position fname_body} {
#fname_body will be "custom" or one of the predefined types light,heavy etc
switch -- $position {
left {
return [tcl::dict::create \
boxlimits [list hlb blc vll]\
boxlimits_top [list hlb blc vll hlt tlc]\
joins [list down]\
bodyjoins [list down-$fname_body]\
]
}
inner {
return [tcl::dict::create \
boxlimits [list hlb blc vll]\
boxlimits_top [list hlb blc vll hlt tlc]\
joins [list down left]\
bodyjoins [list left down-$fname_body]
]
}
right {
return [tcl::dict::create \
boxlimits [list hlb blc vll vlr brc]\
boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\
joins [list down left]\
bodyjoins [list left down-$fname_body]\
]
}
solo {
return [tcl::dict::create \
boxlimits [list hlb blc vll vlr brc]\
boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\
joins [list down]\
bodyjoins [list down-$fname_body]\
]
}
default {
error "Get_boxlimits_and_joins unrecognised position '$position' expected: left inner right solo"
}
}
}
method Get_boxlimits_and_joins1 {position fname_body} {
#fname_body will be "custom" or one of the predefined types light,heavy etc
switch -- $position {
left {
#set header_boxlimits {hlb hlt tlc blc vll}
set header_body_joins [list down-$fname_body]
set boxlimits_position {hlb blc vll}
set boxlimits_toprow [concat $boxlimits_position {hlt tlc}]
set joins {down}
set boxlimits_position [list hlb blc vll]
#set boxlimits_toprow [concat $boxlimits_position {hlt tlc}]
set boxlimits_toprow [list hlb blc vll hlt tlc]
set joins [list down]
}
inner {
#set header_boxlimits {hlb hlt tlc blc vll}
set header_body_joins [list left down-$fname_body]
set boxlimits_position {hlb blc vll}
set boxlimits_toprow [concat $boxlimits_position {hlt tlc}]
set joins {down left}
set boxlimits_position [list hlb blc vll]
#set boxlimits_toprow [concat $boxlimits_position {hlt tlc}]
set boxlimits_toprow [list hlb blc vll hlt tlc]
set joins [list down left]
}
right {
#set header_boxlimits {hlb hlt tlc blc vll vlr trc brc}
set header_body_joins [list left down-$fname_body]
set boxlimits_position {hlb blc vll vlr brc}
set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}]
set joins {down left}
set boxlimits_position [list hlb blc vll vlr brc]
#set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}]
set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc]
set joins [list down left]
}
solo {
#set header_boxlimits {hlb hlt tlc blc vll vlr trc brc}
set header_body_joins [list down-$fname_body]
set boxlimits_position {hlb blc vll vlr brc}
set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}]
set joins {down}
set boxlimits_position [list hlb blc vll vlr brc]
#set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}]
set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc]
set joins [list down]
}
}
return [tcl::dict::create boxlimits $boxlimits_position boxlimits_top $boxlimits_toprow joins $joins bodyjoins $header_body_joins ]
@ -1617,11 +1663,10 @@ tcl::namespace::eval textblock {
set opt_posn [tcl::dict::get $opts -position]
set opt_return [tcl::dict::get $opts -return]
set valid_positions [list left inner right solo]
switch -- $opt_posn {
left - inner - right - solo {}
default {
error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_posn' for -position. Valid values: $valid_positions "
error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_posn' for -position. Valid values: [list left inner right solo] "
}
}
switch -- $opt_return {
@ -1638,15 +1683,12 @@ tcl::namespace::eval textblock {
set topt_show_header [tcl::dict::get $o_opts_table -show_header]
if {$topt_show_header eq ""} {
set allheaders ""
set allheaders 0
set all_cols [tcl::dict::keys $o_columndefs]
foreach c $all_cols {
set headerset [tcl::dict::get $o_columndefs $c -headers]
foreach hdr $headerset {
append allheaders $hdr
incr allheaders [llength [tcl::dict::get $o_columndefs $c -headers]]
}
}
if {$allheaders eq ""} {
if {$allheaders == 0} {
set do_show_header 0
} else {
set do_show_header 1
@ -1682,36 +1724,6 @@ tcl::namespace::eval textblock {
set fname_header $ftype_header
}
switch -- $opt_posn {
left {
#set header_boxlimits {hlb hlt tlc blc vll}
set header_body_joins [list down-$fname_body]
set boxlimits_position {hlb blc vll}
set boxlimits_toprow [concat $boxlimits_position {hlt tlc}]
set joins {down}
}
inner {
#set header_boxlimits {hlb hlt tlc blc vll}
set header_body_joins [list left down-$fname_body]
set boxlimits_position {hlb blc vll}
set boxlimits_toprow [concat $boxlimits_position {hlt tlc}]
set joins {down left}
}
right {
#set header_boxlimits {hlb hlt tlc blc vll vlr trc brc}
set header_body_joins [list left down-$fname_body]
set boxlimits_position {hlb blc vll vlr brc}
set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}]
set joins {down left}
}
solo {
#set header_boxlimits {hlb hlt tlc blc vll vlr trc brc}
set header_body_joins [list down-$fname_body]
set boxlimits_position {hlb blc vll vlr brc}
set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}]
set joins {down}
}
}
set limj [my Get_boxlimits_and_joins $opt_posn $fname_body]
set header_body_joins [tcl::dict::get $limj bodyjoins]
set joins [tcl::dict::get $limj joins]
@ -2073,7 +2085,7 @@ tcl::namespace::eval textblock {
}
}
set part_header [join $adjusted_lines \n]
append output $part_header \n
# append output $part_header \n
}
set r 0
@ -2116,19 +2128,22 @@ tcl::namespace::eval textblock {
} else {
set border_ansi $body_ansibase$body_ansiborder
}
set r 0
set ftblock [expr {[tcl::dict::get $o_opts_table -frametype] eq "block"}]
foreach c $cells {
set ansibase $body_ansibase$opt_col_ansibase
#cells in column - each new c is in a different row
set row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase]
#todo - joinleft,joinright,joindown based on opts in args
#append output [textblock::frame -boxlimits {vll blc hlb} $c]\n
set cell_ansibase ""
set row_bg ""
if {$row_ansibase ne ""} {
set row_bg [punk::ansi::codetype::sgr_merge_singles [list $row_ansibase] -filter_fg 1]
}
set ansibase $body_ansibase$opt_col_ansibase
#todo - joinleft,joinright,joindown based on opts in args
set cell_ansibase ""
set ansiborder_body_col_row $border_ansi$row_bg
set ansiborder_final $ansiborder_body_col_row
#$c will always have ansi resets due to overtype behaviour ?
@ -2172,7 +2187,6 @@ tcl::namespace::eval textblock {
}
}
set ansibase_final $ansibase$row_ansibase$cell_ansibase
if {$r == 0} {
@ -2255,12 +2269,20 @@ tcl::namespace::eval textblock {
set part_body [tcl::string::range $part_body 0 end-1]
}
set return_bodyheight [textblock::height $part_body]
append output $part_body
# append output $part_body
if {$opt_return eq "string"} {
if {$part_header ne ""} {
set output $part_header
if {$part_body ne ""} {
append output \n $part_body
}
} else {
set output $part_body
}
return $output
} else {
return [tcl::dict::create column $output headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight]
return [tcl::dict::create header $part_header body $part_body headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight]
}
}
@ -2661,6 +2683,7 @@ tcl::namespace::eval textblock {
set width_max $colwidth
set test_width $colwidth
set showing_vseps [my Showing_vseps]
set thiscol_widest_header [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen]
tcl::dict::for {h colspans} $header_colspans {
set spanc [lindex $colspans $cidx]
#set headers [tcl::dict::get $cdef -headers]
@ -2668,7 +2691,6 @@ tcl::namespace::eval textblock {
#if {[llength $headers] > 0} {
# set thiscol_widest_header [tcl::mathfunc::max {*}[lmap v $headers {textblock::width $v}]]
#}
set thiscol_widest_header [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen]
if {$spanc eq "1"} {
if {$thiscol_widest_header > $colwidth} {
set test_width [expr {max($thiscol_widest_header,$colwidth)}]
@ -3205,7 +3227,7 @@ tcl::namespace::eval textblock {
set o_column_width_algorithm $opt_algorithm
return $o_calculated_column_widths
}
method print {args} {
method print2 {args} {
variable full_column_cache
set full_column_cache [tcl::dict::create]
@ -3259,7 +3281,7 @@ tcl::namespace::eval textblock {
set columninfo [my get_column_by_index $c -return dict {*}$flags]
tcl::dict::set full_column_cache $c $columninfo
}
set nextcol [tcl::dict::get $columninfo column]
set nextcol [tcl::string::cat [tcl:: dict::get $columninfo header] \n [tcl::dict::get $ columninfo body] ]
set bodywidth [tcl::dict::get $columninfo bodywidth]
if {$table eq ""} {
@ -3320,6 +3342,236 @@ tcl::namespace::eval textblock {
return "No columns matched"
}
}
# using -startcolumn to do slightly less work
method print3 {args} {
if {![llength $args]} {
set cols [tcl::dict::keys $o_columndata]
} else {
set cols [list]
foreach colspec $args {
set allcols [tcl::dict::keys $o_columndata]
if {[tcl::string::first .. $colspec] >=0} {
set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec]
if {[llength $parts] != 3} {
error "[namespace::current]::table error invalid print specification '$colspec'"
}
lassign $parts from _dd to
if {$from eq ""} {set from 0}
if {$to eq ""} {set to end}
set indices [lrange $allcols $from $to]
lappend cols {*}$indices
} else {
set c [lindex $allcols $colspec]
if {$c ne ""} {
lappend cols $c
}
}
}
}
set blocks [list]
set numposns [llength $cols]
set colposn 0
set padwidth 0
set table ""
foreach c $cols {
set flags [list]
if {$colposn == 0 && $colposn == $numposns-1} {
set flags [list -position solo]
} elseif {$colposn == 0} {
set flags [list -position left]
} elseif {$colposn == $numposns-1} {
set flags [list -position right]
} else {
set flags [list -position inner]
}
set columninfo [my get_column_by_index $c -return dict {*}$flags]
set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]]
set bodywidth [tcl::dict::get $columninfo bodywidth]
if {$table eq ""} {
set table $nextcol
set height [textblock::height $table] ;#only need to get height once at start
} else {
set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -overflow 1 -experimental test_mode -transparent $TSUB $table $nextcol]
#set nextcol [textblock::join [textblock::block $padwidth $height $TSUB] $nextcol]
#set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent $TSUB $table[unset table] $nextcol]
#JMN
#set nextcol [textblock::join [textblock::block $padwidth $height "\uFFFF"] $nextcol]
#set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent \uFFFF $table $nextcol]
}
incr padwidth $bodywidth
incr colposn
}
if {[llength $cols]} {
#return [textblock::join {*}$blocks]
if {[tcl::dict::get $o_opts_table -show_edge]} {
#title is considered part of the edge ?
set offset 1 ;#make configurable?
set titlepad [tcl::string::repeat $TSUB $offset]
if {[tcl::dict::get $o_opts_table -title] ne ""} {
set titlealign [tcl::dict::get $o_opts_table -titlealign]
switch -- $titlealign {
left {
set tstring $titlepad[tcl::dict::get $o_opts_table -title]
}
right {
set tstring [tcl::dict::get $o_opts_table -title]$titlepad
}
default {
set tstring [tcl::dict::get $o_opts_table -title]
}
}
set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent]
switch -- $opt_titletransparent {
0 {
set mapchar ""
}
1 {
set mapchar " "
}
default {
#won't work if not a single char - review - check also frame behaviour
set mapchar $opt_titletransparent
}
}
if {$mapchar ne ""} {
set tstring [tcl::string::map [list $mapchar $TSUB] $tstring]
}
set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring]
}
}
return $table
} else {
return "No columns matched"
}
}
#print headers and body using different join mechanisms
# using -startcolumn to do slightly less work
method print {args} {
if {![llength $args]} {
set cols [tcl::dict::keys $o_columndata]
} else {
set cols [list]
foreach colspec $args {
set allcols [tcl::dict::keys $o_columndata]
if {[tcl::string::first .. $colspec] >=0} {
set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec]
if {[llength $parts] != 3} {
error "[namespace::current]::table error invalid print specification '$colspec'"
}
lassign $parts from _dd to
if {$from eq ""} {set from 0}
if {$to eq ""} {set to end}
set indices [lrange $allcols $from $to]
lappend cols {*}$indices
} else {
set c [lindex $allcols $colspec]
if {$c ne ""} {
lappend cols $c
}
}
}
}
set numposns [llength $cols]
set colposn 0
set padwidth 0
set header_build ""
set body_blocks [list]
set headerheight 0
foreach c $cols {
set flags [list]
if {$colposn == 0 && $colposn == $numposns-1} {
set flags [list -position solo]
} elseif {$colposn == 0} {
set flags [list -position left]
} elseif {$colposn == $numposns-1} {
set flags [list -position right]
} else {
set flags [list -position inner]
}
set columninfo [my get_column_by_index $c -return dict {*}$flags]
#set nextcol [tcl::dict::get $columninfo column]
set bodywidth [tcl::dict::get $columninfo bodywidth]
set headerheight [tcl::dict::get $columninfo headerheight]
#set nextcol_lines [split $nextcol \n]
#set nextcol_header [join [lrange $nextcol_lines 0 $headerheight-1] \n]
#set nextcol_body [join [lrange $nextcol_lines $headerheight end] \n]
set nextcol_header [tcl::dict::get $columninfo header]
set nextcol_body [tcl::dict::get $columninfo body]
if {$header_build eq "" && ![llength $body_blocks]} {
set header_build $nextcol_header
lappend body_blocks $nextcol_body
} else {
if {$headerheight > 0} {
set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -overflow 1 -experimental test_mode -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]]
}
lappend body_blocks $nextcol_body
#set body_build [textblock::join $body_build[unset body_build] $nextcol_body]
}
incr padwidth $bodywidth
incr colposn
}
if {![llength $body_blocks]} {
set body_build ""
} else {
set body_build [textblock::join {*}$body_blocks]
}
if {$headerheight > 0} {
set table [tcl::string::cat $header_build \n $body_build]
} else {
set table $body_build
}
if {[llength $cols]} {
if {[tcl::dict::get $o_opts_table -show_edge]} {
#title is considered part of the edge ?
set offset 1 ;#make configurable?
set titlepad [tcl::string::repeat $TSUB $offset]
if {[tcl::dict::get $o_opts_table -title] ne ""} {
set titlealign [tcl::dict::get $o_opts_table -titlealign]
switch -- $titlealign {
left {
set tstring $titlepad[tcl::dict::get $o_opts_table -title]
}
right {
set tstring [tcl::dict::get $o_opts_table -title]$titlepad
}
default {
set tstring [tcl::dict::get $o_opts_table -title]
}
}
set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent]
switch -- $opt_titletransparent {
0 {
set mapchar ""
}
1 {
set mapchar " "
}
default {
#won't work if not a single char - review - check also frame behaviour
set mapchar $opt_titletransparent
}
}
if {$mapchar ne ""} {
set tstring [tcl::string::map [list $mapchar $TSUB] $tstring]
}
set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring]
}
}
return $table
} else {
return "No columns matched"
}
}
method print_bodymatrix {} {
set m [my as_matrix]
$m format 2string
@ -3490,14 +3742,14 @@ tcl::namespace::eval textblock {
tcl::dict::set ecat $e $val
}
set cat [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og]
set ansi [a+ {*}$fc web-black Web-whitesmoke]
set val [list ansi $ansi cat other]
foreach e $cat {
foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] {
tcl::dict::set ecat $e $val
}
set elements1 [list]
set RST [a+]
foreach e $elements {
if {[tcl::dict::exists $ecat $e]} {
set ansi [tcl::dict::get $ecat $e ansi]
@ -3545,20 +3797,19 @@ tcl::namespace::eval textblock {
}
proc list_as_table {table_or_colcount datalist args} {
set defaul ts [tcl::dict::create\
set op ts [tcl::dict::create\
-return string\
-frametype \uFFEF\
-show_edge \uFFEF\
-show_seps \uFFEF\
]
set opts $defaults
foreach {k v} $args {
switch -- $k {
-return - -show_edge - -show_seps - -frametype {
tcl::dict::set opts $k $v
}
default {
error "unrecognised option '$k'. Known options [tcl::dict::keys $defaul ts]"
error "unrecognised option '$k'. Known options [tcl::dict::keys $op ts]"
}
}
}
@ -3977,8 +4228,14 @@ tcl::namespace::eval textblock {
}
}
#todo? special case trailing double-reset - insert between resets?
set lnum 0
if {[punk::ansi::ta::detect $block]} {
set parts [punk::ansi::ta::split_codes $block]
} else {
#single plaintext part
set parts [list $block]
}
set line_chunks [list]
set line_len 0
foreach {pt ansi} $parts {
@ -4527,7 +4784,7 @@ tcl::namespace::eval textblock {
proc frametype {f} {
variable frametypes
set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "]
set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc]
# set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc]
if {$f ni $frametypes} {
set is_custom_dict_ok 1
if {[llength $f] %2 == 0} {
@ -5748,6 +6005,8 @@ tcl::namespace::eval textblock {
}
return $out
}
#options before content argument - which is allowed to be absent
#frame performance (noticeable with complex tables even of modest size) is improved significantly by frame_cache - but is still (2024) a fairly expensive operation.
#
@ -5758,6 +6017,27 @@ tcl::namespace::eval textblock {
# - but we would need to maintain support for the rendered-string based operations too.
proc frame {args} {
variable frametypes
#counterintuitively - in-proc dict create each time is generally slightly faster than linked namespace var
set opts [tcl::dict::create\
-etabs 0\
-type light\
-boxlimits [list hl vl tlc blc trc brc]\
-boxmap {}\
-joins [list]\
-title ""\
-subtitle ""\
-width ""\
-height ""\
-ansiborder ""\
-ansibase ""\
-blockalign "centre"\
-textalign "left"\
-ellipsis 1\
-usecache 1\
-buildcache 1\
]
set expect_optval 0
set argposn 0
set pmax [expr {[llength $args]-1}]
@ -5791,24 +6071,6 @@ tcl::namespace::eval textblock {
}
#todo args -justify left|centre|right (center)
set opts [tcl::dict::create\
-etabs 0\
-type light\
-boxlimits [list hl vl tlc blc trc brc]\
-boxmap {}\
-joins [list]\
-title ""\
-subtitle ""\
-width ""\
-height ""\
-ansiborder ""\
-ansibase ""\
-blockalign "centre"\
-textalign "left"\
-ellipsis 1\
-usecache 1\
-buildcache 1\
]
#todo -blockalignbias -textalignbias?
#use -buildcache 1 with -usecache 0 for debugging cache issues so we can inspect using textblock::frame_cache
foreach {k v} $arglist {
@ -6011,6 +6273,7 @@ tcl::namespace::eval textblock {
#set cache_key [concat $arglist $frame_inner_width $frame_inner_height]
set hashables [concat $arglist $frame_inner_width $frame_inner_height]
package require md5
#set hash $hashables
set hash [md5::md5 -hex $hashables] ;#need fast and unique to content - not cryptographic - review
set cache_key "$hash-$frame_inner_width-$frame_inner_height-actualcontentwidth:$actual_contentwidth"
#should be in a unicode private range different to that used in table construction
