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.
395 lines
16 KiB
395 lines
16 KiB
# -*- tcl -*- |
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
|
# |
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# (C) 2023 |
|
# |
|
# @@ Meta Begin |
|
# Application textblock 999999.0a1.0 |
|
# Meta platform tcl |
|
# Meta license <unspecified> |
|
# @@ Meta End |
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
##e.g package require frobz |
|
#package require punk |
|
package require punk::args |
|
package require punk::char |
|
package require punk::lib |
|
package require patternpunk |
|
package require overtype |
|
package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional? |
|
package require textutil |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# |
|
#Note: A textblock does not necessarily have lines the same length - either in number of characters or print-width |
|
# |
|
namespace eval textblock { |
|
namespace export block width |
|
namespace eval cd { |
|
#todo - save and restore existing namespace export in case macros::cd has default exports in future |
|
namespace eval ::term::ansi::code::macros::cd {namespace export *} |
|
namespace import ::term::ansi::code::macros::cd::* |
|
namespace eval ::term::ansi::code::macros::cd {namespace export -clear} |
|
} |
|
|
|
#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) |
|
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 ""} |
|
if {[string length $char] == 1} { |
|
set row [string repeat $char $blockwidth] |
|
set mtrx [lrepeat $blockheight $row] |
|
return [::join $mtrx \n] |
|
} else { |
|
set charblock [string map [list \r\n \n] $char] |
|
if {[string first \n $charblock] >= 0} { |
|
if {$blockwidth > 1} { |
|
set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] |
|
} else { |
|
set row $charblock |
|
} |
|
} else { |
|
set row [string repeat $char $blockwidth] |
|
} |
|
set mtrx [lrepeat $blockheight $row] |
|
return [::join $mtrx \n] |
|
} |
|
} |
|
|
|
proc width {textblock} { |
|
if {$textblock eq ""} { |
|
return 0 |
|
} |
|
set textblock [textutil::tabify::untabify2 $textblock] |
|
if {[string first \n $textblock] >= 0} { |
|
return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::string_width [stripansi $v]}]] |
|
} |
|
return [punk::char::string_width [stripansi $textblock]] |
|
} |
|
proc height {textblock} { |
|
#empty string still has height 1 (at least for left-right/right-left languages) |
|
set num_le [expr {[string length $textblock]-[string length [string map [list \n {}] $textblock]]}] ;#faster than splitting into single-char list |
|
return [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le |
|
} |
|
#MAINTENANCE - same as overtype::blocksize? |
|
proc size {textblock} { |
|
if {$textblock eq ""} { |
|
return [dict create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings |
|
} |
|
set textblock [textutil::tabify::untabify2 $textblock] |
|
#stripansi on entire block in one go rather than line by line - result should be the same - review - make tests |
|
set textblock [punk::ansi::stripansi $textblock] |
|
if {[string first \n $textblock] >= 0} { |
|
set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::string_width $v}]] |
|
} else { |
|
set width [punk::char::string_width $textblock] |
|
} |
|
set num_le [expr {[string length $textblock]-[string length [string map [list \n {}] $textblock]]}] ;#faster than splitting into single-char list |
|
#our concept of block-height is likely to be different to other line-counting mechanisms |
|
set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le |
|
|
|
return [dict create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [dict values [blocksize <data>]] width height |
|
} |
|
#must be able to handle block as string with or without newlines |
|
#if no newlines - attempt to treat as a list |
|
#must handle whitespace-only string,list elements, and/or lines. |
|
#reviewing 2024 - this seems like too much magic! |
|
proc width1 {block} { |
|
if {$block eq ""} { |
|
return 0 |
|
} |
|
set block [textutil::tabify::untabify2 $block] |
|
if {[string first \n $block] >= 0} { |
|
return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $block] {::punk::char::string_width [stripansi $v]}]] |
|
} |
|
if {[catch {llength $block}]} { |
|
return [::punk::char::string_width [stripansi $block]] |
|
} |
|
if {[llength $block] == 0} { |
|
#could be just a whitespace string |
|
return [string length $block] |
|
} |
|
return [tcl::mathfunc::max {*}[lmap v $block {::punk::char::string_width [stripansi $v]}]] |
|
} |
|
pipealias ::textblock::padleft .= {list $input [string repeat " " $indent]} |/0,padding/1> punk:lib::lines_as_list -- |> .= {lmap v $data {overtype::right $padding $v}} |> punk::lib::list_as_lines -- <input/0,indent/1| |
|
pipealias ::textblock::padright .= {list $input [string repeat " " $colsize]} |/0,padding/1> punk::lib::lines_as_list -- |> .= {lmap v $data {overtype::left $padding $v}} |> punk::lib::list_as_lines -- <input/0,colsize/1| |
|
proc ::textblock::pad {block args} { |
|
set defaults [dict set\ |
|
-padchar " "\ |
|
-which "right"\ |
|
-width ""\ |
|
-overflow 0\ |
|
] |
|
set usage "pad ?-padchar <character>? ?-which right|left|centre? -width <int>" |
|
foreach {k v} $args { |
|
if {$k ni [dict keys $defaults]} { |
|
error "textblock::pad unrecognised option '$k'. Usage: $usage" |
|
} |
|
} |
|
set opts [dict merge $defaults $args] |
|
# -- --- --- --- --- --- --- --- --- --- |
|
set padchar [dict get $opts -padchar] |
|
# -- --- --- --- --- --- --- --- --- --- |
|
set known_whiches [list l left r right c center centre] |
|
set which [string tolower [dict get $opts -which]] |
|
if {$which in [list centre center]} {set which "c"} |
|
if {$which in [list left]} {set which "l"} |
|
if {$which in [list right]} {set which "r"} |
|
if {$which ni $known_whiches} { |
|
error "textblock::pad unrecognised value for -which option. Known values $known_whiches" |
|
} |
|
# -- --- --- --- --- --- --- --- --- --- |
|
set width [dict get $opts -width] |
|
# -- --- --- --- --- --- --- --- --- --- |
|
|
|
if {$width = ""} { |
|
|
|
} |
|
|
|
|
|
} |
|
|
|
|
|
pipealias ::textblock::join_width .= {list $lhs [string repeat " " $w1] $rhs [string repeat " " $w2]} {| |
|
/2,col1/1,col2/3 |
|
>} punk::lib::lines_as_list -- {| |
|
data2 |
|
>} .=lhs> punk::lib::lines_as_list -- {| |
|
>} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| |
|
>} punk::lib::list_as_lines -- <lhs/0,w1/1,rhs/2,w2/3| |
|
|
|
|
|
pipealias ::textblock::joinpair .= {list $lhs [string repeat " " [width $lhs]] $rhs [string repeat " " [width $rhs]]} {| |
|
/2,col1/1,col2/3 |
|
>} .=> punk::lib::lines_as_list -- {| |
|
data2 |
|
>} .=lhs> punk::lib::lines_as_list -- {| |
|
>} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| |
|
>} punk::lib::list_as_lines -- <lhs/0,rhs/1| |
|
|
|
proc ::textblock::join {args} { |
|
lassign [punk::args::opts_values { |
|
blocks -type string -multiple 1 |
|
} $args] _o opts _v values |
|
set blocks [dict get $values blocks] |
|
|
|
set idx 0 |
|
set fordata [list] |
|
foreach b $blocks { |
|
set c($idx) [string repeat " " [width $b]] |
|
lappend fordata "v($idx)" [punk::lib::lines_as_list -- $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] |
|
} |
|
|
|
proc ::textblock::trim {block} { |
|
set trimlines [] |
|
} |
|
|
|
pipealias ::textblock::join_right .= {list $lhs [string repeat " " [width $lhs]] $rhs [string repeat " " [width $rhs]]} {| |
|
/2,col1/1,col2/3 |
|
>} .=> punk::lib::lines_as_list -- {| |
|
data2 |
|
>} .=lhs> punk::lib::lines_as_list -- {| |
|
>} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| |
|
>} punk::lib::list_as_lines <lhs/0,rhs/1| |
|
|
|
proc example {{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 frame {args} { |
|
package require punk::char |
|
|
|
set contents [lindex $args end] |
|
set arglist [lrange $args 0 end-1] |
|
if {[llength $arglist] % 2 != 0} { |
|
error "Usage frame ?-ansi 0|1? <contents>" |
|
} |
|
#todo args -justify left|centre|right (center) |
|
|
|
set defaults [dict create\ |
|
-ansi 0\ |
|
] |
|
set opts [dict merge $defaults $arglist] |
|
# -- --- --- --- --- --- |
|
set ansi [dict get $opts -ansi] |
|
# -- --- --- --- --- --- |
|
|
|
set contents [textutil::tabify::untabify2 $contents] |
|
set contents [string map [list \r\n \n] $contents] |
|
if {[string first \n $contents] >= 0} { |
|
set width [width $contents] |
|
} else { |
|
set width [width [list $contents]] |
|
} |
|
set lines [split $contents \n] |
|
|
|
if {$ansi} { |
|
#old style ansi escape sequences with alternate graphics page G0 |
|
append fs [cd::tlc][string repeat [cd::hl] $width][cd::trc]\n |
|
foreach l $lines { |
|
append fs [cd::vl]${l}[string repeat " " [expr {$width-[::punk::char::string_width [stripansi $l]]}]][cd::vl]\n |
|
} |
|
append fs [cd::blc][string repeat [cd::hl] $width][cd::brc] |
|
return [cd::groptim $fs] |
|
} else { |
|
#unicode box drawing set |
|
set hz [punk::char::charshort boxd_lhz] ;# light horizontal |
|
append fs [punk::char::charshort boxd_ldr][string repeat $hz $width][punk::char::charshort boxd_ldl]\n |
|
set vl [punk::char::charshort boxd_lv] ;#light vertical |
|
foreach l $lines { |
|
append fs $vl${l}[string repeat " " [expr {$width-[::punk::char::string_width [stripansi $l]]}]]$vl\n |
|
} |
|
append fs [punk::char::charshort boxd_lur][string repeat $hz $width][punk::char::charshort boxd_lul] |
|
return $fs |
|
} |
|
|
|
} |
|
proc gcross {{size 1} args} { |
|
if {$size == 0} { |
|
return "" |
|
} |
|
|
|
set defaults [list\ |
|
-max_cross_size 0 |
|
] |
|
set opts [dict merge $defaults $args] |
|
set opt_max_cross_size [dict get $opts -max_cross_size] |
|
|
|
#set fit_size [punk::lib::greatestOddFactor $size] |
|
set fit_size $size |
|
if {$opt_max_cross_size == 0} { |
|
set max_cross_size $fit_size |
|
} else { |
|
#todo - only allow divisors |
|
#set testsize [expr {min($fit_size,$opt_max_cross_size)}] |
|
|
|
set factors [punk::lib::factors $size] |
|
#pick odd size in list that is smaller or equal to test_size |
|
set max_cross_size [lindex $factors end] |
|
set last_ok [lindex $factors 0] |
|
for {set i 0} {$i < [llength $factors]} {incr i} { |
|
set s [lindex $factors $i] |
|
if {$s > $opt_max_cross_size} { |
|
break |
|
} |
|
set last_ok $s |
|
} |
|
set max_cross_size $last_ok |
|
} |
|
set crosscount [expr {$size / $max_cross_size}] |
|
|
|
package require punk::char |
|
set x [punk::char::charshort boxd_ldc] |
|
set bs [punk::char::charshort boxd_ldgullr] |
|
set fs [punk::char::charshort boxd_ldgurll] |
|
|
|
set onecross "" |
|
set crossrows [list] |
|
set armsize [expr {int(floor($max_cross_size /2))}] |
|
set row [lrepeat $max_cross_size " "] |
|
#toparm |
|
for {set i 0} {$i < $armsize} {incr i} { |
|
set r $row |
|
lset r $i $bs |
|
lset r end-$i $fs |
|
#append onecross [::join $r ""] \n |
|
lappend crossrows [::join $r ""] |
|
} |
|
|
|
if {$max_cross_size % 2 != 0} { |
|
#only put centre cross in for odd sized crosses |
|
set r $row |
|
lset r $armsize $x |
|
#append onecross [::join $r ""] \n |
|
lappend crossrows [::join $r ""] |
|
} |
|
|
|
for {set i [expr {$armsize -1}]} {$i >= 0} {incr i -1} { |
|
set r $row |
|
lset r $i $fs |
|
lset r end-$i $bs |
|
#append onecross [::join $r ""] \n |
|
lappend crossrows [::join $r ""] |
|
} |
|
#set onecross [string trimright $onecross \n] |
|
set onecross [::join $crossrows \n] |
|
|
|
#fastest to do row first then columns - because textblock::join must do line by line |
|
|
|
if {$crosscount > 1} { |
|
package require textblock |
|
set row [textblock::join {*}[lrepeat $crosscount $onecross]] |
|
set rows [lrepeat $crosscount $row] |
|
set out [::join $rows \n] |
|
} else { |
|
set out $onecross |
|
} |
|
|
|
return $out |
|
} |
|
|
|
#Test we can join two coloured blocks |
|
proc test_colour {} { |
|
set b1 [a= red]1\n2\n3[a=] |
|
set b2 [a= green]a\nb\nc[a=] |
|
set result [textblock::join $b1 $b2] |
|
puts $result |
|
return [list $b1 $b2 $result] |
|
} |
|
namespace import ::punk::ansi::stripansi |
|
} |
|
|
|
|
|
namespace eval ::textblock::piper { |
|
namespace export * |
|
proc join {rhs pipelinedata} { |
|
tailcall ::textblock::join $pipelinedata $rhs |
|
} |
|
} |
|
interp alias {} piper_blockjoin {} ::textblock::piper::join |
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide textblock [namespace eval textblock { |
|
variable version |
|
set version 999999.0a1.0 |
|
}] |
|
return |