jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
200 Commits
1 Branch
1 Tag
197 MiB
 
 
 
 
 
 
Tree: 7484206820
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '7484206820'
${ noResults }
punkshell/src/modules/textblock-999999.0a1.0.tm

6375 lines
320 KiB
Raw Blame History

# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-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) 2023
#
# @@ Meta Begin
# Application textblock 999999.0a1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
#package require punk
package require punk::args
package require punk::char
package require punk::ansi
package require punk::lib
catch {package require patternpunk}
package require overtype
package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional?
package require textutil
namespace eval textblock {
#review - what about ansi off in punk::console?
namespace import ::punk::ansi::a ::punk::ansi::a+
namespace eval class {
variable opts_table_defaults
set opts_table_defaults [dict create\
-title ""\
-titlealign "left"\
-titletransparent 0\
-frametype "light"\
-frametype_header ""\
-ansibase_header ""\
-ansibase_body ""\
-ansibase_footer ""\
-ansiborder_header ""\
-ansiborder_body ""\
-ansiborder_footer ""\
-ansireset "\uFFeF"\
-framelimits_header "vll vlr hlb hlt tlc trc blc brc"\
-frametype_body ""\
-framelimits_body "vll vlr hlb hlt tlc trc blc brc"\
-framemap_body [list\
topleft {} topinner {} topright {} topsolo {}\
middleleft {} middleinner {} middleright {} middlesolo {}\
bottomleft {} bottominner {} bottomright {} bottomsolo {}\
onlyleft {} onlyinner {} onlyright {} onlysolo {}\
]\
-framemap_header [list\
topleft {} topinner {} topright {} topsolo {}\
middleleft {} middleinner {} middleright {} middlesolo {}\
bottomleft {} bottominner {} bottomright {} bottomsolo {}\
onlyleft {} onlyinner {} onlyright {} onlysolo {}\
]\
-show_edge 1\
-show_seps 1\
-show_hseps ""\
-show_vseps ""\
-show_header ""\
-show_footer ""\
-minwidth ""\
-maxwidth ""\
]
#for 'L' shaped table building pattern (tables bigger than 4x4 will be mostly 'L' patterns)
#ie only vll,blc,hlb used for cells except top row and right column
#top right cell uses all 'O' shape, other top cells use 'C' shape (hlt,tlc,vll,blc,hlb)
#right cells use 'U' shape (vll,blc,hlb,brc,vlr)
#e.g for 4x4
# C C C O
# L L L U
# L L L U
#anti-clockwise elements
set C [list hlt tlc vll blc hlb]
set O [list trc hlt tlc vll blc hlb brc vlr]
set L [list vll blc hlb]
set U [list vll blc hlb brc vlr]
set tops [list trc hlt tlc]
set lefts [list tlc vll blc]
set bottoms [list blc hlb brc]
set rights [list trc brc vlr]
variable table_edge_parts
set table_edge_parts [dict create\
topleft [struct::set intersect $C [concat $tops $lefts]]\
topinner [struct::set intersect $C [concat $tops]]\
topright [struct::set intersect $O [concat $tops $rights]]\
topsolo [struct::set intersect $O [concat $tops $lefts $rights]]\
middleleft [struct::set intersect $L $lefts]\
middleinner [list]\
middleright [struct::set intersect $U $rights]\
middlesolo [struct::set intersect $U [concat $lefts $rights]]\
bottomleft [struct::set intersect $L [concat $lefts $bottoms]]\
bottominner [struct::set intersect $L $bottoms]\
bottomright [struct::set intersect $U [concat $bottoms $rights]]\
bottomsolo [struct::set intersect $U [concat $lefts $bottoms $rights]]\
onlyleft [struct::set intersect $C [concat $tops $lefts $bottoms]]\
onlyinner [struct::set intersect $C [concat $tops $bottoms]]\
onlyright [struct::set intersect $O [concat $tops $bottoms $rights]]\
onlysolo [struct::set intersect $O [concat $tops $lefts $bottoms $rights]]\
]
#for header rows - we don't consider the bottom border as part of the edge - even if table body has no rows
#The usual-case of a single header line is the 'onlyleft,onlyinner,onlyright,onlysolo' set.
variable header_edge_parts
set header_edge_parts [dict create\
topleft [struct::set intersect $C [concat $tops $lefts]]\
topinner [struct::set intersect $C [concat $tops]]\
topright [struct::set intersect $O [concat $tops $rights]]\
topsolo [struct::set intersect $O [concat $tops $lefts $rights]]\
middleleft [struct::set intersect $L $lefts]\
middleinner [list]\
middleright [struct::set intersect $U $rights]\
middlesolo [struct::set intersect $U [concat $lefts $rights]]\
bottomleft [struct::set intersect $L [concat $lefts]]\
bottominner [list]\
bottomright [struct::set intersect $U $rights]\
bottomsolo [struct::set intersect $U [concat $lefts $rights]]\
onlyleft [struct::set intersect $C [concat $tops $lefts]]\
onlyinner [struct::set intersect $C $tops]\
onlyright [struct::set intersect $O [concat $tops $rights]]\
onlysolo [struct::set intersect $O [concat $tops $lefts $rights]]\
]
variable table_hseps
set table_hseps [dict create\
topleft [list blc hlb]\
topinner [list blc hlb]\
topright [list blc hlb brc]\
topsolo [list blc hlb brc]\
middleleft [list blc hlb]\
middleinner [list blc hlb]\
middleright [list blc hlb brc]\
middlesolo [list blc hlb brc]\
bottomleft [list]\
bottominner [list]\
bottomright [list]\
bottomsolo [list]\
onlyleft [list]\
onlyinner [list]\
onlyright [list]\
onlysolo [list]\
]
variable table_vseps
set table_vseps [dict create\
topleft [list]\
topinner [list vll tlc blc]\
topright [list vll tlc blc]\
topsolo [list]\
middleleft [list]\
middleinner [list vll tlc blc]\
middleright [list vll tlc blc]\
middlesolo [list]\
bottomleft [list]\
bottominner [list vll tlc blc]\
bottomright [list vll tlc blc]\
bottomsolo [list]\
onlyleft [list]\
onlyinner [list vll tlc blc]\
onlyright [list vll tlc blc]\
onlysolo [list]\
]
#e.g $t configure -framemap_body [table_edge_map " "]
proc table_edge_map {char} {
variable table_edge_parts
set map [list]
dict for {celltype parts} $table_edge_parts {
set tmap [list]
foreach p $parts {
dict set tmap $p $char
}
dict set map $celltype $tmap
}
return $map
}
proc table_sep_map {char} {
variable table_hseps
set map [list]
dict for {celltype parts} $table_hseps {
set tmap [list]
foreach p $parts {
dict set tmap $p $char
}
dict set map $celltype $tmap
}
return $map
}
proc header_edge_map {char} {
variable header_edge_parts
set map [list]
dict for {celltype parts} $header_edge_parts {
set tmap [list]
foreach p $parts {
dict set tmap $p $char
}
dict set map $celltype $tmap
}
return $map
}
if {[info commands [namespace current]::table] eq ""} {
#*** !doctools
#[subsection {Namespace textblock::class}]
#[para] class definitions
#[list_begin itemized] [comment {- textblock::class groupings -}]
# [item]
# [para] [emph {handler_classes}]
# [list_begin enumerated]
oo::class create [namespace current]::table {
#*** !doctools
#[enum] CLASS [class interface_caphandler.registry]
#[list_begin definitions]
# [para] [emph METHODS]
variable o_opts_table ;#options as configured by user (with exception of -ansireset)
variable o_opts_table_effective; #options in effect - e.g with defaults merged in.
variable o_columndefs
variable o_columndata
variable o_columnstates
variable o_headerstates
variable o_rowdefs
variable o_rowstates
variable o_opts_table_defaults
variable o_opts_header_defaults ;# header data mostly stored in o_columndefs
variable o_opts_column_defaults
variable o_opts_row_defaults
variable TSUB ;#make configurable so user isn't stopped from using our default PUA-unicode char in content (nerdfonts overlap)
variable o_calculated_column_widths
variable o_column_width_algorithm
constructor {args} {
#*** !doctools
#[call class::table [method constructor] [arg args]]
upvar ::textblock::class::opts_table_defaults tdefaults
set o_opts_table_defaults $tdefaults
if {[llength $args] == 1} {
set args [list -title [lindex $args 0]]
}
if {[llength $args] %2 !=0} {
error "[namespace current]::table constructor - unexpected argument count. Require single value being title, or name value pairs"
}
dict for {k v} $args {
if {$k ni [dict keys $o_opts_table_defaults]} {
error "[namespace current]::table unrecognised option '$k'. Known values [dict keys $o_opts_table_defaults]"
}
}
#set o_opts_table [dict merge $o_opts_table_defaults $args]
set o_opts_table $o_opts_table_defaults
set o_opts_table_effective $o_opts_table_defaults
my configure {*}[dict merge $o_opts_table_defaults $args]
set o_columndefs [dict create]
set o_columndata [dict create] ;#we store data by column even though it is often added row by row
set o_columnstates [dict create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly
set o_headerstates [dict create]
set o_rowdefs [dict create] ;#user requested row data e.g -minheight -maxheight
set o_rowstates [dict create] ;#actual row data such as -minheight and -maxheight detected from supplied row data
set TSUB \uF111 ;#should be BMP PUA code to show as either replacement char or nerdfont glyph. See FSUB for comments regarding choices.
set o_calculated_column_widths [list]
set o_column_width_algorithm "span"
set header_defaults [dict create\
-colspans {}\
-values {}\
-ansibase {}\
]
set o_opts_header_defaults $header_defaults
}
method width_algorithm {{alg ""}} {
if {$alg eq ""} {
return $o_column_width_algorithm
}
if {$alg ne $o_column_width_algorithm} {
#invlidate cached widths
set o_calculated_column_widths [list]
}
set o_column_width_algorithm $alg
}
method Get_seps {} {
set requested_seps [dict get $o_opts_table -show_seps]
set requested_seps_h [dict get $o_opts_table -show_hseps]
set requested_seps_v [dict get $o_opts_table -show_vseps]
set seps $requested_seps
set seps_h $requested_seps_h
set seps_v $requested_seps_v
if {$requested_seps eq ""} {
if {$requested_seps_h eq ""} {
set seps_h 1
}
if {$requested_seps_v eq ""} {
set seps_v 1
}
} else {
if {$requested_seps_h eq ""} {
set seps_h $seps
}
if {$requested_seps_v eq ""} {
set seps_v $seps
}
}
return [dict create horizontal $seps_h vertical $seps_v]
}
method Get_frametypes {} {
set requested_ft [dict get $o_opts_table -frametype]
set requested_ft_header [dict get $o_opts_table -frametype_header]
set requested_ft_body [dict get $o_opts_table -frametype_body]
set ft $requested_ft
set ft_header $requested_ft_header
set ft_body $requested_ft_body
switch -- $requested_ft {
light {
if {$requested_ft_header eq ""} {
set ft_header heavy
}
if {$requested_ft_body eq ""} {
set ft_body light
}
}
default {
if {$requested_ft_header eq ""} {
set ft_header $requested_ft
}
if {$requested_ft_body eq ""} {
set ft_body $requested_ft
}
}
}
return [dict create header $ft_header body $ft_body]
}
method Set_effective_framelimits {} {
upvar ::textblock::class::opts_table_defaults tdefaults
set default_blims [dict get $tdefaults -framelimits_body]
set default_hlims [dict get $tdefaults -framelimits_header]
set eff_blims [dict get $o_opts_table_effective -framelimits_body]
set eff_hlims [dict get $o_opts_table_effective -framelimits_header]
set requested_blims [dict get $o_opts_table -framelimits_body]
set requested_hlims [dict get $o_opts_table -framelimits_header]
set blims $eff_blims
set hlims $eff_hlims
switch -- $requested_blims {
"default" {
set blims $default_blims
}
default {
#set blims $requested_blims
set blims [list]
foreach lim $requested_blims {
switch -- $lim {
hl {
lappend blims hlt hlb
}
vl {
lappend blims vll vlr
}
default {
lappend blims $lim
}
}
}
set blims [lsort -unique $blims]
}
}
dict set o_opts_table_effective -framelimits_body $blims
switch -- $requested_hlims {
"default" {
set hlims $default_hlims
}
default {
#set hlims $requested_hlims
set hlims [list]
foreach lim $requested_hlims {
switch -- $lim {
hl {
lappend hlims hlt hlb
}
vl {
lappend hlims vll vlr
}
default {
lappend hlims $lim
}
}
}
set hlims [lsort -unique $hlims]
}
}
dict set o_opts_table_effective -framelimits_header $hlims
return [dict create body $blims header $hlims]
}
method configure args {
if {![llength $args]} {
return $o_opts_table
}
if {[llength $args] == 1} {
if {[lindex $args 0] in [dict keys $o_opts_table_defaults]} {
#query single option
set k [lindex $args 0]
set val [dict get $o_opts_table $k]
set returndict [dict create option $k value $val ansireset "\x1b\[m"]
set infodict [dict create]
switch -- $k {
-ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder_body - -ansiborder_footer {
dict set infodict debug [ansistring VIEW $val]
}
-framemap_body - -framemap_header - -framelimits_body - -framelimits_header {
dict set returndict effective [dict get $o_opts_table_effective $k]
}
}
dict set returndict info $infodict
return $returndict
#return [dict create option $k value $val ansireset "\x1b\[m" info $infodict]
} else {
error "textblock::table configure - unrecognised option '[lindex $args 0]'. Known values [dict keys $o_opts_table_defaults]"
}
}
if {[llength $args] %2 != 0} {
error "[namespace current]::table configure - unexpected argument count. Require name value pairs"
}
dict for {k v} $args {
if {$k ni [dict keys $o_opts_table_defaults]} {
error "[namespace current]::table configure - unrecognised option '$k'. Known values [dict keys $o_opts_table_defaults]"
}
}
set checked_opts [list]
dict for {k v} $args {
switch -- $k {
-ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder-body - -ansiborder_footer {
set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]"
set ansi_codes [list] ;
foreach {pt code} $parts {
if {$pt ne ""} {
#we don't expect plaintext in an ansibase
error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]"
}
if {$code ne ""} {
lappend ansi_codes $code
}
}
set ansival [punk::ansi::codetype::sgr_merge_singles $ansi_codes]
lappend checked_opts $k $ansival
}
-frametype - -frametype_header - -frametype_body {
#frametype will raise an error if v is not a valid custom dict or one of the known predefined types such as light,heavy,double etc
lassign [textblock::frametype $v] _cat category _type ftype
lappend checked_opts $k $v
}
-framemap_body - -framemap_header {
#upvar ::textblock::class::opts_table_defaults tdefaults
#set default_bmap [dict get $tdefaults -framemap_body]
#todo - check keys and map
if {[llength $v] == 1} {
if {$v eq "default"} {
upvar ::textblock::class::opts_table_defaults tdefaults
set default_map [dict get $tdefaults $k]
lappend checked_opts $k $default_map
} else {
error "textblock::table::configure invalid $k value $v. Expected the value 'default' or a dict e.g topleft {hl *}"
}
} else {
dict for {subk subv} $v {
switch -- $subk {
topleft - topinner - topright - topsolo - middleleft - middleinner - middleright - middlesolo - bottomleft - bottominner - bottomright - bottomsolo - onlyleft - onlyinner - onlyright - onlysolo {}
default {
error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}"
}
}
dict for {seg subst} $subv {
switch -- $seg {
hl - hlt - hlb - vl - vll - vlr - trc - tlc - blc - brc {}
default {
error "textblock::table::configure invalid $subk value $seg. Known values {hl hlt hlb vl vll vlr trc tlc blc brc}"
}
}
}
}
lappend checked_opts $k $v
}
}
-framelimits_body - -framelimits_header {
set specific_framelimits [list]
foreach fl $v {
switch -- $fl {
"default" {
lappend specific_framelimits trc hlt tlc vll blc hlb brc vlr
}
hl {
lappend specific_framelimits hlt hlb
}
vl {
lappend specific_framelimits vll vlr
}
hlt - hlb - vll - vlr - trc - tlc - blc - brc {
lappend specific_framelimits $fl
}
default {
error "textblock::table::configure invalid $k '$fl'. Known values {hl hlb hlt vl vll vlr trc tlc blc brc} (or default for all)"
}
}
}
lappend checked_opts $k $specific_framelimits
}
-ansireset {
if {$v eq "\uFFEF"} {
set RST "\x1b\[m" ;#[a]
lappend checked_opts $k $RST
} else {
error "textblock::table::configure -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands"
}
}
-show_hseps {
if {![string is boolean $v]} {
error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string"
}
lappend checked_opts $k $v
#these don't affect column width calculations
}
-show_edge {
if {![string is boolean $v]} {
error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string"
}
lappend checked_opts $k $v
#these don't affect column width calculations - except if table -minwidth/-maxwidth come into play
set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed
}
-show_vseps {
#we allow empty string - so don't use -strict boolean check
if {![string is boolean $v]} {
error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string"
}
#affects width calculations
set o_calculated_column_widths [list]
lappend checked_opts $k $v
}
-minwidth - -maxwidth {
set o_calculated_column_widths [list]
lappend checked_opts $k $v
}
default {
lappend checked_opts $k $v
}
}
}
#all options checked - ok to update o_opts_table and o_opts_table_effective
#set o_opts_table [dict merge $o_opts_table $checked_opts]
dict for {k v} $args {
switch -- $k {
-framemap_header - -framemap_body {
#framemaps don't require setting every key to update.
#e.g configure -framemaps {topleft <map>}
#needs to merge with existing unspecified keys such as topright middleleft etc.
if {$v eq "default"} {
dict set o_opts_table $k default
} else {
if {[dict get $o_opts_table $k] eq "default"} {
dict set o_opts_table $k $v
} else {
dict set o_opts_table $k [dict merge [dict get $o_opts_table $k] $v]
}
}
}
default {
dict set o_opts_table $k $v
}
}
}
#use values from checked_opts for the effective opts
dict for {k v} $checked_opts {
switch -- $k {
-framemap_body - -framemap_header {
set existing [dict get $o_opts_table_effective $k]
set updated $existing
dict for {subk subv} $v {
dict set updated $subk $subv
}
dict set o_opts_table_effective $k $updated
}
-framelimits_body - -framelimits_header {
#my Set_effective_framelimits
dict set o_opts_table_effective $k $v
}
default {
dict set o_opts_table_effective $k $v
}
}
}
#ansireset exception
dict set o_opts_table -ansireset [dict get $o_opts_table_effective -ansireset]
return $o_opts_table
}
#integrate with struct::matrix - allows ::m format 2string $table
method printmatrix {matrix} {
set matrix_rowcount [$matrix rows]
set matrix_colcount [$matrix columns]
set table_colcount [my column_count]
if {$table_colcount == 0} {
for {set c 0} {$c < $matrix_colcount} {incr c} {
my add_column -headers ""
}
}
set table_colcount [my column_count]
if {$table_colcount != $matrix_colcount} {
error "textblock::table::printmatrix column count of table doesn't match column count of matrix"
}
if {[my row_count] > 0} {
my row_clear
}
for {set r 0} {$r < $matrix_rowcount} {incr r} {
my add_row [$matrix get row $r]
}
my print
}
method as_matrix {{cmd ""}} {
if {$cmd eq ""} {
set m [struct::matrix]
} else {
set m [struct::matrix $cmd]
}
$m add columns [dict size $o_columndata]
$m add rows [dict size $o_rowdefs]
dict for {k v} $o_columndata {
$m set column $k $v
}
return $m
}
method add_column {args} {
#*** !doctools
#[call class::table [method add_column] [arg args]]
set defaults [dict create\
-headers [list]\
-header_colspans [list]\
-footers [list]\
-defaultvalue ""\
-ansibase ""\
-ansireset "\uFFEF"\
-minwidth ""\
-maxwidth ""\
-blockalign centre\
-textalign left\
]
#initialise -ansireset with replacement char so we can keep in appropriate dict position for initial configure and then treat as read-only
set o_opts_column_defaults $defaults
if {[llength $args] %2 != 0} {
error "[namespace current]::table::add_column unexpected argument count. Require name value pairs. Known options: [dict keys $defaults]"
}
dict for {k v} $args {
if {$k ni [dict keys $defaults]} {
error "[namespace current]::table::add_column unknown option '$k'. Known options: [dict keys $defaults]"
}
}
set opts [dict merge $defaults $args]
set colcount [dict size $o_columndefs]
dict set o_columndata $colcount [list]
dict set o_columndefs $colcount $defaults ;#ensure record exists
dict set o_columnstates $colcount [dict create minwidthbodyseen 0 maxwidthbodyseen 0 maxwidthheaderseen 0]
set prev_calculated_column_widths $o_calculated_column_widths
if {[catch {
my configure_column $colcount {*}$opts
} errMsg]} {
#configure failed - ensure o_columndata and o_columndefs entries are removed
dict unset o_columndata $colcount
dict unset o_columndefs $colcount
dict unset o_columnstates $colcount
#undo cache invalidation
set o_calculated_column_widths $prev_calculated_column_widths
error "add_column failed to configure with supplied options $opts. Err:\n$errMsg"
}
#any add_column that succeeds should invalidate the calculated column widths
set o_calculated_column_widths [list]
set numrows [my row_count]
if {$numrows > 0} {
#fill column with default values
#puts ">>> adding default values for column $colcount"
set dval [dict get $opts -defaultvalue]
set width [textblock::width $dval]
dict set o_columndata $colcount [lrepeat $numrows $dval]
dict set o_columnstates $colcount maxwidthbodyseen $width
dict set o_columnstates $colcount minwidthbodyseen $width
}
return $colcount
}
method column_count {} {
return [dict size $o_columndefs]
}
method configure_column {index_expression args} {
set cidx [lindex [dict keys $o_columndefs] $index_expression]
if {$cidx eq ""} {
error "textblock::table::configure_column - no column defined at index '$cidx'.Use add_column to define columns"
}
if {![llength $args]} {
return [dict get $o_columndefs $cidx]
} else {
if {[llength $args] == 1} {
if {[lindex $args 0] in [dict keys $o_opts_column_defaults]} {
#query single option
set k [lindex $args 0]
set val [dict get $o_columndefs $cidx $k]
set returndict [dict create option $k value $val ansireset "\x1b\[m"]
set infodict [dict create]
switch -- $k {
-ansibase {
dict set infodict debug [ansistring VIEW $val]
}
}
dict set returndict info $infodict
return $returndict
} else {
error "textblock::table configure_column - unrecognised option '[lindex $args 0]'. Known values [dict keys $o_opts_column_defaults]"
}
}
if {[llength $args] %2 != 0} {
error "textblock::table configure_column unexpected argument count. Require name value pairs. Known options: [dict keys $o_opts_column_defaults]"
}
dict for {k v} $args {
if {$k ni [dict keys $o_opts_column_defaults]} {
error "[namespace current]::table configure_column unknown option '$k'. Known options: [dict keys $o_opts_column_defaults]"
}
}
set checked_opts [list]
set hstates $o_headerstates ;#operate on a copy
set colstate [dict get $o_columnstates $cidx]
dict for {k v} $args {
switch -- $k {
-headers {
set i 0
set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely.
foreach hdr $v {
set currentmax [my header_height_calc $i $cidx] ;#exclude current column - ie look at heights for this header in all other columns
#set this_header_height [textblock::height $hdr]
lassign [textblock::size $hdr] _w this_header_width _h this_header_height
if {$this_header_height >= $currentmax} {
dict set hstates $i maxheightseen $this_header_height
} else {
dict set hstates $i maxheightseen $currentmax
}
if {$this_header_width >= $maxseen} {
set maxseen $this_header_width
}
#if {$this_header_width > [dict get $colstate maxwidthheaderseen]} {
# dict set colstate maxwidthheaderseen $this_header_width
#}
incr i
}
dict set colstate maxwidthheaderseen $maxseen
#review - we could avoid some recalcs if we check current width range compared to previous
set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed
lappend checked_opts $k $v
}
-header_colspans {
#check columns to left to make sure each new colspan for this column makes sense in the overall context
#user may have to adjust colspans in order left to right to avoid these check errors
#note that 'all' represents span all up to the next non-zero defined colspan.
set cspans [my header_colspans]
set h 0
if {[llength $v] > [dict size $cspans]} {
error "configure_column $cidx -header_colspans. Only [dict size $cspans] headers exist. Too many values supplied"
}
foreach s $v {
if {$cidx == 0} {
if {[string is integer -strict $s]} {
if {$s < 1} {
error "configure_column $cidx -header_colspans bad first value '$s' for header '$h' . First column cannot have span less than 1. use 'all' or a positive integer"
}
} else {
if {$s ne "all" && $s ne ""} {
error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'all'"
}
}
} else {
#if {![string is integer -strict $s]} {
# if {$s ne "all" && $s ne ""} {
# error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'all'"
# }
#} else {
set header_spans [dict get $cspans $h]
set remaining [lindex $header_spans 0]
if {$remaining ne "all"} {
incr remaining -1
}
#look at spans defined for previous cols
#we are presuming previous column entries are valid - and only validating if our new entry is ok under that assumption
for {set c 0} {$c < $cidx} {incr c} {
set span [lindex $header_spans $c]
if {$span eq "all"} {
set remaining "all"
} else {
if {$remaining eq "all"} {
if {$span ne "0"} {
#a previous column has ended the 'all' span
set remaining [expr {$span -1}]
}
} else {
if {$span eq "0"} {
incr remaining -1
} else {
set remaining [expr {$span -1}]
}
#allow to go negative
}
}
}
if {$remaining eq "all"} {
#any int >0 ok - what about 'all' immediately following all?
} else {
if {$remaining > 0} {
if {$s ne "0" && $s ne ""} {
error "configure_column $cidx -header_colspans bad span $s for header '$h'. Remaining span is '$remaining' - so a zero colspan is required"
}
} else {
if {$s == 0} {
error "configure_column $cidx -header_colspans bad span $s for header '$h'. No span in place - need >=1 or 'all'"
}
}
}
#}
}
incr h
}
#todo - avoid recalc if no change
set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed
lappend checked_opts $k $v
}
-minwidth {
set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed
lappend checked_opts $k $v
}
-maxwidth {
set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed
lappend checked_opts $k $v
}
-ansibase {
set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]"
set col_ansibase_items [list] ;
foreach {pt code} $parts {
if {$pt ne ""} {
#we don't expect plaintext in an ansibase
error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]"
}
if {$code ne ""} {
lappend col_ansibase_items $code
}
}
set col_ansibase [punk::ansi::codetype::sgr_merge_singles $col_ansibase_items]
lappend checked_opts $k $col_ansibase
}
-ansireset {
if {$v eq "\uFFEF"} {
lappend checked_opts $k "\x1b\[m" ;# [a]
} else {
error "textblock::table::configure_column -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands"
}
}
-blockalign - -textalign {
switch -- $v {
left - right {
lappend checked_opts $k $v
}
centre - centre {
lappend checked_opts $k centre
}
}
}
default {
lappend checked_opts $k $v
}
}
}
#args checked - ok to update headerstates and columndefs and columnstates
set o_headerstates $hstates
dict set o_columnstates $cidx $colstate
set current_opts [dict get $o_columndefs $cidx]
set opts [dict merge $current_opts $checked_opts]
dict set o_columndefs $cidx $opts
if {"-headers" in [dict keys $args]} {
#if the headerlist length for this column has shrunk,and it was the longest - we may now have excess entries in o_headerstates
set zero_heights [list]
dict for {hidx _v} $o_headerstates {
#pass empty string for exclude_column so we don't exclude our own column
if {[my header_height_calc $hidx ""] == 0} {
lappend zero_heights $hidx
}
}
foreach zidx $zero_heights {
dict unset o_headerstates $zidx
}
}
if {"-headers" in [dict keys $args] || "-header_colspans" in [dict keys $args]} {
#check and adjust header_colspans for all columns
}
return [dict get $o_columndefs $cidx]
}
}
method header_count {} {
return [dict size $o_headerstates]
}
method header_count_calc {} {
set max_headers 0
dict for {k cdef} $o_columndefs {
set num_headers [llength [dict get $cdef -headers]]
set max_headers [expr {max($max_headers,$num_headers)}]
}
return $max_headers
}
method header_height {header_index} {
set idx [lindex [dict keys $o_headerstates $header_index]]
return [dict get $o_headerstates $idx maxheightseen]
}
#review - use maxwidth (considering colspans) of each column to determine height after wrapping
# -need to consider whether vertical expansion allowed / maxheight?
method header_height_calc {header_index {exclude_column ""}} {
set dataheight 0
if {$exclude_column eq ""} {
set exclude_colidx ""
} else {
set exclude_colidx [lindex [dict keys $o_columndefs] $exclude_column]
}
dict for {cidx cdef} $o_columndefs {
if {$exclude_colidx == $cidx} {
continue
}
set headerlist [dict get $cdef -headers]
if {$header_index < [llength $headerlist]} {
set this_height [textblock::height [lindex $headerlist $header_index]]
set dataheight [expr {max($dataheight,$this_height)}]
}
}
return $dataheight
}
#return a dict keyed on header index with values representing colspans
#e.g
# 0 {all 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1}
#
method header_colspans {} {
set num_headers [my header_count_calc]
set colspans_by_header [dict create]
dict for {cidx cdef} $o_columndefs {
set headerlist [dict get $cdef -headers]
set colspans_for_column [dict get $cdef -header_colspans]
for {set h 0} {$h < $num_headers} {incr h} {
set headerspans [punk::lib::dict_getdef $colspans_by_header $h [list]]
set defined_span [lindex $colspans_for_column $h]
set i 0
set spanremaining [lindex $headerspans 0]
if {$spanremaining ne "all"} {
if {$spanremaining eq ""} {
set spanremaining 1
}
incr spanremaining -1
}
foreach s $headerspans {
if {$s eq "all"} {
set spanremaining "all"
} elseif {$s == 0} {
if {$spanremaining ne "all"} {
incr spanremaining -1
}
} else {
set spanremaining [expr {$s - 1}]
}
incr i
}
if {$defined_span eq ""} {
if {$spanremaining eq "0"} {
lappend headerspans 1
} else {
#"all" or an integer
lappend headerspans 0
}
} else {
lappend headerspans $defined_span
}
dict set colspans_by_header $h $headerspans
}
}
return $colspans_by_header
}
#should be configure_headerrow ?
method configure_header {index_expression args} {
#the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs.
#It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis
#e.g o_headerstates: 0 {maxheightseen 1} 1 {maxheightseen 2}
set num_headers [my header_count_calc]
set hidx [lindex [dict keys $o_headerstates] $index_expression]
if {$hidx eq ""} {
error "textblock::table::configure_header - no row defined at index '$hidx'."
}
if {$hidx > $num_headers -1} {
#assert - shouldn't happen
error "textblock::table::configure_header error headerstates data is out of sync"
}
if {![llength $args]} {
set colspans_by_header [my header_colspans]
set result [dict create]
dict set result -colspans [dict get $colspans_by_header $hidx]
set header_row_items [list]
dict for {cidx cdef} $o_columndefs {
set colheaders [dict get $cdef -headers]
set relevant_header [lindex $colheaders $hidx]
#The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns
lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate.
}
dict set result -values $header_row_items
return $result
}
if {[llength $args] == 1} {
if {[lindex $args 0] in [dict keys $o_opts_header_defaults]} {
#query single option
set k [lindex $args 0]
#set val [dict get $o_rowdefs $ridx $k]
set infodict [dict create]
switch -- $k {
-values {
set header_row_items [list]
dict for {cidx cdef} $o_columndefs {
set colheaders [dict get $cdef -headers]
set relevant_header [lindex $colheaders $hidx]
#The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns
lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate.
}
set val $header_row_items
set returndict [dict create option $k value $val ansireset "\x1b\[m"]
}
-colspans {
set colspans_by_header [my header_colspans]
set result [dict create]
set val [dict get $colspans_by_header $hidx]
set returndict [dict create option $k value $val ansireset "\x1b\[m"]
}
-ansibase {
set val ???
set returndict [dict create option $k value $val ansireset "\x1b\[m"]
dict set infodict debug [ansistring VIEW $val]
}
}
dict set returndict info $infodict
return $returndict
#return [dict create option $k value $val ansireset "\x1b\[m" info $infodict]
} else {
error "textblock::table configure_header - unrecognised option '[lindex $args 0]'. Known values [dict keys $o_opts_header_defaults]"
}
}
if {[llength $args] %2 != 0} {
error "textblock::table configure_header incorrect number of options following index_expression. Require name value pairs. Known options: [dict keys $o_opts_header_defaults]"
}
dict for {k v} $args {
if {$k ni [dict keys $o_opts_header_defaults]} {
error "[namespace current]::table configure_row unknown option '$k'. Known options: [dict keys $o_opts_header_defaults]"
}
}
set checked_opts [list]
dict for {k v} $args {
switch -- $k {
-ansibase {
set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]"
set header_ansibase_items [list] ;
foreach {pt code} $parts {
if {$pt ne ""} {
#we don't expect plaintext in an ansibase
error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]"
}
if {$code ne ""} {
lappend header_ansibase_items $code
}
}
set header_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items]
error "sorry - -ansibase not yet implemented for header rows"
lappend checked_opts $k $header_ansibase
}
-ansireset {
if {$v eq "\uFFEF"} {
lappend checked_opts $k "\x1b\[m" ;# [a]
} else {
error "textblock::table::configure_header -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands"
}
}
-values {
if {[llength $v] > [dict size $o_columndefs]} {
error "textblock::table::configure_header -values length ([llength $v]) is longer than number of columns ([dict size $o_columndefs])"
}
lappend checked_opts $k $v
}
-colspans {
if {[llength $v] > [dict size $o_columndefs]} {
error "textblock::table::configure_header -colspans length ([llength $v]) is longer than number of columns ([dict size $o_columndefs])"
}
if {[llength $v] < [dict size $o_columndefs]} {
puts stderr "textblock::table::configure_header warning - only [llength $v] spans specified for [dict size $o_columndefs] columns."
puts stderr "It is recommended to set all spans explicitly. (auto-calc not implemented)"
}
if {[llength $v]} {
set firstspan [lindex $v 0]
set first_is_ok 0
if {$firstspan eq "all"} {
set first_is_ok 1
} elseif {[string is integer -strict $firstspan] && $firstspan > 0} {
set first_is_ok 1
}
if {!$first_is_ok} {
error "textblock::table::configure_header -colspans first value '$firstspan' must be integer > 0 or the string \"all\""
}
#we don't mind if there are less colspans specified than columns.. the tail can be deduced from the leading ones specified (review)
set remaining $firstspan
if {$remaining ne "all"} {
incr remaining -1
}
foreach span [lrange $v 1 end] {
if {$remaining eq "all"} {
if {$span eq "all"} {
set remaining "all"
} elseif {$span > 0} {
#ok to reset to higher val immediately or after an all and any number of following zeros
set remaining $span
incr remaining -1
} else {
#zero following an all - leave remaining as all
incr remaining -1
}
} else {
if {$span eq "0"} {
if {$remaining eq "0"} {
error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining - positive or \"all\" value span required"
} else {
incr remaining -1
}
} else {
if {$remaining eq "0"} {
#ok for new span value of all or > 0
set remaining $span
if {$remaining ne "all"} {
incr remaining -1
}
} else {
error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining - zero value span required"
}
}
}
}
}
#empty -colspans list should be ok
#error "sorry - -colspans not yet implemented for header rows - set manually in vertical order via configure_column for now"
lappend checked_opts $k $v
}
default {
lappend checked_opts $k $v
}
}
}
#configured opts all good
dict for {k v} $checked_opts {
switch -- $k {
-values {
set c 0
foreach hval $v {
#retrieve -headers from relevant col, insert at header index, and write back.
set colheaders [dict get $o_columndefs $c -headers]
set missing [expr {($hidx +1) - [llength $colheaders]}]
if {$missing > 0} {
lappend colheaders {*}[lrepeat $missing ""]
}
lset colheaders $hidx $hval
dict set o_columndefs $c -headers $colheaders
#invalidate column width cache
set o_calculated_column_widths [list]
# -- -- -- -- -- --
#also update maxwidthseen & maxheightseen
set i 0
set maxwidthseen 0
set maxheightseen 0
foreach hdr $colheaders {
lassign [textblock::size $hdr] _w this_header_width _h this_header_height
if {$this_header_height >= $maxheightseen} {
dict set o_headerstates $i maxheightseen $this_header_height
} else {
dict set o_headerstates $i maxheightseen $maxheightseen
}
if {$this_header_width >= $maxwidthseen} {
set maxwidthseen $this_header_width
}
incr i
}
dict set o_columnstates $c maxwidthheaderseen $maxwidthseen
# -- -- -- -- -- --
incr c
}
}
-colspans {
#sequence has been verified above - we need to split it and store across columns
set c 0 ;#column index
foreach span $v {
set colspans [dict get $o_columndefs $c -header_colspans]
if {$hidx > [llength $colspans]-1} {
set colspans_by_header [my header_colspans]
#puts ">>>>>?$colspans_by_header"
#we are allowed to lset only one beyond the current length to append
#but there may be even less or no entries present in a column
# - the ability to underspecify and calculate the missing values makes setting the values complicated.
#use the header_colspans calculation to update only those entries necessary
set spanlist [list]
for {set h 0} {$h < $hidx} {incr h} {
set cspans [dict get $colspans_by_header $h]
set requiredval [lindex $cspans $c]
lappend spanlist $requiredval
}
dict set o_columndefs $c -header_colspans $spanlist
set colspans [dict get $o_columndefs $c -header_colspans]
}
lset colspans $hidx $span
dict set o_columndefs $c -header_colspans $colspans
incr c
}
}
}
}
}
method add_row {valuelist args} {
#*** !doctools
#[call class::table [method add_row] [arg args]]
if {[dict size $o_columndefs] > 0 && ([llength $valuelist] && [llength $valuelist] != [dict size $o_columndefs])} {
set msg ""
append msg "add_row - invalid number ([llength $valuelist]) of values in row - Must match existing column count: [dict size $o_columndefs]" \n
append msg "rowdata: $valuelist"
error $msg
}
if {[dict size $o_columndefs] == 0 && ![llength $valuelist]} {
error "add_row - no values supplied, and no columns defined, so cannot use default column values"
}
set defaults [dict create\
-minheight 1\
-maxheight ""\
-ansibase ""\
-ansireset "\uFFEF"\
]
set o_opts_row_defaults $defaults
if {[llength $args] %2 !=0} {
error "[namespace current]::table::add_row unexpected argument count. Require name value pairs. Known options: [dict keys $defaults]"
}
dict for {k v} $args {
switch -- $k {
-minheight - -maxheight - -ansibase - -ansireset {}
default {
error "Invalid option '$k' Known options: [dict keys $defaults] (-ansireset is read-only)"
}
}
}
set opts [dict merge $defaults $args]
set auto_columns 0
if {[dict size $o_columndefs] == 0} {
set auto_columns 1
#no columns defined - auto define with defaults for each column in first supplied row
#auto define columns only valid if no existing columns
#the autocolumns must be added before configure_row - but if configure_row fails - we need to remove them!
foreach el $valuelist {
my add_column
}
} else {
if {![llength $valuelist]} {
dict for {k coldef} $o_columndefs {
lappend valuelist [dict get $coldef -defaultvalue]
}
}
}
set rowcount [dict size $o_rowdefs]
dict set o_rowdefs $rowcount $defaults ;# ensure record exists before configure
if {[catch {
my configure_row $rowcount {*}$opts
} errMsg]} {
#undo anything we saved before configure_row
dict unset o_rowdefs $rowcount
#remove auto_columns
if {$auto_columns} {
set o_columndata [dict create]
set o_columndefs [dict create]
set o_columnstate [dict create]
}
error "add_row failed to configure with supplied options $opts. Err:\n$errMsg"
}
set c 0
set max_height_seen 1
foreach v $valuelist {
set prev_maxwidth [dict get $o_columnstates $c maxwidthbodyseen]
set prev_minwidth [dict get $o_columnstates $c minwidthbodyseen]
dict lappend o_columndata $c $v
set valheight [textblock::height $v]
if {$valheight > $max_height_seen} {
set max_height_seen $valheight
}
set width [textblock::width $v]
if {$width > [dict get $o_columnstates $c maxwidthbodyseen]} {
dict set o_columnstates $c maxwidthbodyseen $width
}
if {$width < [dict get $o_columnstates $c minwidthbodyseen]} {
dict set o_columnstates $c minwidthbodyseen $width
}
if {[dict get $o_columnstates $c maxwidthbodyseen] > $prev_maxwidth || [dict get $o_columnstates $c minwidthbodyseen] < $prev_minwidth} {
#invalidate calculated column width cache if any new value was outside the previous range of widths
set o_calculated_column_widths [list]
}
incr c
}
set opt_maxh [dict get $o_rowdefs $rowcount -maxheight]
if {$opt_maxh ne ""} {
dict set o_rowstates $rowcount -maxheight [expr {min($opt_maxh,$max_height_seen)}]
} else {
dict set o_rowstates $rowcount -maxheight $max_height_seen
}
return $rowcount
}
method configure_row {index_expression args} {
set ridx [lindex [dict keys $o_rowdefs] $index_expression]
if {$ridx eq ""} {
error "textblock::table::configure_row - no row defined at index '$ridx'.Use add_row to define rows"
}
if {![llength $args]} {
return [dict get $o_rowdefs $ridx]
}
if {[llength $args] == 1} {
if {[lindex $args 0] in [dict keys $o_opts_row_defaults]} {
#query single option
set k [lindex $args 0]
set val [dict get $o_rowdefs $ridx $k]
set returndict [dict create option $k value $val ansireset "\x1b\[m"]
set infodict [dict create]
switch -- $k {
-ansibase {
dict set infodict debug [ansistring VIEW $val]
}
}
dict set returndict info $infodict
return $returndict
#return [dict create option $k value $val ansireset "\x1b\[m" info $infodict]
} else {
error "textblock::table configure_row - unrecognised option '[lindex $args 0]'. Known values [dict keys $o_opts_row_defaults]"
}
}
if {[llength $args] %2 != 0} {
error "textblock::table configure_row incorrect number of options following index_expression. Require name value pairs. Known options: [dict keys $o_opts_row_defaults]"
}
dict for {k v} $args {
if {$k ni [dict keys $o_opts_row_defaults]} {
error "[namespace current]::table configure_row unknown option '$k'. Known options: [dict keys $o_opts_row_defaults]"
}
}
set checked_opts [list]
dict for {k v} $args {
switch -- $k {
-ansibase {
set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]"
set row_ansibase_items [list] ;
foreach {pt code} $parts {
if {$pt ne ""} {
#we don't expect plaintext in an ansibase
error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]"
}
if {$code ne ""} {
lappend row_ansibase_items $code
}
}
set row_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items]
lappend checked_opts $k $row_ansibase
}
-ansireset {
if {$v eq "\uFFEF"} {
lappend checked_opts $k "\x1b\[m" ;# [a]
} else {
error "textblock::table::configure_row -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands"
}
}
default {
lappend checked_opts $k $v
}
}
}
set current_opts [dict get $o_rowdefs $ridx]
set opts [dict merge $current_opts $checked_opts]
#check minheight and maxheight together
set opt_minh [dict get $opts -minheight]
set opt_maxh [dict get $opts -maxheight]
if {![string is integer $opt_minh] || ($opt_maxh ne "" && ![string is integer -strict $opt_maxh])} {
error "[namespace current]::table::add_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1"
}
if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} {
error "[namespace current]::table::add_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater"
}
if {$opt_maxh ne "" && $opt_maxh < $opt_minh} {
error "[namespace current]::table::add_row error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'"
}
dict set o_rowstates $ridx -minheight $opt_minh
dict set o_rowdefs $ridx $opts
}
method row_count {} {
return [dict size $o_rowdefs]
}
method row_clear {} {
set o_rowdefs [dict create]
set o_rowstates [dict create]
#The data values are stored by column regardless of whether added row by row
dict for {cidx records} $o_columndata {
dict set o_columndata $cidx [list]
#reset only the body fields in o_columnstates
dict set o_columnstates $cidx minwidthbodyseen 0
dict set o_columnstates $cidx maxwidthbodyseen 0
}
set o_calculated_column_widths [list]
}
method clear {} {
my row_clear
set o_columndefs [dict create]
set o_columndata [dict create]
set o_columnstates [dict create]
}
#method Get_columns_by_name {namematch_list} {
#}
#specify range with x..y
method Get_columns_by_indices {index_list} {
foreach spec $index_list {
if {[string is integer -strict $c]} {
set colidx $c
} else {
dict for {colidx coldef} $o_columndefs {
#if {[string match x x]} {}
}
}
}
}
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 {
#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}
}
}
return [dict create boxlimits $boxlimits_position boxlimits_top $boxlimits_toprow joins $joins bodyjoins $header_body_joins ]
}
method get_column_by_index {index_expression args} {
#puts "+++> get_column_by_index $index_expression $args [namespace current]"
#index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts.
set defaults [dict create\
-position "inner"\
-return "string"\
]
dict for {k v} $args {
switch -- $k {
-position - -return {}
default {
error "[namespace current]::table::get_column_by_index error invalid option '$k'. Known options [dict keys $defaults]"
}
}
}
set opts [dict merge $defaults $args]
set opt_posn [dict get $opts -position]
set opt_return [dict get $opts -return]
set valid_positions [list left inner right solo]
switch -- $opt_posn {
left - inner - right - solo {}
default {
error "[namespace current]::table::get_column_by_index error invalid value '$opt_posn' for -position. Valid values: $valid_positions"
}
}
switch -- $opt_return {
string - dict {}
default {
error "[namespace current]::table::get_column_by_index error invalid value '$opt_return' for -return. Valid values: string dict"
}
}
set columninfo [my get_column_cells_by_index $index_expression]
set header_list [dict get $columninfo headers]
#puts "===== header_list: $header_list"
set cells [dict get $columninfo cells]
set topt_show_header [dict get $o_opts_table -show_header]
if {$topt_show_header eq ""} {
set allheaders ""
set all_cols [dict keys $o_columndefs]
foreach c $all_cols {
set headerset [dict get $o_columndefs $c -headers]
foreach hdr $headerset {
append allheaders $hdr
}
}
if {$allheaders eq ""} {
set do_show_header 0
} else {
set do_show_header 1
}
} else {
set do_show_header $topt_show_header
}
set topt_show_footer [dict get $o_opts_table -show_footer]
set output ""
set part_header ""
set part_body ""
set part_footer ""
set boxlimits ""
set joins ""
set header_boxlimits [list]
set header_body_joins [list]
set ftypes [my Get_frametypes]
set ftype_body [dict get $ftypes body]
if {[llength $ftype_body] >= 2} {
set fname_body "custom"
} else {
set fname_body $ftype_body
}
set ftype_header [dict get $ftypes header]
if {[llength $ftype_header] >= 2} {
set fname_header "custom"
} else {
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 [dict get $limj bodyjoins]
set joins [dict get $limj joins]
set boxlimits_position [dict get $limj boxlimits]
set boxlimits_toprow [dict get $limj boxlimits_top]
#use struct::set instead of simple for loop - will be faster at least when critcl available
set boxlimits [struct::set intersect [dict get $o_opts_table_effective -framelimits_body] $boxlimits_position]
set boxlimits_headerless [struct::set intersect [dict get $o_opts_table_effective -framelimits_body] $boxlimits_toprow]
set header_boxlimits [struct::set intersect [dict get $o_opts_table_effective -framelimits_header] $boxlimits_position]
set header_boxlimits_toprow [struct::set intersect [dict get $o_opts_table_effective -framelimits_header] $boxlimits_toprow]
set fmap [dict get $o_opts_table_effective -framemap_body]
set hmap [dict get $o_opts_table_effective -framemap_header]
#if {![dict get $o_opts_table -show_edge]} {
# set body_edgemap [textblock::class::table_edge_map ""]
# dict for {k v} $fmap {
# #dict set fmap $k [dict merge $v [dict get $body_edgemap $k]]
# }
# set header_edgemap [textblock::class::header_edge_map ""]
# dict for {k v} $hmap {
# #dict set hmap $k [dict merge $v [dict get $header_edgemap $k]]
# }
#}
set sep_elements_horizontal $::textblock::class::table_hseps
set sep_elements_vertical $::textblock::class::table_vseps
set topmap [dict get $fmap top$opt_posn]
set botmap [dict get $fmap bottom$opt_posn]
set midmap [dict get $fmap middle$opt_posn]
set onlymap [dict get $fmap only$opt_posn]
set hdrmap [dict get $hmap only${opt_posn}]
set topseps_h [dict get $sep_elements_horizontal top$opt_posn]
set topseps_v [dict get $sep_elements_vertical top$opt_posn]
set midseps_h [dict get $sep_elements_horizontal middle$opt_posn]
set midseps_v [dict get $sep_elements_vertical middle$opt_posn]
set botseps_v [dict get $sep_elements_vertical bottom$opt_posn]
set onlyseps_v [dict get $sep_elements_vertical only$opt_posn]
#top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway
set headerseps_v [dict get $sep_elements_vertical top$opt_posn]
lassign [my Get_seps] _h show_seps_h _v show_seps_v
set return_headerheight 0
set return_headerwidth 0
set cidx [lindex [dict keys $o_columndefs] $index_expression]
set colwidth [my column_width $cidx]
set col_blockalign [dict get $o_columndefs $cidx -blockalign]
if {$do_show_header} {
#puts "boxlimitsinfo header $opt_posn: -- boxlimits $header_boxlimits -- boxmap $hdrmap"
set ansibase_header [dict get $o_opts_table -ansibase_header] ;#merged to single during configure
set ansiborder_header [dict get $o_opts_table -ansiborder_header]
if {[dict get $o_opts_table -frametype_header] eq "block"} {
set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1]
set ansiborder_final $ansibase_header$ansiborder_header$extrabg
} else {
set ansiborder_final $ansibase_header$ansiborder_header
}
set RST [punk::ansi::a]
set hcolwidth $colwidth
#set hcolwidth [my column_width_configured $cidx]
set hcell_line_blank [string repeat " " $hcolwidth]
set all_colspans [my header_colspans]
#default span_extend_map - used as base to customise with specific joins
set fdef_header [textblock::framedef $ftype_header]
set span_extend_map [dict create \
vll " "\
tlc [dict get $fdef_header hlt]\
blc [dict get $fdef_header hlb]\
]
set framedef_leftbox [textblock::framedef $ftype_header -joins left]
#used for colspan-zero header frames
set framesub_map [list hl $TSUB vll $TSUB vlr $TSUB tlc $TSUB blc $TSUB trc $TSUB brc $TSUB] ;# a debug test
set hrow 0
set hmax [expr {[llength $header_list] -1}]
foreach header $header_list {
set headerspans [dict get $all_colspans $hrow]
set this_span [lindex $headerspans $cidx]
set hval $ansibase_header$header ;#no reset
set rowh [my header_height $hrow]
#set h_lines [lrepeat $rowh $hcell_line_blank]
#set hcell_blank [join $h_lines \n]
#set hval_lines [split $hval \n]
#set hval_lines [lrange $hval_lines 0 $rowh-1]
#set hval_block [join $hval_lines \n]
#set headercell [overtype::left -experimental test_mode $ansibase_header$hcell_blank$RST $hval_block]
if {$hrow == 0} {
set hlims $header_boxlimits_toprow
set rowpos "top"
if {$hrow == $hmax} {
set rowpos "only"
}
} else {
set hlims $header_boxlimits
set rowpos "middle"
if {$hrow == $hmax} {
set rowpos "bottom"
}
}
if {!$show_seps_v} {
set hlims [struct::set difference $hlims $headerseps_v]
}
if {$hrow == $hmax} {
set header_joins $header_body_joins
} else {
set header_joins $joins
}
if {![dict get $o_opts_table -show_edge]} {
set hlims [struct::set difference $hlims [dict get $::textblock::class::header_edge_parts $rowpos$opt_posn] ]
}
#puts ">>> headerspans: $headerspans cidx: $cidx"
if {$this_span eq "all" || $this_span > 0} {
set startmap [dict get $hmap $rowpos${opt_posn}]
#look at spans in header below to determine joins required at blc
if {$show_seps_v} {
if {[dict exists $all_colspans [expr {$hrow+1}]]} {
set next_spanlist [dict get $all_colspans [expr {$hrow+1}]]
set spanbelow [lindex $next_spanlist $cidx]
if {$spanbelow == 0} {
#we don't want a down-join for blc - use a framedef with only left joins
dict set startmap blc [dict get $framedef_leftbox blc]
}
} else {
set next_spanlist [list]
}
}
#supporting wrapping in headers might be a step too difficult for little payoff.
#we would need a flag to enable/disable - plus language-based wrapping alg (see tcllib)
#The interaction with colspans and width calculations makes it likely to have a heavy performance impact and make the code even more complex.
#May be better to require user to pre-wrap as needed
##set hval [textblock::renderspace -width $colwidth -wrap 1 "" $hval]
#review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used
#This ellipsis 0 makes a difference (unwanted ellipsis at rhs of header column that starts span)
# -width is always +2 - as the boxlimits take into account show_vseps and show_edge
#set header_cell_startspan [textblock::frame -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [dict get $ftypes header]\
# -ansibase $ansibase_header -ansiborder $ansiborder_final\
# -boxlimits $hlims -boxmap $startmap -joins $header_joins $hval\
# ]
if {$this_span eq "1"} {
#write the actual value now
set cellcontents $hval
} else {
#just write an empty vertical placeholder. The spanned value will be overtyped below
set cellcontents [join [lrepeat [llength [split $hval \n]] ""] \n]
}
set header_cell_startspan [textblock::frame -blockalign $col_blockalign -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [dict get $ftypes header]\
-ansibase $ansibase_header -ansiborder $ansiborder_final\
-boxlimits $hlims -boxmap $startmap -joins $header_joins $cellcontents\
]
if {$this_span ne "1"} {
#puts "===>\n$header_cell_startspan\n<==="
set spanned_parts [list $header_cell_startspan]
#assert this_span == "all" or >1 ie a header that spans other columns
#therefore more parts to append
#set remaining_cols [lrange [dict keys $o_columndefs] $cidx end]
set remaining_spans [lrange $headerspans $cidx+1 end]
#puts ">> remaining_spans: $remaining_spans"
set spancol [expr {$cidx + 1}]
set h_lines [lrepeat $rowh ""]
set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow
set last [expr {[llength $remaining_spans] -1}]
set i 0
foreach s $remaining_spans {
if {$s == 0} {
if {$i == $last} {
set next_posn right
#set next_posn inner
} else {
set next_posn inner
}
set next_headerseps_v [dict get $sep_elements_vertical top$next_posn] ;#static top ok
set limj [my Get_boxlimits_and_joins $next_posn $fname_body]
set span_joins_body [dict get $limj bodyjoins]
set span_joins [dict get $limj joins]
set span_boxlimits [dict get $limj boxlimits]
set span_boxlimits_top [dict get $limj boxlimits_top]
#use struct::set instead of simple for loop - will be faster at least when critcl available
#set span_boxlimits [struct::set intersect [dict get $o_opts_table_effective -framelimits_body] $span_boxlimits]
#set span_boxlimits_top [struct::set intersect [dict get $o_opts_table_effective -framelimits_body] $span_boxlimits_top]
set header_span_boxlimits [struct::set intersect [dict get $o_opts_table_effective -framelimits_header] $span_boxlimits]
set header_span_boxlimits_top [struct::set intersect [dict get $o_opts_table_effective -framelimits_header] $span_boxlimits_top]
if {$hrow == 0} {
set hlims $header_span_boxlimits_top
} else {
set hlims $header_span_boxlimits
}
set this_span_map $span_extend_map
if {!$show_seps_v} {
set hlims [struct::set difference $hlims $next_headerseps_v]
} else {
if {[llength $next_spanlist]} {
set spanbelow [lindex $next_spanlist $spancol]
if {$spanbelow != 0} {
set downbox [textblock::framedef $ftype_header -joins {down}]
dict set this_span_map blc [dict get $downbox hlbj] ;#horizontal line bottom with down join - to same frametype
}
} else {
#join to body
set downbox [textblock::framedef $ftype_header -joins [list down-$fname_body]]
dict set this_span_map blc [dict get $downbox hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype
}
}
if {$hrow == $hmax} {
set header_joins $span_joins_body
} else {
set header_joins $span_joins
}
if {![dict get $o_opts_table -show_edge]} {
set hlims [struct::set difference $hlims [dict get $::textblock::class::header_edge_parts $rowpos$next_posn] ]
}
set contentwidth [my column_width $spancol]
set header_cell [textblock::frame -ellipsis 0 -width [expr {$contentwidth + 2}] -type [dict get $ftypes header]\
-ansibase $ansibase_header -ansiborder $ansiborder_final\
-boxlimits $hlims -boxmap $this_span_map -joins $header_joins $hcell_blank\
]
lappend spanned_parts $header_cell
} else {
break
}
incr spancol
incr i
}
set spanned_frame [textblock::join {*}$spanned_parts]
if {$hrow == 0} {
set hlims $header_boxlimits_toprow
} else {
set hlims $header_boxlimits
}
if {!$show_seps_v} {
set hlims [struct::set difference $hlims $headerseps_v]
}
if {![dict get $o_opts_table -show_edge]} {
#use the edge_parts corresponding to the column being written to ie use opt_posn
set hlims [struct::set difference $hlims [dict get $::textblock::class::header_edge_parts $rowpos$opt_posn] ]
}
set spacemap [list hl " " vl " " tlc " " blc " " trc " " brc " "] ;#transparent overlay elements
#set spacemap [list hl * vl * tlc * blc * trc * brc *]
#-usecache 1 ok
#hval is not raw headerval - it has been padded to required width and has ansi applied
set hblock [textblock::frame -ellipsis 0 -type $spacemap -boxlimits $hlims -ansibase $ansibase_header $hval] ;#review -ansibase
#puts "==>boxlimits:'$hlims' hval_width:[string length $hval] blockwidth:[textblock::width $hblock]"
#puts $hblock
#puts "==>hval:'$hval'[a]"
#puts "==>hval:'[ansistring VIEW $hval]'"
#set spanned_frame [overtype::renderspace -experimental test_mode -transparent 1 $spanned_frame $hblock]
#spanned values default left - todo make configurable
set spanned_frame [overtype::block -blockalign $col_blockalign -overflow 1 -transparent 1 $spanned_frame $hblock]
} else {
#this_span == 1
set spanned_frame [textblock::join $header_cell_startspan]
}
append part_header $spanned_frame
append part_header \n
} else {
#zero span header directly in this column ie one that is being colspanned by some column to our left
#previous col will already have built lines for this in it's own header rhs overhang
#we need a block of TSUB chars of the right height and width in this column so that we can join this column to the left ones with the TSUBs being transparent.
#set padwidth [my column_datawidth $cidx -headers 0 -data 1 -cached 1]
#if there are no header elements above then we will need a minimum of the column width
#may be extended to the widest portion of the header in the loop below
set padwidth [my column_width $cidx]
#under assumption we are building table using L frame method and that horizontal borders are only ever 1 high
# - we can avoid using a frame - but we potentially need to manually adjust for show_hpos show_edge etc
#avoiding frame here is faster.. but not by much (<10%? on textblock::spantest2 )
if 0 {
#breaks -show_edge 0
if {$rowpos eq "top" && [dict get $o_opts_table -show_edge]} {
set padheight [expr {$rowh + 2}]
} else {
set padheight [expr {$rowh + 1}]
}
set bline [string repeat $TSUB [expr {$padwidth +1}]]
set h_lines [lrepeat $padheight $bline]
set hcell_blank [::join $h_lines \n]
set header_frame $hcell_blank
} else {
set bline [string repeat $TSUB $padwidth]
set h_lines [lrepeat $rowh $bline]
set hcell_blank [::join $h_lines \n]
# -usecache 1 ok
#frame borders will never display - so use the simplest frametype and don't apply any ansi
#puts "===>zerospan hlims: $hlims"
set header_frame [textblock::frame -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\
-boxlimits $hlims -boxmap $framesub_map $hcell_blank\
]
}
append part_header $header_frame\n
}
incr hrow
}
if {![llength $header_list]} {
#no headers - but we've been asked to show_header
#display a zero content-height header (ie outline if edge is being shown - or bottom bar)
set hlims $header_boxlimits_toprow
if {!$show_seps_v} {
set hlims [struct::set difference $hlims $headerseps_v]
}
if {![dict get $o_opts_table -show_edge]} {
set hlims [struct::set difference $hlims [dict get $::textblock::class::header_edge_parts only$opt_posn] ]
}
set header_joins $header_body_joins
set header_frame [textblock::frame -width [expr {$hcolwidth+2}] -type [dict get $ftypes header]\
-ansibase $ansibase_header -ansiborder $ansiborder_final\
-boxlimits $hlims -boxmap $hdrmap -joins $header_joins\
]
append part_header $header_frame\n
}
set part_header [string trimright $part_header \n]
lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight
set padline [string repeat $TSUB $return_headerwidth]
set adjusted_lines [list]
foreach ln [split $part_header \n] {
if {[string first $TSUB $ln] >=0} {
lappend adjusted_lines $padline
} else {
lappend adjusted_lines $ln
}
}
set part_header [join $adjusted_lines \n]
append output $part_header \n
}
set r 0
set rmax [expr {[llength $cells]-1}]
set blims_mid $boxlimits
set blims_top $boxlimits
set blims_bot $boxlimits
set blims_top_headerless $boxlimits_headerless
set blims_only $boxlimits
set blims_only_headerless $boxlimits_headerless
if {!$show_seps_h} {
set blims_mid [struct::set difference $blims_mid $midseps_h]
set blims_top [struct::set difference $blims_top $topseps_h]
set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_h]
}
if {!$show_seps_v} {
set blims_mid [struct::set difference $blims_mid $midseps_v]
set blims_top [struct::set difference $blims_top $topseps_v]
set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_v]
set blims_bot [struct::set difference $blims_bot $botseps_v]
set blims_only [struct::set difference $blims_only $onlyseps_v]
set blims_only_headerless [struct::set difference $blims_only_headerless $onlyseps_v]
}
set colidx [lindex [dict keys $o_columndefs] $index_expression] ;#convert possible end-1,2+2 etc expression to >= 0 integer in dict range
set opt_col_ansibase [dict get $o_columndefs $colidx -ansibase] ;#ordinary merge of codes already done in configure_column
#set colwidth [my column_width $colidx]
set body_ansibase [dict get $o_opts_table -ansibase_body]
#set ansibase [punk::ansi::codetype::sgr_merge_singles [list $body_ansibase $opt_col_ansibase]] ;#allow col to override body
set body_ansiborder [dict get $o_opts_table -ansiborder_body]
if {[dict get $o_opts_table -frametype] eq "block"} {
#block is the only style where bg colour can fill the frame content area exactly if the L-shaped border elements are styled
#we need to only accept background ansi codes from the columndef ansibase for this
set col_bg [punk::ansi::codetype::sgr_merge_singles [list $opt_col_ansibase] -filter_fg 1] ;#special merge for block borders - don't override fg colours
set border_ansi $body_ansibase$body_ansiborder$col_bg
} else {
set border_ansi $body_ansibase$body_ansiborder
}
set r 0
set ftblock [expr {[dict get $o_opts_table -frametype] eq "block"}]
foreach c $cells {
set ansibase $body_ansibase$opt_col_ansibase
set row_ansibase [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 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 ?
#todo - review overtype
if {[punk::ansi::ta::detect $c]} {
#use only the last ansi sequence in the cell value
#Filter out foreground and use background for ansiborder override
set parts [punk::ansi::ta::split_codes_single $c]
#we have detected ansi - so there will always be at least 3 parts beginning and ending with pt pt,ansi,pt,ansi...,pt
set codes [list]
foreach {pt cd} $parts {
if {$cd ne ""} {
lappend codes $cd
}
}
#set takebg [lindex $parts end-1]
#set cell_bg [punk::ansi::codetype::sgr_merge_singles [list $takebg] -filter_fg 1]
set cell_bg [punk::ansi::codetype::sgr_merge_singles $codes -filter_fg 1 -filter_reset 1]
#puts --->[ansistring VIEW $codes]
if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end]]} {
if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end-1]]} {
#special case double reset at end of content
set cell_ansi_tail [punk::ansi::codetype::sgr_merge_singles $codes] ;#no filters
set ansibase ""
set row_ansibase ""
if {$ftblock} {
set ansiborder_final [punk::ansi::codetype::sgr_merge [list $ansiborder_body_col_row] -filter_bg 1]
}
set cell_ansibase $cell_ansi_tail
} else {
#single trailing reset in content
set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase
}
} else {
if {$ftblock} {
#no resets - use cell's bg to extend to the border - only for block frames
set ansiborder_final $ansiborder_body_col_row$cell_bg
}
set cell_ansibase $cell_bg
}
}
set ansibase_final $ansibase$row_ansibase$cell_ansibase
if {$r == 0} {
if {$r == $rmax} {
set joins [lremove $joins [lsearch $joins down*]]
set bmap $onlymap
if {$do_show_header} {
set blims $blims_only
} else {
set blims $blims_only_headerless
}
if {![dict get $o_opts_table -show_edge]} {
set blims [struct::set difference $blims [dict get $::textblock::class::table_edge_parts only$opt_posn] ]
}
} else {
set bmap $topmap
if {$do_show_header} {
set blims $blims_top
} else {
set blims $blims_top_headerless
}
if {![dict get $o_opts_table -show_edge]} {
set blims [struct::set difference $blims [dict get $::textblock::class::table_edge_parts top$opt_posn] ]
}
}
set rowframe [textblock::frame -type [dict get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c]
set return_bodywidth [textblock::width $rowframe]
append part_body $rowframe \n
} else {
if {$r == $rmax} {
set joins [lremove $joins [lsearch $joins down*]]
set bmap $botmap
set blims $blims_bot
if {![dict get $o_opts_table -show_edge]} {
set blims [struct::set difference $blims [dict get $::textblock::class::table_edge_parts bottom$opt_posn] ]
}
} else {
set bmap $midmap
set blims $blims_mid ;#will only be reduced from boxlimits if -show_seps was processed above
if {![dict get $o_opts_table -show_edge]} {
set blims [struct::set difference $blims [dict get $::textblock::class::table_edge_parts middle$opt_posn] ]
}
}
append part_body [textblock::frame -type [dict get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c]\n
}
incr r
}
#return empty (zero content height) row if no rows
if {![llength $cells]} {
set joins [lremove $joins [lsearch $joins down*]]
#we need to know the width of the column to setup the empty cell properly
#even if no header displayed - we should take account of any defined column widths
set colwidth [my column_width $index_expression]
if {$do_show_header} {
set blims $blims_only
} else {
append part_body \n
set blims $blims_only_headerless
}
#note that if show_edge is 0 - then for this empty line - we will not expect to see any bars
#This is because the frame with no data had vertical components made entirely of corner elements
#we could just append a newline when -show_edge is zero, but we want the correct width even when empty - for proper column joins when there are colspanned headers.
#
if {![dict get $o_opts_table -show_edge]} {
#set blims [struct::set difference $blims [dict get $::textblock::class::table_edge_parts only$opt_posn] ]
#append output [textblock::frame -width [expr {$colwidth + 2}] -type [dict get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins]\n
append part_body [string repeat " " $colwidth] \n
set return_bodywidth $colwidth
} else {
set emptyframe [textblock::frame -width [expr {$colwidth + 2}] -type [dict get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins]
append part_body $emptyframe \n
set return_bodywidth [textblock::width $emptyframe]
}
}
#assert bodywidth is integer >=0 whether there are rows or not
#trim only 1 newline
if {[string index $part_body end] eq "\n"} {
set part_body [string range $part_body 0 end-1]
}
set return_bodyheight [textblock::height $part_body]
append output $part_body
if {$opt_return eq "string"} {
return $output
} else {
return [dict create column $output headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight]
}
}
method get_column_cells_by_index {index_expression} {
set cidx [lindex [dict keys $o_columndefs] $index_expression]
if {$cidx eq ""} {
set range ""
if {[dict size $o_columndefs] > 0} {
set range "0..[expr {[dict size $o_columndefs] -1}]"
} else {
set range empty
}
error "table::get_column_cells_by_index no such index $index_expression. Valid range is $range"
}
#assert cidx is integer >=0
set cdef [dict get $o_columndefs $cidx]
set headerlist [dict get $cdef -headers]
set num_header_rows [my header_count]
set ansibase_body [dict get $o_opts_table -ansibase_body]
set ansibase_col [dict get $cdef -ansibase]
set textalign [dict get $cdef -textalign]
switch -- $textalign {
left {set pad right}
right {set pad left}
default {
set pad "centre" ;#todo?
}
}
set ansibase_header [dict get $o_opts_table -ansibase_header]
#set header_underlay $ansibase_header$cell_line_blank
#set hdrwidth [my column_width_configured $cidx]
set all_colspans [my header_colspans]
#store configured widths so we don't look up for each header line
set configured_widths [list]
foreach c [dict keys $o_columndefs] {
#lappend configured_widths [my column_width $c]
#we don't just want the width of the column in the body - or the headers will get truncated
lappend configured_widths [my column_width_configured $c]
}
set output [dict create]
dict set output headers [list]
set showing_vseps [my Showing_vseps]
for {set hrow 0} {$hrow < $num_header_rows} {incr hrow} {
set hdr [lindex $headerlist $hrow]
set header_maxdataheight [my header_height $hrow] ;#from cached headerstates
set headerrow_colspans [dict get $all_colspans $hrow]
set this_span [lindex $headerrow_colspans $cidx]
#set this_hdrwidth [lindex $configured_widths $cidx]
set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span] ;#widest of headers in this col with same span - allows textalign to work with blockalign
set hcell_line_blank [string repeat " " $this_hdrwidth]
set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank]
set hval_lines [split $hdr \n]
set hval_lines [concat $hval_lines $hcell_lines]
set hval_lines [lrange $hval_lines 0 $header_maxdataheight-1] ;#vertical align top
set hval_block [::join $hval_lines \n]
set hcell [textblock::pad $hval_block -width $this_hdrwidth -padchar " " -within_ansi 1 -which $pad]
dict lappend output headers $hcell
}
#set colwidth [my column_width $cidx]
#set cell_line_blank [string repeat " " $colwidth]
set datawidth [my column_datawidth $cidx -headers 0 -footers 0 -data 1 -cached 1]
set cell_line_blank [string repeat " " $datawidth]
set items [dict get $o_columndata $cidx]
#puts "---> columndata $o_columndata"
#set opt_row_ansibase [dict get $o_rowdefs $r -ansibase]
#set cell_ansibase $ansibase_body$ansibase_col$opt_row_ansibase
dict set output cells [list];#ensure we return something for cells key if no items in list
set r 0
foreach cval $items {
#todo move to row_height method ?
set maxdataheight [dict get $o_rowstates $r -maxheight]
set rowdefminh [dict get $o_rowdefs $r -minheight]
set rowdefmaxh [dict get $o_rowdefs $r -maxheight]
if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} {
#an exact height is defined for the row
set rowh $rowdefminh
} else {
if {$rowdefminh eq ""} {
if {$rowdefmaxh eq ""} {
#both defs empty
set rowh $maxdataheight
} else {
set rowh [expr {min(1,$rowdefmaxh,$maxdataheight)}]
}
} else {
if {$rowdefmaxh eq ""} {
set rowh [expr {max($rowdefminh,$maxdataheight)}]
} else {
if {$maxdataheight < $rowdefminh} {
set rowh $rowdefminh
} else {
set rowh [expr {max($rowdefminh,$maxdataheight)}]
}
}
}
}
set cell_lines [lrepeat $rowh $cell_line_blank]
#set cell_blank [join $cell_lines \n]
set cval_lines [split $cval \n]
set cval_lines [concat $cval_lines $cell_lines]
set cval_lines [lrange $cval_lines 0 $rowh-1]
set cval_block [::join $cval_lines \n]
set cell [textblock::pad $cval_block -width $datawidth -padchar " " -within_ansi 1 -which $pad]
#set cell [textblock::pad $cval_block -width $colwidth -padchar " " -within_ansi 0 -which left]
dict lappend output cells $cell
incr r
}
return $output
}
method get_column_values_by_index {index_expression} {
set cidx [lindex [dict keys $o_columndefs] $index_expression]
if {$cidx eq ""} {
return
}
return [dict get $o_columndata $cidx]
}
method debug {args} {
#nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor)
set defaults [dict create\
-usetables 1\
]
dict for {k v} $args {
switch -- $k {
-usetables {}
default {
error "table debug unrecognised option '$k'. Known options: [dict keys $defaults]"
}
}
}
set opts [dict merge $defaults $args]
set opt_usetables [dict get $opts -usetables]
puts stdout "rowdefs: $o_rowdefs"
puts stdout "rowstates: $o_rowstates"
#puts stdout "columndefs: $o_columndefs"
puts stdout "columndefs:"
if {!$opt_usetables} {
dict for {k v} $o_columndefs {
puts " $k $v"
}
} else {
set t [textblock::class::table new]
$t add_column -headers "Col"
dict for {col coldef} $o_columndefs {
foreach property [dict keys $coldef] {
if {$property eq "-ansireset"} {
continue
}
$t add_column -headers $property
}
break
}
#build our inner tables first so we can sync widths
set col_header_tables [dict create]
set max_widths [dict create 0 0 1 0 2 0 3 0] ;#max inner table column widths
dict for {col coldef} $o_columndefs {
set row [list $col]
set colheaders [dict get $coldef -headers]
#inner table probably overkill here ..but just as easy
set htable [textblock::class::table new]
$htable configure -show_header 1 -show_edge 0 -show_hseps 0
$htable add_column -headers row
$htable add_column -headers text
$htable add_column -headers WxH
$htable add_column -headers span
set hnum 0
set spans [dict get $o_columndefs $col -header_colspans]
foreach h $colheaders s $spans {
lassign [textblock::size $h] _w width _h height
$htable add_row [list "$hnum " $h "${width}x${height}" $s]
incr hnum
}
$htable configure_column 0 -ansibase [a+ web-dimgray]
dict set col_header_tables $col $htable
set colwidths [$htable column_widths]
set icol 0
foreach w $colwidths {
if {$w > [dict get $max_widths $icol]} {
dict set max_widths $icol $w
}
incr icol
}
}
dict for {col coldef} $o_columndefs {
set row [list $col]
dict for {property val} $coldef {
switch -- $property {
-ansireset {continue}
-headers {
set htable [dict get $col_header_tables $col]
dict for {innercol maxw} $max_widths {
$htable configure_column $innercol -minwidth $maxw -blockalign left
}
lappend row [$htable print]
$htable destroy
}
default {
lappend row $val
}
}
}
$t add_row $row
}
$t configure -show_header 1
puts stdout [$t print]
$t destroy
}
puts stdout "columnstates: $o_columnstates"
puts stdout "headerstates: $o_headerstates"
dict for {k coldef} $o_columndefs {
if {[dict exists $o_columndata $k]} {
set headerlist [dict get $coldef -headers]
set coldata [dict get $o_columndata $k]
set colinfo "rowcount: [llength $coldata]"
set allfields [concat $headerlist $coldata]
if {[llength $allfields]} {
set widest [tcl::mathfunc::max {*}[lmap v $allfields {textblock::width $v}]]
} else {
set widest 0
}
append colinfo " widest of headers and data: $widest"
} else {
set colinfo "WARNING - no columndata record for column key '$k'"
}
puts stdout "column $k columndata info: $colinfo"
}
set result ""
set cols [list]
set max [expr {[dict size $o_columndefs]-1}]
foreach c [dict keys $o_columndefs] {
if {$c == 0} {
lappend cols [my get_column_by_index $c -position left] " "
} elseif {$c == $max} {
lappend cols [my get_column_by_index $c -position right]
} else {
lappend cols [my get_column_by_index $c -position inner] " "
}
}
append result [textblock::join {*}$cols]
return $result
}
#column width including headers - but without colspan consideration
method column_width_configured {index_expression} {
set cidx [lindex [dict keys $o_columndefs] $index_expression]
if {$cidx eq ""} {
return
}
#assert cidx is now >=0 integer within the range of defined columns
set cdef [dict get $o_columndefs $cidx]
set defminw [dict get $cdef -minwidth]
set defmaxw [dict get $cdef -maxwidth]
if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} {
#an exact width is defined for the column - no need to look at data width
set colwidth $defminw
} else {
#set widest [my column_datawidth $cidx -headers 1 -data 1 -footers 1]
set hwidest [dict get $o_columnstates $cidx maxwidthheaderseen]
#set hwidest [my column_datawidth $cidx -headers 1 -colspan 1 -data 0 -footers 1]
#set hwidest_singlespan ??
set bwidest [dict get $o_columnstates $cidx maxwidthbodyseen]
set widest [expr {max($hwidest,$bwidest)}]
#todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration.
#if so - a truncated line shouldn't be included in our width calculation
if {$defminw eq ""} {
if {$defmaxw eq ""} {
set colwidth $widest
} else {
set colwidth [expr {min($defmaxw,$widest)}]
}
} else {
if {$defmaxw eq ""} {
set colwidth [expr {max($defminw,$widest)}]
} else {
if {$widest < $defminw} {
set colwidth $defminw
} else {
if {$widest > $defmaxw} {
set colwidth $defmaxw
} else {
set colwidth [expr {max($defminw,$widest)}]
}
}
}
}
}
return $colwidth
}
method column_width {index_expression} {
if {[llength $o_calculated_column_widths] != [dict size $o_columndefs]} {
my calculate_column_widths -algorithm $o_column_width_algorithm
}
return [lindex $o_calculated_column_widths $index_expression]
}
method column_widths {} {
if {[llength $o_calculated_column_widths] != [dict size $o_columndefs]} {
my calculate_column_widths -algorithm $o_column_width_algorithm
}
return $o_calculated_column_widths
}
#width of a table includes borders and seps
#whereas width of a column refers to the borderless width (inner width)
method width {} {
#calculate width based on assumption frame verticals are 1-wide - review - what about custom unicode double-wide frame?
set colwidths [my column_widths]
set contentwidth [tcl::mathop::+ {*}$colwidths]
set twidth $contentwidth
if {[my Showing_vseps]} {
incr twidth [llength $colwidths]
incr twidth -1
}
if {[dict get $o_opts_table -show_edge]} {
incr twidth 2
}
return $twidth
}
#column *body* content width
method basic_column_width {index_expression} {
set cidx [lindex [dict keys $o_columndefs] $index_expression]
if {$cidx eq ""} {
return
}
#puts "===column_width $index_expression"
#assert cidx is now >=0 integer within the range of defined columns
set cdef [dict get $o_columndefs $cidx]
set defminw [dict get $cdef -minwidth]
set defmaxw [dict get $cdef -maxwidth]
if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} {
#an exact width is defined for the column - no need to look at data width
#review - this can result in truncation of spanning headers - even though there is enough width in the span-cell to place the full header
set colwidth $defminw
} else {
#set widest [my column_datawidth $cidx -headers 0 -data 1 -footers 0]
set widest [dict get $o_columnstates $cidx maxwidthbodyseen]
#todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration.
#if so - a truncated line shouldn't be included in our width calculation
if {$defminw eq ""} {
if {$defmaxw eq ""} {
set colwidth $widest
} else {
set colwidth [expr {min($defmaxw,$widest)}]
}
} else {
if {$defmaxw eq ""} {
set colwidth [expr {max($defminw,$widest)}]
} else {
if {$widest < $defminw} {
set colwidth $defminw
} else {
if {$widest > $defmaxw} {
set colwidth $defmaxw
} else {
set colwidth [expr {max($defminw,$widest)}]
}
}
}
}
}
set configured_widths [list]
foreach c [dict keys $o_columndefs] {
lappend configured_widths [my column_width_configured $c]
}
set header_colspans [my header_colspans]
set width_max $colwidth
set test_width $colwidth
set showing_vseps [my Showing_vseps]
dict for {h colspans} $header_colspans {
set spanc [lindex $colspans $cidx]
#set headers [dict get $cdef -headers]
#set thiscol_widest_header 0
#if {[llength $headers] > 0} {
# set thiscol_widest_header [tcl::mathfunc::max {*}[lmap v $headers {textblock::width $v}]]
#}
set thiscol_widest_header [dict get $o_columnstates $cidx maxwidthheaderseen]
if {$spanc eq "1"} {
if {$thiscol_widest_header > $colwidth} {
set test_width [expr {max($thiscol_widest_header,$colwidth)}]
if {$defmaxw ne ""} {
set test_width [expr {min($colwidth,$defmaxw)}]
}
}
set width_max [expr {max($test_width,$width_max)}]
continue
}
if {$spanc eq "all" || $spanc > 1} {
set spanned [list] ;#spanned is other columns spanned - not including this one
set cnext [expr {$cidx +1}]
set spanlength [lindex $colspans $cnext]
while {$spanlength eq "0" && $cnext < [llength $colspans]} {
lappend spanned $cnext
incr cnext
set spanlength [lindex $colspans $cnext]
}
set others_width 0
foreach col $spanned {
incr others_width [lindex $configured_widths $col]
if {$showing_vseps} {
incr others_width 1
}
}
set total_spanned_width [expr {$width_max + $others_width}]
if {$thiscol_widest_header > $total_spanned_width} {
#this just allocates the extra space in the current column - which is not great.
#A proper algorithm for distributing width created by headers to all the spanned columns is needed.
#This is a tricky problem with multiple header lines and arbitrary spans.
#The calculation should probably be done on the table as a whole first and this function should just look up that result.
#Trying to calculate on a specific column only is unlikely to be easy or efficient.
set needed [expr {$thiscol_widest_header - $total_spanned_width}]
#puts "-->>col $cidx needed ($thiscol_widest_header - $total_spanned_width): $needed (spanned $spanned)"
if {$defmaxw ne ""} {
set test_width [expr {min($colwidth+$needed,$defmaxw)}]
} else {
set test_width [expr {$colwidth + $needed}]
}
}
}
set width_max [expr {max($test_width,$width_max)}]
}
#alternative to all the above shennanigans.. let the body cell data determine the size and just wrap the headers
#could also split the needed width amongst the spanned columns? configurable for whether cells expand?
set expand_first_column 1
if {$expand_first_column} {
set colwidth $width_max
}
#puts "---column_width $cidx = $colwidth"
return $colwidth
}
method Showing_vseps {} {
#review - show_seps and override mechanism for show_vseps show_hseps - document.
set seps [dict get $o_opts_table -show_seps]
set vseps [dict get $o_opts_table -show_vseps]
if {$seps eq ""} {
if {$vseps eq "" || $vseps} {
return true
}
} elseif {$seps} {
if {$vseps eq "" || $vseps} {
return true
}
} else {
if {$vseps ne "" && $vseps} {
return true
}
}
return false
}
method column_datawidth {index_expression args} {
set defaults [dict create\
-headers 0\
-footers 0\
-colspan *\
-data 1\
-cached 1\
]
#-colspan is relevant to header/footer data only
dict for {k v} $args {
switch -- $k {
-headers - -footers - -colspan - -data - -cached {}
default {
error "column_datawidth unrecognised flag '$k'. Known flags: [dict keys $defaults]"
}
}
}
set opts [dict merge $defaults $args]
set opt_colspan [dict get $opts -colspan]
set cidx [lindex [dict keys $o_columndefs] $index_expression]
if {$cidx eq ""} {
return
}
if {[dict get $opts -cached]} {
set hwidest 0
set bwidest 0
set fwidest 0
if {[dict get $opts -headers]} {
if {$opt_colspan eq "*"} {
set hwidest [dict get $o_columnstates $cidx maxwidthheaderseen]
} else {
set colheaders [dict get $o_columndefs $cidx -headers]
set all_colspans_by_header [my header_colspans]
set hlist [list]
dict for {hrow cspans} $all_colspans_by_header {
set s [lindex $cspans $cidx]
#todo - map 'all' entries to a number?
#we should build a version of header_colspans that does this
if {$s eq $opt_colspan} {
lappend hlist [lindex $colheaders $hrow]
}
}
#set widest1 [tcl::mathfunc::max {*}[lmap v $cmds {string length $v}]]
if {[llength $hlist]} {
set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]]
} else {
set hwidest 0
}
}
}
if {[dict get $opts -data]} {
set bwidest [dict get $o_columnstates $cidx maxwidthbodyseen]
}
if {[dict get $opts -footers]} {
#TODO!
#set bwidest [dict get $o_columnstates $cidx maxwidthfooterseen]
}
return [expr {max($hwidest,$bwidest,$fwidest)}]
}
#assert cidx is >=0 integer in valid range of keys for o_columndefs
set values [list]
if {[dict get $opts -headers]} {
lappend values {*}[dict get $o_columndefs $cidx -headers]
}
if {[dict get $opts -data]} {
if {[dict exists $o_columndata $cidx]} {
lappend values {*}[dict get $o_columndata $cidx]
}
}
if {[dict get $opts -footers]} {
lappend values {*}[dict get $o_columndefs $cidx -footers]
}
if {[llength $values]} {
set widest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]]
} else {
set widest 0
}
return $widest
}
#print1 uses basic column joining - useful for testing/debug especially with colspans
method print1 {args} {
if {![llength $args]} {
set cols [dict keys $o_columndata]
} else {
set cols [list]
foreach colspec $args {
set allcols [dict keys $o_columndata]
if {[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 colposn 0
set numposns [llength $cols]
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]
}
lappend blocks [my get_column_by_index $c {*}$flags]
incr colposn
}
if {[llength $blocks]} {
return [textblock::join {*}$blocks]
} else {
return "No columns matched"
}
}
method columncalc_spans {allocmethod} {
set colwidths [dict create] ;# to use dict incr
set colspace_added [dict create]
set ordered_spans [dict create]
dict for {col spandata} [my spangroups] {
set dwidth [my column_datawidth $col -data 1 -headers 0 -footers 0 -cached 1]
set minwidth [dict get $o_columndefs $col -minwidth]
set maxwidth [dict get $o_columndefs $col -maxwidth]
if {$minwidth ne ""} {
if {$dwidth < $minwidth} {
set dwidth $minwidth
}
}
if {$maxwidth ne ""} {
if {$dwidth > $maxwidth} {
set dwidth $maxwidth
}
}
dict set colwidths $col $dwidth ;#spangroups is ordered by column - so colwidths dict will be correctly ordered
dict set colspace_added $col 0
set spanlengths [dict get $spandata spanlengths]
foreach slen $spanlengths {
set spans [dict get $spandata spangroups $slen]
set spans [lsort -index 7 -integer $spans]
foreach s $spans {
set hwidth [dict get $s headerwidth]
set hrow [dict get $s hrow]
set scol [dict get $s startcol]
dict set ordered_spans $scol,$hrow membercols $col $dwidth
dict set ordered_spans $scol,$hrow headerwidth $hwidth
}
}
}
dict for {spanid spandata} $ordered_spans {
lassign [split $spanid ,] startcol hrow
set memcols [dict get $spandata membercols] ;#dict with col and initial width - we ignore initial width, it's there in case we want to allocate space based on initial data width ratios
set colids [dict keys $memcols]
set hwidth [dict get $spandata headerwidth]
set num_cols_spanned [dict size $memcols]
if {$num_cols_spanned == 1} {
set col [lindex $memcols 0]
set space_to_alloc [expr {$hwidth - [dict get $colwidths $col]}]
if {$space_to_alloc > 0} {
dict set colwidths $col $hwidth
dict set colspace_added $col $space_to_alloc
}
} elseif {$num_cols_spanned > 1} {
set spannedwidth 0
foreach col $colids {
incr spannedwidth [dict get $colwidths $col]
}
set space_to_alloc [expr {$hwidth - $spannedwidth}]
if {[my Showing_vseps]} {
set sepcount [expr {$num_cols_spanned -1}]
incr space_to_alloc -$sepcount
}
#review - we want to reduce overallocation to earlier or later columns - hence the use of colspace_added
switch -- $allocmethod {
0 {
#add to least-expanded each time
#safer than method 1 - pretty balanced
if {$space_to_alloc > 0} {
for {set i 0} {$i < $space_to_alloc} {incr i} {
set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added]
set ordered_all_colids [dict keys $ordered_colspace_added]
foreach testcolid $ordered_all_colids {
if {$testcolid in $colids} {
#assert - we will always find a match
set colid $testcolid
break
}
}
dict incr colwidths $colid
dict incr colspace_added $colid
}
}
}
1 {
#adds space to all columns - not just those spanned - risk of underallocating and truncating some headers!
#probably not a good idea for tables with complex headers and spans
while {$space_to_alloc > 0} {
set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added]
set ordered_colids [dict keys $ordered_colspace_added]
foreach col $ordered_colids {
dict incr colwidths $col
dict incr colspace_added $col
incr space_to_alloc -1
if {$space_to_alloc == 0} {
break
}
}
}
}
}
}
}
set column_widths [dict values $colwidths]
#todo - -maxwidth etc
set table_minwidth [dict get $o_opts_table -minwidth] ;#min width including frame elements
if {[string is integer -strict $table_minwidth]} {
set contentwidth [tcl::mathop::+ {*}$column_widths]
set twidth $contentwidth
if {[my Showing_vseps]} {
incr twidth [llength $column_widths]
incr twidth -1
}
if {[dict get $o_opts_table -show_edge]} {
incr twidth 2
}
#
set shortfall [expr {$table_minwidth - $twidth}]
if {$shortfall > 0} {
set space_to_alloc $shortfall
while {$space_to_alloc > 0} {
set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added]
set ordered_colids [dict keys $ordered_colspace_added]
foreach col $ordered_colids {
dict incr colwidths $col
dict incr colspace_added $col
incr space_to_alloc -1
if {$space_to_alloc == 0} {
break
}
}
}
set column_widths [dict values $colwidths]
}
}
return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added]
}
#spangroups keyed by column
method spangroups {} {
set column_count [dict size $o_columndefs]
set spangroups [dict create]
set headerwidths [dict create] ;#key on col,hrow
foreach c [dict keys $o_columndefs] {
dict set spangroups $c [list spanlengths {}]
set spanlist [my column_get_spaninfo $c]
set index_spanlen_val 5
set spanlist [lsort -index $index_spanlen_val -integer $spanlist]
set ungrouped $spanlist
while {[llength $ungrouped]} {
set spanlen [lindex $ungrouped 0 $index_spanlen_val]
set spangroup_posns [lsearch -all -index $index_spanlen_val $ungrouped $spanlen]
set sgroup [list]
foreach p $spangroup_posns {
set spaninfo [lindex $ungrouped $p]
set hcol [dict get $spaninfo startcol]
set hrow [dict get $spaninfo hrow]
set header [lindex [dict get $o_columndefs $hcol -headers] $hrow]
if {[dict exists $headerwidths $hcol,$hrow]} {
set hwidth [dict get $headerwidths $hcol,$hrow]
} else {
set hwidth [textblock::width $header]
dict set headerwidths $hcol,$hrow $hwidth
}
lappend spaninfo headerwidth $hwidth
lappend sgroup $spaninfo
}
set spanlengths [dict get $spangroups $c spanlengths]
lappend spanlengths $spanlen
dict set spangroups $c spanlengths $spanlengths
dict set spangroups $c spangroups $spanlen $sgroup
set ungrouped [lremove $ungrouped {*}$spangroup_posns]
}
}
return $spangroups
}
method column_get_own_spans {cidx} {
set colspans_for_column [dict get $o_columndefs $cidx -header_colspans]
}
method column_get_spaninfo {cidx} {
set spans_by_header [my header_colspans]
set colspans_for_column [dict get $o_columndefs $cidx -header_colspans]
set spaninfo [list]
set numcols [dict size $o_columndefs]
#note that 'all' can occur in positions other than column 0 - meaning all remaining
dict for {hrow rawspans} $spans_by_header {
set thiscol_spanval [lindex $rawspans $cidx]
if {$thiscol_spanval eq "all" || $thiscol_spanval > 0} {
set spanstartcol $cidx ;#own column
if {$thiscol_spanval eq "all"} {
set spanlen [expr {$numcols - $cidx}]
} else {
set spanlen $thiscol_spanval
}
} else {
#look left til we see an all or a non-zero value
for {set i $cidx} {$i > -1} {incr i -1} {
set s [lindex $rawspans $i]
if {$s eq "all" || $s > 0} {
set spanstartcol $i
if {$s eq "all"} {
set spanlen [expr {$numcols - $i}]
} else {
set spanlen $s
}
break
}
}
}
#assert - we should always find 1 answer for each header row
lappend spaninfo [list hrow $hrow startcol $spanstartcol spanlen $spanlen]
}
return $spaninfo
}
method calculate_column_widths {args} {
set column_count [dict size $o_columndefs]
set defaults [dict create\
-algorithm $o_column_width_algorithm\
]
dict for {k v} $args {
switch -- $k {
-algorithm {}
default {
error "Unknown option '$k'. Known options: [dict keys $defaults]"
}
}
}
set opts [dict merge $defaults $args]
set opt_algorithm [dict get $opts -algorithm]
#puts stderr "--- recalculating column widths -algorithm $opt_algorithm"
set known_algorithms [list basic simplistic span]
switch -- $opt_algorithm {
basic {
#basic column by column - This allocates extra space to first span/column as they're encountered.
#This can leave the table quite unbalanced with regards to whitespace and the table is also not as compact as it could be especially with regards to header colspans
#The header values can extend over some of the spanned columns - but not optimally so.
set o_calculated_column_widths [list]
for {set c 0} {$c < $column_count} {incr c} {
lappend o_calculated_column_widths [my basic_column_width $c]
}
}
simplistic {
#just uses the widest column data or header element.
#this is even less compact than basic and doesn't allow header colspan values to extend beyond their first spanned column
#This is a conservative option potentially useful in testing/debugging.
set o_calculated_column_widths [list]
for {set c 0} {$c < $column_count} {incr c} {
lappend o_calculated_column_widths [my column_width_configured $c]
}
}
span {
#widest of smallest spans first method
set calcresult [my columncalc_spans 0]
set o_calculated_column_widths [dict get $calcresult colwidths]
}
span2 {
#allocates more evenly - but truncates headers sometimes
set calcresult [my columncalc_spans 1]
set o_calculated_column_widths [dict get $calcresult colwidths]
}
default {
error "calculate_column_widths unknown algorithm $opt_algorithm"
}
}
#remember the last algorithm used
set o_column_width_algorithm $opt_algorithm
return $o_calculated_column_widths
}
method print {args} {
variable full_column_cache
set full_column_cache [dict create]
if {![llength $args]} {
set cols [dict keys $o_columndata]
} else {
set cols [list]
foreach colspec $args {
set allcols [dict keys $o_columndata]
if {[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 colposn 0
set numposns [llength $cols]
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]
}
#lappend blocks [my get_column_by_index $c {*}$flags]
#todo - only check and store in cache if table has header or footer colspans > 1
if {[dict exists $full_column_cache $c]} {
#puts "!!print used full_column_cache for $c"
set columninfo [dict get $full_column_cache $c]
} else {
set columninfo [my get_column_by_index $c -return dict {*}$flags]
dict set full_column_cache $c $columninfo
}
set nextcol [dict get $columninfo column]
set bodywidth [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 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 {[dict get $o_opts_table -show_edge]} {
#title is considered part of the edge ?
set offset 1 ;#make configurable?
set titlepad [string repeat $TSUB $offset]
if {[dict get $o_opts_table -title] ne ""} {
set titlealign [dict get $o_opts_table -titlealign]
switch -- $titlealign {
left {
set tstring $titlepad[dict get $o_opts_table -title]
}
right {
set tstring [dict get $o_opts_table -title]$titlepad
}
default {
set tstring [dict get $o_opts_table -title]
}
}
set opt_titletransparent [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 [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
}
#*** !doctools
#[list_end]
}
#*** !doctools
# [list_end] [comment {- end enumeration provider_classes }]
#[list_end] [comment {- end itemized list textblock::class groupings -}]
}
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#
#Note: A textblock does not necessarily have lines the same length - either in number of characters or print-width
#
namespace eval textblock {
namespace export block width
namespace eval cd {
#todo - save and restore existing namespace export in case macros::cd has default exports in future
namespace eval ::term::ansi::code::macros::cd {namespace export *}
namespace import ::term::ansi::code::macros::cd::*
namespace eval ::term::ansi::code::macros::cd {namespace export -clear}
}
proc spantest {} {
set t [list_as_table 5 {a b c d e aa bb cc dd ee X Y} -return object]
$t configure_column 0 -headers {span3 span4 span5/5 "span-all etc blah 123 hmmmmm" span2}
$t configure_column 0 -header_colspans {3 4 5 all 2}
$t configure_column 2 -headers {"" "" "" "" c2span2_etc}
$t configure_column 2 -header_colspans {0 0 0 0 2}
$t configure -show_header 1 -ansiborder_header [a+ cyan]
return $t
}
#more complex colspans
proc spantest2 {} {
set t [list_as_table 5 {a b c d e aa bb cc dd ee X Y} -return object]
$t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" c0span2}
$t configure_column 0 -header_colspans {3 4 1 all 2}
$t configure_column 1 -header_colspans {0 0 2 0 0}
$t configure_column 2 -headers {"" "" "" "" c2span2}
$t configure_column 2 -header_colspans {0 0 0 0 2}
$t configure_column 3 -header_colspans {1 0 2 0 0}
$t configure -show_header 1 -ansiborder_header [a+ cyan]
return $t
}
proc spantest3 {} {
set t [list_as_table 5 {a b c d e aa bb cc dd ee X Y} -return object]
$t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" "c0span2 etc blah" c0span1}
$t configure_column 0 -header_colspans {3 4 1 all 2 1}
$t configure_column 1 -header_colspans {0 0 4 0 0 1}
$t configure_column 1 -headers {"" "" "c1span4" "" "" "c1nospan"}
$t configure_column 2 -headers {"" "" "" "" "" c2span2}
$t configure_column 2 -header_colspans {0 0 0 0 1 2}
$t configure_column 4 -headers {"4" "444" "" "" "" "44"}
$t configure -show_header 1 -ansiborder_header [a+ cyan]
return $t
}
proc periodic {args} {
#For an impressive interactive terminal app (javascript)
# see: https://github.com/spirometaxas/periodic-table-cli
set defaults [dict create\
-return "string"\
-compact 1\
]
dict for {k v} $args {
switch -- $k {
-return - -compact {}
default {
"textblock::periodic unknown option '$k'. Known options: [dict keys $defaults]"
}
}
}
set opts [dict merge $defaults $args]
set opt_return [dict get $opts -return]
#examples ptable.com
set elements [list\
1 H "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" He\
2 Li Be "" "" "" "" "" "" "" "" "" "" B C N O F Ne\
3 Na Mg "" "" "" "" "" "" "" "" "" "" Al Si P S Cl Ar\
4 K Ca Sc Ti V Cr Mn Fe Co Ni Cu Zn Ga Ge As Se Br Kr\
5 Rb Sr Y Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb Te I Xe\
6 Cs Ba "" Hf Ta W Re Os Ir Pt Au Hg Tl Pb Bi Po At Rn\
7 Fr Ra "" Rf Db Sg Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og\
" " " " " " " " " " " " " " " " " " " " " " " " "" "" "" "" "" "" ""\
"" "" "" 6 La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu\
"" "" "" 7 Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr\
]
set type_colours [list]
set ecat [dict create]
set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra]
set ansi [a+ Web-gold web-black]
foreach e $cat_alkaline_earth {
dict set ecat $e [list ansi $ansi cat alkaline_earth]
}
set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I]
set ansi [a+ Web-lightgreen web-black]
foreach e $cat_reactive_nonmetal {
dict set ecat $e [list ansi $ansi cat reactive_nonmetal]
}
set cat [list Li Na K Rb Cs Fr]
set ansi [a+ Web-Khaki web-black]
foreach e $cat {
dict set ecat $e [list ansi $ansi cat alkali_metals]
}
set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs]
set ansi [a+ Web-lightsalmon web-black]
foreach e $cat {
dict set ecat $e [list ansi $ansi cat transition_metals]
}
set cat [list Al Ga In Sn Tl Pb Bi Po]
set ansi [a+ Web-lightskyblue web-black]
foreach e $cat {
dict set ecat $e [list ansi $ansi cat post_transition_metals]
}
set cat [list B Si Ge As Sb Te At]
set ansi [a+ Web-turquoise web-black]
foreach e $cat {
dict set ecat $e [list ansi $ansi cat metalloids]
}
set cat [list He Ne Ar Kr Xe Rn]
set ansi [a+ Web-orchid web-black]
foreach e $cat {
dict set ecat $e [list ansi $ansi cat noble_gases]
}
set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr]
set ansi [a+ Web-plum web-black]
foreach e $cat {
dict set ecat $e [list ansi $ansi cat actinoids]
}
set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu]
set ansi [a+ Web-tan web-black]
foreach e $cat {
dict set ecat $e [list ansi $ansi cat lanthanoids]
}
set cat [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og]
set ansi [a+ Web-whitesmoke web-black]
foreach e $cat {
dict set ecat $e [list ansi $ansi cat other]
}
set elements1 [list]
foreach e $elements {
if {[dict exists $ecat $e]} {
set ansi [dict get $ecat $e ansi]
#lappend elements1 [textblock::pad $ansi$e -width 2 -which right]
#no need to pad here - table column_configure -textalign default of left will do the work of padding right anyway
lappend elements1 $ansi$e
} else {
lappend elements1 $e
}
}
set t [list_as_table 19 $elements1 -return obj]
#todo - keep simple table with symbols as base - map symbols to descriptions etc for more verbose table options
set header_0 [list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18]
set c 0
foreach h $header_0 {
$t configure_column $c -headers [list $h] -minwidth 2
incr c
}
for {set c 0} {$c < [$t column_count]} {incr c} {
$t configure_column $c -minwidth 3
}
if {[dict get $opts -compact]} {
$t configure -show_hseps 0
$t configure -show_header 0
$t configure -show_edge 0
} else {
$t configure -show_header 1
}
if {$opt_return eq "string"} {
$t configure -frametype_header light
$t configure -ansiborder_header [a+ web-white]
$t configure -ansibase_header [a+ Web-black]
$t configure -ansibase_body [a+ Web-black]
$t configure -ansiborder_body [a+ web-black]
$t configure -frametype block
set output [textblock::frame -ansiborder [a+ Web-black web-cornflowerblue] -type heavy -title "[a+ Web-black] Periodic Table " [$t print]]
return $output
}
return $t
}
proc list_as_table {table_or_colcount datalist args} {
set defaults [dict create\
-return string\
-frametype \uFFEF\
-show_edge \uFFEF\
-show_seps \uFFEF\
]
foreach {k v} $args {
switch -- $k {
-return - -show_edge - -show_seps - -frametype {}
default {
error "unrecognised option '$k'. Known options [dict keys $defaults]"
}
}
}
set opts [dict merge $defaults $args]
set count [llength $datalist]
set is_new_table 0
if {[string is integer -strict $table_or_colcount]} {
set cols $table_or_colcount
set is_new_table 1
#defaults for new table only
if {[dict get $opts -frametype] eq "\uFFEF"} {
dict set opts -frametype "light"
}
if {[dict get $opts -show_edge] eq "\uFFEF"} {
dict set opts -show_edge 1
}
if {[dict get $opts -show_seps] eq "\uFFEF"} {
dict set opts -show_seps 1
}
set t [textblock::class::table new -show_header 0 -show_edge [dict get $opts -show_edge] -frametype [dict get $opts -frametype] -show_seps [dict get $opts -show_seps]]
for {set c 0} {$c < $cols} {incr c} {
$t add_column -headers [list $c]
}
} else {
if {[namespace tail [info object class $table_or_colcount]] ne "table"} {
error "textblock::list_as_table error - table_or_colcount must be an integer or an existing table object"
}
set t $table_or_colcount
if {[dict get $opts -frametype] ne "\uFFEF"} {
$t configure -frametype [dict get $opts -frametype]
}
if {[dict get $opts -show_edge] ne "\uFFEF"} {
$t configure -show_edge [dict get $opts -show_edge]
}
$t row_clear
set cols [$t column_count]
}
set full_rows [expr {$count / $cols}]
set last_items [expr {$count % $cols}]
set rowdata [list]
set row [list]
set i 0
if {$full_rows > 0} {
for {set r 0} {$r < $full_rows} {incr r} {
set j [expr {$i + ($cols -1)}]
set row [lrange $datalist $i $j]
incr i $cols
lappend rowdata $row
}
}
if {$last_items > 0} {
set idx [expr {$last_items -1}]
lappend rowdata [lrange $datalist end-$idx end]
}
foreach row $rowdata {
set shortfall [expr {$cols - [llength $row]}]
if {$shortfall > 0} {
set row [concat $row [lrepeat $shortfall ""]]
}
$t add_row $row
}
#puts stdout $rowdata
if {[dict get $opts -return] eq "string"} {
set result [$t print]
if {$is_new_table} {
$t destroy
}
return $result
} else {
return $t
}
}
#return a homogenous block of characters - ie lines all same length, all same character
#printing-width in terminal columns is not necessarily same as blockwidth even if a single char is passed (could be full-width unicode character)
#This can have ansi SGR codes - but to repeat blocks containing ansi-movements, the block should first be rendered to a static output with something like overtype::left
proc block {blockwidth blockheight {char " "}} {
if {$blockwidth < 0} {
error "textblock::block blockwidth must be an integer greater than or equal to zero"
}
if {$blockheight <= 0} {
error "textblock::block blockheight must be a positive integer"
}
if {$char eq ""} {return ""}
#using string length is ok
if {[string length $char] == 1} {
set row [string repeat $char $blockwidth]
set mtrx [lrepeat $blockheight $row]
return [::join $mtrx \n]
} else {
set charblock [string map [list \r\n \n] $char]
if {[string last \n $charblock] >= 0} {
if {$blockwidth > 1} {
#set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks )
set row [textblock::join {*}[lrepeat $blockwidth $charblock]]
} else {
set row $charblock
}
} else {
set row [string repeat $char $blockwidth]
}
set mtrx [lrepeat $blockheight $row]
return [::join $mtrx \n]
}
}
proc testblock {size {colour ""}} {
if {$size <1 || $size > 15} {
error "textblock::testblock only sizes between 1 and 15 inclusive supported"
}
set rainbow_list [list]
lappend rainbow_list {30 47} ;#black White
lappend rainbow_list {31 46} ;#red Cyan
lappend rainbow_list {32 45} ;#green Purple
lappend rainbow_list {33 44} ;#yellow Blue
lappend rainbow_list {34 43} ;#blue Yellow
lappend rainbow_list {35 42} ;#purple Green
lappend rainbow_list {36 41} ;#cyan Red
lappend rainbow_list {37 40} ;#white Black
lappend rainbow_list {black Yellow}
lappend rainbow_list red
lappend rainbow_list green
lappend rainbow_list yellow
lappend rainbow_list blue
lappend rainbow_list purple
lappend rainbow_list cyan
lappend rainbow_list {white Red}
set rainbow_direction "horizontal"
set vpos [lsearch $colour vertical]
if {$vpos >= 0} {
set rainbow_direction vertical
set colour [lremove $colour $vpos]
}
set hpos [lsearch $colour horizontal]
if {$hpos >=0} {
#horizontal is the default and superfluous but allowed for symmetry
set colour [lremove $colour $hpos]
}
set chars [concat [punk::range 1 9] A B C D E F]
set charsubset [lrange $chars 0 $size-1]
if {"noreset" in $colour} {
set RST ""
} else {
set RST [a]
}
if {"rainbow" in $colour && $rainbow_direction eq "vertical"} {
#column first - colour change each column
set c [::join $charsubset \n]
set clist [list]
for {set i 0} {$i <$size} {incr i} {
set colour2 [string map [list rainbow [lindex $rainbow_list $i]] $colour]
set ansi [a+ {*}$colour2]
set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi]
lappend clist ${ansicode}$c$RST
}
if {"noreset" in $colour} {
return [textblock::join -ansiresets 0 {*}$clist]
} else {
return [textblock::join {*}$clist]
}
} elseif {"rainbow" in $colour} {
#direction must be horizontal
set block ""
for {set r 0} {$r < $size} {incr r} {
set colour2 [string map [list rainbow [lindex $rainbow_list $r]] $colour]
set ansi [a+ {*}$colour2]
set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi]
set row "$ansicode"
foreach c $charsubset {
append row $c
}
append row $RST
append block $row\n
}
set block [string trimright $block \n]
return $block
} else {
#row first -
set rows [list]
foreach ch $charsubset {
lappend rows [string repeat $ch $size]
}
set block [::join $rows \n]
if {$colour ne ""} {
set block [a+ {*}$colour]$block$RST
}
return $block
}
}
interp alias {} testblock {} textblock::testblock
#todo - consider 'elastic tabstops' for textblocks where tab acts as a column separator and adjacent lines with the same number of tabs form a sort of table
proc width {textblock} {
#backspaces, vertical tabs ?
if {$textblock eq ""} {
return 0
}
#textutil::tabify is a reasonable hack when there are no ansi SGR codes - but probably not always what we want even then - review
if {[string last \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]
}
if {[punk::ansi::ta::detect $textblock]} {
set textblock [punk::ansi::stripansi $textblock]
}
if {[string last \n $textblock] >= 0} {
return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]]
}
return [punk::char::ansifreestring_width $textblock]
}
#when we know the block is uniform in width - just examine topline
proc widthtopline {textblock} {
set firstnl [string first \n $textblock]
if {$firstnl >= 0} {
set tl [string range $textblock 0 $firstnl]
} else {
set tl $textblock
}
if {[punk::ansi::ta::detect $tl]} {
set tl [punk::ansi::stripansi $tl]
}
return [punk::char::ansifreestring_width $tl]
}
#uses tcl's string length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function.
proc string_length_line_max textblock {
tcl::mathfunc::max {*}[lmap v [split $textblock \n] {string length $v}]
}
proc string_length_line_min textblock {
tcl::mathfunc::min {*}[lmap v [split $textblock \n] {string length $v}]
}
proc height {textblock} {
#This is the height as it will/would-be rendered - not the number of input lines purely in terms of le
#empty string still has height 1 (at least for left-right/right-left languages)
#vertical tab on a proper terminal should move directly down.
#Whether or not the terminal in use actually does this - we need to calculate as if it does. (there might not even be a terminal)
set num_le [expr {[string length $textblock]-[string length [string map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list
return [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le
}
#MAINTENANCE - same as overtype::blocksize?
proc size {textblock} {
if {$textblock eq ""} {
return [dict create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings
}
#strangely - string last (windows tcl8.7 anway) is faster than string first for large strings when the needle not in the haystack
if {[string last \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]
}
#stripansi 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::stripansi $textblock]
}
if {[string last \n $textblock] >= 0} {
#set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]]
set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]]
} else {
set width [punk::char::ansifreestring_width $textblock]
}
set num_le [expr {[string length $textblock]-[string length [string map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list
#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 [dict create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [dict values [blocksize <data>]] width height
}
#must be able to handle block as string with or without newlines
#if no newlines - attempt to treat as a list
#must handle whitespace-only string,list elements, and/or lines.
#reviewing 2024 - this seems like too much magic!
proc width1 {block} {
if {$block eq ""} {
return 0
}
if {[info exists punk::console::tabwidth]} {
set tw $::punk::console::tabwidth
} else {
set tw 8
}
set block [textutil::tabify::untabify2 $block $tw]
if {[string last \n $block] >= 0} {
return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $block] {::punk::char::string_width [stripansi $v]}]]
}
if {[catch {llength $block}]} {
return [::punk::char::string_width [stripansi $block]]
}
if {[llength $block] == 0} {
#could be just a whitespace string
return [string length $block]
}
return [tcl::mathfunc::max {*}[lmap v $block {::punk::char::string_width [stripansi $v]}]]
}
#we shouldn't make textblock depend on the punk pipeline system
#pipealias ::textblock::padleft .= {list $input [string repeat " " $indent]} |/0,padding/1> punk:lib::lines_as_list -- |> .= {lmap v $data {overtype::right $padding $v}} |> punk::lib::list_as_lines -- <input/0,indent/1|
#pipealias ::textblock::padright .= {list $input [string repeat " " $colsize]} |/0,padding/1> punk::lib::lines_as_list -- |> .= {lmap v $data {overtype::left $padding $v}} |> punk::lib::list_as_lines -- <input/0,colsize/1|
proc ::textblock::pad {block args} {
set defaults [dict create\
-padchar " "\
-which "right"\
-width ""\
-overflow 0\
-within_ansi 0\
]
#review!?
#-within_ansi means after a leading ansi code when doing left pad on all but last line
#-within_ansi means before a trailing ansi code when doing right pad on all but last line
set usage "pad ?-padchar <sp>|<character>? ?-which right|left|centre? ?-width auto|<int>? ?-within_ansi 1|0?"
foreach {k v} $args {
switch -- $k {
-padchar - -which - -width - -overflow - -within_ansi {}
default {
error "textblock::pad unrecognised option '$k'. Usage: $usage"
}
}
}
set opts [dict merge $defaults $args]
# -- --- --- --- --- --- --- --- --- ---
set padchar [dict get $opts -padchar]
#if padchar width (screen width) > 1 - length calculations will not be correct
#we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a string map
#The caller may also use ansi within the padchar - although it's unlikely to be efficient.
# -- --- --- --- --- --- --- --- --- ---
set known_whiches [list l left r right c center centre]
set opt_which [string tolower [dict get $opts -which]]
switch -- $opt_which {
center - centre - c {
set which c
}
left - l {
set which l
}
right - r {
set which r
}
default {
error "textblock::pad unrecognised value for -which option. Known values $known_whiches"
}
}
# -- --- --- --- --- --- --- --- --- ---
set opt_width [dict get $opts -width]
switch -- $opt_width {
"" - auto {
set width auto
}
default {
if {![string is integer -strict $opt_width] || $opt_width < 0} {
error "textblock::pad -width must be an integer >=0"
}
set width $opt_width
}
}
# -- --- --- --- --- --- --- --- --- ---
set opt_withinansi [dict get $opts -within_ansi]
switch -- $opt_withinansi {
0 - 1 {}
default {
set opt_withinansi 2
}
}
# -- --- --- --- --- --- --- --- --- ---
set datawidth [textblock::width $block]
if {$width eq "auto"} {
set width $datawidth
}
set lines [list]
if {$block eq ""} {
#we need to treat as a line
return [string repeat $padchar $width]
}
#review - tcl format can only pad with zeros or spaces?
#experimental fallback to supposedly faster simpler 'format' but we still need to compensate for double-width or non-printing chars - and it won't work on strings with ansi SGR codes
if 0 {
#review - surprisingly, this doesn't seem to be a performance win
#No detectable diff on small blocks - slightly worse on large blocks
if {($padchar eq " " || $padchar eq "0") && ![punk::ansi::ta::detect $block]} {
#This will still be wrong for example with diacritics on terminals that don't collapse the space following a diacritic, and don't correctly report cursor position
#(i.e as at 2024 - lots of them) wezterm on windows at least does the right thing.
set block [string map [list \r\n \n] $block]
if {$which eq "l"} {
set fmt "%+${padchar}*s"
} else {
set fmt "%-${padchar}*s"
}
foreach ln [split $block \n] {
#set lnwidth [punk::char::ansifreestring_width $ln]
set lnwidth [punk::char::grapheme_width_cached $ln]
set lnlen [string length $ln]
set diff [expr $lnwidth - $lnlen]
#we need trickwidth to get format to pad a string with a different terminal width compared to string length
set trickwidth [expr {$width - $diff}] ;#may 'subtract' a positive or negative int (ie will add to trickwidth if negative)
lappend lines [format $fmt $trickwidth $ln]
}
return [::join $lines \n]
}
}
set lnum 0
set parts [punk::ansi::ta::split_codes $block]
set line_chunks [list]
set line_len 0
foreach {pt ansi} $parts {
if {$pt ne ""} {
set has_nl [expr {[string last \n $pt]>=0}]
if {$has_nl} {
set pt [string map [list \r\n \n] $pt]
set partlines [split $pt \n]
} else {
set partlines [list $pt]
}
set last [expr {[llength $partlines]-1}]
set p 0
foreach pl $partlines {
lappend line_chunks $pl
#incr line_len [punk::char::ansifreestring_width $pl]
incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak
if {$p != $last} {
#do padding
set missing [expr {$width - $line_len}]
if {$missing > 0} {
set pad [string repeat $padchar $missing]
switch -- $which-$opt_withinansi {
r-0 {
lappend line_chunks $pad
}
r-1 {
if {[lindex $line_chunks end] eq ""} {
set line_chunks [linsert $line_chunks end-2 $pad]
} else {
lappend line_chunks $pad
}
}
r-2 {
lappend line_chunks $pad
}
l-0 {
set line_chunks [linsert $line_chunks 0 $pad]
}
l-1 {
if {[lindex $line_chunks 0] eq ""} {
set line_chunks [linsert $line_chunks 2 $pad]
} else {
set line_chunks [linsert $line_chunks 0 $pad]
}
}
l-2 {
if {$lnum == 0} {
if {[lindex $line_chunks 0] eq ""} {
set line_chunks [linsert $line_chunks 2 $pad]
} else {
set line_chunks [linsert $line_chunks 0 $pad]
}
} else {
set line_chunks [linsert $line_chunks 0 $pad]
}
}
}
}
lappend lines [::join $line_chunks ""]
set line_chunks [list]
set line_len 0
incr lnum
}
incr p
}
} else {
#we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes
lappend line_chunks ""
}
#don't let trailing empty ansi affect the line_chunks length
if {$ansi ne ""} {
lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content?
}
}
#pad last line
set missing [expr {$width - $line_len}]
if {$missing > 0} {
set pad [string repeat $padchar $missing]
switch -- $which-$opt_withinansi {
r-0 {
lappend line_chunks $pad
}
r-1 {
if {[lindex $line_chunks end] eq ""} {
set line_chunks [linsert $line_chunks end-2 $pad]
} else {
lappend line_chunks $pad
}
}
r-2 {
if {[lindex $line_chunks end] eq ""} {
set line_chunks [linsert $line_chunks end-2 $pad]
} else {
lappend line_chunks $pad
}
#lappend line_chunks $pad
}
l-0 {
#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]
}
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]
}
}
}
lappend lines [::join $line_chunks ""]
return [::join $lines \n]
}
#left insertion into a list resulting from punk::ansi::ta::split_codes or split_codes_single
#resulting list is no longer a valid ansisplit list
proc _insert_before_text_or_last_ansi {str ansisplits} {
if {[llength $ansisplits] == 1} {
#ansisplits was a split on plaintext only
return [list $str [lindex $ansisplits 0]]
} elseif {[llength $ansisplits] == 0} {
return [list $str]
}
if {[llength $ansisplits] %2 != 1} {
error "_insert_before_text_or_last_ansi ansisplits list is not a valid resultlist from an ansi split - must be odd number of elements pt,ansi,pt,ansi...pt"
}
set out [list]
set i 0
set i_last_code [expr {[llength $ansisplits]-3}] ;#would normally be -2 - but our i is jumping to each pt - not every element
foreach {pt code} $ansisplits {
if {$pt ne ""} {
return [lappend out $str {*}[lrange $ansisplits $i end]]
}
if {$i == $i_last_code} {
return [lappend out $str {*}[lrange $ansisplits $i end]]
}
#code being empty can only occur when we have reached last pt
#we have returned by then.
lappend out $code
incr i 2
}
error "_insert_before_text_or_last_ansi failed on input str:[ansistring VIEW $str] ansisplits:[ansistring VIEW $ansisplits]"
}
proc pad_test {block} {
set width [textblock::width $block]
set padtowidth [expr {$width + 10}]
set left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0]
set left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1]
set left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2]
set right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0]
set right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1]
set right2 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 2]
set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2]
set t [textblock::list_as_table 3 $testlist -return object]
$t configure_column 0 -headers [list "ansi"]
$t configure_column 1 -headers [list "Left"]
$t configure_column 2 -headers [list "Right"]
$t configure -show_header 1
puts stdout [$t print]
return $t
}
proc pad_test_blocklist {blocklist args} {
set defaults [dict create\
-description ""\
-blockheaders ""\
]
foreach {k v} $args {
switch -- $k {
-description - -blockheaders {}
default {
error "pad_test_blocklist unrecognised option '$k'. Known options: [dict keys $defaults]"
}
}
}
set opts [dict merge $defaults $args]
set opt_blockheaders [dict get $opts -blockheaders]
set bheaders [dict create]
if {$opt_blockheaders ne ""} {
set b 0
foreach h $opt_blockheaders {
if {$b < [llength $blocklist]} {
dict set bheaders $b $h
}
incr b
}
}
set b 0
set blockinfo [dict create]
foreach block $blocklist {
set width [textblock::width $block]
dict set blockinfo $b width $width
set padtowidth [expr {$width + 3}]
dict set blockinfo $b left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0]
dict set blockinfo $b left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1]
dict set blockinfo $b left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2]
dict set blockinfo $b right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0]
dict set blockinfo $b right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1]
dict set blockinfo $b right2 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 2]
incr b
}
set r0 [list "0"]
set r1 [list "1"]
set r2 [list "2"]
set r3 [list "column\ncolours"]
#1
#test without table padding
#we need to textblock::join each item to ensure we don't get the table's own textblock::pad interfering
#(basically a mechanism to add extra resets at start and end of each line)
#dict for {b bdict} $blockinfo {
# lappend r0 [textblock::join [dict get $blockinfo $b left0]] [textblock::join [dict get $blockinfo $b right0]]
# lappend r1 [textblock::join [dict get $blockinfo $b left1]] [textblock::join [dict get $blockinfo $b right1]]
# lappend r2 [textblock::join [dict get $blockinfo $b left2]] [textblock::join [dict get $blockinfo $b right2]]
#}
#2 - the more useful one?
dict for {b bdict} $blockinfo {
lappend r0 [dict get $blockinfo $b left0] [dict get $blockinfo $b right0]
lappend r1 [dict get $blockinfo $b left1] [dict get $blockinfo $b right1]
lappend r2 [dict get $blockinfo $b left2] [dict get $blockinfo $b right2]
lappend r3 "" ""
}
set rows [concat $r0 $r1 $r2 $r3]
set column_ansi [a+ web-white Web-Gray]
set t [textblock::list_as_table [expr {1 + (2 * [dict size $blockinfo])}] $rows -return object]
$t configure_column 0 -headers [list [dict get $opts -description] "within_ansi"] -ansibase $column_ansi
set col 1
dict for {b bdict} $blockinfo {
if {[dict exists $bheaders $b]} {
set hdr [dict get $bheaders $b]
} else {
set hdr "Block $b"
}
$t configure_column $col -headers [list $hdr "Left"] -minwidth [expr {$padtowidth + 2}]
$t configure_column $col -header_colspans 2 -ansibase $column_ansi
incr col
$t configure_column $col -headers [list "-" "Right"] -minwidth [expr {$padtowidth + 2}] -ansibase $column_ansi
incr col
}
$t configure -show_header 1
puts stdout [$t print]
return $t
}
proc pad_example {} {
set headers [list]
set blocks [list]
lappend blocks "[textblock::testblock 4 rainbow]"
lappend headers "rainbow 4x4\nresets at line extremes\nnothing trailing"
lappend blocks "[textblock::testblock 4 rainbow][a]"
lappend headers "rainbow 4x4\nresets at line extremes\ntrailing reset"
lappend blocks "[textblock::testblock 4 rainbow]\n[a+ Web-Green]"
lappend headers "rainbow 4x4\nresets at line extremes\ntrailing nl&green bg"
lappend blocks "[textblock::testblock 4 {rainbow noreset}]"
lappend headers "rainbow 4x4\nno line resets\nnothing trailing"
lappend blocks "[textblock::testblock 4 {rainbow noreset}][a]"
lappend headers "rainbow 4x4\nno line resets\ntrailing reset"
lappend blocks "[textblock::testblock 4 {rainbow noreset}]\n[a+ Web-Green]"
lappend headers "rainbow 4x4\nno line resets\ntrailing nl&green bg"
set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers]
}
proc pad_example2 {} {
set headers [list]
set blocks [list]
lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n"
lappend headers "red on blue 4x4\nno inner resets\ntrailing nl"
lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a]"
lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&reset"
lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a+ Web-Green]"
lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&green bg"
set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers]
}
#playing with syntax
# pipealias ::textblock::join_width .= {list $lhs [string repeat " " $w1] $rhs [string repeat " " $w2]} {|
# /2,col1/1,col2/3
# >} punk::lib::lines_as_list -- {|
# data2
# >} .=lhs> punk::lib::lines_as_list -- {|
# >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {|
# >} punk::lib::list_as_lines -- <lhs/0,w1/1,rhs/2,w2/3|
#
# pipealias ::textblock::joinpair .= {list $lhs [string repeat " " [width $lhs]] $rhs [string repeat " " [width $rhs]]} {|
# /2,col1/1,col2/3
# >} .=> punk::lib::lines_as_list -- {|
# data2
# >} .=lhs> punk::lib::lines_as_list -- {|
# >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {|
# >} punk::lib::list_as_lines -- <lhs/0,rhs/1|
proc ::textblock::join1 {args} {
lassign [punk::args::opts_values {
-ansiresets -default 1 -type integer
blocks -type string -multiple 1
} $args] _o opts _v values
set blocks [dict get $values blocks]
set idx 0
set fordata [list]
foreach b $blocks {
set c($idx) [string repeat " " [width $b]]
lappend fordata "v($idx)" [punk::lib::lines_as_list {*}$opts -- $b]
incr idx
}
set outlines [list]
foreach {*}$fordata {
set row ""
foreach colidx [lsort -integer -increasing [array names c]] {
append row [overtype::left $c($colidx) $v($colidx)]
}
lappend outlines $row
}
return [punk::lib::list_as_lines -- $outlines]
}
#for joining 'rendered' blocks of plain or ansi text. Being 'rendered' means they are without ansi movement sequences as these have been processed
#they may however still be 'ragged' ie differing line lengths
proc ::textblock::join {args} {
#lassign [punk::lib::opts_values {
# blocks -type string -multiple 1
#} $args] _o opts _v values
#set blocks [dict get $values blocks]
#-ansireplays is always on (if ansi detected)
#we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets
#textblock::join is already somewhat expensive - we don't want to do much argument processing
#also "--" is a legitimate joining block - so we need to support that too without too much risk of misinterpretation
#this makes for a somewhat messy api.. -- is required if first block is actually -- (or the very unlikely case the first block is intended to be -ansiresets)
set ansiresets auto
switch -- [lindex $args 0] {
-- {
set blocks [lrange $args 1 end]
}
-ansiresets {
if {[lindex $args 2] eq "--"} {
set blocks [lrange $args 3 end]
} else {
set blocks [lrange $args 2 end]
}
set ansiresets [lindex $args 1]
}
default {
set blocks $args
}
}
if {![llength $blocks]} {
return
}
set idx 0
set fordata [list]
set colindices [list]
foreach b $blocks {
set c($idx) [string repeat " " [width $b]]
set w($idx) [width $b] ;#we need the width of a rendered block for per-row renderline calls
#fairly commonly a block may be a vertical list of chars e.g something like 1\n2\n3 or -\n-\n-\n-
#for determining a shortcut to avoid unnecessary ta::detect - (e.g width <=1) we can't use result of textblock::width as it strips ansi.
#testing of any decent size block line by line - even with max_string_length_line is slower than ta::detect anyway.
if {[punk::ansi::ta::detect $b]} {
lappend fordata "v($idx)" [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b]
} else {
#each block is being rendered into its own empty column - we don't need resets if it has no ansi, even if blocks to left and right do have ansi
lappend fordata "v($idx)" [split $b \n]
}
lappend colindices $idx
incr idx
}
set outlines [list]
#set colindices [lsort -integer -increasing [array names c]]
foreach {*}$fordata {
set row ""
foreach colidx $colindices {
#we know we have a single line, no ansi in underlay and no overflow required - so we can use renderline directly
#append row [overtype::renderline -width $w($colidx) -insert_mode 0 -info 0 $c($colidx) $v($colidx)]
append row [textblock::pad $v($colidx) -width $w($colidx) -which right -padchar " "]
}
lappend outlines $row
}
return [::join $outlines \n]
}
proc ::textblock::trim {block} {
error "textblock::trim unimplemented"
set trimlines ""
}
#pipealias ::textblock::join_right .= {list $lhs [string repeat " " [width $lhs]] $rhs [string repeat " " [width $rhs]]} {|
# /2,col1/1,col2/3
# >} .=> punk::lib::lines_as_list -- {|
# data2
# >} .=lhs> punk::lib::lines_as_list -- {|
# >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {|
# >} punk::lib::list_as_lines <lhs/0,rhs/1|
proc example {} {
set pleft [>punk . rhs]
set pright [>punk . lhs]
set prightair [>punk . lhs_air]
set red [a+ red]; set redb [a+ red bold]
set green [a+ green]; set greenb [a+ green bold]
set cyan [a+ cyan];set cyanb [a+ cyan bold]
set blue [a+ blue];set blueb [a+ blue bold]
set RST [a]
set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz]
set punks [textblock::join $pleft $pright]
set pleft_greenb $greenb$pleft$RST
set pright_redb $redb$pright$RST
set prightair_cyanb $cyanb$prightair$RST
set cpunks [textblock::join $pleft_greenb $pright_redb]
set out ""
append out $punks \n
append out $cpunks \n
append out [textblock::join $punks $cpunks] \n
set 2frames_a [textblock::join [textblock::frame $cpunks] [textblock::frame $punks]]
append out $2frames_a \n
set 2frames_b [textblock::join [textblock::frame -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -ansiborder $greenb -title "fancypunks" $cpunks]]
append out [textblock::frame -title "punks" $2frames_b\n$RST$2frames_a] \n
set fancy [overtype::right [overtype::left [textblock::frame -ansiborder [a+ green bold] -type heavy -title ${redb}PATTERN$RST -subtitle ${redb}PUNK$RST $prightair_cyanb] "$blueb\n\n\P\nU\nN\nK$RST"] "$blueb\n\nL\nI\nF\nE"]
set spantable [[spantest] print]
append out [textblock::join $fancy " " $spantable] \n
#append out [textblock::frame -title gr $gr0]
append out [textblock::periodic]
return $out
}
proc example3 {{text "test\netc\nmore text"}} {
package require patternpunk
.= textblock::join [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7]] [>punk . lhs] |> .=>1 textblock::join " " |> .=>1 textblock::join $text |> .=>1 textblock::join [>punk . rhs] |> .=>1 textblock::join [punk::lib::list_as_lines -- [lrepeat 7 " | "]]
}
proc example2 {{text "test\netc\nmore text"}} {
package require patternpunk
.= textblock::join\
[punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7 8]]\
[>punk . lhs]\
" "\
$text\
[>punk . rhs]\
[punk::lib::list_as_lines -- [lrepeat 8 " | "]]
}
proc table {args} {
upvar ::textblock::class::opts_table_defaults toptdefaults
set defaults [dict create\
-rows [list]\
-headers [list]\
-return string\
]
set defaults [dict merge $defaults $toptdefaults] ;# -title -frametype -show_header etc
set opts [dict merge $defaults $args]
# -- --- --- ---
set opt_return [dict get $opts -return]
set opt_rows [dict get $opts -rows]
set opt_headers [dict get $opts -headers]
# -- --- --- ---
set topts [dict create]
set toptkeys [dict keys $toptdefaults]
dict for {k v} $opts {
if {$k in $toptkeys} {
dict set topts $k $v
}
}
set t [textblock::class::table new {*}$topts]
foreach h $opt_headers {
$t add_column -headers [list $h]
}
if {[$t column_count] == 0} {
if {[llength $opt_rows]} {
set r0 [lindex $opt_rows 0]
foreach c $r0 {
$t add_column
}
}
}
foreach r $opt_rows {
$t add_row $r
}
if {$opt_return eq "string"} {
set result [$t print]
$t destroy
return $result
} else {
return $t
}
}
variable frametypes
set frametypes [list light heavy arc double block block1 ascii altg]
#class::table needs to be able to determine valid frametypes
proc frametypes {} {
variable frametypes
return $frametypes
}
proc frametype {f} {
variable frametypes
set default_custom [dict create hl " " vl " " 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} {
#custom dict may leave out keys - but cannot have unknown keys
dict for {k v} $f {
switch -- $k {
hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {}
default {
#k not in custom_keys
set is_custom_dict_ok 0
break
}
}
}
} else {
set is_custom_dict_ok 0
}
if {!$is_custom_dict_ok} {
error "frame option -type must be one of known types: $frametypes or a dictionary with any of keys hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc"
}
set custom_frame [dict merge $default_custom $f]
return [dict create category custom type $custom_frame]
} else {
return [dict create category predefined type $f]
}
}
variable framedef_cache [dict create]
proc framedef {f args} {
#unicode box drawing only provides enough characters for seamless joining of unicode boxes light and heavy.
#e.g with characters such as \u2539 Box Drawings Right Light and Left Up Heavy.
#the double glyphs in box drawing can do a limited set of joins to light lines - but not enough for seamless table layouts.
#the arc set can't even join to itself e.g with curved equivalents of T-like shapes
variable framedef_cache
set cache_key [concat $f $args]
if {[dict exists $framedef_cache $cache_key]} {
return [dict get $framedef_cache $cache_key]
}
set defaults [dict create\
-joins ""\
-boxonly 0\
]
dict for {k v} $args {
switch -- $k {
-joins - -boxonly {}
default {
error "framedef unknown option '$k'. Known options [dict keys $args]"
}
}
}
set opts [dict merge $defaults $args]
set joins [dict get $opts -joins]
set boxonly [dict get $opts -boxonly]
#sorted order down left right up
#1 x choose 4
#4 x choose 3
#6 x choose 2
#4 x choose 1
#15 combos
set join_directions [list]
#targets - light,heavy (double?) - seem to be some required glyphs missing from unicode
#e.g down-light, up-heavy
set join_targets [dict create left "" down "" right "" up ""]
foreach jt $joins {
lassign [split $jt -] direction target
if {$target ne ""} {
dict set join_targets $direction $target
}
lappend join_directions $direction
}
set join_directions [lsort -unique $join_directions]
set do_joins [::join $join_directions _]
switch -- $f {
"altg" {
#old style ansi escape sequences with alternate graphics page G0
set hl [cd::hl]
set hlt $hl
set hlb $hl
set vl [cd::vl]
set vll $vl
set vlr $vl
set tlc [cd::tlc]
set trc [cd::trc]
set blc [cd::blc]
set brc [cd::brc]
#horizontal and vertical bar joins
set hltj $hlt
set hlbj $hlb
set vllj $vll
set vlrj $vlr
#No join targets available to join altg to other box styles
switch -- $do_joins {
down {
#1
set blc [punk::ansi::g0 t] ;#(ltj)
set brc [punk::ansi::g0 u] ;#(rtj)
set hlbj [punk::ansi::g0 w] ;#(ttj)
} left {
#2
set tlc [punk::ansi::g0 w] ;#(ttj)
set blc [punk::ansi::g0 v] ;#(btj)
set vllj [punk::ansi::g0 u] ;#(rtj)
}
right {
#3
set trc [punk::ansi::g0 w] ;#(ttj)
set brc [punk::ansi::g0 v] ;#(btj)
set vlrj [punk::ansi::g0 t] ;#(ltj)
}
up {
#4
set tlc [punk::ansi::g0 t] ;#(ltj)
set trc [punk::ansi::g0 u] ;#(rtj)
set hltj [punk::ansi::g0 v];#(btj)
}
down_left {
#5
set blc [punk::ansi::g0 n] ;#(fwj)
set tlc [punk::ansi::g0 w] ;#(ttj)
set brc [punk::ansi::g0 u] ;#(rtj)
set hlbj [punk::ansi::g0 w] ;#(ttj)
set vllj [punk::ansi::g0 u] ;#(rtj)
}
down_right {
#6
set blc [punk::ansi::g0 t] ;#(ltj)
set trc [punk::ansi::g0 w] ;#(ttj)
set brc [punk::ansi::g0 n] ;#(fwj)
set hlbj [punk::ansi::g0 w] ;#(ttj)
set vlrj [punk::ansi::g0 t] ;#(ltj)
}
down_up {
#7
set blc [punk::ansi::g0 t] ;#(ltj)
set brc [punk::ansi::g0 u] ;#(rtj)
set tlc [punk::ansi::g0 t] ;#(ltj)
set trc [punk::ansi::g0 u] ;#(rtj)
set hlbj [punk::ansi::g0 w] ;#(ttj)
set hltj [punk::ansi::g0 v];#(btj)
}
left_right {
#8
#from 2
set tlc [punk::ansi::g0 w] ;#(ttj)
set blc [punk::ansi::g0 v] ;#(btj)
#from3
set trc [punk::ansi::g0 w] ;#(ttj)
set brc [punk::ansi::g0 v] ;#(btj)
set vllj [punk::ansi::g0 u] ;#(rtj)
set vlrj [punk::ansi::g0 t] ;#(ltj)
}
left_up {
#9
set tlc [punk::ansi::g0 n] ;#(fwj)
set trc [punk::ansi::g0 u] ;#(rtj)
set blc [punk::ansi::g0 v] ;#(btj)
set vllj [punk::ansi::g0 u] ;#(rtj)
}
right_up {
#10
set tlc [punk::ansi::g0 t] ;#(ltj)
set trc [punk::ansi::g0 n] ;#(fwj)
set brc [punk::ansi::g0 v] ;#(btj)
set hltj [punk::ansi::g0 v];#(btj)
set vlrj [punk::ansi::g0 t] ;#(ltj)
}
down_left_right {
#11
set blc [punk::ansi::g0 n] ;#(fwj)
set brc [punk::ansi::g0 n] ;#(fwj)
set trc [punk::ansi::g0 w] ;#(ttj)
set tlc [punk::ansi::g0 w] ;#(ttj)
set vllj [punk::ansi::g0 u] ;#(rtj)
set vlrj [punk::ansi::g0 t] ;#(ltj)
set hlbj [punk::ansi::g0 w] ;#(ttj)
}
down_left_up {
#12
set tlc [punk::ansi::g0 n] ;#(fwj)
set blc [punk::ansi::g0 n] ;#(fwj)
set trc [punk::ansi::g0 u] ;#(rtj)
set brc [punk::ansi::g0 u] ;#(rtj)
set vllj [punk::ansi::g0 u] ;#(rtj)
set hltj [punk::ansi::g0 v];#(btj)
set hlbj [punk::ansi::g0 w] ;#(ttj)
}
down_right_up {
#13
set tlc [punk::ansi::g0 t] ;#(ltj)
set blc [punk::ansi::g0 t] ;#(ltj)
set trc [punk::ansi::g0 n] ;#(fwj)
set brc [punk::ansi::g0 n] ;#(fwj)
set hltj [punk::ansi::g0 v];#(btj)
set vlrj [punk::ansi::g0 t] ;#(ltj)
set hlbj [punk::ansi::g0 w] ;#(ttj)
}
left_right_up {
#14
set tlc [punk::ansi::g0 n] ;#(fwj)
set trc [punk::ansi::g0 n] ;#(fwj)
set blc [punk::ansi::g0 v] ;#(btj)
set brc [punk::ansi::g0 v] ;#(btj)
set vllj [punk::ansi::g0 u] ;#(rtj)
set hltj [punk::ansi::g0 v];#(btj)
set vlrj [punk::ansi::g0 t] ;#(ltj)
}
down_left_right_up {
#15
set tlc [punk::ansi::g0 n] ;#(fwj)
set blc [punk::ansi::g0 n] ;#(fwj)
set trc [punk::ansi::g0 n] ;#(fwj)
set brc [punk::ansi::g0 n] ;#(fwj)
set vllj [punk::ansi::g0 u] ;#(rtj)
set hltj [punk::ansi::g0 v];#(btj)
set vlrj [punk::ansi::g0 t] ;#(ltj)
set hlbj [punk::ansi::g0 w] ;#(ttj)
}
}
}
"ascii" {
set hl -
set hlt -
set hlb -
set vl |
set vll |
set vlr |
set tlc +
set trc +
set blc +
set brc +
#horizontal and vertical bar joins
#set hltj $hlt
#set hlbj $hlb
#set vllj $vll
#set vlrj $vlr
#ascii + is small - can reasonably be considered a join to anything?
set hltj +
set hlbj +
set vllj +
set vlrj +
#our corners are all + already - so we won't do anything for directions or targets
}
"light" {
#unicode box drawing set
set hl [punk::char::charshort boxd_lhz] ;# light horizontal
set hlt $hl
set hlb $hl
set vl [punk::char::charshort boxd_lv] ;#light vertical
set vll $vl
set vlr $vl
set tlc [punk::char::charshort boxd_ldr]
set trc [punk::char::charshort boxd_ldl]
set blc [punk::char::charshort boxd_lur]
set brc [punk::char::charshort boxd_lul]
#horizontal and vertical bar joins
set hltj $hlt
set hlbj $hlb
set vllj $vll
set vlrj $vlr
#15 combos
#sort order: down left right up
#ltj,rtj,ttj,btj e.g left T junction etc.
#Look at from the perspective of a frame/table outline with a clean border and arms pointing inwards
#set targetdown,targetleft,targetright,targetup vars
#default empty targets to current box type 'light'
foreach dir {down left right up} {
set target [dict get $join_targets $dir]
switch -- $target {
"" - light {
set target$dir light
}
ascii - altg - arc {
set target$dir light
}
heavy {
set target$dir $target
}
default {
set target$dir other
}
}
}
switch -- $do_joins {
down {
#1
switch -- $targetdown {
heavy {
set blc [punk::char::charshort boxd_dhrul] ;#\u251f down hieavy and right up light (ltj)
set brc \u2527 ;#boxd_dhlul down heavy and left up light (rtj)
set hlbj \u2530 ;# down heavy (ttj)
}
light {
set blc \u251c ;#[punk::char::charshort boxd_lvr] light vertical and right (ltj)
set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj)
set hlbj \u252c ;# (ttj)
}
}
}
left {
#2
switch -- $targetleft {
heavy {
set tlc \u252d ;# Left Heavy and Right Down Light (ttj)
set blc \u2535 ;# Left Heavy and Right Up Light (btj)
set vllj \u2525 ;# left heavy (rtj)
}
light {
set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft
set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj)
set vllj \u2524 ;# (rtj)
}
}
}
right {
#3
switch -- $targetright {
heavy {
set trc \u252e ;#Right Heavy and Left Down Light (ttj)
set brc \u2536 ;#Right Heavy and Left up Light (btj)
set vlrj \u251d;#right heavy (ltj)
}
light {
set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj)
set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj)
set vlrj \u251c;# (ltj)
}
}
}
up {
#4
switch -- $targetup {
heavy {
set tlc \u251e ;#up heavy (ltj)
set trc \u2526 ;#up heavy (rtj)
}
light {
set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj)
set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj)
}
}
}
down_left {
#5
switch -- $targetdown-$targetleft {
other-light {
set blc \u2534 ;#(btj)
set tlc \u252c ;#(ttj)
#brc - default corner
set vllj \u2524 ;# (rtj)
}
other-other {
#default corners
}
other-heavy {
set blc \u2535 ;# heavy left (btj)
set tlc \u252d ;#heavy left (ttj)
#brc default corner
set vllj \u2525 ;# heavy left (rtj)
}
heavy-light {
set blc \u2541 ;# heavy down (fwj)
set tlc \u252c ;# light (ttj)
set brc \u2527 ;# heavy down (rtj)
set vllj \u2524 ;# (rtj)
set hlbj \u2530 ;# heavy down (ttj)
}
heavy-other {
set blc \u251f ;#heavy down (ltj)
#tlc - default corner
set brc \u2527 ;#heavy down (rtj)
set hlbj \u2530 ;# heavy down (ttj)
}
heavy-heavy {
set blc \u2545 ;#heavy down and left (fwj)
set tlc \u252d ;#heavy left (ttj)
set brc \u2527 ;#heavy down (rtj)
set vllj \u2525 ;# heavy left (rtj)
set hlbj \u2530 ;# heavy down (ttj)
}
light-light {
set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj)
set tlc \u252c ;# boxd_ldhz (ttj)
set brc \u2524 ;# boxd_lvl light vertical and left(rtj)
set vllj \u2524 ;# (rtj)
set hlbj \u252c ;# (ttj)
}
light-other {
set blc \u251c ;# (ltj)
#tlc - default corner
set brc \u2524 ;# boxd_lvl (rtj)
set hlbj \u252c ;# (ttj)
}
light-heavy {
set blc \u253d ;# heavy left (fwj)
set tlc \u252d ;# heavy left (ttj)
set brc \u2524 ;# light (rtj)
set vllj \u2525 ;# heavy left (rtj)
set hlbj \u252c ;# (ttj)
}
default {
set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj)
set tlc \u252c ;# [punk::char::charshort boxd_ldhz] ;#T shape (ttj)
set brc \u2524 ;# [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj)
}
}
}
down_right {
#6
set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj)
set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj)
set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj)
}
down_up {
#7
set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj)
set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj)
set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj)
set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj)
}
left_right {
#8
#from 2
set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft
set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj)
#from3
set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj)
set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj)
}
left_up {
#9
set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj)
set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj)
set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj)
}
right_up {
#10
set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj)
set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj)
set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj)
}
down_left_right {
#11
set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj)
set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj)
set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj)
set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj)
}
down_left_up {
#12
set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj)
set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj)
set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj)
set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj)
}
down_right_up {
#13
set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj)
set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj)
set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj)
set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj)
}
left_right_up {
#14
set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj)
set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj)
set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj)
set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj)
}
down_left_right_up {
#15
set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj)
set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj)
set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj)
set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj)
}
}
#four way junction (cd::fwj) (punk::ansi::g0 n) (punk::char::charshort lvhz) (+)
}
"heavy" {
#unicode box drawing set
set hl [punk::char::charshort boxd_hhz] ;# light horizontal
set hlt $hl
set hlb $hl
set vl [punk::char::charshort boxd_hv] ;#light vertical
set vll $vl
set vlr $vl
set tlc [punk::char::charshort boxd_hdr]
set trc [punk::char::charshort boxd_hdl]
set blc [punk::char::charshort boxd_hur]
set brc [punk::char::charshort boxd_hul]
#horizontal and vertical bar joins
set hltj $hlt
set hlbj $hlb
set vllj $vll
set vlrj $vlr
#set targetdown,targetleft,targetright,targetup vars
#default empty targets to current box type 'heavy'
foreach dir {down left right up} {
set target [dict get $join_targets $dir]
switch -- $target {
"" - heavy {
set target$dir heavy
}
light - ascii - altg - arc {
set target$dir light
}
default {
set target$dir other
}
}
}
switch -- $do_joins {
down {
#1
switch -- $targetdown {
light {
set blc [punk::char::charshort boxd_dlruh] ;#\u2521 down light and right up heavy (ltj)
set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj)
set hlbj \u252F ;#down light (ttj)
}
heavy {
set blc [punk::char::charshort boxd_hvr] ;# (ltj)
set brc [punk::char::charshort boxd_hvl] ;# (rtj)
set hlbj \u2533 ;# down heavy (ttj)
}
}
}
left {
#2
switch -- $targetleft {
light {
set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj)
set blc [punk::char::charshort boxd_llruh] ;#\u253a Left Light and Right Up Heavy (btj)
set vllj \u2528 ;# left light (rtj)
}
heavy {
set tlc [punk::char::charshort boxd_hdhz] ;# (ttj)
set blc [punk::char::charshort boxd_huhz] ;# (btj)
set vllj \u252b ;#(rtj)
}
}
}
right {
#3
switch -- $targetright {
light {
set trc [punk::char::charshort boxd_rlldh] ;#\u2531 Right Light and Left Down Heavy (ttj)
set brc [punk::char::charshort boxd_rlluh] ;#\u2539 Right Light and Left Up Heavy(btj)
set vlrj \u2520 ;#right light (ltj)
}
heavy {
set trc [punk::char::charshort boxd_hdhz] ;#T shape (ttj)
set brc [punk::char::charshort boxd_huhz] ;# (btj)
set vlrj \u2523 ;# (ltj)
}
}
}
up {
#4
switch -- $targetup {
light {
set tlc [punk::char::charshort boxd_ulrdh] ;#\u2522 Up Light and Right Down Heavy (ltj)
set trc [punk::char::charshort boxd_ulldh] ;#\u252a Up Light and Left Down Heavy (rtj)
set hltj \u2537 ;# up light (btj)
}
heavy {
set tlc [punk::char::charshort boxd_hvr] ;# (ltj)
set trc [punk::char::charshort boxd_hvl] ;# (rtj)
set hltj \u253b ;# (btj)
}
}
}
down_left {
#down_left is the main join type used for 'L' shaped cell border table building where we boxlimit to {vll hlb blc}
#5
switch -- down-$targetdown-left-$targetleft {
down-light-left-heavy {
set blc [punk::char::charshort boxd_dluhzh] ;#down light and up horizontal heavy (fwj)
set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj)
set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) (at tlc down stays heavy)
set hlbj \u252F ;# down light (ttj)
set vllj \u252b ;#(rtj)
}
down-heavy-left-light {
set blc [punk::char::charshort boxd_llrvh] ;# left light and right Vertical Heavy (fwj)
set brc [punk::char::charshort boxd_hvl] ;# (rtj) (at brc left must stay heavy)
set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj)
set hlbj \u2533 ;# down heavy (ttj)
set vllj \u2528 ;# left light (rtj)
}
down-light-left-light {
set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj)
set brc [punk::char::charshort boxd_dlluh] ;#\u2529 Down Light and left Up Heavy (rtj) (left must stay heavy)
set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) (we are in heavy - so down must stay heavy at tlc)
set hlbj \u252F ;# down light (ttj)
set vllj \u2528 ;# left light (rtj)
}
down-heavy-left-heavy {
set blc [punk::char::charshort boxd_hvhz] ;# (fwj)
set brc [punk::char::charshort boxd_hvl] ;# (rtj)
set tlc [punk::char::charshort boxd_hdhz] ;# (ttj)
set hlbj \u2533 ;#(ttj)
set vllj \u252b ;#(rtj)
}
down-other-left-heavy {
set blc \u253b ;#boxd_huhz Heavy Up and Horizontal (btj)
#leave brc default corner
set tlc \u2533 ;#hdhz Heavy Down and Horizontal (ttj)
set vllj \u252b ;#(rtj)
}
down-other-left-light {
set blc \u253a ;#llruh Left Light and Right Up Heavy (btj)
#leave brc default corner
set tlc \u2532 ;#llrdh Left Light and Right Down Heavy (ttj)
set vllj \u2528 ;# left light (rtj)
}
down-heavy-left-other {
set blc \u2523 ;#hvr Heavy Vertical and Right (ltj)
set brc \u252b ;#hvl Heavy Veritcal and Left (rtj)
#leave tlc default corner
set hlbj \u2533 ;#(ttj)
}
down-light-left-other {
set blc \u2521 ;#dlruh Down Light and Right Up Heavy (ltj)
set brc \u2529 ;#dlluh Down Light and Left Up Heavy (rtj)
#leave tlc default corner
set hlbj \u252F ;# down light (ttj)
}
}
}
down_right {
#6
set blc [punk::char::charshort boxd_hvr] ;# (ltj) (blc right&up stay heavy)
set trc [punk::char::charshort boxd_hdhz] ;# (ttj) (tlc down&left stay heavy)
set brc [punk::char::charshort boxd_hvhz] ;# (fwj) (brc left&up heavy)
}
down_up {
#7
set blc [punk::char::charshort boxd_hvr] ;# (ltj)
set brc [punk::char::charshort boxd_hvl] ;# (rtj)
set tlc [punk::char::charshort boxd_hvr] ;# (ltj)
set trc [punk::char::charshort boxd_hvl] ;# (rtj)
}
left_right {
#8
#from 2
set tlc [punk::char::charshort boxd_hdhz] ;# (ttj)
set blc [punk::char::charshort boxd_huhz] ;# (btj)
#from3
set trc [punk::char::charshort boxd_hdhz] ;# (ttj)
set brc [punk::char::charshort boxd_huhz] ;# (btj)
}
left_up {
#9
set tlc [punk::char::charshort boxd_hvhz] ;# (fwj)
set trc [punk::char::charshort boxd_hvl] ;# (rtj)
set blc [punk::char::charshort boxd_huhz] ;# (btj)
}
right_up {
#10
set tlc [punk::char::charshort boxd_hvr] ;# (ltj)
set trc [punk::char::charshort boxd_hvhz] ;# (fwj)
set brc [punk::char::charshort boxd_huhz] ;# (btj)
}
down_left_right {
#11
set blc [punk::char::charshort boxd_hvhz] ;# (fwj)
set brc [punk::char::charshort boxd_hvhz] ;# (fwj)
set trc [punk::char::charshort boxd_hdhz] ;# (ttj)
set tlc [punk::char::charshort boxd_hdhz] ;# (ttj)
}
down_left_up {
#12
set tlc [punk::char::charshort boxd_hvhz] ;# (fwj)
set blc [punk::char::charshort boxd_hvhz] ;# (fwj)
set trc [punk::char::charshort boxd_hvl] ;# (rtj)
set brc [punk::char::charshort boxd_hvl] ;# (rtj)
}
down_right_up {
#13
set tlc [punk::char::charshort boxd_hvr] ;# (ltj)
set blc [punk::char::charshort boxd_hvr] ;# (ltj)
set trc [punk::char::charshort boxd_hvhz] ;# (fwj)
set brc [punk::char::charshort boxd_hvhz] ;# (fwj)
}
left_right_up {
#14
set tlc [punk::char::charshort boxd_hvhz] ;# (fwj)
set trc [punk::char::charshort boxd_hvhz] ;# (fwj)
set blc [punk::char::charshort boxd_huhz] ;# (btj)
set brc [punk::char::charshort boxd_huhz] ;# (btj)
}
down_left_right_up {
#15
set tlc [punk::char::charshort boxd_hvhz] ;# (fwj)
set blc [punk::char::charshort boxd_hvhz] ;# (fwj)
set trc [punk::char::charshort boxd_hvhz] ;# (fwj)
set brc [punk::char::charshort boxd_hvhz] ;# (fwj)
}
}
}
"double" {
#unicode box drawing set
set hl [punk::char::charshort boxd_dhz] ;# double horizontal \U2550
set hlt $hl
set hlb $hl
set vl [punk::char::charshort boxd_dv] ;#double vertical \U2551
set vll $vl
set vlr $vl
set tlc [punk::char::charshort boxd_ddr] ;#double down and right \U2554
set trc [punk::char::charshort boxd_ddl] ;#double down and left \U2557
set blc [punk::char::charshort boxd_dur] ;#double up and right \U255A
set brc [punk::char::charshort boxd_dul] ;#double up and left \U255D
#horizontal and vertical bar joins
set hltj $hlt
set hlbj $hlb
set vllj $vll
set vlrj $vlr
# \u256c (fwj)
#set targetdown,targetleft,targetright,targetup vars
#default empty targets to current box type 'double'
foreach dir {down left right up} {
set target [dict get $join_targets $dir]
switch -- $target {
"" - double {
set target$dir double
}
light {
set target$dir light
}
default {
set target$dir other
}
}
}
#unicode provides no joining for double to anything else
#better to leave a gap by using default double corners if join target is not empty or double
switch -- $do_joins {
down {
#1
switch -- $targetdown {
double {
set blc \u2560 ;# (ltj)
set brc \u2563 ;# (rtj)
set hlbj \u2566 ;# (ttj)
}
light {
set hlbj \u2564 ;# down light (ttj)
}
}
}
left {
#2
switch -- $targetleft {
double {
set tlc \u2566 ;# (ttj)
set blc \u2569 ;# (btj)
set vllj \u2563 ;# (rtj)
}
light {
set vllj \u2562 ;# light left (rtj)
}
}
}
right {
#3
switch -- $targetright {
double {
set trc \u2566 ;# (ttj)
set brc \u2569 ;# (btj)
}
light {
set vlrj \u255F ;# light right (ltj)
}
}
}
up {
#4
switch -- $targetup {
double {
set tlc \u2560 ;# (ltj)
set trc \u2563 ;# (rtj)
set hltj \u2569 ;# (btj)
}
light {
set hltj \u2567 ;#up light (btj)
}
}
}
down_left {
#5
switch -- $targetdown-$targetleft {
double-double {
set blc \u256c ;# (fwj)
set brc \u2563 ;# (rtj)
set tlc \u2566 ;# (ttj)
set hlbj \u2566 ;# (ttj)
}
double-light {
#no corner joins treat corners like 'other'
set blc \u2560 ;# (ltj)
set brc \u2563 ;# (rtj)
set hlbj \u2566 ;# (ttj)
set vllj \u2562 ;# light left (rtj)
}
double-other {
set blc \u2560 ;# (ltj)
set brc \u2563 ;# (rtj)
#leave tlc as ordinary double corner
}
light-double {
set vllj \u2563 ;# (rtj)
set hlbj \u2564 ;# light down (ttj)
}
light-light {
set vllj \u2562 ;# light left (rtj)
set hlbj \u2564 ;# light down (ttj)
}
other-light {
set vllj \u2562 ;# light left (rtj)
}
other-double {
set blc \u2569 ;# (btj)
#leave brc as ordinary double corner
set tlc \u2566 ;# (ttj)
}
}
}
down_right {
#6
switch -- $targetdown-$targetright {
double-double {
set blc \u2560 ;# (ltj)
set trc \u2566 ;# (ttj)
set brc \u256c ;# (fwj)
set hlbj \u2566 ;# (ttj)
}
double-other {
set blc \u2560 ;# (ltj)
#leave trc default
set brc \u2563 ;# (rtj)
}
other-double {
#leave blc default
set trc \u2566 ;# (ttj)
set brc \u2569 ;#(btj)
}
}
}
down_up {
#7
switch -- $targetdown-$targetup {
double-double {
set blc \u2560 ;# (ltj)
set brc \u2563 ;# (rtj)
set tlc \u2560 ;# (ltj)
set trc \u2563 ;# (rtj)
set hltj \u2569 ;# (btj)
set hlbj \u2566 ;# (ttj)
}
}
}
left_right {
#8
#from 2
set tlc [punk::char::charshort boxd_hdhz] ;# (ttj)
set blc [punk::char::charshort boxd_huhz] ;# (btj)
#from3
set trc [punk::char::charshort boxd_hdhz] ;# (ttj)
set brc [punk::char::charshort boxd_huhz] ;# (btj)
}
left_up {
#9
set tlc [punk::char::charshort boxd_hvhz] ;# (fwj)
set trc [punk::char::charshort boxd_hvl] ;# (rtj)
set blc [punk::char::charshort boxd_huhz] ;# (btj)
set hltj \u2569 ;# (btj)
set vllj \u2563 ;# (rtj)
}
right_up {
#10
set tlc [punk::char::charshort boxd_hvr] ;# (ltj)
set trc [punk::char::charshort boxd_hvhz] ;# (fwj)
set brc [punk::char::charshort boxd_huhz] ;# (btj)
set hltj \u2569 ;# (btj)
set vlrj \u2560 ;# (ltj)
}
down_left_right {
#11
set blc [punk::char::charshort boxd_hvhz] ;# (fwj)
set brc [punk::char::charshort boxd_hvhz] ;# (fwj)
set trc [punk::char::charshort boxd_hdhz] ;# (ttj)
set tlc [punk::char::charshort boxd_hdhz] ;# (ttj)
set hlbj \u2566 ;# (ttj)
set vlrj \u2560 ;# (ltj)
}
down_left_up {
#12
set tlc [punk::char::charshort boxd_hvhz] ;# (fwj)
set blc [punk::char::charshort boxd_hvhz] ;# (fwj)
set trc [punk::char::charshort boxd_hvl] ;# (rtj)
set brc [punk::char::charshort boxd_hvl] ;# (rtj)
set hltj \u2569 ;# (btj)
set hlbj \u2566 ;# (ttj)
}
down_right_up {
#13
set tlc [punk::char::charshort boxd_hvr] ;# (ltj)
set blc [punk::char::charshort boxd_hvr] ;# (ltj)
set trc [punk::char::charshort boxd_hvhz] ;# (fwj)
set brc [punk::char::charshort boxd_hvhz] ;# (fwj)
set hltj \u2569 ;# (btj)
set hlbj \u2566 ;# (ttj)
}
left_right_up {
#14
set tlc [punk::char::charshort boxd_hvhz] ;# (fwj)
set trc [punk::char::charshort boxd_hvhz] ;# (fwj)
set blc [punk::char::charshort boxd_huhz] ;# (btj)
set brc [punk::char::charshort boxd_huhz] ;# (btj)
set hltj \u2569 ;# (btj)
}
down_left_right_up {
#15
set tlc [punk::char::charshort boxd_hvhz] ;# (fwj)
set blc [punk::char::charshort boxd_hvhz] ;# (fwj)
set trc [punk::char::charshort boxd_hvhz] ;# (fwj)
set brc [punk::char::charshort boxd_hvhz] ;# (fwj)
set hltj \u2569 ;# (btj)
set hlbj \u2566 ;# (ttj)
}
}
}
"arc" {
#unicode box drawing set
set hl [punk::char::charshort boxd_lhz] ;# light horizontal
set hlt $hl
set hlb $hl
set vl [punk::char::charshort boxd_lv] ;#light vertical
set vll $vl
set vlr $vl
set tlc [punk::char::charshort boxd_ladr] ;#light arc down and right \U256D
set trc [punk::char::charshort boxd_ladl] ;#light arc down and left \U256E
set blc [punk::char::charshort boxd_laur] ;#light arc up and right \U2570
set brc [punk::char::charshort boxd_laul] ;#light arc up and left \U256F
#horizontal and vertical bar joins
set hltj $hlt
set hlbj $hlb
set vllj $vll
set vlrj $vlr
#set targetdown,targetleft,targetright,targetup vars
#default empty targets to current box type 'arc'
foreach dir {down left right up} {
set target [dict get $join_targets $dir]
switch -- $target {
"" - arc {
set target$dir self
}
default {
set target$dir other
}
}
}
switch -- $do_joins {
down {
#1
switch -- $targetdown {
self {
set blc \u251c ;# *light (ltj)
#set blc \u29FD ;# misc math right-pointing curved angle bracket (ltj) - positioned too far left
#set blc \u227b ;# math succeeds char. joins on right ok - gaps top and bottom - almost passable
#set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal
#set brc \u2524 ;# *light(rtj)
#set brc \u29FC ;# misc math left-pointing curved angle bracket (rtj)
}
}
}
left {
#2
switch -- $targetleft {
self {
set tlc \u252c ;# *light(ttj) - need a low positioned curved y shape - nothing apparent
#set blc \u2144 ;# (btj) - upside down y - positioning too low for arc
set blc \u2534 ;# *light (btj)
}
}
}
right {
#3
switch -- $targetright {
self {
set trc \u252c ;# *light (ttj)
#set brc \u2144 ;# (btj)
set brc \u2534 ;# *light (btj)
}
}
}
up {
#4
switch -- $targetup {
self {
set tlc \u251c ;# *light (ltj)
set trc \u2524 ;# *light(rtj)
}
}
}
down_left {
#5
switch -- $targetdown-$targetleft {
self-self {
#set blc \u27e1 ;# white concave-sided diamond - positioned too far right
#set blc \u27e3 ;# concave sided diamond with rightwards tick - positioned too low, too right - big gaps
set brc \u2524 ;# *light (rtj)
set tlc \u252c ;# *light (ttj)
}
self-other {
#set blc \u2560 ;# (ltj)
#set brc \u2563 ;# (rtj)
#leave tlc as ordinary double corner
}
other-self {
#set blc \u2569 ;# (btj)
#leave brc as ordinary double corner
#set tlc \u2566 ;# (ttj)
}
}
}
}
}
block1 {
set hlt \u2581 ;# lower one eighth block
set hlb \u2594 ;# upper one eighth block
set vll \u258f ;# left one eighth block
set vlr \u2595 ;# right one eighth block
set tlc \u2581 ;# lower one eighth block
set trc \u2581 ;# lower one eighth block
set blc \u2594 ;# upper one eighth block
set brc \u2594 ;# upper one eight block
#horizontal and vertical bar joins
set hltj $hlt
set hlbj $hlb
set vllj $vll
set vlrj $vlr
}
blockxx {
set hlt \u2594 ;# upper one eighth block
set hlb \u2581 ;# lower one eighth block
set vll \u2595 ;# right one eighth block
set vlr \u258f ;# left one eighth block
set tlc \u2595 ;# right one eighth block
set trc \u258f ;# left one eighth block
set blc \u2595 ;# right one eighth block
set brc \u258f ;# left one eighth block
#horizontal and vertical bar joins
set hltj $hlt
set hlbj $hlb
set vllj $vll
set vlrj $vlr
}
block {
set hlt \u2580 ;#upper half
set hlb \u2584 ;#lower half
set vll \u258c ;#left half
set vlr \u2590 ;#right half
set tlc \u259b ;#upper left corner half
set trc \u259c
set blc \u2599
set brc \u259f
#horizontal and vertical bar joins
set hltj $hlt
set hlbj $hlb
set vllj $vll
set vlrj $vlr
}
default {
set default_custom [dict create hl " " vl " " tlc " " trc " " blc " " brc " "]
set custom_frame [dict merge $default_custom $f]
dict with custom_frame {} ;#extract keys as vars
if {[dict exists $custom_frame hlt]} {
set hlt [dict get $custom_frame hlt]
} else {
set hlt $hl
}
if {[dict exists $custom_frame hlb]} {
set hlb [dict get $custom_frame hlb]
} else {
set hlb $hl
}
if {[dict exists $custom_frame vll]} {
set vll [dict get $custom_frame vll]
} else {
set vll $vl
}
if {[dict exists $custom_frame vlr]} {
set vlr [dict get $custom_frame vlr]
} else {
set vlr $vl
}
#horizontal and vertical bar joins
set hltj $hlt
set hlbj $hlb
set vllj $vll
set vlrj $vlr
}
}
if {$boxonly} {
set result [dict create\
tlc $tlc hlt $hlt trc $trc\
vll $vll vlr $vlr\
blc $blc hlb $hlb brc $brc\
]
dict set framedef_cache $cache_key $result
return $result
} else {
set result [dict create\
tlc $tlc hlt $hlt trc $trc\
vll $vll vlr $vlr\
blc $blc hlb $hlb brc $brc\
hltj $hltj\
hlbj $hlbj\
vllj $vllj\
vlrj $vlrj\
]
dict set framedef_cache $cache_key $result
return $result
}
}
variable frame_cache
set frame_cache [dict create]
proc frame_cache {{action ""}} {
if {$action ni [list clear ""]} {
error "frame_cache action '$action' not understood. Valid actions: clear"
}
variable frame_cache
set out ""
if {[catch {
set termwidth [dict get [punk::console::get_size] columns]
}]} {
set termwidth 80
}
dict for {k v} $frame_cache {
lassign $v _f frame _used used
#set fwidth [textblock::widthtopline $frame]
#review - are cached frames uniform width lines?
set fwidth [textblock::width $frame]
set frameinfo "$k used:$used "
set allinone_width [expr {[string length $frameinfo] + $fwidth}]
if {$allinone_width >= $termwidth} {
#split across 2 lines
append out "$frameinfo\n"
append out $frame \n
} else {
append out [textblock::join $frameinfo $frame]\n
}
append out \n ;# frames used to build tables often have joins - keep a line in between for clarity
}
if {$action eq "clear"} {
set frame_cache [dict create]
append out \nCLEARED
}
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.
proc frame {args} {
variable frametypes
set expect_optval 0
set argposn 0
set pmax [expr {[llength $args]-1}]
set has_contents 0 ;#differentiate between empty string and no content supplied
set contents ""
set arglist [list]
foreach a $args {
if {!$expect_optval} {
if {$argposn < $pmax} {
if {[string match -* $a]} {
set expect_optval 1
lappend arglist $a
} else {
error "textblock::frame expects -option <value> pairs"
}
} else {
set has_contents 1
set contents $a
}
} else {
lappend arglist $a
set expect_optval 0
}
incr argposn
}
#set contents [lindex $args end]
#set arglist [lrange $args 0 end-1]
if {[llength $arglist] % 2 != 0} {
error "Usage frame ?-type unicode|altg|ascii|<dict hl (c) vl (c) tlc (c) trc (c) blc (c) brc (c)>? ?-title <ansitext>? ?-subtitle <ansitext>? ?-width <columns>? ?-ansiborder <ansi_sgr>? ?-boxlimits hl|hlt|hlb|vl|vll|vlr|tlc|blc|brc? ?-joins left|right|up|down? <contents>"
}
#todo args -justify left|centre|right (center)
set defaults [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
set opts [dict merge $defaults $arglist]
foreach {k v} $opts {
switch -- $k {
-etabs - -type - -boxlimits - -boxmap - -joins - -title - -subtitle - -width - -height - -ansiborder - -ansibase - -blockalign - -textalign - -ellipsis - -usecache - -buildcache {}
default {
error "frame option '$k' not understood. Valid options are [dict keys $defaults]"
}
}
}
# -- --- --- --- --- ---
set opt_etabs [dict get $opts -etabs]
set opt_type [dict get $opts -type]
set opt_boxlimits [dict get $opts -boxlimits]
set opt_joins [dict get $opts -joins]
set opt_boxmap [dict get $opts -boxmap]
set opt_usecache [dict get $opts -usecache]
set opt_buildcache [dict get $opts -buildcache]
set usecache $opt_usecache ;#may need to override
set buildcache $opt_buildcache
set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc]
set known_frametypes $frametypes ;# light, heavey etc as defined in textblock::frametypes variable
set default_custom [dict create hl " " vl " " tlc " " trc " " blc " " brc " "]
lassign [textblock::frametype $opt_type] _cat category _type ftype
if {$category eq "custom"} {
set custom_frame $ftype
set frameset "custom"
set framedef $custom_frame
} else {
#category = predefined
set frameset $ftype ;# light,heavy etc
set framedef $ftype
}
set is_boxlimits_ok 1
set exact_boxlimits [list]
foreach v $opt_boxlimits {
switch -- $v {
hl {
lappend exact_boxlimits hlt hlb
}
vl {
lappend exact_boxlimits vll vlr
}
hlt - hlb - vll - vlr - tlc - trc - blc - brc {
lappend exact_boxlimits $v
}
default {
#k not in custom_keys
set is_boxlimits_ok 0
break
}
}
}
if {!$is_boxlimits_ok} {
error "frame option -boxlimits '$opt_boxlimits' must contain only values from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc"
}
set exact_boxlimits [lsort -unique $exact_boxlimits]
set is_joins_ok 1
foreach v $opt_joins {
lassign [split $v -] direction target
switch -- $direction {
left - right - up - down {}
default {
set is_joins_ok 0
break
}
}
switch -- $target {
"" - light - heavy - ascii - altg - arc - double - custom - block - block1 {}
default {
set is_joins_ok 0
break
}
}
}
if {!$is_joins_ok} {
error "frame option -joins '$opt_joins' must contain only values from the set: left,right,up,down with targets heavy,light,ascii,altg,arc,double,block,block1,custom e.g down-light"
}
set is_boxmap_ok 1
dict for {boxelement subst} $opt_boxmap {
switch -- $boxelement {
hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {}
default {
set is_boxmap_ok 0
break
}
}
}
if {!$is_boxmap_ok} {
error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc"
}
#sorted order down left right up
#1 x choose 4
#4 x choose 3
#6 x choose 2
#4 x choose 1
#15 combos
set join_directions [list]
#targets - light,heavy (double?) - seem to be some required glyphs missing from unicode
#e.g down-light, up-heavy
set join_targets [dict create left "" down "" right "" up ""]
foreach jt $opt_joins {
lassign [split $jt -] direction target
if {$target ne ""} {
dict set join_targets $direction $target
}
lappend join_directions $direction
}
set join_directions [lsort -unique $join_directions]
set do_joins [::join $join_directions _]
# -- --- --- --- --- ---
set opt_title [dict get $opts -title]
set opt_subtitle [dict get $opts -subtitle]
set opt_width [dict get $opts -width]
set opt_height [dict get $opts -height]
# -- --- --- --- --- ---
set opt_blockalign [dict get $opts -blockalign]
switch -- $opt_blockalign {
left - right - centre - center {}
default {
error "frame option -blockalign must be left|right|centre|center - received: $opt_blockalign"
}
}
#these are all valid commands for overtype::<cmd>
# -- --- --- --- --- ---
set opt_textalign [dict get $opts -textalign]
switch -- $opt_textalign {
left - right - centre - center {}
default {
error "frame option -textalign must be left|right|centre|center - received: $opt_textalign"
}
}
# -- --- --- --- --- ---
set opt_ansiborder [dict get $opts -ansiborder]
set opt_ansibase [dict get $opts -ansibase] ;#experimental
set opt_ellipsis [dict get $opts -ellipsis]
# -- --- --- --- --- ---
if {$has_contents} {
if {[string last \t $contents] >= 0} {
if {[info exists punk::console::tabwidth]} {
set tw $::punk::console::tabwidth
} else {
set tw 8
}
if {$opt_etabs} {
set contents [textutil::tabify::untabify2 $contents $tw]
}
}
set contents [string map [list \r\n \n] $contents]
set actual_contentwidth [textblock::width $contents] ;#length of longest line in contents (contents can be ragged)
set actual_contentheight [textblock::height $contents]
} else {
set actual_contentwidth 0
set actual_contentheight 0
}
if {$opt_title ne ""} {
set titlewidth [punk::ansi::printing_length $opt_title]
set content_or_title_width [expr {max($actual_contentwidth,$titlewidth)}]
} else {
set titlewith 0
set content_or_title_width $actual_contentwidth
}
if {$opt_width eq ""} {
set frame_inner_width $content_or_title_width
} else {
set frame_inner_width [expr {max(0,$opt_width - 2)}] ;#default
}
if {$opt_height eq ""} {
set frame_inner_height $actual_contentheight
} else {
set frame_inner_height [expr {max(0,$opt_height -2)}] ;#default
}
if {$frame_inner_height == 0 && $frame_inner_width == 0} {
set has_contents 0
}
#todo - render it with vertical overflow so we can process ansi moves?
#set linecount [textblock::height $contents]
set linecount $frame_inner_height
# -- --- --- --- --- --- --- --- ---
variable frame_cache
#review - custom frame affects frame_inner_width - exclude from caching?
#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 [md5::md5 -hex $hashables]
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
#e.g BMP PUA U+E000 -> U+F8FF - although this is commonly used for example by nerdfonts
#also supplementary private use blocks
#however these display double wide on for example cmd terminal despite having wcswidth 1 (makes layout debugging difficult)
#U+F0000 -> U+FFFD
#U+100000 -> U+10FFFD
#FSUB options: \uf0ff \uF1FF \uf2ff (no nerdfont glyphs - should look like standard replacement char) \uF2DD (circular thingy)
#should be something someone is unlikely to use as part of a custom frame character.
#ideally a glyph that doesn't auto-expand into whitespace and is countable when in a string (narrower is better)
#As nerdfont glyphs tend to be mostly equal height & width - circular glyphs tend to be more distinguishable in a string
#terminal settings may need to be adjusted to stop auto glyph resizing - a rather annoying misfeature that some people seem to think they like.
#e.g in wezterm config: allow_square_glyphs_to_overflow_width = "Never"
#review - we could consider wasting a few cycles to check for a conflict and use a different FSUB
set FSUB \uF2DD
#this occurs commonly in table building with colspans - review
if {$actual_contentwidth > $frame_inner_width || $actual_contentheight != $frame_inner_height} {
set usecache 0
#set buildcache 0 ;#comment out for debug/analysis so we can see
#puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'"
set cache_key [a+ Web-red web-white]$cache_key[a]
}
if {$buildcache && $actual_contentwidth < $frame_inner_width} {
#colourise cache_key to warn
if {$actual_contentwidth == 0} {
#we can still substitute with right length
set cache_key [a+ Web-steelblue web-black]$cache_key[a]
} else {
#actual_contentwidth is narrower than frame - check template's patternwidth
if {[dict exists $frame_cache $cache_key]} {
set cache_patternwidth [dict get $frame_cache $cache_key patternwidth]
} else {
set cache_patternwidth [$actual_contentwidth]
}
if {$actual_contentwidth < $cache_patternwidth} {
set usecache 0
set cache_key [a+ Web-orange web-black]$cache_key[a]
} elseif {$actual_contentwidth == $cache_patternwidth} {
#set usecache 1
} else {
#actual_contentwidth > pattern
set usecache 0
set cache_key [a+ Web-red web-black]$cache_key[a]
}
}
}
#JMN debug
#set usecache 0
set is_cached 0
if {$usecache && [dict exists $frame_cache $cache_key]} {
set cache_patternwidth [dict get $frame_cache $cache_key patternwidth]
set template [dict get $frame_cache $cache_key frame]
set used [dict get $frame_cache $cache_key used]
dict set frame_cache $cache_key used [expr {$used+1}] ;#update existing record
set is_cached 1
}
# -- --- --- --- --- --- --- --- ---
if {!$is_cached} {
set rst [a]
#set column [string repeat " " $frame_inner_width] ;#default - may need to override for custom frame
set underlayline [string repeat " " $frame_inner_width]
set underlay [::join [lrepeat $linecount $underlayline] \n]
set vll_width 1 ;#default for all except custom (printing width)
set vlr_width 1
set framedef [textblock::framedef $framedef -joins $opt_joins]
dict with framedef {} ;#extract vll,hlt,tlc etc vars
#puts "---> $opt_boxmap"
#review - we handle double-wide in custom frames - what about for boxmaps?
dict for {boxelement sub} $opt_boxmap {
if {$boxelement eq "vl"} {
set vll $sub
set vlr $sub
set hl $sub
} elseif {$boxelement eq "hl"} {
set hlt $sub
set hlb $sub
set hl $sub
} else {
set $boxelement $sub
}
}
switch -- $frameset {
custom {
#REVIEW - textblock::table assumes that at least the vl elements are 1-wide
#generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though
#if no ansi, these widths are reasonable to maintain in grapheme_width_cached indefinitely
set vll_width [punk::ansi::printing_length $vll]
set hlb_width [punk::ansi::printing_length $hlb]
set hlt_width [punk::ansi::printing_length $hlt]
set vlr_width [punk::ansi::printing_length $vlr]
set tlc_width [punk::ansi::printing_length $tlc]
set trc_width [punk::ansi::printing_length $trc]
set blc_width [punk::ansi::printing_length $blc]
set brc_width [punk::ansi::printing_length $brc]
set framewidth [expr {$frame_inner_width + 2}] ;#reverse default assumption
if {$opt_width eq ""} {
#width wasn't specified - so user is expecting frame to adapt to title/contents
#content shouldn't truncate because of extra wide frame
#review - punk::console::get_size ? wrapping? quite hard to support with colspans
set frame_inner_width $content_or_title_width
set tbarwidth [expr {$content_or_title_width + 2 - $tlc_width - $trc_width - 2 + $vll_width + $vlr_width}] ;#+/2's for difference between border element widths and standard element single-width
set bbarwidth [expr {$content_or_title_width + 2 - $blc_width - $brc_width - 2 + $vll_width + $vlr_width}]
} else {
set frame_inner_width [expr $opt_width - $vll_width - $vlr_width] ;#content may be truncated
set tbarwidth [expr {$opt_width - $tlc_width - $trc_width}]
set bbarwidth [expr {$opt_width - $blc_width - $brc_width}]
}
#set column [string repeat " " $frame_inner_width]
set underlayline [string repeat " " $frame_inner_width]
set underlay [::join [lrepeat $linecount $underlayline] \n]
#cache?
if {$hlt_width == 1} {
set tbar [string repeat $hlt $tbarwidth]
} else {
#possibly mixed width chars that make up hlt - string range won't get width right
set blank [string repeat " " $tbarwidth]
if {$hlt_width > 0} {
set count [expr {($tbarwidth / $hlt_width) + 1}]
} else {
set count 0
}
set tbar [string repeat $hlt $count]
#set tbar [string range $tbar 0 $tbarwidth-1]
set tbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $tbar];#spaces for exposed halves of 2w chars instead of default replacement character
}
if {$hlb_width == 1} {
set bbar [string repeat $hlb $bbarwidth]
} else {
set blank [string repeat " " $bbarwidth]
if {$hlb_width > 0} {
set count [expr {($bbarwidth / $hlb_width) + 1}]
} else {
set count 0
}
set bbar [string repeat $hlb $count]
#set bbar [string range $bbar 0 $bbarwidth-1]
set bbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $bbar]
}
}
altg {
set tbar [string repeat $hlt $frame_inner_width]
set tbar [cd::groptim $tbar]
set bbar [string repeat $hlb $frame_inner_width]
set bbar [cd::groptim $bbar]
}
default {
set tbar [string repeat $hlt $frame_inner_width]
set bbar [string repeat $hlb $frame_inner_width]
}
}
set leftborder 0
set rightborder 0
set topborder 0
set bottomborder 0
# hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {}
#puts "----->$exact_boxlimits"
foreach lim $exact_boxlimits {
switch -- $lim {
hlt {
set topborder 1
}
hlb {
set bottomborder 1
}
vll {
set leftborder 1
}
vlr {
set rightborder 1
}
tlc {
set topborder 1
set leftborder 1
}
trc {
set topborder 1
set rightborder 1
}
blc {
set bottomborder 1
set leftborder 1
}
brc {
set bottomborder 1
set rightborder 1
}
}
}
if {$opt_width ne "" && $opt_width < 2} {
set rightborder 0
}
#keep lhs/rhs separate? can we do vertical text on sidebars?
set lhs [string repeat $vll\n $linecount]
set lhs [string range $lhs 0 end-1]
set rhs [string repeat $vlr\n $linecount]
set rhs [string range $rhs 0 end-1]
if {$opt_ansiborder ne ""} {
set tbar $opt_ansiborder$tbar$rst
set bbar $opt_ansiborder$bbar$rst
set tlc $opt_ansiborder$tlc$rst
set trc $opt_ansiborder$trc$rst
set blc $opt_ansiborder$blc$rst
set brc $opt_ansiborder$brc$rst
set lhs $opt_ansiborder$lhs$rst ;#wrap the whole block and let textblock::join figure it out
set rhs $opt_ansiborder$rhs$rst
}
#boxlimits used for partial borders in table generation
set all_exact_boxlimits [list vll vlr hlt hlb tlc blc trc brc]
set unspecified_limits [struct::set difference $all_exact_boxlimits $exact_boxlimits]
foreach lim $unspecified_limits {
switch -- $lim {
vll {
set blank_vll [string repeat " " $vll_width]
set lhs [string repeat $blank_vll\n $linecount]
set lhs [string range $lhs 0 end-1]
}
vlr {
set blank_vlr [string repeat " " $vlr_width]
set rhs [string repeat $blank_vlr\n $linecount]
set rhs [string range $rhs 0 end-1]
}
hlt {
set bar_width [punk::ansi::printing_length $tbar]
set tbar [string repeat " " $bar_width]
}
tlc {
set tlc_width [punk::ansi::printing_length $tlc]
set tlc [string repeat " " $tlc_width]
}
trc {
set trc_width [punk::ansi::printing_length $trc]
set trc [string repeat " " $trc_width]
}
hlb {
set bar_width [punk::ansi::printing_length $bbar]
set bbar [string repeat " " $bar_width]
}
blc {
set blc_width [punk::ansi::printing_length $blc]
set blc [string repeat " " $blc_width]
}
brc {
set brc_width [punk::ansi::printing_length $brc]
set brc [string repeat " " $brc_width]
}
}
}
if {$opt_title ne ""} {
set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off
} else {
set topbar $tbar
}
if {$opt_subtitle ne ""} {
set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off
} else {
set bottombar $bbar
}
if {$opt_ansibase eq ""} {
set rstbase [a]
} else {
set rstbase [a]$opt_ansibase
}
if {$opt_title ne ""} {
#title overrides -boxlimits for topborder
set topborder 1
}
set fs ""
set fscached ""
set cache_patternwidth 0
#todo - output nothing except maybe newlines depending on if opt_height 0 and/or opt_width 0?
if {$topborder} {
if {$leftborder && $rightborder} {
append fs $tlc$topbar$trc
} else {
if {$leftborder} {
append fs $tlc$topbar
} elseif {$rightborder} {
append fs $topbar$trc
} else {
append fs $topbar
}
}
}
append fscached $fs
if {$has_contents || $opt_height > 2} {
#if {$topborder && $fs ne "xx"} {
# append fs \n
#}
if {$topborder} {
append fs \n
append fscached \n
}
switch -- $opt_textalign {
right {set pad "left"}
left {set pad "right"}
default {set pad $opt_textalign}
}
#set textaligned_contents [textblock::pad $contents -width $actual_contentwidth -which $pad -within_ansi 1]
#set inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$textaligned_contents]
set cache_contentline [string repeat $FSUB $actual_contentwidth]
set cache_patternwidth $actual_contentwidth
set cache_contentpattern [::join [lrepeat $linecount $cache_contentline] \n]
set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$cache_contentpattern]
#after overtype::block - our actual patternwidth may be less
set cache_patternwidth [string length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]]
if {$leftborder && $rightborder} {
#set bodyparts [list $lhs $inner $rhs]
set cache_bodyparts [list $lhs $cache_inner $rhs]
} else {
if {$leftborder} {
#set bodyparts [list $lhs $inner]
set cache_bodyparts [list $lhs $cache_inner]
} elseif {$rightborder} {
#set bodyparts [list $inner $rhs]
set cache_bodyparts [list $cache_inner $rhs]
} else {
#set bodyparts [list $inner]
set cache_bodyparts [list $cache_inner]
}
}
#set body [textblock::join -- {*}$bodyparts]
set cache_body [textblock::join -- {*}$cache_bodyparts]
append fscached $cache_body
#append fs $body
}
if {$opt_height eq "" || $opt_height > 1} {
if {$opt_subtitle ne ""} {
#subtitle overrides boxlimits for bottomborder
set bottomborder 1
}
if {$bottomborder} {
if {($topborder & $fs ne "xx" ) || ($has_contents || $opt_height > 2)} {
#append fs \n
append fscached \n
}
if {$leftborder && $rightborder} {
#append fs $blc$bottombar$brc
append fscached $blc$bottombar$brc
} else {
if {$leftborder} {
#append fs $blc$bottombar
append fscached $blc$bottombar
} elseif {$rightborder} {
#append fs $bottombar$brc
append fscached $bottombar$brc
} else {
#append fs $bottombar
append fscached $bottombar
}
}
}
}
set template $fscached
;#end !$is_cached
}
#use the same mechanism to build the final frame - whether from cache or template
if {$actual_contentwidth == 0} {
set fs [string map [list $FSUB " "] $template]
} else {
set resultlines [list]
set overwritable [string repeat $FSUB $cache_patternwidth]
set contentindex 0
switch -- $opt_textalign {
left {set pad right}
right {set pad left}
default {set pad $opt_textalign}
}
#review
if {[string is integer -strict $opt_height] && $actual_contentheight < ($opt_height -2)} {
set diff [expr {($opt_height -2) - $actual_contentheight}]
append contents [::join [lrepeat $diff \n] ""]
}
set paddedcontents [textblock::pad $contents -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth)
set paddedwidth [textblock::widthtopline $paddedcontents]
#review - horizontal truncation
if {$paddedwidth > $cache_patternwidth} {
set paddedcontents [overtype::renderspace -width $cache_patternwidth "" $paddedcontents]
}
set contentblock [textblock::join $paddedcontents] ;#make sure each line has ansi replays
set tlines [split $template \n]
#we will need to strip off the leading reset on each line when stitching together with template lines so that ansibase can come into play too.
#after textblock::join the reset will be a separate code ie should be exactly ESC[0m
set R [a]
set rlen [string length $R]
set clines [split $contentblock \n]
foreach tline $tlines {
if {[string first $FSUB $tline] >= 0} {
set content_line [lindex $clines $contentindex]
if {[string first $R $content_line] == 0} {
set content_line [string range $content_line $rlen end]
}
#make sure to replay opt_ansibase to the right of the replacement
lappend resultlines [string map [list $overwritable $content_line$opt_ansibase] $tline]
incr contentindex
} else {
lappend resultlines $tline
}
}
set fs [::join $resultlines \n]
}
if {$is_cached} {
return $fs
} else {
if {$buildcache} {
dict set frame_cache $cache_key [list frame $template used 0 patternwidth $cache_patternwidth]
}
return $fs
}
}
proc gcross {{size 1} args} {
if {$size == 0} {
return ""
}
set defaults [list\
-max_cross_size 0
]
set opts [dict merge $defaults $args]
set opt_max_cross_size [dict get $opts -max_cross_size]
#set fit_size [punk::lib::greatestOddFactor $size]
set fit_size $size
if {$opt_max_cross_size == 0} {
set max_cross_size $fit_size
} else {
#todo - only allow divisors
#set testsize [expr {min($fit_size,$opt_max_cross_size)}]
set factors [punk::lib::factors $size]
#pick odd size in list that is smaller or equal to test_size
set max_cross_size [lindex $factors end]
set last_ok [lindex $factors 0]
for {set i 0} {$i < [llength $factors]} {incr i} {
set s [lindex $factors $i]
if {$s > $opt_max_cross_size} {
break
}
set last_ok $s
}
set max_cross_size $last_ok
}
set crosscount [expr {$size / $max_cross_size}]
package require punk::char
set x [punk::char::charshort boxd_ldc]
set bs [punk::char::charshort boxd_ldgullr]
set fs [punk::char::charshort boxd_ldgurll]
set onecross ""
set crossrows [list]
set armsize [expr {int(floor($max_cross_size /2))}]
set row [lrepeat $max_cross_size " "]
#toparm
for {set i 0} {$i < $armsize} {incr i} {
set r $row
lset r $i $bs
lset r end-$i $fs
#append onecross [::join $r ""] \n
lappend crossrows [::join $r ""]
}
if {$max_cross_size % 2 != 0} {
#only put centre cross in for odd sized crosses
set r $row
lset r $armsize $x
#append onecross [::join $r ""] \n
lappend crossrows [::join $r ""]
}
for {set i [expr {$armsize -1}]} {$i >= 0} {incr i -1} {
set r $row
lset r $i $fs
lset r end-$i $bs
#append onecross [::join $r ""] \n
lappend crossrows [::join $r ""]
}
#set onecross [string trimright $onecross \n]
set onecross [::join $crossrows \n]
#fastest to do row first then columns - because textblock::join must do line by line
if {$crosscount > 1} {
package require textblock
set row [textblock::join {*}[lrepeat $crosscount $onecross]]
set rows [lrepeat $crosscount $row]
set out [::join $rows \n]
} else {
set out $onecross
}
return $out
}
#Test we can join two coloured blocks
proc test_colour {} {
set b1 [a= red]1\n2\n3[a=]
set b2 [a= green]a\nb\nc[a=]
set result [textblock::join $b1 $b2]
puts $result
#return [list $b1 $b2 $result]
return [ansistring VIEW $result]
}
namespace import ::punk::ansi::stripansi
}
namespace eval ::textblock::piper {
namespace export *
proc join {rhs pipelinedata} {
tailcall ::textblock::join -- $pipelinedata $rhs
}
}
interp alias {} piper_blockjoin {} ::textblock::piper::join
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide textblock [namespace eval textblock {
variable version
set version 999999.0a1.0
}]
return