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.
284 Commits
1 Branch
1 Tag
197 MiB
 
 
 
 
 
 
Tree: 5336b12bd5
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '5336b12bd5'
${ noResults }
punkshell/src/modules/textblock-999999.0a1.0.tm

8520 lines
434 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
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_textblock 0 999999.0a1.0]
#[copyright "2024"]
#[titledesc {punk textblock functions}] [comment {-- Name section and table of contents description --}]
#[moddesc {punk textblock}] [comment {-- Description at end of page heading --}]
#[require textblock]
#[keywords module ansi text layout colour table frame console terminal]
#[description]
#[para] Ansi-aware terminal textblock manipulation
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of textblock
#[subsection Concepts]
#[para]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by textblock
#[list_begin itemized]
#*** !doctools
#[item] [package {Tcl 8.6-}]
#[item] [package {punk::args}]
#[item] [package {punk::char}]
#[item] [package {punk::ansi}]
#[item] [package {punk::lib}]
#[item] [package {overtype}]
#[item] [package {term::ansi::code::macros}]
#[item] [package {textutil}]
## Requirements
package require Tcl 8.6-
package require punk::args
package require punk::char
package require punk::ansi
package require punk::lib
catch {package require patternpunk}
package require overtype
#safebase interps as at 2024-08 can't access deeper paths - even though they are below the supposed safe list.
if {[catch {
package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional?
} errM]} {
#catch this too in case stderr not available
catch {
puts stderr "textblock package failed to load term::ansi::code::macros with error: $errM"
}
}
package require textutil
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval textblock {
#review - what about ansi off in punk::console?
tcl::namespace::import ::punk::ansi::a ::punk::ansi::a+
tcl::namespace::export block frame frame_cache framedef frametypes gcross height width widthtopline join join_basic list_as_table pad testblock
#NOTE sha1, although computationally more intensive, tends to be faster than md5 on modern cpus
#(more likely to be optimised for modern cpu features?)
#(This speed improvement may not apply for short strings)
variable use_hash ;#framecache
set use_hash none ;#slightly faster but uglier layout for viewing frame_cache display
#if {![catch {package require sha1}]} {
# set use_hash sha1
#} elseif {![catch {package require md5}]} {
# set use_hash md5
#} else {
# set use_hash none
#}
proc use_hash {args} {
set choices [list none]
set unavailable [list]
set pkgs [package names]
if {"md5" in $pkgs} {
lappend choices md5
} else {
lappend unavailable md5
}
if {"sha1" in $pkgs} {
lappend choices sha1
} else {
lappend unavailable sha1
}
set choicemsg ""
if {[llength $unavailable]} {
set choicemsg " (unavailable packages: $unavailable)"
}
set argd [punk::args::get_dict [tstr -return string {
@id -id ::textblock::use_hash
@cmd -name "textblock::use_hash" -help\
"Hashing algorithm to use for framecache lookup.
'none' may be slightly faster but less compact
when viewing textblock::framecache"
@values -min 0 -max 1
hash_algorithm -choices {${$choices}} -optional 1 -help\
"algorithm choice ${$choicemsg}"
}] $args]
variable use_hash
if {![dict exists $argd received hash_algorithm]} {
return $use_hash
}
set use_hash [dict get $argd values hash_algorithm]
}
tcl::namespace::eval class {
variable opts_table_defaults
set opts_table_defaults [tcl::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 ""\
]
variable opts_column_defaults
set opts_column_defaults [tcl::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
#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 [tcl::dict::create\
topleft [struct::set intersect $C [concat $tops $lefts]]\
topinner [struct::set intersect $C $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 [tcl::dict::create\
topleft [struct::set intersect $C [list {*}$tops {*}$lefts]]\
topinner [struct::set intersect $C $tops]\
topright [struct::set intersect $O [list {*}$tops {*}$rights]]\
topsolo [struct::set intersect $O [list {*}$tops {*}$lefts {*}$rights]]\
middleleft [struct::set intersect $L $lefts]\
middleinner [list]\
middleright [struct::set intersect $U $rights]\
middlesolo [struct::set intersect $U [list {*}$lefts {*}$rights]]\
bottomleft [struct::set intersect $L $lefts]\
bottominner [list]\
bottomright [struct::set intersect $U $rights]\
bottomsolo [struct::set intersect $U [list {*}$lefts {*}$rights]]\
onlyleft [struct::set intersect $C [list {*}$tops {*}$lefts]]\
onlyinner [struct::set intersect $C $tops]\
onlyright [struct::set intersect $O [list {*}$tops {*}$rights]]\
onlysolo [struct::set intersect $O [list {*}$tops {*}$lefts {*}$rights]]\
]
variable table_hseps
set table_hseps [tcl::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 [tcl::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]\
]
#ensembles seem to be not compiled in safe interp
#https://core.tcl-lang.org/tcl/tktview/1095bf7f75
#as we want textblock to be usable in safe interps - use tcl::dict::for as a partial workaround
#This at least means the script argument, especially switch statements can get compiled.
#It does however affect all ensemble commands - so even 'dict get/set' etc won't be as efficient in a safe interp.
#e.g $t configure -framemap_body [table_edge_map " "]
# -- --- --- --- ---
#unused?
proc table_edge_map {char} {
variable table_edge_parts
set map [list]
tcl::dict::for {celltype parts} $table_edge_parts {
set tmap [list]
foreach p $parts {
tcl::dict::set tmap $p $char
}
tcl::dict::set map $celltype $tmap
}
return $map
}
proc table_sep_map {char} {
variable table_hseps
set map [list]
tcl::dict::for {celltype parts} $table_hseps {
set tmap [list]
foreach p $parts {
tcl::dict::set tmap $p $char
}
tcl::dict::set map $celltype $tmap
}
return $map
}
proc header_edge_map {char} {
variable header_edge_parts
set map [list]
tcl::dict::for {celltype parts} $header_edge_parts {
set tmap [list]
foreach p $parts {
tcl::dict::set tmap $p $char
}
tcl::dict::set map $celltype $tmap
}
return $map
}
# -- --- --- --- ---
if {[tcl::info::commands [tcl::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]
#this makes new table objects a little faster when multiple opts specified as well as to configure
#as tables are a heavyweight thing, but handy to nest sometimes - we'll take what we can get
set topt_keys [tcl::dict::keys $::textblock::class::opts_table_defaults]
set switch_keys_valid_topts [punk::lib::lmapflat v $topt_keys {list $v -}]
set switch_keys_valid_topts [lrange $switch_keys_valid_topts 0 end-1] ;#remove last dash
set copt_keys [tcl::dict::keys $::textblock::class::opts_column_defaults]
set switch_keys_valid_copts [punk::lib::lmapflat v $copt_keys {list $v -}]
set switch_keys_valid_copts [lrange $switch_keys_valid_copts 0 end-1]
oo::class create [tcl::namespace::current]::table [tcl::string::map [list %topt_keys% $topt_keys %topt_switchkeys% $switch_keys_valid_topts %copt_keys% $copt_keys %copt_switchkeys% $switch_keys_valid_copts] {
#*** !doctools
#[enum] CLASS [class textblock::class::table]
#[list_begin definitions]
#[para] Create a table suitable for terminal output with various border styles.
#[para] The table can contain multiline cells and ANSI colour and text style attributes.
#[para] Multiple header rows can be configured.
#[para] Header rows can span columns - data rows cannot.
#[para] The restriction on data rows is to maintain compatibility of the data with a Tcl matrix command
#[para] (see get_matrix command)
#[para] Both header and data cells can have various text and blockalignments configured.
# [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_headerdefs
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]]
#[para] TODO - document the many options
set o_opts_table_defaults $::textblock::class::opts_table_defaults
set o_opts_column_defaults $::textblock::class::opts_column_defaults
if {[llength $args] == 1} {
set args [list -title [lindex $args 0]]
}
if {[llength $args] %2 !=0} {
error "[tcl::namespace::current]::table constructor - unexpected argument count. Require single value being title, or name value pairs"
}
set o_opts_table $o_opts_table_defaults
set o_opts_table_effective $o_opts_table_defaults
##todo - test with punk::lib::show_jump_tables - how?
foreach {k v} $args {
switch -- $k {
%topt_switchkeys% {
tcl::dict::set o_opts_table $k $v
}
default {
error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]"
}
}
}
#foreach {k v} $args {
# #todo - convert to literal switch using tcl::string::map so we don't have to define o_opts_table_defaults here.
# if {$k ni [tcl::dict::keys $o_opts_table_defaults]} {
# error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]"
# }
#}
#set o_opts_table [tcl::dict::merge $o_opts_table_defaults $args]
#my configure {*}[tcl::dict::merge $o_opts_table_defaults $args]
set o_columndefs [tcl::dict::create]
set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row
set o_columnstates [tcl::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_headerdefs [tcl::dict::create] ;#by header-row
set o_headerstates [tcl::dict::create]
set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight
set o_rowstates [tcl::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 o_opts_header_defaults [tcl::dict::create\
-colspans {}\
-values {}\
-ansibase {}\
-ansireset "\x1b\[m"\
-minheight 1\
-maxheight ""\
]
my configure {*}$o_opts_table
}
method width_algorithm {{alg ""}} {
if {$alg eq ""} {
return $o_column_width_algorithm
}
if {$alg ne $o_column_width_algorithm} {
#invalidate cached widths
set o_calculated_column_widths [list]
}
set o_column_width_algorithm $alg
}
method Get_seps {} {
set requested_seps [tcl::dict::get $o_opts_table -show_seps]
set requested_seps_h [tcl::dict::get $o_opts_table -show_hseps]
set requested_seps_v [tcl::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 [tcl::dict::create horizontal $seps_h vertical $seps_v]
}
method Get_frametypes {} {
set requested_ft [tcl::dict::get $o_opts_table -frametype]
set requested_ft_header [tcl::dict::get $o_opts_table -frametype_header]
set requested_ft_body [tcl::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
}
}
light_b {
if {$requested_ft_header eq ""} {
set ft_header heavy_b
}
if {$requested_ft_body eq ""} {
set ft_body light_b
}
}
light_c {
if {$requested_ft_header eq ""} {
set ft_header heavy_c
}
if {$requested_ft_body eq ""} {
set ft_body light_c
}
}
default {
if {$requested_ft_header eq ""} {
set ft_header $requested_ft
}
if {$requested_ft_body eq ""} {
set ft_body $requested_ft
}
}
}
return [tcl::dict::create header $ft_header body $ft_body]
}
method Set_effective_framelimits {} {
upvar ::textblock::class::opts_table_defaults tdefaults
set default_blims [tcl::dict::get $tdefaults -framelimits_body]
set default_hlims [tcl::dict::get $tdefaults -framelimits_header]
set eff_blims [tcl::dict::get $o_opts_table_effective -framelimits_body]
set eff_hlims [tcl::dict::get $o_opts_table_effective -framelimits_header]
set requested_blims [tcl::dict::get $o_opts_table -framelimits_body]
set requested_hlims [tcl::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]
}
}
tcl::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]
}
}
tcl::dict::set o_opts_table_effective -framelimits_header $hlims
return [tcl::dict::create body $blims header $hlims]
}
method configure {args} {
#*** !doctools
#[call class::table [method configure] [arg args]]
#[para] get or set various table-level properties
if {![llength $args]} {
return $o_opts_table
}
if {[llength $args] == 1} {
if {[lindex $args 0] in [list %topt_keys%]} {
#query single option
set k [lindex $args 0]
set val [tcl::dict::get $o_opts_table $k]
set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"]
set infodict [tcl::dict::create]
switch -- $k {
-ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder_body - -ansiborder_footer {
tcl::dict::set infodict debug [ansistring VIEW $val]
}
-framemap_body - -framemap_header - -framelimits_body - -framelimits_header {
tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k]
}
}
tcl::dict::set returndict info $infodict
return $returndict
#return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict]
} else {
error "textblock::table configure - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_table_defaults]"
}
}
if {[llength $args] %2 != 0} {
error "[tcl::namespace::current]::table configure - unexpected argument count. Require name value pairs"
}
foreach {k v} $args {
switch -- $k {
%topt_switchkeys% {}
default {
error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]"
}
}
#if {$k ni [tcl::dict::keys $o_opts_table_defaults]} {
# error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]"
#}
}
set checked_opts [list]
foreach {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 [tcl::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 [tcl::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 {
#safe jumptable test
#dict for {subk subv} $v {}
foreach {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}"
}
}
#safe jumptable test
#dict for {seg subst} $subv {}
foreach {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 {![tcl::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 {![tcl::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 {![tcl::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 [tcl::dict::merge $o_opts_table $checked_opts]
foreach {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"} {
tcl::dict::set o_opts_table $k default
} else {
if {[tcl::dict::get $o_opts_table $k] eq "default"} {
tcl::dict::set o_opts_table $k $v
} else {
tcl::dict::set o_opts_table $k [tcl::dict::merge [tcl::dict::get $o_opts_table $k] $v]
}
}
}
-title {
set twidth [punk::ansi::printing_length $v]
if {[my width] < [expr {$twidth+2}]} {
set o_calculated_column_widths [list]
tcl::dict::set o_opts_table -minwidth [expr {$twidth+2}]
}
tcl::dict::set o_opts_table -title $v
}
default {
tcl::dict::set o_opts_table $k $v
}
}
}
#use values from checked_opts for the effective opts
#safe jumptable test
#dict for {k v} $checked_opts {}
#foreach {k v} $checked_opts {}
tcl::dict::for {k v} $checked_opts {
switch -- $k {
-framemap_body - -framemap_header {
set existing [tcl::dict::get $o_opts_table_effective $k]
#set updated $existing
#dict for {subk subv} $v {
# tcl::dict::set updated $subk $subv
#}
#tcl::dict::set o_opts_table_effective $k $updated
tcl::dict::set o_opts_table_effective $k [tcl::dict::merge $existing $v]
}
-framelimits_body - -framelimits_header {
#my Set_effective_framelimits
tcl::dict::set o_opts_table_effective $k $v
}
default {
tcl::dict::set o_opts_table_effective $k $v
}
}
}
#ansireset exception
tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset]
return $o_opts_table
}
#integrate with struct::matrix - allows ::m format 2string $table
method printmatrix {matrix} {
#*** !doctools
#[call class::table [method printmatrix] [arg matrix]]
#[para] clear all table rows and print a matrix into the table
#[para] The rowxcolumn structure must match
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 ""}} {
#*** !doctools
#[call class::table [method as_matrix] [arg ?cmd?]]
#[para] return a struct::matrix command representing the data portion of the table.
if {$cmd eq ""} {
set m [struct::matrix]
} else {
set m [struct::matrix $cmd]
}
$m add columns [tcl::dict::size $o_columndata]
$m add rows [tcl::dict::size $o_rowdefs]
tcl::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]]
if {[llength $args] %2 != 0} {
error "[tcl::namespace::current]::table::add_column unexpected argument count. Require name value pairs. Known options: %copt_keys%"
}
set opts $o_opts_column_defaults
foreach {k v} $args {
switch -- $k {
%copt_switchkeys% {
tcl::dict::set opts $k $v
}
default {
error "[tcl::namespace::current]::table::add_column unknown option '$k'. Known options: %copt_keys%"
}
}
}
set colcount [tcl::dict::size $o_columndefs]
tcl::dict::set o_columndata $colcount [list]
#tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists
tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists
tcl::dict::set o_columnstates $colcount [tcl::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
tcl::dict::unset o_columndata $colcount
tcl::dict::unset o_columndefs $colcount
tcl::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 [tcl::dict::get $opts -defaultvalue]
set width [textblock::width $dval]
tcl::dict::set o_columndata $colcount [lrepeat $numrows $dval]
tcl::dict::set o_columnstates $colcount maxwidthbodyseen $width
tcl::dict::set o_columnstates $colcount minwidthbodyseen $width
}
return $colcount
}
method column_count {} {
#*** !doctools
#[call class::table [method column_count]]
#[para] return the number of columns
return [tcl::dict::size $o_columndefs]
}
method configure_column {index_expression args} {
#*** !doctools
#[call class::table [method configure_column] [arg index_expression] [arg args]]
#[para] - undocumented
set cidx [lindex [tcl::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 [tcl::dict::get $o_columndefs $cidx]
} else {
if {[llength $args] == 1} {
if {[lindex $args 0] in [list %copt_keys%]} {
#query single option
set k [lindex $args 0]
set val [tcl::dict::get $o_columndefs $cidx $k]
set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"]
set infodict [tcl::dict::create]
switch -- $k {
-ansibase {
tcl::dict::set infodict debug [ansistring VIEW $val]
}
}
tcl::dict::set returndict info $infodict
return $returndict
} else {
error "textblock::table configure_column - unrecognised option '[lindex $args 0]'. Known values %copt_keys%"
}
}
if {[llength $args] %2 != 0} {
error "textblock::table configure_column unexpected argument count. Require name value pairs. Known options: %copt_keys%"
}
foreach {k v} $args {
switch -- $k {
%copt_switchkeys% {}
default {
error "[tcl::namespace::current]::table configure_column unknown option '$k'. Known options: %copt_keys%"
}
}
}
set checked_opts [tcl::dict::get $o_columndefs $cidx] ;#copy of current state
set hstates $o_headerstates ;#operate on a copy
set colstate [tcl::dict::get $o_columnstates $cidx]
set args_got_headers 0
set args_got_header_colspans 0
foreach {k v} $args {
switch -- $k {
-headers {
set args_got_headers 1
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} {
tcl::dict::set hstates $i maxheightseen $this_header_height
} else {
tcl::dict::set hstates $i maxheightseen $currentmax
}
if {$this_header_width >= $maxseen} {
set maxseen $this_header_width
}
#if {$this_header_width > [tcl::dict::get $colstate maxwidthheaderseen]} {
# tcl::dict::set colstate maxwidthheaderseen $this_header_width
#}
incr i
}
tcl::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
tcl::dict::set checked_opts $k $v
}
-header_colspans {
set args_got_header_colspans 1
#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 'any' represents span all up to the next non-zero defined colspan.
set cspans [my header_colspans]
set h 0
if {[llength $v] > [tcl::dict::size $cspans]} {
error "configure_column $cidx -header_colspans. Only [tcl::dict::size $cspans] headers exist. Too many values supplied"
}
foreach s $v {
if {$cidx == 0} {
if {[tcl::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 'any' or a positive integer"
}
} else {
if {$s ne "any" && $s ne ""} {
error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'"
}
}
} else {
#if {![tcl::string::is integer -strict $s]} {
# if {$s ne "any" && $s ne ""} {
# error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'"
# }
#} else {
set header_spans [tcl::dict::get $cspans $h]
set remaining [lindex $header_spans 0]
if {$remaining ne "any"} {
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 "any"} {
set remaining "any"
} else {
if {$remaining eq "any"} {
if {$span ne "0"} {
#a previous column has ended the 'any' 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 "any"} {
#any int >0 ok - what about 'any' immediately following any?
} 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 'any'"
}
}
}
#}
}
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
tcl::dict::set checked_opts $k $v
}
-minwidth {
set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed
tcl::dict::set checked_opts $k $v
}
-maxwidth {
set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed
tcl::dict::set 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]
tcl::dict::set checked_opts $k $col_ansibase
}
-ansireset {
if {$v eq "\uFFEF"} {
tcl::dict::set 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 {
tcl::dict::set checked_opts $k $v
}
centre - centre {
tcl::dict::set checked_opts $k centre
}
}
}
default {
tcl::dict::set checked_opts $k $v
}
}
}
#args checked - ok to update headerstates, headerdefs and columndefs and columnstates
tcl::dict::set o_columndefs $cidx $checked_opts
set o_headerstates $hstates
dict for {hidx hstate} $hstates {
#configure_header
if {![dict exists $o_headerdefs $hidx]} {
#remove calculated members -values -colspans
set hdefaults [dict remove $o_opts_header_defaults -values -colspans]
dict set o_headerdefs $hidx $hdefaults
}
}
tcl::dict::set o_columnstates $cidx $colstate
if {$args_got_headers} {
#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]
tcl::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 {
tcl::dict::unset o_headerstates $zidx
}
}
if {$args_got_headers || $args_got_header_colspans} {
#check and adjust header_colspans for all columns
}
return [tcl::dict::get $o_columndefs $cidx]
}
}
method header_count {} {
#*** !doctools
#[call class::table [method header_count]]
#[para] return the number of header rows
return [tcl::dict::size $o_headerstates]
}
method header_count_calc {} {
set max_headers 0
tcl::dict::for {k cdef} $o_columndefs {
set num_headers [llength [tcl::dict::get $cdef -headers]]
set max_headers [expr {max($max_headers,$num_headers)}]
}
return $max_headers
}
method header_height {header_index} {
#*** !doctools
#[call class::table [method header_height] [arg header_index]]
#[para] return the height of a header as the number of content-lines
set idx [lindex [tcl::dict::keys $o_headerstates $header_index]]
return [tcl::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 [tcl::dict::keys $o_columndefs] $exclude_column]
}
tcl::dict::for {cidx cdef} $o_columndefs {
if {$exclude_colidx == $cidx} {
continue
}
set headerlist [tcl::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 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1}
#
method header_colspans {} {
#*** !doctools
#[call class::table [method header_colspans]]
#[para] Show the colspans configured for all headers
#set num_headers [my header_count_calc]
set num_headers [my header_count]
set colspans_by_header [tcl::dict::create]
tcl::dict::for {cidx cdef} $o_columndefs {
set headerlist [tcl::dict::get $cdef -headers]
set colspans_for_column [tcl::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 "any"} {
if {$spanremaining eq ""} {
set spanremaining 1
}
incr spanremaining -1
}
foreach s $headerspans {
if {$s eq "any"} {
set spanremaining "any"
} elseif {$s == 0} {
if {$spanremaining ne "any"} {
incr spanremaining -1
}
} else {
set spanremaining [expr {$s - 1}]
}
incr i
}
if {$defined_span eq ""} {
if {$spanremaining eq "0"} {
lappend headerspans 1
} else {
#"any" or an integer
lappend headerspans 0
}
} else {
lappend headerspans $defined_span
}
tcl::dict::set colspans_by_header $h $headerspans
}
}
return $colspans_by_header
}
#e.g
# 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 any 1} 3 {any 0 0 1}
#convert to
# 0 {4 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1}
method header_colspans_numeric {} {
set hcolspans [my header_colspans]
if {![tcl::dict::size $hcolspans]} {
return
}
set numcols [llength [tcl::dict::get $hcolspans 0]] ;#assert: all are the same
tcl::dict::for {h spans} $hcolspans {
set c 0 ;#column index
foreach s $spans {
if {$s eq "any"} {
set spanlen 1
for {set i [expr {$c+1}]} {$i < $numcols} {incr i} {
#next 'any' or non-zero ends an 'any' span
if {[lindex $spans $i] ne "0"} {
break
}
incr spanlen
}
#overwrite the 'any' with it's actual span
set modified_spans [dict get $hcolspans $h]
lset modified_spans $c $spanlen
dict set hcolspans $h $modified_spans
}
incr c
}
}
return $hcolspans
}
method configure_header {index_expression args} {
#*** !doctools
#[call class::table [method configure_header]]
#[para] - configure header row-wise
#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 [tcl::dict::keys $o_headerstates] $index_expression]
if {$hidx eq ""} {
error "textblock::table::configure_header - no header row defined at index '$index_expression'."
}
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 [tcl::dict::create]
tcl::dict::set result -colspans [tcl::dict::get $colspans_by_header $hidx]
set header_row_items [list]
tcl::dict::for {cidx cdef} $o_columndefs {
set colheaders [tcl::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.
}
tcl::dict::set result -values $header_row_items
#review - ensure always a headerdef record for each header?
if {[tcl::dict::exists $o_headerdefs $hidx]} {
set result [tcl::dict::merge $result [tcl::dict::get $o_headerdefs $hidx]]
} else {
#warn for now
puts stderr "no headerdef record for header $hidx"
}
return $result
}
if {[llength $args] == 1} {
if {[lindex $args 0] in [tcl::dict::keys $o_opts_header_defaults]} {
#query single option
set k [lindex $args 0]
#set val [tcl::dict::get $o_rowdefs $ridx $k]
set infodict [tcl::dict::create]
#todo
# -blockalignments and -textalignments lists
# must match number of values if not empty? - e.g -blockalignments {left right "" centre left ""}
#if there is a value it overrides alignments specified on the column
switch -- $k {
-values {
set header_row_items [list]
tcl::dict::for {cidx cdef} $o_columndefs {
set colheaders [tcl::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 [tcl::dict::create option $k value $val ansireset "\x1b\[m"]
}
-colspans {
set colspans_by_header [my header_colspans]
set result [tcl::dict::create]
set val [tcl::dict::get $colspans_by_header $hidx]
#ansireset not required
set returndict [tcl::dict::create option $k value $val]
}
-ansibase {
set val ???
set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"]
tcl::dict::set infodict debug [ansistring VIEW $val]
}
}
tcl::dict::set returndict info $infodict
return $returndict
#return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict]
} else {
error "textblock::table configure_header - unrecognised option '[lindex $args 0]'. Known values [tcl::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: [tcl::dict::keys $o_opts_header_defaults]"
}
foreach {k v} $args {
if {$k ni [tcl::dict::keys $o_opts_header_defaults]} {
error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_header_defaults]"
}
}
set checked_opts [list]
#safe jumptable test
#dict for {k v} $args {}
foreach {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 $header_ansibase_items]
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] > [tcl::dict::size $o_columndefs]} {
error "textblock::table::configure_header -values length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])"
}
lappend checked_opts $k $v
}
-colspans {
set numcols [tcl::dict::size $o_columndefs]
if {[llength $v] > $numcols} {
error "textblock::table::configure_header -colspans length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])"
}
if {[llength $v] < $numcols} {
puts stderr "textblock::table::configure_header warning - only [llength $v] spans specified for [tcl::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 "any"} {
set first_is_ok 1
} elseif {[tcl::string::is integer -strict $firstspan] && $firstspan > 0 && $firstspan <= $numcols} {
set first_is_ok 1
}
if {!$first_is_ok} {
error "textblock::table::configure_header -colspans first value '$firstspan' must be integer > 0 & <= $numcols or the string \"any\""
}
#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 "any"} {
incr remaining -1
}
set spanview $v
set sidx 1
#because we allow 'any' - be careful when doing < or > comparisons - as we are mixing integer and string comparisons if we don't test for 'any' first
foreach span [lrange $v 1 end] {
if {$remaining eq "any"} {
if {$span eq "any"} {
set remaining "any"
} elseif {$span > 0} {
#ok to reset to higher val immediately or after an any and any number of following zeros
if {$span > ($numcols - $sidx)} {
lset spanview $sidx [a+ web-red]$span[a]
error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview"
}
set remaining $span
incr remaining -1
} else {
#zero following an any - leave remaining as any
}
} else {
if {$span eq "0"} {
if {$remaining eq "0"} {
lset spanview $sidx [a+ web-red]$span[a]
error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require positive or \"any\" value.[a] $spanview"
} else {
incr remaining -1
}
} else {
if {$remaining eq "0"} {
#ok for new span value of any or > 0
if {$span ne "any" && $span > ($numcols - $sidx)} {
lset spanview $sidx [a+ web-red]$span[a]
error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview"
}
set remaining $span
if {$remaining ne "any"} {
incr remaining -1
}
} else {
lset spanview $sidx [a+ web-red]$span[a]
error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require zero value span.[a] $spanview"
}
}
}
incr sidx
}
}
#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
#safe jumptable test
#dict for {k v} $checked_opts {}
#foreach {k v} $checked_opts {}
# headerdefs excludes -values and -colspans
set update_hdefs [tcl::dict::get $o_headerdefs $hidx]
tcl::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 thiscol_headers_vertical [tcl::dict::get $o_columndefs $c -headers]
set missing [expr {($hidx +1) - [llength $thiscol_headers_vertical]}]
if {$missing > 0} {
lappend thiscol_headers_vertical {*}[lrepeat $missing ""]
}
lset thiscol_headers_vertical $hidx $hval
tcl::dict::set o_columndefs $c -headers $thiscol_headers_vertical
#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 $thiscol_headers_vertical {
lassign [textblock::size $hdr] _w this_header_width _h this_header_height
set maxheightseen [punk::lib::dict_getdef $o_headerstates $i maxheightseen 0]
if {$this_header_height >= $maxheightseen} {
tcl::dict::set o_headerstates $i maxheightseen $this_header_height
} else {
tcl::dict::set o_headerstates $i maxheightseen $maxheightseen
}
if {$this_header_width >= $maxwidthseen} {
set maxwidthseen $this_header_width
}
incr i
}
tcl::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 [tcl::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 [tcl::dict::get $colspans_by_header $h]
set requiredval [lindex $cspans $c]
lappend spanlist $requiredval
}
tcl::dict::set o_columndefs $c -header_colspans $spanlist
set colspans [tcl::dict::get $o_columndefs $c -header_colspans]
}
lset colspans $hidx $span
tcl::dict::set o_columndefs $c -header_colspans $colspans
incr c
}
}
default {
dict set update_hdefs $k $v
}
}
}
set opt_minh [tcl::dict::get $update_hdefs -minheight]
set opt_maxh [tcl::dict::get $update_hdefs -maxheight]
#todo - allow zero values to hide/collapse
# - see also configure_row
if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)"
}
if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)"
}
if {$opt_maxh ne "" && $opt_maxh < $opt_minh} {
error "[tcl::namespace::current]::table::configure_header error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'"
}
#set o_headerstate $hidx -minheight? -maxheight? ???
tcl::dict::set o_headerdefs $hidx $update_hdefs
}
method add_row {valuelist args} {
#*** !doctools
#[call class::table [method add_row]\
# [arg valuelist]\
# [opt "[option -minheight] [arg int_minheight]"]\
# [opt "[option -maxheight] [arg int_maxheight]"]\
# [opt "[option -ansibase] [arg ansicode]"]\
#]
if {[tcl::dict::size $o_columndefs] > 0 && ([llength $valuelist] && [llength $valuelist] != [tcl::dict::size $o_columndefs])} {
set msg ""
append msg "add_row - invalid number ([llength $valuelist]) of values in row - Must match existing column count: [tcl::dict::size $o_columndefs]" \n
append msg "rowdata: $valuelist"
error $msg
}
if {[tcl::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 [tcl::dict::create\
-minheight 1\
-maxheight ""\
-ansibase ""\
-ansireset "\uFFEF"\
]
set o_opts_row_defaults $defaults
if {[llength $args] %2 !=0} {
error "[tcl::namespace::current]::table::add_row unexpected argument count. Require name value pairs. Known options: [tcl::dict::keys $defaults]"
}
#safe jumptable test
#dict for {k v} $args {}
foreach {k v} $args {
switch -- $k {
-minheight - -maxheight - -ansibase - -ansireset {}
default {
error "Invalid option '$k' Known options: [tcl::dict::keys $defaults] (-ansireset is read-only)"
}
}
}
set opts [tcl::dict::merge $defaults $args]
set auto_columns 0
if {[tcl::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]} {
tcl::dict::for {k coldef} $o_columndefs {
lappend valuelist [tcl::dict::get $coldef -defaultvalue]
}
}
}
set rowcount [tcl::dict::size $o_rowdefs]
tcl::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
tcl::dict::unset o_rowdefs $rowcount
#remove auto_columns
if {$auto_columns} {
set o_columndata [tcl::dict::create]
set o_columndefs [tcl::dict::create]
set o_columnstate [tcl::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 [tcl::dict::get $o_columnstates $c maxwidthbodyseen]
set prev_minwidth [tcl::dict::get $o_columnstates $c minwidthbodyseen]
tcl::dict::lappend o_columndata $c $v
lassign [textblock::size_as_list $v] valwidth valheight
if {$valheight > $max_height_seen} {
set max_height_seen $valheight
}
if {$valwidth > [tcl::dict::get $o_columnstates $c maxwidthbodyseen]} {
tcl::dict::set o_columnstates $c maxwidthbodyseen $valwidth
}
if {$valwidth < [tcl::dict::get $o_columnstates $c minwidthbodyseen]} {
tcl::dict::set o_columnstates $c minwidthbodyseen $valwidth
}
if {[tcl::dict::get $o_columnstates $c maxwidthbodyseen] > $prev_maxwidth || [tcl::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 [tcl::dict::get $o_rowdefs $rowcount -maxheight]
if {$opt_maxh ne ""} {
tcl::dict::set o_rowstates $rowcount -maxheight [expr {min($opt_maxh,$max_height_seen)}]
} else {
tcl::dict::set o_rowstates $rowcount -maxheight $max_height_seen
}
return $rowcount
}
method configure_row {index_expression args} {
#*** !doctools
#[call class::table [method configure_row]\
# [arg index_expression]\
# [opt "[option -minheight] [arg int_minheight]"]\
# [opt "[option -maxheight] [arg int_maxheight]"]\
# [opt "[option -ansibase] [arg ansicode]"]\
#]
set ridx [lindex [tcl::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 [tcl::dict::get $o_rowdefs $ridx]
}
if {[llength $args] == 1} {
if {[lindex $args 0] in [tcl::dict::keys $o_opts_row_defaults]} {
#query single option
set k [lindex $args 0]
set val [tcl::dict::get $o_rowdefs $ridx $k]
set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"]
set infodict [tcl::dict::create]
switch -- $k {
-ansibase {
tcl::dict::set infodict debug [ansistring VIEW $val]
}
}
tcl::dict::set returndict info $infodict
return $returndict
#return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict]
} else {
error "textblock::table configure_row - unrecognised option '[lindex $args 0]'. Known values [tcl::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: [tcl::dict::keys $o_opts_row_defaults]"
}
foreach {k v} $args {
if {$k ni [tcl::dict::keys $o_opts_row_defaults]} {
error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_row_defaults]"
}
}
set checked_opts [list]
foreach {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 [tcl::dict::get $o_rowdefs $ridx]
set opts [tcl::dict::merge $current_opts $checked_opts]
#check minheight and maxheight together
set opt_minh [tcl::dict::get $opts -minheight]
set opt_maxh [tcl::dict::get $opts -maxheight]
#todo - allow zero values to hide/collapse rows as is possible with columns
if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} {
error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)"
}
if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} {
error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)"
}
if {$opt_maxh ne "" && $opt_maxh < $opt_minh} {
error "[tcl::namespace::current]::table::configure_row error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'"
}
tcl::dict::set o_rowstates $ridx -minheight $opt_minh
tcl::dict::set o_rowdefs $ridx $opts
}
method row_count {} {
#*** !doctools
#[call class::table [method row_count]]
#[para] return the number of data rows in the table.
return [tcl::dict::size $o_rowdefs]
}
method row_clear {} {
#*** !doctools
#[call class::table [method row_clear]]
#[para] Remove all rows without resetting column data.
#[para] When adding new rows the number of entries will need to match the existing column count.
set o_rowdefs [tcl::dict::create]
set o_rowstates [tcl::dict::create]
#The data values are stored by column regardless of whether added row by row
tcl::dict::for {cidx records} $o_columndata {
tcl::dict::set o_columndata $cidx [list]
#reset only the body fields in o_columnstates
tcl::dict::set o_columnstates $cidx minwidthbodyseen 0
tcl::dict::set o_columnstates $cidx maxwidthbodyseen 0
}
set o_calculated_column_widths [list]
}
method clear {} {
#*** !doctools
#[call class::table [method clear]]
#[para] Remove all row and column data.
#[para] If a subsequent call to add_row is made it can contain any number of values.
#[para] Further calls to add_row will need to contain the same number of values
#[para] as the first call unless default values have been set for the missing columns (review - in flux).
my row_clear
set o_columndefs [tcl::dict::create]
set o_columndata [tcl::dict::create]
set o_columnstates [tcl::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 {[tcl::string::is integer -strict $c]} {
set colidx $c
} else {
tcl::dict::for {colidx coldef} $o_columndefs {
#if {[tcl::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 {
return [tcl::dict::create \
boxlimits [list hlb blc vll]\
boxlimits_top [list hlb blc vll hlt tlc]\
joins [list down]\
bodyjoins [list down-$fname_body]\
]
}
inner {
return [tcl::dict::create \
boxlimits [list hlb blc vll]\
boxlimits_top [list hlb blc vll hlt tlc]\
joins [list down left]\
bodyjoins [list left down-$fname_body]
]
}
right {
return [tcl::dict::create \
boxlimits [list hlb blc vll vlr brc]\
boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\
joins [list down left]\
bodyjoins [list left down-$fname_body]\
]
}
solo {
return [tcl::dict::create \
boxlimits [list hlb blc vll vlr brc]\
boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\
joins [list down]\
bodyjoins [list down-$fname_body]\
]
}
default {
error "Get_boxlimits_and_joins unrecognised position '$position' expected: left inner right solo"
}
}
}
method Get_boxlimits_and_joins1 {position fname_body} {
#fname_body will be "custom" or one of the predefined types light,heavy etc
switch -- $position {
left {
#set header_boxlimits {hlb hlt tlc blc vll}
set header_body_joins [list down-$fname_body]
set boxlimits_position [list hlb blc vll]
#set boxlimits_toprow [concat $boxlimits_position {hlt tlc}]
set boxlimits_toprow [list hlb blc vll hlt tlc]
set joins [list down]
}
inner {
#set header_boxlimits {hlb hlt tlc blc vll}
set header_body_joins [list left down-$fname_body]
set boxlimits_position [list hlb blc vll]
#set boxlimits_toprow [concat $boxlimits_position {hlt tlc}]
set boxlimits_toprow [list hlb blc vll hlt tlc]
set joins [list down left]
}
right {
#set header_boxlimits {hlb hlt tlc blc vll vlr trc brc}
set header_body_joins [list left down-$fname_body]
set boxlimits_position [list hlb blc vll vlr brc]
#set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}]
set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc]
set joins [list down left]
}
solo {
#set header_boxlimits {hlb hlt tlc blc vll vlr trc brc}
set header_body_joins [list down-$fname_body]
set boxlimits_position [list hlb blc vll vlr brc]
#set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}]
set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc]
set joins [list down]
}
}
return [tcl::dict::create boxlimits $boxlimits_position boxlimits_top $boxlimits_toprow joins $joins bodyjoins $header_body_joins ]
}
method get_column_by_index {index_expression args} {
#puts "+++> get_column_by_index $index_expression $args [tcl::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 opts [tcl::dict::create\
-position "inner"\
-return "string"\
]
foreach {k v} $args {
switch -- $k {
-position - -return {
tcl::dict::set opts $k $v
}
default {
error "[tcl::namespace::current]::table::get_column_by_index error invalid option '$k'. Known options [tcl::dict::keys $opts]"
}
}
}
set opt_posn [tcl::dict::get $opts -position]
set opt_return [tcl::dict::get $opts -return]
switch -- $opt_posn {
left - inner - right - solo {}
default {
error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_posn' for -position. Valid values: [list left inner right solo]"
}
}
switch -- $opt_return {
string - dict {}
default {
error "[tcl::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 [tcl::dict::get $columninfo headers]
#puts "===== header_list: $header_list"
set cells [tcl::dict::get $columninfo cells]
set topt_show_header [tcl::dict::get $o_opts_table -show_header]
if {$topt_show_header eq ""} {
set allheaders 0
set all_cols [tcl::dict::keys $o_columndefs]
foreach c $all_cols {
incr allheaders [llength [tcl::dict::get $o_columndefs $c -headers]]
}
if {$allheaders == 0} {
set do_show_header 0
} else {
set do_show_header 1
}
} else {
set do_show_header $topt_show_header
}
set topt_show_footer [tcl::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 [tcl::dict::get $ftypes body]
if {[llength $ftype_body] >= 2} {
set fname_body "custom"
} else {
set fname_body $ftype_body
}
set ftype_header [tcl::dict::get $ftypes header]
if {[llength $ftype_header] >= 2} {
set fname_header "custom"
} else {
set fname_header $ftype_header
}
set limj [my Get_boxlimits_and_joins $opt_posn $fname_body]
set header_body_joins [tcl::dict::get $limj bodyjoins]
set joins [tcl::dict::get $limj joins]
set boxlimits_position [tcl::dict::get $limj boxlimits]
set boxlimits_toprow [tcl::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 [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_position]
set boxlimits_headerless [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_toprow]
set header_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_position]
set header_boxlimits_toprow [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_toprow]
set fmap [tcl::dict::get $o_opts_table_effective -framemap_body]
set hmap [tcl::dict::get $o_opts_table_effective -framemap_header]
#if {![tcl::dict::get $o_opts_table -show_edge]} {
# set body_edgemap [textblock::class::table_edge_map ""]
# dict for {k v} $fmap {
# #tcl::dict::set fmap $k [tcl::dict::merge $v [tcl::dict::get $body_edgemap $k]]
# }
# set header_edgemap [textblock::class::header_edge_map ""]
# dict for {k v} $hmap {
# #tcl::dict::set hmap $k [tcl::dict::merge $v [tcl::dict::get $header_edgemap $k]]
# }
#}
set sep_elements_horizontal $::textblock::class::table_hseps
set sep_elements_vertical $::textblock::class::table_vseps
set topmap [tcl::dict::get $fmap top$opt_posn]
set botmap [tcl::dict::get $fmap bottom$opt_posn]
set midmap [tcl::dict::get $fmap middle$opt_posn]
set onlymap [tcl::dict::get $fmap only$opt_posn]
set hdrmap [tcl::dict::get $hmap only${opt_posn}]
set topseps_h [tcl::dict::get $sep_elements_horizontal top$opt_posn]
set midseps_h [tcl::dict::get $sep_elements_horizontal middle$opt_posn]
set topseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn]
set midseps_v [tcl::dict::get $sep_elements_vertical middle$opt_posn]
set botseps_v [tcl::dict::get $sep_elements_vertical bottom$opt_posn]
set onlyseps_v [tcl::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 [tcl::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 [tcl::dict::keys $o_columndefs] $index_expression]
set colwidth [my column_width $cidx]
set col_blockalign [tcl::dict::get $o_columndefs $cidx -blockalign]
if {$do_show_header} {
#puts "boxlimitsinfo header $opt_posn: -- boxlimits $header_boxlimits -- boxmap $hdrmap"
set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] ;#merged to single during configure
set ansiborder_header [tcl::dict::get $o_opts_table -ansiborder_header]
if {[tcl::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 [tcl::string::repeat " " $hcolwidth]
set all_colspans [my header_colspans_numeric]
#put our framedef calls together
set fdef_header [textblock::framedef $ftype_header]
set framedef_leftbox [textblock::framedef -joins left $ftype_header]
set framedef_headerdown_same [textblock::framedef -joins {down} $ftype_header]
set framedef_headerdown_body [textblock::framedef -joins [list down-$fname_body] $ftype_header]
#default span_extend_map - used as base to customise with specific joins
set span_extend_map [tcl::dict::create \
vll " "\
tlc [tcl::dict::get $fdef_header hlt]\
blc [tcl::dict::get $fdef_header hlb]\
]
#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 [tcl::dict::get $all_colspans $hrow]
set this_span [lindex $headerspans $cidx]
#set hval $ansibase_header$header ;#no reset
set hval $header
set rowh [my header_height $hrow]
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 {![tcl::dict::get $o_opts_table -show_edge]} {
set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ]
}
#puts ">>> headerspans: $headerspans cidx: $cidx"
#if {$this_span eq "any" || $this_span > 0} {}
#changed to processing only numeric colspans
if {$this_span > 0} {
set startmap [tcl::dict::get $hmap $rowpos${opt_posn}]
#look at spans in header below to determine joins required at blc
if {$show_seps_v} {
if {[tcl::dict::exists $all_colspans [expr {$hrow+1}]]} {
set next_spanlist [tcl::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
tcl::dict::set startmap blc [tcl::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 [tcl::dict::get $ftypes header]\
# -ansibase $ansibase_header -ansiborder $ansiborder_final\
# -boxlimits $hlims -boxmap $startmap -joins $header_joins $hval\
# ]
if {$this_span == 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 -checkargs 0 -blockalign $col_blockalign -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\
-ansibase $ansibase_header -ansiborder $ansiborder_final\
-boxlimits $hlims -boxmap $startmap -joins $header_joins $cellcontents\
]
if {$this_span != 1} {
#puts "===>\n$header_cell_startspan\n<==="
set spanned_parts [list $header_cell_startspan]
#assert this_span == "any" or >1 ie a header that spans other columns
#therefore more parts to append
#set remaining_cols [lrange [tcl::dict::keys $o_columndefs] $cidx end]
set remaining_spans [lrange $headerspans $cidx+1 end]
set spanval [join $remaining_spans ""] ;#so we can test for all zeros
set spans_to_rhs 0
if {[expr {$spanval}] == 0} {
#puts stderr "SPANS TO RHS"
set spans_to_rhs 1
}
#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 [tcl::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 [tcl::dict::get $limj bodyjoins]
set span_joins [tcl::dict::get $limj joins]
set span_boxlimits [tcl::dict::get $limj boxlimits]
set span_boxlimits_top [tcl::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 [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits]
#set span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits_top]
set header_span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits]
set header_span_boxlimits_top [struct::set intersect [tcl::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} {
tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_same hlbj] ;#horizontal line bottom with down join - to same frametype
}
} else {
#join to body
tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body 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 {![tcl::dict::get $o_opts_table -show_edge]} {
set hlims [struct::set difference $hlims [tcl::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 [tcl::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
}
#JMN
#spanned_parts are all built with textblock::frame - therefore uniform-width lines - can use join_basic
set spanned_frame [textblock::join_basic -- {*}$spanned_parts]
if {$spans_to_rhs} {
if {$cidx == 0} {
set fake_posn solo
} else {
set fake_posn right
}
set x_limj [my Get_boxlimits_and_joins $fake_posn $fname_body]
if {$hrow == 0} {
set x_boxlimits_toprow [tcl::dict::get $x_limj boxlimits_top]
set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_toprow]
} else {
set x_boxlimits_position [tcl::dict::get $x_limj boxlimits]
set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_position]
}
} else {
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 {![tcl::dict::get $o_opts_table -show_edge]} {
if {$spans_to_rhs} {
#assert fake_posn has been set above based on cidx and spans_to_rhs
set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts ${rowpos}$fake_posn] ]
} else {
#use the edge_parts corresponding to the column being written to ie use opt_posn
set hlims [struct::set difference $hlims [tcl::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 -checkargs 0 -ellipsis 0 -type $spacemap -boxlimits $hlims -ansibase $ansibase_header $hval] ;#review -ansibase
#puts "==>boxlimits:'$hlims' hval_width:[tcl::string::length $hval] blockwidth:[textblock::width $hblock]"
#puts $hblock
#puts "==>hval:'$hval'[a]"
#puts "==>hval:'[ansistring VIEW $hval]'"
#set spanned_frame [overtype::renderspace -transparent 1 $spanned_frame $hblock]
#spanned values default left - todo make configurable
#TODO
#consider that currently blockaligning for spanned columns must always use the blockalign value from the starting column of the span
#we could conceivably have an override that could be set somehow with configure_header for customization of alignments of individual spans or span sizes?
#this seems like a likely requirement. The first spanned column may well have different alignment requirements than the span.
#(e.g if first spanned col happens to be numeric it probably warrants right textalign (if not blockalign) but we don't necessarily want the spanning header or even a non-spanning header to be right aligned)
set spanned_frame [overtype::block -blockalign $col_blockalign -overflow 1 -transparent 1 $spanned_frame $hblock]
#POTENTIAL BUG (fixed with spans_to_rhs above)
#when -blockalign right and colspan extends to rhs - last char of longest of that spanlength will overlap right edge (if show_edge 1)
#we need to shift 1 to the left when doing our overtype with blockalign right
#we normally do this by using the hlims based on position - effectively we need a rhs position set of hlims for anything that colspans to the right edge
#(even though the column position may be left or inner)
} else {
#this_span == 1
set spanned_frame [textblock::join_basic -- $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" && [tcl::dict::get $o_opts_table -show_edge]} {
set padheight [expr {$rowh + 2}]
} else {
set padheight [expr {$rowh + 1}]
}
set bline [tcl::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 [tcl::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 -checkargs 0 -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 {![tcl::dict::get $o_opts_table -show_edge]} {
set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts only$opt_posn] ]
}
set header_joins $header_body_joins
set header_frame [textblock::frame -checkargs 0 -width [expr {$hcolwidth+2}] -type [tcl::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 [tcl::string::trimright $part_header \n]
lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight
set padline [tcl::string::repeat $TSUB $return_headerwidth]
set adjusted_lines [list]
foreach ln [split $part_header \n] {
if {[tcl::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 [tcl::dict::keys $o_columndefs] $index_expression] ;#convert possible end-1,2+2 etc expression to >= 0 integer in dict range
set opt_col_ansibase [tcl::dict::get $o_columndefs $colidx -ansibase] ;#ordinary merge of codes already done in configure_column
#set colwidth [my column_width $colidx]
set body_ansibase [tcl::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 [tcl::dict::get $o_opts_table -ansiborder_body]
if {[tcl::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 {[tcl::dict::get $o_opts_table -frametype] eq "block"}]
foreach c $cells {
#cells in column - each new c is in a different row
set row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase]
set row_bg ""
if {$row_ansibase ne ""} {
set row_bg [punk::ansi::codetype::sgr_merge_singles [list $row_ansibase] -filter_fg 1]
}
set ansibase $body_ansibase$opt_col_ansibase
#todo - joinleft,joinright,joindown based on opts in args
set cell_ansibase ""
set ansiborder_body_col_row $border_ansi$row_bg
set ansiborder_final $ansiborder_body_col_row
#$c will always have ansi resets due to overtype behaviour ?
#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 {![tcl::dict::get $o_opts_table -show_edge]} {
set blims [struct::set difference $blims [tcl::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 {![tcl::dict::get $o_opts_table -show_edge]} {
set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts top$opt_posn] ]
}
}
set rowframe [textblock::frame -checkargs 0 -type [tcl::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::widthtopline $rowframe] ;#frame lines always same width - just look at top line
append part_body $rowframe \n
} else {
if {$r == $rmax} {
set joins [lremove $joins [lsearch $joins down*]]
set bmap $botmap
set blims $blims_bot
if {![tcl::dict::get $o_opts_table -show_edge]} {
set blims [struct::set difference $blims [tcl::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 {![tcl::dict::get $o_opts_table -show_edge]} {
set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts middle$opt_posn] ]
}
}
append part_body [textblock::frame -checkargs 0 -type [tcl::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 {![tcl::dict::get $o_opts_table -show_edge]} {
#set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ]
#append output [textblock::frame -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins]\n
append part_body [tcl::string::repeat " " $colwidth] \n
set return_bodywidth $colwidth
} else {
set emptyframe [textblock::frame -checkargs 0 -width [expr {$colwidth + 2}] -type [tcl::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 {[tcl::string::index $part_body end] eq "\n"} {
set part_body [tcl::string::range $part_body 0 end-1]
}
set return_bodyheight [textblock::height $part_body]
#append output $part_body
if {$opt_return eq "string"} {
if {$part_header ne ""} {
set output $part_header
if {$part_body ne ""} {
append output \n $part_body
}
} else {
set output $part_body
}
return $output
} else {
return [tcl::dict::create header $part_header body $part_body headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight]
}
}
method get_column_cells_by_index {index_expression} {
#*** !doctools
#[call class::table [method get_column_cells_by_index] [arg index_expression]]
#[para] Return a dict with keys 'headers' and 'cells' giving column header and data values
set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression]
if {$cidx eq ""} {
set range ""
if {[tcl::dict::size $o_columndefs] > 0} {
set range "0..[expr {[tcl::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 num_header_rows [my header_count]
set cdef [tcl::dict::get $o_columndefs $cidx]
set headerlist [tcl::dict::get $cdef -headers]
set ansibase_col [tcl::dict::get $cdef -ansibase]
set textalign [tcl::dict::get $cdef -textalign]
switch -- $textalign {
left {set pad right}
right {set pad left}
default {
set pad "centre" ;#todo?
}
}
#set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body]
#set ansibase_header [tcl::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]
#we need to replace the 'any' entries with their actual span lengths before passing any -colspan values to column_datawidth - hence use header_colspans_numeric
set all_colspans [my header_colspans_numeric]
#JMN
#store configured widths so we don't look up for each header line
#set configured_widths [list]
#foreach c [tcl::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 [tcl::dict::create]
tcl::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]
#jjj
set header_maxdataheight [tcl::dict::get $o_headerstates $hrow maxheightseen]
#set header_maxdataheight [my header_height $hrow] ;#from cached headerstates
set headerdefminh [tcl::dict::get $o_headerdefs $hrow -minheight]
set headerdefmaxh [tcl::dict::get $o_headerdefs $hrow -maxheight]
if {"$headerdefminh$headerdefmaxh" ne "" && $headerdefminh eq $headerdefmaxh} {
set headerh $headerdefminh ;#exact height defined for the row
} else {
if {$headerdefminh eq ""} {
if {$headerdefmaxh eq ""} {
#both defs empty
set headerh $header_maxdataheight
} else {
set headerh [expr {min(1,$headerdefmaxh,$header_maxdataheight)}]
}
} else {
if {$headerdefmaxh eq ""} {
set headerh [expr {max($headerdefminh,$header_maxdataheight)}]
} else {
if {$header_maxdataheight < $headerdefminh} {
set headerh $headerdefminh
} else {
set headerh [expr {max($headerdefminh,$header_maxdataheight)}]
}
}
}
}
set headerrow_colspans [tcl::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 -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign
set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth]
set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank]
set hval_lines [split $hdr \n]
#jmn concat
#set hval_lines [concat $hval_lines $hcell_lines]
set hval_lines [list {*}$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]
tcl::dict::lappend output headers $hcell
}
#set colwidth [my column_width $cidx]
#set cell_line_blank [tcl::string::repeat " " $colwidth]
set datawidth [my column_datawidth $cidx -headers 0 -footers 0 -data 1 -cached 1]
set cell_line_blank [tcl::string::repeat " " $datawidth]
set items [tcl::dict::get $o_columndata $cidx]
#puts "---> columndata $o_columndata"
#set opt_row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase]
#set cell_ansibase $ansibase_body$ansibase_col$opt_row_ansibase
tcl::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 [tcl::dict::get $o_rowstates $r -maxheight]
set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight]
set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight]
if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} {
set rowh $rowdefminh ;#an exact height is defined for the row
} 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]
#jmn
#set cval_lines [concat $cval_lines $cell_lines]
lappend cval_lines {*}$cell_lines
set cval_lines [lrange $cval_lines 0 $rowh-1]
set cval_block [::join $cval_lines \n]
#//JMN assert widest cval_line = datawidth = known_blockwidth
set cell [textblock::pad $cval_block -known_blockwidth $datawidth -width $datawidth -padchar " " -within_ansi 1 -which $pad]
#set cell [textblock::pad $cval_block -width $colwidth -padchar " " -within_ansi 0 -which left]
tcl::dict::lappend output cells $cell
incr r
}
return $output
}
method get_column_values_by_index {index_expression} {
#*** !doctools
#[call class::table [method get_column_values_by_index] [arg index_expression]]
#[para] List the cell values of a column from the data area only (no header values)
set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression]
if {$cidx eq ""} {
return
}
return [tcl::dict::get $o_columndata $cidx]
}
method debug {args} {
#*** !doctools
#[call class::table [method debug]]
#[para] display lots of debug information about how the table is constructed.
#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 [tcl::dict::create\
-usetables 1\
]
foreach {k v} $args {
switch -- $k {
-usetables {}
default {
error "table debug unrecognised option '$k'. Known options: [tcl::dict::keys $defaults]"
}
}
}
set opts [tcl::dict::merge $defaults $args]
set opt_usetables [tcl::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} {
tcl::dict::for {k v} $o_columndefs {
puts " $k $v"
}
} else {
set t [textblock::class::table new]
$t add_column -headers "Col"
tcl::dict::for {col coldef} $o_columndefs {
foreach property [tcl::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 [tcl::dict::create]
set max_widths [tcl::dict::create 0 0 1 0 2 0 3 0] ;#max inner table column widths
tcl::dict::for {col coldef} $o_columndefs {
set row [list $col]
set colheaders [tcl::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 [tcl::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]
tcl::dict::set col_header_tables $col $htable
set colwidths [$htable column_widths]
set icol 0
foreach w $colwidths {
if {$w > [tcl::dict::get $max_widths $icol]} {
tcl::dict::set max_widths $icol $w
}
incr icol
}
}
#safe jumptable test
#dict for {col coldef} $o_columndefs {}
tcl::dict::for {col coldef} $o_columndefs {
set row [list $col]
#safe jumptable test
#dict for {property val} $coldef {}
tcl::dict::for {property val} $coldef {
switch -- $property {
-ansireset {continue}
-headers {
set htable [tcl::dict::get $col_header_tables $col]
tcl::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 "headerdefs: $o_headerdefs"
puts stdout "headerstates: $o_headerstates"
tcl::dict::for {k coldef} $o_columndefs {
if {[tcl::dict::exists $o_columndata $k]} {
set headerlist [tcl::dict::get $coldef -headers]
set coldata [tcl::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 {[tcl::dict::size $o_columndefs]-1}]
foreach c [tcl::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 [tcl::dict::keys $o_columndefs] $index_expression]
if {$cidx eq ""} {
return
}
#assert cidx is now >=0 integer within the range of defined columns
set cdef [tcl::dict::get $o_columndefs $cidx]
set defminw [tcl::dict::get $cdef -minwidth]
set defmaxw [tcl::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 [tcl::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 [tcl::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} {
#*** !doctools
#[call class::table [method column_width] [arg index_expression]]
#[para] inner width of column ie the available cell-width without borders/separators
if {[llength $o_calculated_column_widths] != [tcl::dict::size $o_columndefs]} {
my calculate_column_widths -algorithm $o_column_width_algorithm
}
return [lindex $o_calculated_column_widths $index_expression]
}
method column_widths {} {
#*** !doctools
#[call class::table [method column_width]]
#[para] ordered list of column widths (inner widths)
if {[llength $o_calculated_column_widths] != [tcl::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 {} {
#*** !doctools
#[call class::table [method width]]
#[para] width of the table including borders and separators
#[para] calculate width based on assumption frame verticals are 1 screen-column wide
#[para] (review - consider possibility of 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 {[tcl::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 [tcl::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 [tcl::dict::get $o_columndefs $cidx]
set defminw [tcl::dict::get $cdef -minwidth]
set defmaxw [tcl::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 [tcl::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 [tcl::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]
set thiscol_widest_header [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen]
tcl::dict::for {h colspans} $header_colspans {
set spanc [lindex $colspans $cidx]
#set headers [tcl::dict::get $cdef -headers]
#set thiscol_widest_header 0
#if {[llength $headers] > 0} {
# set thiscol_widest_header [tcl::mathfunc::max {*}[lmap v $headers {textblock::width $v}]]
#}
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 "any" || $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 [tcl::dict::get $o_opts_table -show_seps]
set vseps [tcl::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 opts [tcl::dict::create\
-headers 0\
-footers 0\
-colspan unspecified\
-data 1\
-cached 1\
]
#NOTE: -colspan any is not the same as *
#
#-colspan is relevant to header/footer data only
foreach {k v} $args {
switch -- $k {
-headers - -footers - -colspan - -data - -cached {
tcl::dict::set opts $k $v
}
default {
error "column_datawidth unrecognised flag '$k'. Known flags: [tcl::dict::keys $opts]"
}
}
}
set opt_colspan [tcl::dict::get $opts -colspan]
switch -- $opt_colspan {
* - unspecified {}
any {
error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0 (use header_colspans_numeric to get actual spans)"
}
default {
if {![string is integer -strict $opt_colspan]} {
error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0"
}
}
}
set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression]
if {$cidx eq ""} {
return
}
if {[tcl::dict::get $opts -cached]} {
set hwidest 0
set bwidest 0
set fwidest 0
if {[tcl::dict::get $opts -headers]} {
if {$opt_colspan in {* unspecified}} {
set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen]
} else {
#this is not cached
# -- --- --- ---
set colheaders [tcl::dict::get $o_columndefs $cidx -headers]
set all_colspans_by_header [my header_colspans_numeric]
set hlist [list]
tcl::dict::for {hrow cspans} $all_colspans_by_header {
set s [lindex $cspans $cidx]
if {$s eq $opt_colspan} {
lappend hlist [lindex $colheaders $hrow]
}
}
if {[llength $hlist]} {
set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]]
} else {
set hwidest 0
}
# -- --- --- ---
}
}
if {[tcl::dict::get $opts -data]} {
set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen]
}
if {[tcl::dict::get $opts -footers]} {
#TODO!
#set bwidest [tcl::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]
set hwidest 0
if {[tcl::dict::get $opts -headers]} {
if {$opt_colspan in {* unspecified}} {
lappend values {*}[tcl::dict::get $o_columndefs $cidx -headers]
} else {
# -- --- --- ---
set colheaders [tcl::dict::get $o_columndefs $cidx -headers]
set all_colspans_by_header [my header_colspans_numeric]
set hlist [list]
tcl::dict::for {hrow cspans} $all_colspans_by_header {
set s [lindex $cspans $cidx]
if {$s eq $opt_colspan} {
lappend hlist [lindex $colheaders $hrow]
}
}
if {[llength $hlist]} {
set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]]
} else {
set hwidest 0
}
# -- --- --- ---
}
}
if {[tcl::dict::get $opts -data]} {
if {[tcl::dict::exists $o_columndata $cidx]} {
lappend values {*}[tcl::dict::get $o_columndata $cidx]
}
}
if {[tcl::dict::get $opts -footers]} {
lappend values {*}[tcl::dict::get $o_columndefs $cidx -footers]
}
if {[llength $values]} {
set valwidest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]]
set widest [expr {max($valwidest,$hwidest)}]
} else {
set widest $hwidest
}
return $widest
}
#print1 uses basic column joining - useful for testing/debug especially with colspans
method print1 {args} {
if {![llength $args]} {
set cols [tcl::dict::keys $o_columndata]
} else {
set cols [list]
foreach colspec $args {
set allcols [tcl::dict::keys $o_columndata]
if {[tcl::string::first .. $colspec] >=0} {
set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec]
if {[llength $parts] != 3} {
error "[namespace::current]::table error invalid print specification '$colspec'"
}
lassign $parts from _dd to
if {$from eq ""} {set from 0 }
if {$to eq ""} {set to end}
set indices [lrange $allcols $from $to]
lappend cols {*}$indices
} else {
set c [lindex $allcols $colspec]
if {$c ne ""} {
lappend cols $c
}
}
}
}
set blocks [list]
set 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 [tcl::dict::create] ;# to use tcl::dict::incr
set colspace_added [tcl::dict::create]
set ordered_spans [tcl::dict::create]
tcl::dict::for {col spandata} [my spangroups] {
set dwidth [my column_datawidth $col -data 1 -headers 0 -footers 0 -cached 1]
set minwidth [tcl::dict::get $o_columndefs $col -minwidth]
set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth]
if {$minwidth ne ""} {
if {$dwidth < $minwidth} {
set dwidth $minwidth
}
}
if {$maxwidth ne ""} {
if {$dwidth > $maxwidth} {
set dwidth $maxwidth
}
}
tcl::dict::set colwidths $col $dwidth ;#spangroups is ordered by column - so colwidths dict will be correctly ordered
tcl::dict::set colspace_added $col 0
set spanlengths [tcl::dict::get $spandata spanlengths]
foreach slen $spanlengths {
set spans [tcl::dict::get $spandata spangroups $slen]
set spans [lsort -index 7 -integer $spans]
foreach s $spans {
set hwidth [tcl::dict::get $s headerwidth]
set hrow [tcl::dict::get $s hrow]
set scol [tcl::dict::get $s startcol]
tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth
tcl::dict::set ordered_spans $scol,$hrow headerwidth $hwidth
}
}
}
#safe jumptable test
#dict for {spanid spandata} $ordered_spans {}
tcl::dict::for {spanid spandata} $ordered_spans {
lassign [split $spanid ,] startcol hrow
set memcols [tcl::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 [tcl::dict::keys $memcols]
set hwidth [tcl::dict::get $spandata headerwidth]
set num_cols_spanned [tcl::dict::size $memcols]
if {$num_cols_spanned == 1} {
set col [lindex $memcols 0]
set space_to_alloc [expr {$hwidth - [tcl::dict::get $colwidths $col]}]
if {$space_to_alloc > 0} {
set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth]
if {$maxwidth ne ""} {
if {$maxwidth > [tcl::dict::get $colwidths $col]} {
set can_alloc [expr {$maxwidth - [tcl::dict::get $colwidths $col]}]
} else {
set can_alloc 0
}
set will_alloc [expr {min($space_to_alloc,$can_alloc)}]
} else {
set will_alloc $space_to_alloc
}
if {$will_alloc} {
#tcl::dict::set colwidths $col $hwidth
tcl::dict::incr colwidths $col $will_alloc
tcl::dict::set colspace_added $col $will_alloc
}
#log!
#if {$will_alloc < $space_to_alloc} {
# #todo - debug only
# puts stderr "max width $maxwidth hit for col $col - cannot allocate extra [expr {$space_to_alloc - $will_alloc}]"
#}
}
} elseif {$num_cols_spanned > 1} {
set spannedwidth 0
foreach col $colids {
incr spannedwidth [tcl::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 {
least {
#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 [tcl::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
}
}
tcl::dict::incr colwidths $colid
tcl::dict::incr colspace_added $colid
}
}
}
least_unmaxed {
#TODO - fix header truncation/overflow issues when they are restricted by column maxwidth
#(we should be able to collapse column width to zero and have header colspans gracefully respond)
#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 [tcl::dict::keys $ordered_colspace_added]
set colid ""
foreach testcolid $ordered_all_colids {
set maxwidth [tcl::dict::get $o_columndefs $testcolid -maxwidth]
set can_alloc [expr {$maxwidth eq "" || $maxwidth > [tcl::dict::get $colwidths $testcolid]}]
if {$testcolid in $colids} {
if {$can_alloc} {
set colid $testcolid
break
} else {
#remove from future consideration in for loop
#log!
#puts stderr "max width $maxwidth hit for col $testcolid"
tcl::dict::unset colspace_added $testcolid
}
}
}
if {$colid ne ""} {
tcl::dict::incr colwidths $colid
tcl::dict::incr colspace_added $colid
}
}
}
}
all {
#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 [tcl::dict::keys $ordered_colspace_added]
foreach col $ordered_colids {
tcl::dict::incr colwidths $col
tcl::dict::incr colspace_added $col
incr space_to_alloc -1
if {$space_to_alloc == 0} {
break
}
}
}
}
}
}
}
set column_widths [tcl::dict::values $colwidths]
#todo - -maxwidth etc
set table_minwidth [tcl::dict::get $o_opts_table -minwidth] ;#min width including frame elements
if {[tcl::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 {[tcl::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 [tcl::dict::keys $ordered_colspace_added]
foreach col $ordered_colids {
tcl::dict::incr colwidths $col
tcl::dict::incr colspace_added $col
incr space_to_alloc -1
if {$space_to_alloc == 0} {
break
}
}
}
set column_widths [tcl::dict::values $colwidths]
}
}
return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added]
}
#spangroups keyed by column
method spangroups {} {
#*** !doctools
#[call class::table [method spangroups]]
#[para] return a dict keyed by column-index showing advanced span information
#[para] (debug tool)
set column_count [tcl::dict::size $o_columndefs]
set spangroups [tcl::dict::create]
set headerwidths [tcl::dict::create] ;#key on col,hrow
foreach c [tcl::dict::keys $o_columndefs] {
tcl::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 [tcl::dict::get $spaninfo startcol]
set hrow [tcl::dict::get $spaninfo hrow]
set header [lindex [tcl::dict::get $o_columndefs $hcol -headers] $hrow]
if {[tcl::dict::exists $headerwidths $hcol,$hrow]} {
set hwidth [tcl::dict::get $headerwidths $hcol,$hrow]
} else {
set hwidth [textblock::width $header]
tcl::dict::set headerwidths $hcol,$hrow $hwidth
}
lappend spaninfo headerwidth $hwidth
lappend sgroup $spaninfo
}
set spanlengths [tcl::dict::get $spangroups $c spanlengths]
lappend spanlengths $spanlen
tcl::dict::set spangroups $c spanlengths $spanlengths
tcl::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 [tcl::dict::get $o_columndefs $cidx -header_colspans]
}
method column_get_spaninfo {cidx} {
set spans_by_header [my header_colspans]
set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans]
set spaninfo [list]
set numcols [tcl::dict::size $o_columndefs]
#note that 'any' can occur in positions other than column 0 - meaning any remaining until next non-zero span
tcl::dict::for {hrow rawspans} $spans_by_header {
set thiscol_spanval [lindex $rawspans $cidx]
if {$thiscol_spanval eq "any" || $thiscol_spanval > 0} {
set spanstartcol $cidx ;#own column
if {$thiscol_spanval eq "any"} {
#scan right to first non-zero to get actual length of 'any' span
#REVIEW!
set spanlen 1
for {set i [expr {$cidx+1}]} {$i < $numcols} {incr i} {
#abort at next any or number or empty string
if {[lindex $rawspans $i] ne "0"} {
break
}
incr spanlen
}
#set spanlen [expr {$numcols - $cidx}]
} else {
set spanlen $thiscol_spanval
}
} else {
#look left til we see an any or a non-zero value
for {set i $cidx} {$i > -1} {incr i -1} {
set s [lindex $rawspans $i]
if {$s eq "any" || $s > 0} {
set spanstartcol $i
if {$s eq "any"} {
#REVIEW!
#set spanlen [expr {$numcols - $i}]
set spanlen 1
#now scan right to see how long the 'any' actually is
for {set j [expr {$i+1}]} {$j < $numcols} {incr j} {
if {[lindex $rawspans $j] ne "0"} {
break
}
incr spanlen
}
} 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 [tcl::dict::size $o_columndefs]
set opts [tcl::dict::create\
-algorithm $o_column_width_algorithm\
]
foreach {k v} $args {
switch -- $k {
-algorithm {
tcl::dict::set opts $k $v
}
default {
error "Unknown option '$k'. Known options: [tcl::dict::keys $opts]"
}
}
}
set opt_algorithm [tcl::dict::get $opts -algorithm]
#puts stderr "--- recalculating column widths -algorithm $opt_algorithm"
set known_algorithms [list basic simplistic span span2]
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 least]
set calcresult [my columncalc_spans least_unmaxed]
set o_calculated_column_widths [tcl::dict::get $calcresult colwidths]
}
span2 {
#allocates more evenly - but truncates headers sometimes
set calcresult [my columncalc_spans all]
set o_calculated_column_widths [tcl::dict::get $calcresult colwidths]
}
default {
error "calculate_column_widths unknown algorithm $opt_algorithm. Known algorithms: $known_algorithms"
}
}
#remember the last algorithm used
set o_column_width_algorithm $opt_algorithm
return $o_calculated_column_widths
}
method print2 {args} {
variable full_column_cache
set full_column_cache [tcl::dict::create]
if {![llength $args]} {
set cols [tcl::dict::keys $o_columndata]
} else {
set cols [list]
foreach colspec $args {
set allcols [tcl::dict::keys $o_columndata]
if {[tcl::string::first .. $colspec] >=0} {
set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec]
if {[llength $parts] != 3} {
error "[namespace::current]::table error invalid print specification '$colspec'"
}
lassign $parts from _dd to
if {$from eq ""} {set from 0}
if {$to eq ""} {set to end}
set indices [lrange $allcols $from $to]
lappend cols {*}$indices
} else {
set c [lindex $allcols $colspec]
if {$c ne ""} {
lappend cols $c
}
}
}
}
set blocks [list]
set 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 {[tcl::dict::exists $full_column_cache $c]} {
#puts "!!print used full_column_cache for $c"
set columninfo [tcl::dict::get $full_column_cache $c]
} else {
set columninfo [my get_column_by_index $c -return dict {*}$flags]
tcl::dict::set full_column_cache $c $columninfo
}
set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]]
set bodywidth [tcl::dict::get $columninfo bodywidth]
if {$table eq ""} {
set table $nextcol
set height [textblock::height $table] ;#only need to get height once at start
} else {
set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol]
set table [overtype::renderspace -expand_right 1 -transparent $TSUB $table[unset table] $nextcol]
#JMN
#set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol]
#set table [overtype::renderspace -expand_right 1 -transparent \uFFFF $table $nextcol]
}
incr padwidth $bodywidth
incr colposn
}
if {[llength $cols]} {
#return [textblock::join -- {*}$blocks]
if {[tcl::dict::get $o_opts_table -show_edge]} {
#title is considered part of the edge ?
set offset 1 ;#make configurable?
set titlepad [tcl::string::repeat $TSUB $offset]
if {[tcl::dict::get $o_opts_table -title] ne ""} {
set titlealign [tcl::dict::get $o_opts_table -titlealign]
switch -- $titlealign {
left {
set tstring $titlepad[tcl::dict::get $o_opts_table -title]
}
right {
set tstring [tcl::dict::get $o_opts_table -title]$titlepad
}
default {
set tstring [tcl::dict::get $o_opts_table -title]
}
}
set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent]
switch -- $opt_titletransparent {
0 {
set mapchar ""
}
1 {
set mapchar " "
}
default {
#won't work if not a single char - review - check also frame behaviour
set mapchar $opt_titletransparent
}
}
if {$mapchar ne ""} {
set tstring [tcl::string::map [list $mapchar $TSUB] $tstring]
}
set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring]
}
}
return $table
} else {
return "No columns matched"
}
}
# using -startcolumn to do slightly less work
method print3 {args} {
if {![llength $args]} {
set cols [tcl::dict::keys $o_columndata]
} else {
set cols [list]
foreach colspec $args {
set allcols [tcl::dict::keys $o_columndata]
if {[tcl::string::first .. $colspec] >=0} {
set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec]
if {[llength $parts] != 3} {
error "[namespace::current]::table error invalid print specification '$colspec'"
}
lassign $parts from _dd to
if {$from eq ""} {set from 0}
if {$to eq ""} {set to end}
set indices [lrange $allcols $from $to]
lappend cols {*}$indices
} else {
set c [lindex $allcols $colspec]
if {$c ne ""} {
lappend cols $c
}
}
}
}
set blocks [list]
set numposns [llength $cols]
set colposn 0
set padwidth 0
set table ""
foreach c $cols {
set flags [list]
if {$colposn == 0 && $colposn == $numposns-1} {
set flags [list -position solo]
} elseif {$colposn == 0} {
set flags [list -position left]
} elseif {$colposn == $numposns-1} {
set flags [list -position right]
} else {
set flags [list -position inner]
}
set columninfo [my get_column_by_index $c -return dict {*}$flags]
set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]]
set bodywidth [tcl::dict::get $columninfo bodywidth]
if {$table eq ""} {
set table $nextcol
set height [textblock::height $table] ;#only need to get height once at start
} else {
set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $table $nextcol]
}
incr padwidth $bodywidth
incr colposn
}
if {[llength $cols]} {
#return [textblock::join -- {*}$blocks]
if {[tcl::dict::get $o_opts_table -show_edge]} {
#title is considered part of the edge ?
set offset 1 ;#make configurable?
set titlepad [tcl::string::repeat $TSUB $offset]
if {[tcl::dict::get $o_opts_table -title] ne ""} {
set titlealign [tcl::dict::get $o_opts_table -titlealign]
switch -- $titlealign {
left {
set tstring $titlepad[tcl::dict::get $o_opts_table -title]
}
right {
set tstring [tcl::dict::get $o_opts_table -title]$titlepad
}
default {
set tstring [tcl::dict::get $o_opts_table -title]
}
}
set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent]
switch -- $opt_titletransparent {
0 {
set mapchar ""
}
1 {
set mapchar " "
}
default {
#won't work if not a single char - review - check also frame behaviour
set mapchar $opt_titletransparent
}
}
if {$mapchar ne ""} {
set tstring [tcl::string::map [list $mapchar $TSUB] $tstring]
}
set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring]
}
}
return $table
} else {
return "No columns matched"
}
}
#print headers and body using different join mechanisms
# using -startcolumn to do slightly less work
method print {args} {
#*** !doctools
#[call class::table [method print]]
#[para] Return the table as text suitable for console display
if {![llength $args]} {
set cols [tcl::dict::keys $o_columndata]
} else {
set cols [list]
foreach colspec $args {
set allcols [tcl::dict::keys $o_columndata]
if {[tcl::string::first .. $colspec] >=0} {
set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec]
if {[llength $parts] != 3} {
error "[namespace::current]::table error invalid print specification '$colspec'"
}
lassign $parts from _dd to
if {$from eq ""} {set from 0}
if {$to eq ""} {set to end}
set indices [lrange $allcols $from $to]
lappend cols {*}$indices
} else {
set c [lindex $allcols $colspec]
if {$c ne ""} {
lappend cols $c
}
}
}
}
set numposns [llength $cols]
set colposn 0
set padwidth 0
set header_build ""
set body_blocks [list]
set headerheight 0
foreach c $cols {
set flags [list]
if {$colposn == 0 && $colposn == $numposns-1} {
set flags [list -position solo]
} elseif {$colposn == 0} {
set flags [list -position left]
} elseif {$colposn == $numposns-1} {
set flags [list -position right]
} else {
set flags [list -position inner]
}
set columninfo [my get_column_by_index $c -return dict {*}$flags]
#set nextcol [tcl::dict::get $columninfo column]
set bodywidth [tcl::dict::get $columninfo bodywidth]
set headerheight [tcl::dict::get $columninfo headerheight]
#set nextcol_lines [split $nextcol \n]
#set nextcol_header [join [lrange $nextcol_lines 0 $headerheight-1] \n]
#set nextcol_body [join [lrange $nextcol_lines $headerheight end] \n]
set nextcol_header [tcl::dict::get $columninfo header]
set nextcol_body [tcl::dict::get $columninfo body]
if {$header_build eq "" && ![llength $body_blocks]} {
set header_build $nextcol_header
} else {
if {$headerheight > 0} {
set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]]
}
#set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body]
}
lappend body_blocks $nextcol_body
incr padwidth $bodywidth
incr colposn
}
if {![llength $body_blocks]} {
set body_build ""
} else {
#body blocks should not be ragged - so can use join_basic
set body_build [textblock::join_basic -- {*}$body_blocks]
}
if {$headerheight > 0} {
set table [tcl::string::cat $header_build \n $body_build]
} else {
set table $body_build
}
if {[llength $cols]} {
if {[tcl::dict::get $o_opts_table -show_edge]} {
#title is considered part of the edge ?
set offset 1 ;#make configurable?
set titlepad [tcl::string::repeat $TSUB $offset]
if {[tcl::dict::get $o_opts_table -title] ne ""} {
set titlealign [tcl::dict::get $o_opts_table -titlealign]
switch -- $titlealign {
left {
set tstring $titlepad[tcl::dict::get $o_opts_table -title]
}
right {
set tstring [tcl::dict::get $o_opts_table -title]$titlepad
}
default {
set tstring [tcl::dict::get $o_opts_table -title]
}
}
set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent]
switch -- $opt_titletransparent {
0 {
set mapchar ""
}
1 {
set mapchar " "
}
default {
#won't work if not a single char - review - check also frame behaviour
set mapchar $opt_titletransparent
}
}
if {$mapchar ne ""} {
set tstring [tcl::string::map [list $mapchar $TSUB] $tstring]
}
set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring]
}
}
return $table
} else {
return "No columns matched"
}
}
method print_bodymatrix {} {
#*** !doctools
#[call class::table [method print_bodymatrix]]
#[para] output the matrix string corresponding to the body data using the matrix 2string format
#[para] this will be a table without borders,headers,title etc and will exclude additional ANSI applied due to table, row or column settings.
#[para] If the original cell data itself contains ANSI - the output will still contain those ansi codes.
#
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
#
tcl::namespace::eval textblock {
variable frametypes
set frametypes [list light light_b light_c heavy heavy_b heavy_c arc arc_b arc_c double block block1 block2 block2hack ascii altg]
#class::table needs to be able to determine valid frametypes
proc frametypes {} {
variable frametypes
return $frametypes
}
tcl::namespace::eval cd {
#todo - save and restore existing tcl::namespace::export in case macros::cd has default exports in future
tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export *}
tcl::namespace::import ::term::ansi::code::macros::cd::*
tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export -clear}
}
proc spantest {} {
set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}]
$t configure_column 0 -headers [list span3 "1-span4\n2-span4 second line" span5/5 "span-all etc blah 123 hmmmmm" span2]
$t configure_column 0 -header_colspans {3 4 5 any 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
}
proc spantest1 {} {
set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}]
$t configure_column 0 -headers [list "span3-any longer than other span any" "1-span4\n2-span4 second line" "span-any short aligned?" "span5/5 longest etc blah 123" span2]
$t configure_column 0 -header_colspans {any 4 any 5 2}
$t configure_column 2 -headers {"" "" "" "" c2span2_etc}
$t configure_column 2 -header_colspans {0 0 0 0 2}
$t configure_column 3 -header_colspans {1 0 0 0 0}
$t configure -show_header 1 -ansiborder_header [a+ cyan]
$t configure_column 0 -blockalign right ;#trigger KNOWN BUG overwrite of right edge by last char of spanning col (in this case fullspan from left - but also happens for any span extending to rhs)
return $t
}
#more complex colspans
proc spantest2 {} {
set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}]
$t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" c0span2}
$t configure_column 0 -header_colspans {3 4 1 any 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 -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}]
$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 any 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
}
punk::args::definition {
@id -id ::textblock::periodic
@cmd -name textblock::periodic -help "A rudimentary periodic table
This is primarily a test of textblock::class::table"
-return -default table\
-choices {table tableobject}\
-help "default choice 'table' returns the displayable table output"
-compact -default 1 -type boolean -help "compact true defaults: -show_vseps 0 -show_header 0 -show_edge 0"
-frame -default 1 -type boolean
-show_vseps -default "" -type boolean
-show_header -default "" -type boolean
-show_edge -default "" -type boolean
-forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured"
@values -min 0 -max 0
}
proc periodic {args} {
#For an impressive interactive terminal app (javascript)
# see: https://github.com/spirometaxas/periodic-table-cli
set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts]
set opt_return [tcl::dict::get $opts -return]
if {[tcl::dict::get $opts -forcecolour]} {
set fc forcecolour
} else {
set fc ""
}
#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 [tcl::dict::create]
set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra]
set ansi [a+ {*}$fc web-black Web-gold]
set val [list ansi $ansi cat alkaline_earth]
foreach e $cat_alkaline_earth {
tcl::dict::set ecat $e $val
}
set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I]
#set ansi [a+ {*}$fc web-black Web-lightgreen]
set ansi [a+ {*}$fc black Term-113]
set val [list ansi $ansi cat reactive_nonmetal]
foreach e $cat_reactive_nonmetal {
tcl::dict::set ecat $e $val
}
set cat [list Li Na K Rb Cs Fr]
#set ansi [a+ {*}$fc web-black Web-Khaki]
set ansi [a+ {*}$fc black Term-lightgoldenrod2]
set val [list ansi $ansi cat alkali_metals]
foreach e $cat {
tcl::dict::set ecat $e $val
}
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+ {*}$fc web-black Web-lightsalmon]
set ansi [a+ {*}$fc black Term-orange1]
set val [list ansi $ansi cat transition_metals]
foreach e $cat {
tcl::dict::set ecat $e $val
}
set cat [list Al Ga In Sn Tl Pb Bi Po]
set ansi [a+ {*}$fc web-black Web-lightskyblue]
set val [list ansi $ansi cat post_transition_metals]
foreach e $cat {
tcl::dict::set ecat $e $val
}
set cat [list B Si Ge As Sb Te At]
#set ansi [a+ {*}$fc web-black Web-turquoise]
set ansi [a+ {*}$fc black Brightcyan]
set val [list ansi $ansi cat metalloids]
foreach e $cat {
tcl::dict::set ecat $e $val
}
set cat [list He Ne Ar Kr Xe Rn]
set ansi [a+ {*}$fc web-black Web-orchid]
set val [list ansi $ansi cat noble_gases]
foreach e $cat {
tcl::dict::set ecat $e $val
}
set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr]
set ansi [a+ {*}$fc web-black Web-plum]
set val [list ansi $ansi cat actinoids]
foreach e $cat {
tcl::dict::set ecat $e $val
}
set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu]
#set ansi [a+ {*}$fc web-black Web-tan]
set ansi [a+ {*}$fc black Term-tan]
set val [list ansi $ansi cat lanthanoids]
foreach e $cat {
tcl::dict::set ecat $e $val
}
set ansi [a+ {*}$fc web-black Web-whitesmoke]
set val [list ansi $ansi cat other]
foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] {
tcl::dict::set ecat $e $val
}
set elements1 [list]
set RST [a+]
foreach e $elements {
if {[tcl::dict::exists $ecat $e]} {
set ansi [tcl::dict::get $ecat $e ansi]
#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 -columns 19 -return tableobject $elements1]
#(defaults to show_hseps 0)
#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
}
set ccount [$t column_count]
for {set c 0} {$c < $ccount} {incr c} {
$t configure_column $c -minwidth 3
}
if {[tcl::dict::get $opts -compact]} {
#compact defaults - but let explicit arguments override
set conf [dict create -show_vseps 0 -show_header 0 -show_edge 0]
} else {
set conf [dict create -show_vseps 1 -show_header 1 -show_edge 1]
}
dict for {k v} $conf {
if {[dict get $opts $k] ne ""} {
dict set conf $k [dict get $opts $k]
}
}
set moreopts [dict create\
-frametype_header light\
-ansiborder_header [a+ {*}$fc brightwhite]\
-ansibase_header [a+ {*}$fc Black]\
-ansibase_body [a+ {*}$fc Black]\
-ansiborder_body [a+ {*}$fc black]\
-frametype block
]
$t configure {*}[dict merge $conf $moreopts]
#-ansiborder_header [a+ {*}$fc web-white]\
if {$opt_return eq "table"} {
if {[dict get $opts -frame]} {
#set output [textblock::frame -ansiborder [a+ {*}$fc Black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]]
#set output [textblock::frame -ansiborder [a+ {*}$fc Black term-deepskyblue2] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]]
set output [textblock::frame -checkargs 0 -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]]
} else {
set output [$t print]
}
$t destroy
return $output
}
return $t
}
proc bookend_lines {block start {end "\x1b\[m"}} {
set out ""
foreach ln [split $block \n] {
append out $start $ln $end \n
}
return [string range $out 0 end-1]
}
proc ansibase_lines {block {newprefix ""}} {
set base ""
set out ""
if {$newprefix eq ""} {
foreach ln [split $block \n] {
set parts [punk::ansi::ta::split_codes $ln]
if {[lindex $parts 0] eq ""} {
if {[lindex $parts 1] ne "" && ![punk::ansi::codetype::is_sgr_reset [lindex $parts 1]]} {
set base [lindex $parts 1]
append out $base
} else {
append out $base
}
} else {
#leading plaintext - maintain our base
append out $base [lindex $parts 0] [lindex $parts 1]
}
set code_idx 3
foreach {pt code} [lrange $parts 2 end] {
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set parts [linsert $parts $code_idx+1 $base]
}
incr code_idx 2
}
append out {*}[lrange $parts 2 end] \n
}
return [string range $out 0 end-1]
} else {
set base $newprefix
foreach ln [split $block \n] {
set parts [punk::ansi::ta::split_codes $ln]
set code_idx 1
set offset 0
foreach {pt code} $parts {
if {$code_idx == 1} {
#first pt & code
if {$pt ne ""} {
#leading plaintext
set parts [linsert $parts 0 $base]
incr offset
}
}
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set parts [linsert $parts [expr {$code_idx+1+$offset}] $base]
incr offset
}
incr code_idx 2
}
append out {*}$parts \n
}
return [string range $out 0 end-1]
}
}
set FRAMETYPES [textblock::frametypes]
punk::args::definition [punk::lib::tstr -return string {
@id -id ::textblock::list_as_table
@cmd -name "textblock::list_as_table" -help\
"Display a list in a bordered table
"
-return -default table -choices {table tableobject}
-frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\
-help "frame type or dict for custom frame"
-show_edge -default "" -type boolean\
-help "show outer border of table"
-show_seps -default "" -type boolean
-show_vseps -default "" -type boolean\
-help "Show vertical table separators"
-show_hseps -default "" -type boolean\
-help "Show horizontal table separators
(default 0 if no existing -table supplied)"
-table -default "" -type string\
-help "existing table object to use"
-colheaders -default "" -type list\
-help "list of lists. list of column header values. Outer list must match number of columns"
-header -default "" -type list -multiple 1\
-help "Each supplied -header argument is a header row.
The number of values for each must be <= number of columns"
-show_header -type boolean\
-help "Whether to show a header row.
Omit for unspecified/automatic,
in which case it will display only if -headers list was supplied."
-action -default "append" -choices {append replace}\
-help "row insertion method if existing -table is supplied
if append is chosen the new values will always start at the first column"
-columns -default "" -type integer\
-help "Number of table columns
Will default to 2 if not using an existing -table object"
@values -min 0 -max 1
datalist -default {} -type list -help "flat list of table cell values which will be wrapped based on -columns value"
}]
proc list_as_table {args} {
set FRAMETYPES [textblock::frametypes]
set argd [punk::args::get_by_id ::textblock::list_as_table $args]
set opts [dict get $argd opts]
set datalist [dict get $argd values datalist]
set existing_table [dict get $opts -table]
set opt_columns [dict get $opts -columns]
set count [llength $datalist]
set is_new_table 0
if {$existing_table ne ""} {
if {[tcl::namespace::tail [info object class $existing_table]] ne "table"} {
error "textblock::list_as_table error -table must be an existing table object (e.g set t \[textblock::class::table new\])"
}
set t $existing_table
foreach prop {-frametype -show_edge -show_seps -show_vseps -show_hseps} {
if {[tcl::dict::get $opts $prop] ne ""} {
$t configure $prop [tcl::dict::get $opts $prop]
}
}
if {[dict get $opts -action] eq "replace"} {
$t row_clear
}
set cols [$t column_count]
if {[tcl::string::is integer -strict $opt_columns]} {
if {$opt_columns > $cols} {
set extra [expr {$opt_columns - $cols}]
for {set c 0} {$c < $extra} {incr c} {
$t add_column
}
} elseif {$opt_columns < $cols} {
#todo - auto add blank values in the datalist
error "Number of columns requested: $opt_columns is less than existing number of columns $cols - not yet supported"
}
set cols [$t column_count]
}
} else {
set is_new_table 1
set colheaders {}
if {[tcl::dict::get $opts -colheaders] ne ""} {
set colheaders [dict get $opts -colheaders]
} else {
set colheaders [list]
}
set r 0
foreach ch $colheaders {
set rows [llength $ch]
if {$r < $rows} {
set r $rows
}
}
if {[llength [tcl::dict::get $opts -header]]} {
foreach hrow [tcl::dict::get $opts -header] {
set c 0
foreach cell $hrow {
if {[llength $colheaders] < $c+1} {
lappend colheaders [lrepeat $r {}]
}
set colinfo [lindex $colheaders $c]
if {$r > [llength $colinfo]} {
set diff [expr {$r - [llength $colinfo]}]
lappend colinfo {*}[lrepeat $diff {}]
}
lappend colinfo $cell
lset colheaders $c $colinfo
incr c
}
incr r
}
}
if {[llength $colheaders] > 0} {
if {![tcl::dict::exists $opts received -show_header]} {
set show_header 1
} else {
set show_header [tcl::dict::get $opts -show_header]
}
} else {
if {![tcl::dict::exists $opts received -show_header]} {
set show_header 0
} else {
set show_header [tcl::dict::get $opts -show_header]
}
}
if {[tcl::string::is integer -strict $opt_columns]} {
set cols $opt_columns
if {[llength $colheaders] && $cols != [llength $colheaders]} {
error "list_as_table number of columns ($cols) doesn't match supplied number of headers ([llength $colheaders])"
}
} else {
#review
if {[llength $colheaders]} {
set cols [llength $colheaders]
} else {
set cols 2 ;#seems a reasonable default
}
}
#defaults for new table only
#if {[tcl::dict::get $opts -show_seps] eq ""} {
# tcl::dict::set opts -show_seps 1
#}
if {[tcl::dict::get $opts -show_edge] eq ""} {
tcl::dict::set opts -show_edge 1
}
if {[tcl::dict::get $opts -show_vseps] eq ""} {
tcl::dict::set opts -show_vseps 1
}
if {[tcl::dict::get $opts -show_hseps] eq ""} {
tcl::dict::set opts -show_hseps 0
}
set t [textblock::class::table new\
-show_header $show_header\
-show_edge [tcl::dict::get $opts -show_edge]\
-frametype [tcl::dict::get $opts -frametype]\
-show_seps [tcl::dict::get $opts -show_seps]\
-show_vseps [tcl::dict::get $opts -show_vseps]\
-show_hseps [tcl::dict::get $opts -show_hseps]\
]
if {[llength $colheaders]} {
for {set c 0} {$c < $cols} {incr c} {
$t add_column -headers [lindex $colheaders $c]
}
} else {
for {set c 0} {$c < $cols} {incr c} {
$t add_column -headers [list $c]
}
}
}
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 ""]]
lappend row {*}[lrepeat $shortfall ""]
}
$t add_row $row
}
#puts stdout $rowdata
if {[tcl::dict::get $opts -return] eq "table"} {
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 tcl::string::length is ok
if {[tcl::string::length $char] == 1} {
set row [tcl::string::repeat $char $blockwidth]
set mtrx [lrepeat $blockheight $row]
return [::join $mtrx \n]
} else {
set charblock [tcl::string::map [list \r\n \n] $char]
if {[tcl::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_basic -- {*}[lrepeat $blockwidth $charblock]]
} else {
set row $charblock
}
} else {
set row [tcl::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 [list {*}[punk::lib::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 [tcl::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_basic -ansiresets 0 -- {*}$clist]
} else {
return [textblock::join_basic -- {*}$clist]
}
} elseif {"rainbow" in $colour} {
#direction must be horizontal
set block ""
for {set r 0} {$r < $size} {incr r} {
set colour2 [tcl::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 [tcl::string::trimright $block \n]
return $block
} else {
#row first -
set rows [list]
foreach ch $charsubset {
lappend rows [tcl::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 {[tcl::string::last \t $textblock] >= 0} {
if {[tcl::info::exists punk::console::tabwidth]} {
set tw $::punk::console::tabwidth
} else {
set tw 8
}
set textblock [textutil::tabify::untabify2 $textblock $tw]
}
if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} {
#ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions)
set textblock [punk::ansi::ansistripraw $textblock]
}
if {[tcl::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]
}
#gather info about whether ragged (samewidth each line = false) and min width
proc widthinfo {textblock} {
#backspaces, vertical tabs ?
if {$textblock eq ""} {
return [dict create width 0 minwidth 0 ragged 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 {[tcl::string::last \t $textblock] >= 0} {
if {[tcl::info::exists punk::console::tabwidth]} {
set tw $::punk::console::tabwidth
} else {
set tw 8
}
set textblock [textutil::tabify::untabify2 $textblock $tw]
}
if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} {
#ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions)
set textblock [punk::ansi::ansistripraw $textblock]
}
if {[tcl::string::last \n $textblock] >= 0} {
#return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]]
set widths [lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]
set max [tcl::mathfunc::max {*}$widths]
set min [tcl::mathfunc::min {*}$widths]
set ragged [expr {$min != $max}]
return [dict create width $max minwidth $min ragged $ragged]
}
#single line
set w [punk::char::ansifreestring_width $textblock]
return [dict create width $w minwidth $w ragged 0]
}
#when we know the block is uniform in width - just examine topline
proc widthtopline {textblock} {
set firstnl [tcl::string::first \n $textblock]
if {$firstnl >= 0} {
set tl [tcl::string::range $textblock 0 $firstnl]
} else {
set tl $textblock
}
if {[punk::ansi::ta::detect $tl]} {
set tl [punk::ansi::ansistripraw $tl]
}
return [punk::char::ansifreestring_width $tl]
}
#uses tcl's tcl::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] {tcl::string::length $v}]
set max 0
foreach ln [split $textblock \n] {
if {[tcl::string::length $ln] > $max} {set max [tcl::string::length $ln]}
}
return $max
}
#*slightly* slower
#proc string_length_line_max {textblock} {
# tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}]
#}
proc string_length_line_min textblock {
tcl::mathfunc::min {*}[lmap v [split $textblock \n] {tcl::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 {[tcl::string::length $textblock]-[tcl::string::length [tcl::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 [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings
}
#strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack
if {[tcl::string::last \t $textblock] >= 0} {
if {[tcl::info::exists punk::console::tabwidth]} {
set tw $::punk::console::tabwidth
} else {
set tw 8
}
set textblock [textutil::tabify::untabify2 $textblock $tw]
}
#ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests
if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} {
set textblock [punk::ansi::ansistripraw $textblock]
}
if {[tcl::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 {[tcl::string::length $textblock]-[tcl::string::length [tcl::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 [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
proc size2 {textblock} {
if {$textblock eq ""} {
return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings
}
#strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack
if {[tcl::string::last \t $textblock] >= 0} {
if {[tcl::info::exists punk::console::tabwidth]} {
set tw $::punk::console::tabwidth
} else {
set tw 8
}
set textblock [textutil::tabify::untabify2 $textblock $tw]
}
#ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests
if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} {
set textblock [punk::ansi::ansistripraw $textblock]
}
if {[tcl::string::last \n $textblock] >= 0} {
#set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]]
set lines [split $textblock \n]
set num_le [expr {[llength $lines]-1}]
#set width [tcl::mathfunc::max {*}[lmap v $lines {::punk::char::ansifreestring_width $v}]]
set width 0
foreach ln $lines {
set w [::punk::char::ansifreestring_width $ln]
if {$w > $width} {
set width $w
}
}
} else {
set num_le 0
set width [punk::char::ansifreestring_width $textblock]
}
#set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::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 [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
proc size_as_opts {textblock} {
set sz [size $textblock]
return [dict create -width [dict get $sz width] -height [dict get $sz height]]
}
proc size_as_list {textblock} {
set sz [size $textblock]
return [list [dict get $sz width] [dict get $sz 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 {[tcl::info::exists punk::console::tabwidth]} {
set tw $::punk::console::tabwidth
} else {
set tw 8
}
set block [textutil::tabify::untabify2 $block $tw]
if {[tcl::string::last \n $block] >= 0} {
return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $block] {::punk::char::string_width [ansistrip $v]}]]
}
if {[catch {llength $block}]} {
return [::punk::char::string_width [ansistrip $block]]
}
if {[llength $block] == 0} {
#could be just a whitespace string
return [tcl::string::length $block]
}
return [tcl::mathfunc::max {*}[lmap v $block {::punk::char::string_width [ansistrip $v]}]]
}
#we shouldn't make textblock depend on the punk pipeline system
#pipealias ::textblock::padleft .= {list $input [tcl::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 [tcl::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 opts [tcl::dict::create\
-padchar " "\
-which "right"\
-known_blockwidth ""\
-known_samewidth ""\
-known_hasansi ""\
-width ""\
-overflow 0\
-within_ansi 0\
]
#known_samewidth of empty string means we don't know either way, 0 is definitely 'ragged', 1 is definitely homogenous
#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 block ?-padchar <sp>|<character>? ?-which right|left|centre? ?-known_hasansi \"\"|<bool>? ?-known_blockwidth \"\"|<int>? ?-width auto|<int>? ?-within_ansi 1|0?"
foreach {k v} $args {
switch -- $k {
-padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi {
tcl::dict::set opts $k $v
}
default {
error "textblock::pad unrecognised option '$k'. Usage: $usage"
}
}
}
# -- --- --- --- --- --- --- --- --- ---
set padchar [tcl::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 tcl::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 [tcl::string::tolower [tcl::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 [tcl::dict::get $opts -width]
switch -- $opt_width {
"" - auto {
set width auto
}
default {
if {![tcl::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 [tcl::dict::get $opts -within_ansi]
switch -- $opt_withinansi {
0 - 1 {}
default {
set opt_withinansi 2
}
}
# -- --- --- --- --- --- --- --- --- ---
set known_blockwidth [tcl::dict::get $opts -known_blockwidth]
set known_samewidth [tcl::dict::get $opts -known_samewidth] ;# if true - we have a known non-ragged block, if false - could be either.
set datawidth ""
if {$width eq "auto"} {
#for auto - we
if {$known_blockwidth eq ""} {
if {$known_samewidth ne "" && $known_samewidth} {
set datawidth [textblock::widthtopline $block]
} else {
#set datawidth [textblock::width $block]
set widthinfo [textblock::widthinfo $block]
set known_samewidth [expr {![dict get $widthinfo ragged]}] ;#review - a false value here is definite, distinguished from unknown which would be empty string - so we can take advantage of it
set datawidth [dict get $widthinfo width]
}
} else {
set datawidth $known_blockwidth
}
set width $datawidth ;# this is the width we want to pad out to
#assert datawidth has been set to widest line, taking ansi & 2wide chars into account
} else {
#only call width functions if known_samewidth - otherwise let the pad algorithm below determine it as we go
if {$known_samewidth ne "" && $known_samewidth} {
if {$known_blockwidth eq ""} {
set datawidth [textblock::widthtopline $block
} else {
set datawidth $known_blockwidth
}
}
#assert datawidth may still be empty string
}
#assertion
#we can now use the states of datawidth and known_samewidth to determine if algorithm below should calculate widths as it goes.
set lines [list]
set padcharsize [punk::ansi::printing_length $padchar]
set pad_has_ansi [punk::ansi::ta::detect $padchar]
if {$block eq ""} {
#we need to treat as a line
set repeats [expr {int(ceil($width / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width
#TODO
#review - what happens when padchar has ansi, or the width would split a double-wide unicode char?
#we shouldn't be using string range if there is ansi - (overtype? ansistring range?)
#we should use overtype with suitable replacement char (space?) for chopped double-wides
if {!$pad_has_ansi} {
return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1]
} else {
set base [tcl::string::repeat " " $width]
return [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]]
}
}
#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
#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 [tcl::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 [tcl::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]
# }
#todo? special case trailing double-reset - insert between resets?
set lnum 0
set known_hasansi [tcl::dict::get $opts -known_hasansi]
if {$known_hasansi eq ""} {
set block_has_ansi [punk::ansi::ta::detect $block]
} else {
set block_has_ansi $known_hasansi
}
if {$block_has_ansi} {
set parts [punk::ansi::ta::split_codes $block]
} else {
#single plaintext part
set parts [list $block]
}
set line_chunks [list]
set line_len 0
set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad
foreach {pt ansi} $parts {
if {$pt ne ""} {
set has_nl [expr {[tcl::string::last \n $pt]>=0}]
if {$has_nl} {
set pt [tcl::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]
if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} {
incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW
}
if {$p != $last} {
#do padding
if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} {
set missing [expr {$width - $line_len}]
} else {
set missing [expr {$width - $datawidth}]
}
if {$missing > 0} {
#commonly in a block - many lines will have the same pad - cache based on missing
#padchar may be more than 1 wide - because of 2wide unicode and or multiple chars
if {[tcl::dict::exists $pad_cache $missing]} {
set pad [tcl::dict::get $pad_cache $missing]
} else {
set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width
if {!$pad_has_ansi} {
set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1]
} else {
set base [tcl::string::repeat " " $missing]
set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]]
}
dict set pad_cache $missing $pad
}
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
if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} {
set missing [expr {$width - $line_len}]
} else {
set missing [expr {$width - $datawidth}]
}
if {$missing > 0} {
if {[tcl::dict::exists $pad_cache $missing]} {
set pad [tcl::dict::get $pad_cache $missing]
} else {
set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width
if {!$pad_has_ansi} {
set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1]
} else {
set base [tcl::string::repeat " " $missing]
set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]]
}
}
#set pad [tcl::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 -known_blockwidth $width -width $padtowidth -padchar . -which left -within_ansi 0]
set left1 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which left -within_ansi 1]
set left2 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which left -within_ansi 2]
set right0 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 0]
set right1 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 1]
set right2 [textblock::pad $block -known_blockwidth $width -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 -columns 3 -return tableobject $testlist]
$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 opts [tcl::dict::create\
-description ""\
-blockheaders ""\
]
foreach {k v} $args {
switch -- $k {
-description - -blockheaders {
tcl::dict::set opts $k $v
}
default {
error "pad_test_blocklist unrecognised option '$k'. Known options: [tcl::dict::keys $opts]"
}
}
}
set opt_blockheaders [tcl::dict::get $opts -blockheaders]
set bheaders [tcl::dict::create]
if {$opt_blockheaders ne ""} {
set b 0
foreach h $opt_blockheaders {
if {$b < [llength $blocklist]} {
tcl::dict::set bheaders $b $h
}
incr b
}
}
set b 0
set blockinfo [tcl::dict::create]
foreach block $blocklist {
set width [textblock::width $block]
tcl::dict::set blockinfo $b width $width
set padtowidth [expr {$width + 3}]
tcl::dict::set blockinfo $b left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0]
tcl::dict::set blockinfo $b left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1]
tcl::dict::set blockinfo $b left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2]
tcl::dict::set blockinfo $b right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0]
tcl::dict::set blockinfo $b right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1]
tcl::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 [tcl::dict::get $blockinfo $b left0]] [textblock::join [tcl::dict::get $blockinfo $b right0]]
# lappend r1 [textblock::join [tcl::dict::get $blockinfo $b left1]] [textblock::join [tcl::dict::get $blockinfo $b right1]]
# lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]]
#}
#2 - the more useful one?
tcl::dict::for {b bdict} $blockinfo {
lappend r0 [tcl::dict::get $blockinfo $b left0] [tcl::dict::get $blockinfo $b right0]
lappend r1 [tcl::dict::get $blockinfo $b left1] [tcl::dict::get $blockinfo $b right1]
lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::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 -columns [expr {1 + (2 * [tcl::dict::size $blockinfo])}] -return tableobject $rows]
$t configure_column 0 -headers [list [tcl::dict::get $opts -description] "within_ansi"] -ansibase $column_ansi
set col 1
tcl::dict::for {b bdict} $blockinfo {
if {[tcl::dict::exists $bheaders $b]} {
set hdr [tcl::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 [tcl::string::repeat " " $w1] $rhs [tcl::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 [tcl::string::repeat " " [width $lhs]] $rhs [tcl::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::get_dict {
-ansiresets -default 1 -type integer
blocks -type string -multiple 1
} $args] _l leaders _o opts _v values
set blocks [tcl::dict::get $values blocks]
set idx 0
set fordata [list]
foreach b $blocks {
set c($idx) [tcl::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]
}
punk::args::definition {
@id -id ::textblock::join_basic
@cmd -name textblock::join_basic -help\
"Join blocks of text line by line but don't add padding on each line to enforce uniform width.
Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner
"
-- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags"
-ansiresets -type any -default auto
blocks -type any -multiple 1
}
#join without regard to each line length in a block (no padding added to make each block uniform)
proc ::textblock::join_basic {args} {
set argd [punk::args::get_by_id ::textblock::join_basic $args]
set ansiresets [tcl::dict::get $argd opts -ansiresets]
set blocks [tcl::dict::get $argd values blocks]
#-ansireplays is always on (if ansi detected)
# -- is a legimate block
#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)
if {![llength $blocks]} {
return
}
set rowcount 0
set blocklists [list]
foreach b $blocks {
if {[punk::ansi::ta::detect $b]} {
#-ansireplays 1 quite expensive e.g 7ms in 2024
set bl [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b]
} else {
set bl [split $b \n]
}
if {[llength $bl] > $rowcount} {
set rowcount [llength $bl]
}
lappend blocklists $bl
}
set outlines [list]
for {set r 0} {$r < $rowcount} {incr r} {
set row ""
for {set c 0} {$c < [llength $blocks]} {incr c} {
append row [lindex $blocklists $c $r]
}
lappend outlines $row
}
return [::join $outlines \n]
}
proc ::textblock::join_basic2 {args} {
#@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width.
# Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner
#"
set argd [punk::args::get_dict {
-- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags"
-ansiresets -type any -default auto
blocks -type any -multiple 1
} $args]
set ansiresets [tcl::dict::get $argd opts -ansiresets]
set blocks [tcl::dict::get $argd values blocks]
#-ansireplays is always on (if ansi detected)
# -- is a legimate block
#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)
if {![llength $blocks]} {
return
}
set idx 0
set fordata [list]
set colindices [list]
foreach b $blocks {
if {[punk::ansi::ta::detect $b]} {
lappend fordata "v($idx)" [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b]
} else {
lappend fordata "v($idx)" [split $b \n]
}
lappend colindices $idx
incr idx
}
set outlines [list]
foreach {*}$fordata {
set row {}
foreach colidx $colindices {
lappend row $v($colidx)
}
lappend outlines [::join $row ""]
}
return [::join $outlines \n]
}
#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} {
#set argd [punk::args::get_dict {
# blocks -type string -multiple 1
#} $args]
#set opts [tcl::dict::get $argd opts]
#set blocks [tcl::dict::get $argd 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]
set ansiresets [lindex $args 1]
} else {
error "end of opts marker -- is mandatory."
}
}
default {
if {[catch {tcl::prefix::match {-ansiresets} [lindex $args 0]} fullopt]} {
error "first flag must be -ansiresets or end of opts marker --"
} else {
if {[lindex $args 2] eq "--"} {
set blocks [lrange $args 3 end]
set ansiresets [lindex $args 1]
} else {
error "end of opts marker -- is mandatory"
}
}
}
}
if {![llength $blocks]} {
return
}
set idx 0
set blocklists [list]
set rowcount 0
foreach b $blocks {
#we need the width of a rendered block for per-row renderline calls or padding
#we may as well use widthinfo to also determine raggedness state to pass on to pad function
#set bwidth [width $b]
set widthinfo [widthinfo $b]
set bwidth [dict get $widthinfo width]
set is_samewidth [expr {![dict get $widthinfo ragged]}]
#set c($idx) [tcl::string::repeat " " [set w($idx)]]
#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.
#blocks passed to join can be ragged - so we can't pass -known_samewidth to pad
if {[punk::ansi::ta::detect $b]} {
# - we need to join to use pad - even though we then need to immediately resplit REVIEW (make line list version of pad?)
set replay_block [::join [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] \n]
set bl [split [textblock::pad $replay_block -known_hasansi 1 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n]
} 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
set bl [split [textblock::pad $b -known_hasansi 0 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n]
}
set rowcount [expr {max($rowcount,[llength $bl])}]
lappend blocklists $bl
set width($idx) $bwidth
incr idx
}
set outlines [list]
for {set r 0} {$r < $rowcount} {incr r} {
set row ""
for {set c 0} {$c < [llength $blocklists]} {incr c} {
set cell [lindex $blocklists $c $r]
if {$cell eq ""} {
set cell [string repeat " " $width($c)]
}
append row $cell
}
lappend outlines $row
}
return [::join $outlines \n]
}
proc ::textblock::join2 {args} {
#set argd [punk::args::get_dict {
# blocks -type string -multiple 1
#} $args]
#set opts [tcl::dict::get $argd opts]
#set blocks [tcl::dict::get $argd 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]
set ansiresets [lindex $args 1]
} else {
error "end of opts marker -- is mandatory."
}
}
default {
if {[catch {tcl::prefix::match {-ansiresets} [lindex $args 0]} fullopt]} {
error "first flag must be -ansiresets or end of opts marker --"
} else {
if {[lindex $args 2] eq "--"} {
set blocks [lrange $args 3 end]
set ansiresets [lindex $args 1]
} else {
error "end of opts marker -- is mandatory"
}
}
}
}
if {![llength $blocks]} {
return
}
set idx 0
set fordata [list]
set colindices [list]
foreach b $blocks {
set w($idx) [width $b] ;#we need the width of a rendered block for per-row renderline calls or padding
#set c($idx) [tcl::string::repeat " " [set w($idx)]]
#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]
# - we need to join to use pad - even though we then need to immediately resplit REVIEW (make line list version of pad?)
set replay_block [::join [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] \n]
lappend fordata "v($idx)" [split [textblock::pad $replay_block -known_hasansi 1 -known_blockwidth $w($idx) -width $w($idx) -which right -padchar " "] \n]
} 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 fordata "v($idx)" [split [textblock::pad $b -known_hasansi 0 -known_blockwidth $w($idx) -width $w($idx) -which right -padchar " "] \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 " "]
#short blocks need to have empty lines padded too
if {$v($colidx) eq ""} {
append row [string repeat " " $w($colidx)]
} else {
append row $v($colidx)
}
}
lappend outlines $row
}
return [::join $outlines \n]
}
# This calls textblock::pad per cell :/
proc ::textblock::join3 {args} {
#set argd [punk::args::get_dict {
# blocks -type string -multiple 1
#} $args]
#set opts [tcl::dict::get $argd opts]
#set blocks [tcl::dict::get $argd 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]
set ansiresets [lindex $args 1]
} else {
error "end of opts marker -- is mandatory."
}
}
default {
if {[catch {tcl::prefix::match {-ansiresets} [lindex $args 0]} fullopt]} {
error "first flag must be -ansiresets or end of opts marker --"
} else {
if {[lindex $args 2] eq "--"} {
set blocks [lrange $args 3 end]
set ansiresets [lindex $args 1]
} else {
error "end of opts marker -- is mandatory"
}
}
}
}
if {![llength $blocks]} {
return
}
set idx 0
set fordata [list]
set colindices [list]
foreach b $blocks {
set w($idx) [width $b] ;#we need the width of a rendered block for per-row renderline calls or padding
#set c($idx) [tcl::string::repeat " " [set w($idx)]]
#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
}
#puts stderr "--->outlines len: [llength $outlines]"
return [::join $outlines \n]
}
proc ::textblock::trim {block} {
error "textblock::trim unimplemented"
set trimlines ""
}
#pipealias ::textblock::join_right .= {list $lhs [tcl::string::repeat " " [width $lhs]] $rhs [tcl::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 welcome_test {} {
package require punk::ansi
set ansi [textblock::join -- " " [punk::ansi::ansicat src/testansi/publicdomain/roysac/roy-welc.ans 80x8]]
# Ansi art courtesy of Carsten Cumbrowski aka Roy/SAC - roysac.com
set table [[textblock::spantest] print]
set punks [a+ web-lawngreen][>punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a]
set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks]
set testblock [textblock::testblock 15 rainbow]
set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks]
set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents]
}
proc example {args} {
set opts [tcl::dict::create -forcecolour 0]
foreach {k v} $args {
switch -- $k {
-forcecolour {
tcl::dict::set opts $k $v
}
default {
error "textblock::example unrecognised option '$k'. Known-options: [tcl::dict::keys $opts]"
}
}
}
set opt_forcecolour 0
if {[tcl::dict::get $opts -forcecolour]} {
set fc forcecolour
set opt_forcecolour 1
} else {
set fc ""
}
set pleft [>punk . rhs]
set pright [>punk . lhs]
set prightair [>punk . lhs_air]
set red [a+ {*}$fc red]; set redb [a+ {*}$fc red bold]
set green [a+ {*}$fc green]; set greenb [a+ {*}$fc green bold]
set cyan [a+ {*}$fc cyan];set cyanb [a+ {*}$fc cyan bold]
set blue [a+ {*}$fc blue];set blueb [a+ {*}$fc 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 -checkargs 0 $cpunks] [textblock::frame -checkargs 0 $punks]]
append out $2frames_a \n
set 2frames_b [textblock::join -- [textblock::frame -checkargs 0 -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -checkargs 0 -ansiborder $greenb -title "fancypunks" $cpunks]]
append out [textblock::frame -checkargs 0 -title "punks" $2frames_b\n$RST$2frames_a] \n
set punkdeck [overtype::right [overtype::left [textblock::frame -checkargs 0 -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\nD\nE\nC\nK"]
set spantable [[spantest] print]
append out [textblock::join -- $punkdeck " " $spantable] \n
#append out [textblock::frame -title gr $gr0]
append out [textblock::periodic -forcecolour $opt_forcecolour]
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} {
#todo - use punk::args
upvar ::textblock::class::opts_table_defaults toptdefaults
set defaults [tcl::dict::create\
-rows [list]\
-headers [list]\
-return string\
]
set defaults [tcl::dict::merge $defaults $toptdefaults] ;# -title -frametype -show_header etc
set opts [tcl::dict::merge $defaults $args]
# -- --- --- ---
set opt_return [tcl::dict::get $opts -return]
set opt_rows [tcl::dict::get $opts -rows]
set opt_headers [tcl::dict::get $opts -headers]
# -- --- --- ---
set topts [tcl::dict::create]
set toptkeys [tcl::dict::keys $toptdefaults]
tcl::dict::for {k v} $opts {
if {$k in $toptkeys} {
tcl::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
}
}
proc frametype {f} {
#set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc]
switch -- $f {
light - light_b - light_c - heavy - heavy_b - heavy_c - arc - arc_b - arc_c - double - block - block1 - block2 - block2hack - ascii - altg {
return [tcl::dict::create category predefined type $f]
}
default {
set is_custom_dict_ok 1
if {[llength $f] %2 == 0} {
#custom dict may leave out keys - but cannot have unknown keys
foreach {k v} $f {
switch -- $k {
all - hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {}
hltj - hlbj - vllj - vlrj {
#also allow extra join arguments
}
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: $::textblock::frametypes or a dictionary with any of keys all,hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc"
}
if {[dict exists $f all]} {
return [tcl::dict::create category custom type $f]
} else {
set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "]
set custom_frame [tcl::dict::merge $default_custom $f]
return [tcl::dict::create category custom type $custom_frame]
}
}
}
}
variable framedef_cache [tcl::dict::create]
proc framedef {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
#we use the simplest cache_key possible - performance sensitive as called multiple times in table building.
variable framedef_cache
set cache_key $args
if {[tcl::dict::exists $framedef_cache $cache_key]} {
return [tcl::dict::get $framedef_cache $cache_key]
}
#here we avoid the punk::args usage on the happy path, even though punk::args is fairly fast, in favour of an even faster literal switch on the happy path
#this means we have some duplication in where our flags/opts are defined: here in opts, and in spec below to give nicer error output without affecting performance.
#It also means we can't specify checks on the option types etc
set opts [tcl::dict::create\
-joins ""\
-boxonly 0\
]
set bad_option 0
set values [list]
for {set i 0} {$i < [llength $args]} {incr i} {
set a [lindex $args $i]
set a2 [tcl::prefix match -error "" {-- -joins -boxonly} $a]
switch -- $a2 {
-joins - -boxonly {
tcl::dict::set opts $a2 [lindex $args [incr i]]
}
-- {
set values [lrange $args $i+1 end]
break
}
default {
if {[string match -* $a]} {
set bad_option 1
} else {
set values [lrange $args $i end]
}
break
}
}
}
set f [lindex $values 0]
set rawglobs [lrange $values 1 end]
if {![llength $rawglobs] || "all" in $rawglobs || "*" in $rawglobs} {
set globs *
} else {
set globs [list]
foreach g $rawglobs {
switch -- $g {
hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc -
hltj - hlbj - vllj - vlrj {
lappend globs $g
}
corner - corners {
lappend globs tlc blc trc brc
}
noncorner - noncorners {
#same as verticals + horizontals
lappend globs hl* vl*
}
vertical - verticals {
#we don't consider the corners part of this
lappend globs vl*
}
horizontal - horizontals {
lappend globs hl*
}
top - tops {
lappend globs tlc trc hlt*
}
bottom - bottoms {
lappend globs blc brc hlb*
}
left - lefts - lhs {
lappend globs tlc blc vll*
}
right - rights - rhs {
lappend globs trc brc vlr*
}
default {
#must look like a glob search if not one of the above
if {[regexp {[*?\[\]]} $g]} {
lappend globs $g
} else {
set bad_option 1
}
}
}
}
}
if {$bad_option || [llength $values] == 0} {
#no framedef supplied, or unrecognised opt seen
set spec [string map [list <ftlist> $::textblock::frametypes] {
@id -id ::textblock::framedef
@cmd -name textblock::framedef\
-help "Return a dict of the elements that make up a frame border.
May return a subset of available elements based on memberglob values."
-joins -default "" -type list\
-help "List of join directions, any of: up down left right
or those combined with another frametype e.g left-heavy down-light."
-boxonly -default 0 -type boolean\
-help "-boxonly true restricts results to the corner,vertical and horizontal box elements
It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj."
@values -min 1
frametype -choices "<ftlist>" -choiceprefix 0 -choicerestricted 0 -type dict\
-help "name from the predefined frametypes or an adhoc dictionary."
memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices {
corner noncorner top bottom vertical horizontal left right
hl hlt hlb vsl vll vlr tlc trc blc brc hltj hlbj vllj vlrj
}\
-help "restrict to keys matching memberglob."
}]
#append spec \n "frametype -help \"A predefined \""
punk::args::get_dict $spec $args
return
}
set joins [tcl::dict::get $opts -joins]
set boxonly [tcl::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 [tcl::dict::create left "" down "" right "" up ""]
foreach jt $joins {
lassign [split $jt -] direction target
if {$target ne ""} {
tcl::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 rawtarget [tcl::dict::get $join_targets $dir]
lassign [split $rawtarget _] target ;# treat variants light light_b lightc the same
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)
switch -- $targetleft-$targetright {
heavy-light {
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)
set vlrj \u251c;#right light (ltj)
}
heavy-other {
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)
}
heavy-heavy {
set vllj \u2525 ;# left heavy (rtj)
set vlrj \u251d;#right heavy (ltj)
set tlc \u252d ;# Left Heavy and Right Down Light (ttj)
set blc \u2535 ;# Left Heavy and Right Up Light (btj)
set trc \u252e ;#Right Heavy and Left Down Light (ttj)
set brc \u2536 ;#Right Heavy and Left up Light (btj)
}
light-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)
set vllj \u2524 ;# left light (rtj)
}
light-other {
set vllj \u2524 ;# left light (rtj)
}
light-light {
set vllj \u2524 ;# left light (rtj)
set vlrj \u251c;#right light (ltj)
}
}
#set vllj \u2525 ;# left heavy (rtj)
#set vllj \u2524 ;# left light (rtj)
#set vlrj \u251d;#right heavy (ltj)
#set vlrj \u251c;#right light (ltj)
}
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) (+)
}
light_b {
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 " "
set hlbj " "
set vllj " "
set vlrj " "
set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner vll vlr vllj vlrj]
tcl::dict::with arcframe {} ;#extract keys as vars
}
light_c {
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 " "
set hlbj " "
set vllj " "
set vlrj " "
set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner]
tcl::dict::with arcframe {} ;#extract keys as vars
}
"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 [tcl::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)
}
}
}
heavy_b {
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 " "
set hlbj " "
set vllj " "
set vlrj " "
set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner vll vlr vllj vlrj]
tcl::dict::with arcframe {} ;#extract keys as vars
}
heavy_c {
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 " "
set hlbj " "
set vllj " "
set vlrj " "
set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner]
tcl::dict::with arcframe {} ;#extract keys as vars
}
"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 [tcl::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 tlc \U2566 ;# (ttj)
#set blc [punk::char::charshort boxd_huhz] ;# (btj)
set blc \u2569 ;# (btj)
#from3
set trc [punk::char::charshort boxd_ddhz] ;# (ttj)
set brc [punk::char::charshort boxd_duhz] ;# (btj)
}
left_up {
#9
set tlc [punk::char::charshort boxd_dvhz] ;# (fwj)
set trc [punk::char::charshort boxd_dvl] ;# (rtj)
set blc [punk::char::charshort boxd_duhz] ;# (btj)
set hltj \u2569 ;# (btj)
set vllj \u2563 ;# (rtj)
}
right_up {
#10
set tlc [punk::char::charshort boxd_dvr] ;# (ltj)
set trc [punk::char::charshort boxd_dvhz] ;# (fwj)
set brc [punk::char::charshort boxd_duhz] ;# (btj)
set hltj \u2569 ;# (btj)
set vlrj \u2560 ;# (ltj)
}
down_left_right {
#11
set blc [punk::char::charshort boxd_dvhz] ;# (fwj)
set brc [punk::char::charshort boxd_dvhz] ;# (fwj)
set trc [punk::char::charshort boxd_ddhz] ;# (ttj)
set tlc [punk::char::charshort boxd_ddhz] ;# (ttj)
set hlbj \u2566 ;# (ttj)
set vlrj \u2560 ;# (ltj)
}
down_left_up {
#12
set tlc [punk::char::charshort boxd_dvhz] ;# (fwj)
set blc [punk::char::charshort boxd_dvhz] ;# (fwj)
set trc [punk::char::charshort boxd_dvl] ;# (rtj)
set brc [punk::char::charshort boxd_dvl] ;# (rtj)
set hltj \u2569 ;# (btj)
set hlbj \u2566 ;# (ttj)
}
down_right_up {
#13
set tlc [punk::char::charshort boxd_dvr] ;# (ltj)
set blc [punk::char::charshort boxd_dvr] ;# (ltj)
set trc [punk::char::charshort boxd_dvhz] ;# (fwj)
set brc [punk::char::charshort boxd_dvhz] ;# (fwj)
set hltj \u2569 ;# (btj)
set hlbj \u2566 ;# (ttj)
}
left_right_up {
#14
set tlc [punk::char::charshort boxd_dvhz] ;# (fwj)
set trc [punk::char::charshort boxd_dvhz] ;# (fwj)
set blc [punk::char::charshort boxd_duhz] ;# (btj)
set brc [punk::char::charshort boxd_duhz] ;# (btj)
set hltj \u2569 ;# (btj)
}
down_left_right_up {
#15
set tlc [punk::char::charshort boxd_dvhz] ;# (fwj)
set blc [punk::char::charshort boxd_dvhz] ;# (fwj)
set trc [punk::char::charshort boxd_dvhz] ;# (fwj)
set brc [punk::char::charshort boxd_dvhz] ;# (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 [tcl::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 blc \u2bce ;# from "Miscellaneous Symbols and Arrows" - positioned too far right
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)
}
}
}
down_right {
switch -- $targetdown-$targetright {
self-self {
#set brc \u2bce ;# from "Miscellaneous Symbols and Arrows" - positioned too far right
set trc \u252c ;# (ttj)
set blc \u2524 ;# (rtj)
}
}
}
}
}
arc_b {
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 " "
set hlbj " "
set vllj " "
set vlrj " "
set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner vll vlr vllj vlrj]
tcl::dict::with arcframe {} ;#extract keys as vars
}
arc_c {
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 " "
set hlbj " "
set vllj " "
set vlrj " "
set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner]
tcl::dict::with arcframe {} ;#extract keys as vars
}
block1 {
#box drawing as far as we can go without extra blocks from legacy computing unicode block - which is unfortunately not commonly supported
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
}
block2 {
#the resultant table will have text appear towards top of each box
#with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps
set hlt \u2594 ;# upper one eighth block
set hlb \u2581 ;# lower one eighth block
set vlr \u2595 ;# right one eighth block
set vll \u258f ;# left one eighth block
#some terminals (on windows as at 2024) miscount width of these single-width blocks internally
#resulting in extra spacing that is sometimes well removed from the character itself (e.g at next ansi reset)
#This was fixed in windows-terminal based systems (2021) but persists in others.
#https://github.com/microsoft/terminal/issues/11694
set tlc \U1fb7d ;#legacy block
set trc \U1fb7e ;#legacy block
set blc \U1fb7c ;#legacy block
set brc \U1fb7f ;#legacy block
if {[punk::console::check::has_bug_legacysymbolwidth]} {
#rather than totally fail on some mixed layout that happens to use block2 - just degrade it - but prevent alignment problems
set sp \u00a0 ;#non breaking space (plain space may act transparent in some use cases)
set tlc $sp
set trc $sp
set blc $sp
set brc $sp
}
#horizontal and vertical bar joins
set hltj $hlt
set hlbj $hlb
set vllj $vll
set vlrj $vlr
}
block2hack {
#the resultant table will have text appear towards top of each box
#with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps
set hlt \u2594 ;# upper one eighth block
set hlb \u2581 ;# lower one eighth block
set vlr \u2595 ;# right one eighth block
set vll \u258f ;# left one eighth block
#see comments in block2 regarding the problems in some terminals that this *may* hack around to some extent.
#the caller probably only needs block2hack if block2 doesn't work
#1)
#review - this hack looks sort of promising - but overtype::renderline needs fixing ?
#set tlc \U1fb7d\b ;#legacy block
#set trc \U1fb7e\b ;#legacy block
#set blc \U1fb7c\b ;#legacy block
#set brc \U1fb7f\b ;#legacy block
#2) - works on cmd.exe and some others
# a 'privacy message' is 'probably' also not supported on the old terminal but is on newer ones
#known exception - conemu on windows - displays junk for various ansi codes - (and slow terminal anyway)
#this hack has a reasonable chance of working
#except that the punk overtype library does recognise PMs
#A single backspace however is an unlikely and generally unuseful PM - so there is a corresponding hack in the renderline system to pass this PM through!
#ugly - in that we don't know the application specifics of what the PM data contains and where it's going.
set tlc \U1fb7d\x1b^\b\x1b\\ ;#legacy block
set trc \U1fb7e\x1b^\b\x1b\\ ;#legacy block
set blc \U1fb7c\x1b^\b\x1b\\ ;#legacy block
set brc \U1fb7f\x1b^\b\x1b\\ ;#legacy 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 [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] ;#only default the general types - these form defaults for more specific types if they're missing
set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "]
if {"all" in [dict keys $f]} {
set A [dict get $f all]
set default_custom [tcl::dict::create hl $A vl $A tlc $A trc $A blc $A brc $A]
}
if {[llength $f] % 2} {
#todo - retrieve usage from punk::args
error "textblock::frametype frametype '$f' is not one of the predefined frametypes: $::textblock::frametypes and does not appear to be a dictionary for a custom frametype"
}
#unknown order of keys specified by user - validate before creating vars as we need more general elements to be available as defaults
dict for {k v} $f {
switch -- $k {
all - hl - vl - tlc - trc - blc - brc - hlt - hlb - vll - vlr - hltj - hlbj - vllj - vlrj {}
default {
error "textblock::frametype '$f' has unknown element '$k'"
}
}
}
#verified keys - safe to extract as vars
set custom_frame [tcl::dict::merge $default_custom $f]
tcl::dict::with custom_frame {} ;#extract keys as vars
#longer j vars must be after their more specific counterparts in the list being processed by foreach
foreach t {hlt hlb vll vlr hltj hlbj vllj vlrj} {
if {[tcl::dict::exists $custom_frame $t]} {
set $t [tcl::dict::get $custom_frame $t]
} else {
#set more explicit type to it's more general counterpart if it's missing
#e.g hlt -> hl
#e.g hltj -> hlt
set $t [set [string range $t 0 end-1]]
}
}
#assert vars hl vl tlc trc blc brc hlt hlb vll vlr hltj hlbj vllj vlrj are all set
#horizontal and vertical bar joins - key/variable ends with 'j'
}
}
if {$boxonly} {
set result [tcl::dict::create\
tlc $tlc hlt $hlt trc $trc\
vll $vll vlr $vlr\
blc $blc hlb $hlb brc $brc\
]
} else {
set result [tcl::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\
]
}
set result [dict filter $result key {*}$globs]
tcl::dict::set framedef_cache $cache_key $result
return $result
}
variable frame_cache
set frame_cache [tcl::dict::create]
punk::args::definition {
@id -id ::textblock::frame_cache
@cmd -name textblock::frame_cache -help\
"Display or clear the frame cache."
-action -default {} -choices {clear} -help\
"Clear the textblock::frame_cache dictionary"
-pretty -default 1 -help\
"Use 'pdict textblock::frame_cache */*' for prettier output"
@values -min 0 -max 0
}
proc frame_cache {args} {
set argd [punk::args::get_by_id ::textblock::frame_cache $args]
set action [dict get $argd opts -action]
if {$action ni [list clear ""]} {
error "frame_cache action '$action' not understood. Valid actions: clear"
}
variable frame_cache
if {[dict get $argd opts -pretty]} {
set out [pdict -chan none frame_cache */*]
} else {
set out ""
if {[catch {
set termwidth [tcl::dict::get [punk::console::get_size] columns]
}]} {
set termwidth 80
}
tcl::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 {[tcl::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 [tcl::dict::create]
append out \nCLEARED
}
return $out
}
variable FRAMETYPES
set FRAMETYPES [textblock::frametypes]
variable EG
set EG [a+ brightblack]
variable RST
set RST [a]
proc frame_samples {} {
set FRAMETYPELABELS [dict create]
if {[info commands ::textblock::frame] ne ""} {
foreach ft [frametypes] {
dict set FRAMETYPELABELS $ft [textblock::frame -checkargs 0 -type $ft " "]
}
}
set FRAMETYPELABELS [dict remove $FRAMETYPELABELS block2hack]
return $FRAMETYPELABELS
}
#proc EG {} "return {[a+ brightblack]}"
#make EG fetch from SGR cache so as to abide by colour off/on
proc EG {} {
a+ brightblack
}
#proc RST {} "return {\x1b\[m}"
proc RST {} {
return "\x1b\[m"
}
#catch 22 for -choicelabels - need some sort of lazy evaluation
# ${[textblock::frame_samples]}
#todo punk::args alias for centre center etc?
punk::args::definition -dynamic 1 {
@id -id ::textblock::frame
@cmd -name "textblock::frame"\
-help "Frame a block of text with a border."
-checkargs -default 1 -type boolean\
-help "If true do extra argument checks and
provide more comprehensive error info.
Set false for slight performance improvement."
-etabs -default 0\
-help "expanding tabs - experimental/unimplemented."
-type -default light -choices {${[textblock::frametypes]}} -choicerestricted 0 -choicecolumns 8 -type dict\
-choicelabels {
${[textblock::frame_samples]}
}\
-help "Type of border for frame."
-boxlimits -default {hl vl tlc blc trc brc} -type list -help "Limit the border box to listed elements.
passing an empty string will result in no box, but title/subtitle will still appear if supplied.
${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}"
-boxmap -default {} -type dict
-joins -default {} -type list
-title -default "" -type string -regexprefail {\n}\
-help "Frame title placed on topbar - no newlines.
May contain ANSI - no trailing reset required.
${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing
e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}"
-subtitle -default "" -type string -regexprefail {\n}\
-help "Frame subtitle placed on bottombar - no newlines
May contain Ansi - no trailing reset required."
-width -default "" -type int\
-help "Width of resulting frame including borders.
If omitted or empty-string, the width will be determined automatically based on content."
-height -default "" -type int\
-help "Height of resulting frame including borders."
-ansiborder -default "" -type ansistring\
-help "Ansi escape sequence to set border attributes.
${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents
e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::RST]}"
-ansibase -default "" -type ansistring\
-help "Default ANSI attributes within frame."
-blockalign -default centre -choices {left right centre}\
-help "Alignment of the content block within the frame."
-pad -default 1 -type boolean -help "Whether to pad within the ANSI so content background
extends within the content block inside the frame.
Has no effect if no ANSI in content."
-textalign -default left -choices {left right centre}\
-help "Alignment of text within the content block. (centre unimplemented)"
-ellipsis -default 1 -type boolean\
-help "Whether to show elipsis for truncated content and title/subtitle."
-usecache -default 1 -type boolean
-buildcache -default 1 -type boolean
-crm_mode -default 0 -type boolean\
-help "Show ANSI control characters within frame contents.
(Control Representation Mode)
Frame width doesn't adapt and content may be truncated
so -width may need to be manually set to display more."
@values -min 0 -max 1
contents -default "" -type string\
-help "Frame contents - may be a block of text containing newlines and ANSI.
Text may be 'ragged' - ie unequal line-lengths.
No trailing ANSI reset required.
${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}"
}
#options before content argument - which is allowed to be absent
#frame performance (noticeable with complex tables even of modest size) is improved somewhat by frame_cache - but is still (2024) a fairly expensive operation.
#
#consider if we can use -sticky nsew instead of -blockalign (as per Tk grid -sticky option)
# This would require some sort of expand equivalent e.g for -sticky ew or -sticky ns - for which we have to decide a meaning for text.. e.g ansi padding?
#We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand
#we could refactor as an object and provide a -return object option, then use stored -sticky data to influence how another object renders into it
# - but we would need to maintain support for the rendered-string based operations too.
proc frame {args} {
variable frametypes
variable use_hash
#counterintuitively - in-proc dict create each time is generally slightly faster than linked namespace var
set opts [tcl::dict::create\
-etabs 0\
-type light\
-boxlimits [list hl vl tlc blc trc brc]\
-boxmap {}\
-joins [list]\
-title ""\
-subtitle ""\
-width ""\
-height ""\
-ansiborder ""\
-ansibase ""\
-blockalign "centre"\
-textalign "left"\
-ellipsis 1\
-usecache 1\
-buildcache 1\
-pad 1\
-crm_mode 0\
-checkargs 1\
]
#-pad 1 is default so that simple 'textblock::frame "[a+ Red]a \nbbb[a]" extends the bg colour on the short ragged lines (and empty lines)
# for ansi art - -pad 0 is likely to be preferable
set has_contents 0
set optlist $args ;#initial only - content will be removed
#no solo opts for frame
if {[llength $args] %2 == 0} {
if {[lindex $args end-1] eq "--"} {
set contents [lpop optlist end]
set has_contents 1
lpop optlist end ;#drop the end-of-opts flag
} else {
set optlist $args
set contents ""
}
} else {
set contents [lpop optlist end]
set has_contents 1
}
#todo args -justify left|centre|right (center)
#todo -blockalignbias -textalignbias?
#use -buildcache 1 with -usecache 0 for debugging cache issues so we can inspect using textblock::frame_cache
set optnames [tcl::dict::keys $opts]
set opts_ok 1 ;#default assumption
foreach {k v} $optlist {
set k2 [tcl::prefix::match -error "" $optnames $k]
switch -- $k2 {
-etabs - -type - -boxlimits - -boxmap - -joins
- -title - -subtitle - -width - -height
- -ansiborder - -ansibase
- -blockalign - -textalign - -ellipsis
- -crm_mode
- -usecache - -buildcache - -pad
- -checkargs {
tcl::dict::set opts $k2 $v
}
default {
#error "frame option '$k' not understood. Valid options are $optnames"
set opts_ok 0
break
}
}
}
set check_args [dict get $opts -checkargs]
#only use punk::args if check_args is true or our basic checks failed
#never need to checkargs if only one argument supplied even if it looks like an option - as it will be treated as data to frame
if {[llength $args] != 1 && (!$opts_ok || $check_args)} {
set argd [punk::args::get_by_id ::textblock::frame $args]
set opts [dict get $argd opts]
set contents [dict get $argd values contents]
}
# -- --- --- --- --- ---
# cache relevant
set opt_usecache [tcl::dict::get $opts -usecache]
set opt_buildcache [tcl::dict::get $opts -buildcache]
set usecache $opt_usecache ;#may need to override
set opt_etabs [tcl::dict::get $opts -etabs] ;#affects contentwidth - needed before cache determination
set opt_crm_mode [tcl::dict::get $opts -crm_mode]
# -- --- --- --- --- ---
set opt_type [tcl::dict::get $opts -type]
set opt_boxlimits [tcl::dict::get $opts -boxlimits]
set opt_joins [tcl::dict::get $opts -joins]
set opt_boxmap [tcl::dict::get $opts -boxmap]
set buildcache $opt_buildcache
set opt_pad [tcl::dict::get $opts -pad]
# -- --- --- --- --- ---
set opt_title [tcl::dict::get $opts -title]
set opt_subtitle [tcl::dict::get $opts -subtitle]
set opt_width [tcl::dict::get $opts -width]
set opt_height [tcl::dict::get $opts -height]
# -- --- --- --- --- ---
set opt_ansiborder [tcl::dict::get $opts -ansiborder]
set opt_ansibase [tcl::dict::get $opts -ansibase] ;#experimental
set opt_ellipsis [tcl::dict::get $opts -ellipsis]
set opt_blockalign [tcl::dict::get $opts -blockalign]
set opt_textalign [tcl::dict::get $opts -textalign]
set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc]
set known_frametypes $frametypes ;# light, heavey etc as defined in the ::textblock::frametypes variable
set default_custom [tcl::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
}
#if check_args?
#REVIEW - now done in framedef?
#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 [tcl::dict::create left "" down "" right "" up ""]
#foreach jt $opt_joins {
# lassign [split $jt -] direction target
# if {$target ne ""} {
# tcl::dict::set join_targets $direction $target
# }
# lappend join_directions $direction
#}
#set join_directions [lsort -unique $join_directions]
#set do_joins [::join $join_directions _]
# -- --- --- --- --- ---
if {$has_contents} {
if {[tcl::string::last \t $contents] >= 0} {
if {[tcl::info::exists punk::console::tabwidth]} {
set tw $::punk::console::tabwidth
} else {
set tw 8
}
if {$opt_etabs} {
#todo
set contents [textutil::tabify::untabify2 $contents $tw]
}
}
set contents [tcl::string::map {\r\n \n} $contents]
if {$opt_crm_mode} {
if {$opt_height eq ""} {
set h [textblock::height $contents]
} else {
set h [expr {$opt_height -2}]
}
if {$opt_width eq ""} {
set w [textblock::width $contents]
} else {
set w [expr {$opt_width -2}]
}
set contents [overtype::renderspace -crm_mode 1 -wrap 1 -width $w -height $h "" $contents]
set actual_contentwidth $w
set actual_contentheight $h
} else {
#set actual_contentwidth [textblock::width $contents] ;#length of longest line in contents (contents can be ragged)
#set actual_contentheight [textblock::height $contents]
lassign [textblock::size_as_list $contents] actual_contentwidth actual_contentheight
}
} 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
}
#opt_subtitle ??
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 $optlist $frame_inner_width $frame_inner_height]
#jmn
#set hashables [concat $optlist $frame_inner_width $frame_inner_height]
set hashables [list {*}$optlist $frame_inner_width $frame_inner_height]
switch -- $use_hash {
sha1 {
package require sha1
set hash [sha1::sha1 [encoding convertto utf-8 $hashables]]
}
md5 {
package require md5
if {[package vsatisfies [package present md5] 2- ] } {
set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review
} else {
set hash [md5::md5 [encoding convertto utf-8 $hashables]]
}
}
none {
set hash $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 {[tcl::dict::exists $frame_cache $cache_key]} {
set cache_patternwidth [tcl::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 && [tcl::dict::exists $frame_cache $cache_key]} {
set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth]
set template [tcl::dict::get $frame_cache $cache_key frame]
set used [tcl::dict::get $frame_cache $cache_key used]
tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record
set is_cached 1
}
# -- --- --- --- --- --- --- --- ---
if {!$is_cached} {
# -- --- --- --- ---
# -- --- --- --- ---
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 - light_b - light_c - heavy - heavy_b - heavy_c - ascii - altg - arc - arc_b - arc_c - double - custom - block - block1 - block2 {}
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
tcl::dict::for {boxelement subst} $opt_boxmap {
switch -- $boxelement {
hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {}
hltj - hlbj - vllj - vlrj {}
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,hltj,hlbj,vllj,vlrj"
}
# -- --- --- --- --- ---
#these are all valid commands for overtype::<cmd>
switch -- $opt_textalign {
left - right - centre - center {}
default {
error "frame option -textalign must be left|right|centre|center - received: $opt_textalign"
}
}
# -- --- --- --- --- ---
switch -- $opt_blockalign {
left - right - centre - center {}
default {
error "frame option -blockalign must be left|right|centre|center - received: $opt_blockalign"
}
}
# -- --- --- --- ---
# -- --- --- --- ---
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
}
}
}
#review vllj etc?
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 rst [a]
#set column [tcl::string::repeat " " $frame_inner_width] ;#default - may need to override for custom frame
set underlayline [tcl::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 -joins $opt_joins $framedef]
tcl::dict::with framedef {} ;#extract vll,hlt,tlc etc vars
#puts "---> $opt_boxmap"
#review - we handle double-wide in custom frames - what about for boxmaps?
tcl::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 [tcl::string::repeat " " $frame_inner_width]
set underlayline [tcl::string::repeat " " $frame_inner_width]
set underlay [::join [lrepeat $linecount $underlayline] \n]
#cache?
if {$hlt_width == 1} {
set tbar [tcl::string::repeat $hlt $tbarwidth]
} else {
#possibly mixed width chars that make up hlt - tcl::string::range won't get width right
set blank [tcl::string::repeat " " $tbarwidth]
if {$hlt_width > 0} {
set count [expr {($tbarwidth / $hlt_width) + 1}]
} else {
set count 0
}
set tbar [tcl::string::repeat $hlt $count]
#set tbar [tcl::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 [tcl::string::repeat $hlb $bbarwidth]
} else {
set blank [tcl::string::repeat " " $bbarwidth]
if {$hlb_width > 0} {
set count [expr {($bbarwidth / $hlb_width) + 1}]
} else {
set count 0
}
set bbar [tcl::string::repeat $hlb $count]
#set bbar [tcl::string::range $bbar 0 $bbarwidth-1]
set bbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $bbar]
}
}
altg {
set tbar [tcl::string::repeat $hlt $frame_inner_width]
set tbar [cd::groptim $tbar]
set bbar [tcl::string::repeat $hlb $frame_inner_width]
set bbar [cd::groptim $bbar]
}
default {
set tbar [tcl::string::repeat $hlt $frame_inner_width]
set bbar [tcl::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 [tcl::string::repeat $vll\n $linecount]
set lhs [tcl::string::range $lhs 0 end-1]
set rhs [tcl::string::repeat $vlr\n $linecount]
set rhs [tcl::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 [tcl::string::repeat " " $vll_width]
set lhs [tcl::string::repeat $blank_vll\n $linecount]
set lhs [tcl::string::range $lhs 0 end-1]
}
vlr {
set blank_vlr [tcl::string::repeat " " $vlr_width]
set rhs [tcl::string::repeat $blank_vlr\n $linecount]
set rhs [tcl::string::range $rhs 0 end-1]
}
hlt {
set bar_width [punk::ansi::printing_length $tbar]
set tbar [tcl::string::repeat " " $bar_width]
}
tlc {
set tlc_width [punk::ansi::printing_length $tlc]
set tlc [tcl::string::repeat " " $tlc_width]
}
trc {
set trc_width [punk::ansi::printing_length $trc]
set trc [tcl::string::repeat " " $trc_width]
}
hlb {
set bar_width [punk::ansi::printing_length $bbar]
set bbar [tcl::string::repeat " " $bar_width]
}
blc {
set blc_width [punk::ansi::printing_length $blc]
set blc [tcl::string::repeat " " $blc_width]
}
brc {
set brc_width [punk::ansi::printing_length $brc]
set brc [tcl::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 [tcl::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 [tcl::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]
#JMN test
#assert - lhs, cache_inner, rhs non-ragged - so can use join_basic REVIEW
#set cache_body [textblock::join -- {*}$cache_bodyparts]
set cache_body [textblock::join_basic -- {*}$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 [tcl::string::map [list $FSUB " "] $template]
} else {
set resultlines [list]
set overwritable [tcl::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 {[tcl::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] ""] ;# should not affect actual_contentwidth
}
#set cwidth [textblock::width $contents]
set cwidth $actual_contentwidth
if {$opt_pad} {
set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -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]
}
#important to supply end of opts -- to textblock::join - particularly here with arbitrary data
set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays
} else {
if {$cwidth > $cache_patternwidth} {
set contents [overtype::renderspace -width $cache_patternwidth "" $contents]
}
set contentblock [textblock::join -- $contents] ;# adds ansiresets and any required replays on each line
}
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 [tcl::string::length $R]
set clines [split $contentblock \n]
foreach tline $tlines {
if {[tcl::string::first $FSUB $tline] >= 0} {
set content_line [lindex $clines $contentindex]
if {[tcl::string::first $R $content_line] == 0} {
set content_line [tcl::string::range $content_line $rlen end]
}
#make sure to replay opt_ansibase to the right of the replacement
lappend resultlines [tcl::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} {
tcl::dict::set frame_cache $cache_key [list frame $template used 0 patternwidth $cache_patternwidth]
}
return $fs
}
}
punk::args::definition {
@id -id ::textblock::gcross
-max_cross_size -default 0 -type integer -help "Largest size cross to use to make up the block
Only cross sizes that divide the size of the overall block will be used.
e.g if the 'size' chosen is 19 (a prime number) - only 1 or the full size of 19 can be used as the crosses to make up the block.
Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors)
If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used.
"
@values -min 0 -max 1
size -default 1 -type integer
}
proc gcross {args} {
set argd [punk::args::get_by_id ::textblock::gcross $args]
set size [dict get $argd values size]
set opts [dict get $argd opts]
if {$size == 0} {
return ""
}
set opt_max_cross_size [tcl::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} {
#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 [tcl::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} {
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]
}
tcl::namespace::import ::punk::ansi::ansistrip
}
tcl::namespace::eval ::textblock::piper {
tcl::namespace::export *
proc join {rhs pipelinedata} {
tailcall ::textblock::join -- $pipelinedata $rhs
}
}
interp alias {} piper_blockjoin {} ::textblock::piper::join
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide textblock [tcl::namespace::eval textblock {
variable version
set version 999999.0a1.0
}]
return
#*** !doctools
#[manpage_end]