jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

use term- instead of web- colours for better support of terminals without 256 colour

master
Julian Noble 2 weeks ago
parent
834a472cf2
commit
6d4f929374
7 changed files with 157 additions and 101 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 24
      src/bootsupport/modules/punk/console-0.1.1.tm
  2. 18
      src/bootsupport/modules/punk/ns-0.1.0.tm
  3. 80
      src/bootsupport/modules/textblock-0.1.3.tm
  4. 14
      src/modules/punk/blockletter-999999.0a1.0.tm
  5. 24
      src/modules/punk/console-999999.0a1.0.tm
  6. 18
      src/modules/punk/ns-999999.0a1.0.tm
  7. 80
      src/modules/textblock-999999.0a1.0.tm

24
src/bootsupport/modules/punk/console-0.1.1.tm
Unescape View File

@ -702,14 +702,20 @@ namespace eval punk::console {
-terminal -default {stdin stdout} -type list -help\
"terminal (currently list of in/out channels) (todo - object?)"
-passthrough -default "" -choices {tmux auto} -choicecolumns 1 -choicelabels {
-passthrough -default "none" -choices {none tmux auto} -choicecolumns 1 -choicelabels {
none\
{ ANSI sent without any passthrough wrapping.
A terminal multiplexer such as tmux,screen,zellij may
not pass the request through to the underlying terminal(s)
This is the recommended/normal value for the option.}
tmux\
{ Wrap ANSI sequence with tmux passthrough sequence.
\x1bPtmux\;<originalsequence_with_escapes_doubled>\x1b\\
Note that a tmux session could be connected to multiple
terminals (perhaps of different types) - in which case multiple
responses may be received. Passthrough should generally
be avoided except for debug/test purposes.
responses may be received in a non-deterministic order.
Passthrough should generally be avoided except for debug/test
purposes.
}
auto\
{ Use existence of ::env(TMUX) to detect tmux and
@ -800,7 +806,7 @@ namespace eval punk::console {
set runningid [lindex $queue 0]
if {$runningid ne $callid} {
set ::punk::console::ansi_response_wait($runningid) $::punk::console::ansi_response_wait($runningid)
update ;#REVIEW - probably a bad idea
update ;#REVIEW - possibly a bad idea
after 10
set runningid [lindex $queue 0] ;#jn test
}
@ -874,8 +880,10 @@ namespace eval punk::console {
#we should care more about performance in raw mode - as ultimately that's the one we prefer for full features
#------------------
# 1) faster - races?
#first read will read 3 bytes JJJJ
$this_handler $input $callid $capturingendregex
$this_handler $input $callid $capturingendregex
#JJJJ
#$this_handler $input $callid $capturingendregex
if {$ignoreok || $waitvar($callid) ne "ok"} {
chan event $input readable [list $this_handler $input $callid $capturingendregex]
}
@ -1074,7 +1082,11 @@ namespace eval punk::console {
upvar ::punk::console::ansi_response_tsclock tsclock
#endregex should explicitly have a trailing $
set status [catch {read $chan 1} bytes]
if {[string length $chunks($callid)] == 0} {
set status [catch {read $chan 3} bytes]
} else {
set status [catch {read $chan 1} bytes]
}
if { $status != 0 } {
# Error on the channel
chan event $chan readable {}

18
src/bootsupport/modules/punk/ns-0.1.0.tm
Unescape View File

@ -1355,14 +1355,18 @@ tcl::namespace::eval punk::ns {
set a [a+ bold purple]
set e [a+ bold yellow]
set p [a+ bold white]
set c_nat [a+ web-gray] ;#native
set c_int [a+ web-orange] ;#interps
set c_cor [a+ web-hotpink] ;#coroutines
#set c_nat [a+ web-gray] ;#native
set c_nat [a+ term-silver] ;#native
set c_int [a+ term-orange1] ;#interps
set c_cor [a+ term-hotpink] ;#coroutines
set c_ooo [a+ bold cyan] ;#object
set c_ooc [a+ web-aquamarine] ;#class
set c_ooO [a+ web-dodgerblue] ;#privateObject
set c_ooC [a+ web-lightskyblue] ;#privateClass
set c_zst [a+ web-yellow] ;#zlibstreams
#set c_ooc [a+ web-aquamarine] ;#class
set c_ooc [a+ term-aqua] ;#class
#set c_ooO [a+ web-dodgerblue] ;#privateObject
set c_ooO [a+ term-purple-c] ;#privateObject
#set c_ooC [a+ web-lightskyblue] ;#privateClass
set c_ooC [a+ term-cornflowerblue] ;#privateClass
set c_zst [a+ term-yellow] ;#zlibstreams
set a1 [a][a+ cyan]
foreach ch1 $children1 ch2 $children2 cmd1 $elements1 cmd2 $elements2 cmd3 $elements3 cmd4 $elements4 {

80
src/bootsupport/modules/textblock-0.1.3.tm
Unescape View File

@ -1497,7 +1497,7 @@ tcl::namespace::eval textblock {
} 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]
lset spanview $sidx [a+ term-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
@ -1508,7 +1508,7 @@ tcl::namespace::eval textblock {
} else {
if {$span eq "0"} {
if {$remaining eq "0"} {
lset spanview $sidx [a+ web-red]$span[a]
lset spanview $sidx [a+ term-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
@ -1517,7 +1517,7 @@ tcl::namespace::eval textblock {
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]
lset spanview $sidx [a+ term-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
@ -1525,7 +1525,7 @@ tcl::namespace::eval textblock {
incr remaining -1
}
} else {
lset spanview $sidx [a+ web-red]$span[a]
lset spanview $sidx [a+ term-red]$span[a]
error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require zero value span.[a] $spanview"
}
}
@ -2926,7 +2926,7 @@ tcl::namespace::eval textblock {
$htable add_row [list "$hnum " $h "${width}x${height}" $s]
incr hnum
}
$htable configure_column 0 -ansibase [a+ web-dimgray]
$htable configure_column 0 -ansibase [a+ term-grey]
tcl::dict::set col_header_tables $col $htable
set colwidths [$htable column_widths]
set icol 0
@ -4294,7 +4294,8 @@ tcl::namespace::eval textblock {
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 ansi [a+ {*}$fc web-black Web-gold]
set ansi [a+ {*}$fc term-black Term-gold1]
set val [list ansi $ansi cat alkaline_earth]
foreach e $cat_alkaline_earth {
tcl::dict::set ecat $e $val
@ -4302,7 +4303,7 @@ tcl::namespace::eval textblock {
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 ansi [a+ {*}$fc term-black Term-113]
set val [list ansi $ansi cat reactive_nonmetal]
foreach e $cat_reactive_nonmetal {
tcl::dict::set ecat $e $val
@ -4310,7 +4311,7 @@ tcl::namespace::eval textblock {
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 ansi [a+ {*}$fc term-black Term-lightgoldenrod2]
set val [list ansi $ansi cat alkali_metals]
foreach e $cat {
tcl::dict::set ecat $e $val
@ -4318,14 +4319,16 @@ tcl::namespace::eval textblock {
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 ansi [a+ {*}$fc term-black Term-salmon1]
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 ansi [a+ {*}$fc web-black Web-lightskyblue]
set ansi [a+ {*}$fc term-black Term-lightsteelblue]
set val [list ansi $ansi cat post_transition_metals]
foreach e $cat {
tcl::dict::set ecat $e $val
@ -4333,21 +4336,25 @@ tcl::namespace::eval textblock {
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 ansi [a+ {*}$fc black Brightcyan]
set ansi [a+ {*}$fc term-black Term-skyblue1]
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 ansi [a+ {*}$fc web-black Web-orchid]
set ansi [a+ {*}$fc term-black Term-purple-c]
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 ansi [a+ {*}$fc web-black Web-plum]
set ansi [a+ {*}$fc term-black Term-plum1]
set val [list ansi $ansi cat actinoids]
foreach e $cat {
tcl::dict::set ecat $e $val
@ -4361,7 +4368,8 @@ tcl::namespace::eval textblock {
tcl::dict::set ecat $e $val
}
set ansi [a+ {*}$fc web-black Web-whitesmoke]
#set ansi [a+ {*}$fc web-black Web-whitesmoke]
set ansi [a+ {*}$fc term-black Term-silver]
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
@ -4818,6 +4826,7 @@ tcl::namespace::eval textblock {
the colour stripes will be oriented
in this direction.
"
-noreset -type none
@values -min 0 -max 1
colour -type list -default {} -optional 1 -help\
"List of Ansi colour names
@ -4832,8 +4841,10 @@ tcl::namespace::eval textblock {
proc testblock {args} {
set argd [punk::args::parse $args withid ::textblock::testblock]
set colour [dict get $argd values colour]
set size [dict get $argd opts -size]
lassign [dict values $argd] leaders opts values received
set colour [dict get $values colour]
set size [dict get $opts -size]
set noreset [dict exists $received -noreset]
set rainbow_list [list]
lappend rainbow_list {30 47} ;#black White
@ -4879,7 +4890,7 @@ tcl::namespace::eval textblock {
set longbows [concat {*}[lrepeat $numsets $rainbow_list]]
set rainbow_list [lrange $longbows 0 $size-1]
}
if {"noreset" in $colour} {
if {$noreset} {
set RST ""
} else {
set RST [a]
@ -4896,7 +4907,7 @@ tcl::namespace::eval textblock {
set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi]
lappend clist ${ansicode}$c$RST
}
if {"noreset" in $colour} {
if {$noreset} {
return [textblock::join_basic -ansiresets 0 -- {*}$clist]
} else {
#return [textblock::join_basic -- {*}$clist]
@ -5642,22 +5653,22 @@ tcl::namespace::eval textblock {
set headers [list]
set blocks [list]
lappend blocks "[textblock::testblock 4 rainbow]"
lappend blocks "[textblock::testblock -size 4 rainbow]"
lappend headers "rainbow 4x4\nresets at line extremes\nnothing trailing"
lappend blocks "[textblock::testblock 4 rainbow][a]"
lappend blocks "[textblock::testblock -size 4 rainbow][a]"
lappend headers "rainbow 4x4\nresets at line extremes\ntrailing reset"
lappend blocks "[textblock::testblock 4 rainbow]\n[a+ Web-Green]"
lappend blocks "[textblock::testblock -size 4 rainbow]\n[a+ Term-green]"
lappend headers "rainbow 4x4\nresets at line extremes\ntrailing nl&green bg"
lappend blocks "[textblock::testblock 4 {rainbow noreset}]"
lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}]"
lappend headers "rainbow 4x4\nno line resets\nnothing trailing"
lappend blocks "[textblock::testblock 4 {rainbow noreset}][a]"
lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}][a]"
lappend headers "rainbow 4x4\nno line resets\ntrailing reset"
lappend blocks "[textblock::testblock 4 {rainbow noreset}]\n[a+ Web-Green]"
lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}]\n[a+ Term-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]
@ -5665,13 +5676,13 @@ tcl::namespace::eval textblock {
proc pad_example2 {} {
set headers [list]
set blocks [list]
lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n"
lappend blocks "[a+ term-red Term-cornflowerblue][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 blocks "[a+ term-red Term-cornflowerblue][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 blocks "[a+ term-red Term-cornflowerblue][textblock::block 4 4 x]\n[a+ Term-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]
@ -6113,14 +6124,14 @@ tcl::namespace::eval textblock {
proc welcome_test {} {
package require punk::ansi
package require patternpunk
set ansi [textblock::join -- " " [punk::ansi::ansicat src/testansi/publicdomain/roysac/ROY-WELC.ANS 80x8]]
set ansi [textblock::join -- " " [punk::ansi::ansicat -dimensions 80x8 src/testansi/publicdomain/roysac/ROY-WELC.ANS]]
# 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 punks [a+ term-lime][>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 -size 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]
set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ term-orange1] $contents]
}
@ -8350,13 +8361,14 @@ tcl::namespace::eval textblock {
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]
set cache_key [a+ Term-red term-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]
#set cache_key [a+ Web-steelblue term-black]$cache_key[a]
set cache_key [a+ Term-cornflowerblue term-black]$cache_key[a]
} else {
#actual_contentwidth is narrower than frame - check template's patternwidth
if {[tcl::dict::exists $frame_cache $cache_key]} {
@ -8366,13 +8378,13 @@ tcl::namespace::eval textblock {
}
if {$actual_contentwidth < $cache_patternwidth} {
set usecache 0
set cache_key [a+ Web-orange web-black]$cache_key[a]
set cache_key [a+ Term-orange1 term-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]
set cache_key [a+ Term-red term-black]$cache_key[a]
}
}
}

14
src/modules/punk/blockletter-999999.0a1.0.tm
Unescape View File

@ -116,13 +116,13 @@ tcl::namespace::eval punk::blockletter {
set default_frametype {vl \u00a0 hl \u00a0 tlc \u00a0 trc \u00a0 blc \u00a0 brc \u00a0}
# colours in order for T c l T k
set logo_letter_colours [list Web-red Web-green Web-royalblue Web-purple Web-orange]
#set logo_letter_colours [list Web-red Web-green Web-royalblue Web-purple Web-orange]
set logo_letter_colours [list Red Green Blue Purple Yellow]
punk::args::define [tstr -return string {
@id -id ::punk::blockletter::logo
-frametype -default {${$default_frametype}}
-outlinecolour -default "web-white"
-outlinecolour -default "term-white"
-backgroundcolour -default {} -help "e.g Web-white
This argument is the name as accepted by punk::ansi::a+"
@values -min 0 -max 0
@ -220,8 +220,8 @@ tcl::namespace::eval punk::blockletter {
punk::args::define [tstr -return string {
@id -id ::punk::blockletter::text
-bgcolour -default "Web-red"
-bordercolour -default "web-white"
-bgcolour -default "Term-red"
-bordercolour -default "term-white"
-frametype -default {${$default_frametype}}
@values -min 1 -max 1
str -help "Text to convert to blockletters
@ -286,9 +286,9 @@ tcl::namespace::eval punk::blockletter::lib {
@id -id ::punk::blockletter::lib::block
-height -default 2
-width -default 4
-frametype -default {${$::punk::blockletter::default_frametype}}
-bgcolour -default "Web-red"
-bordercolour -default "web-white"
-frametype -default {${$::punk::blockletter::default_frametype}}
-bgcolour -default "Term-red"
-bordercolour -default "term-white"
@values -min 0 -max 0
}]
proc block {args} {

24
src/modules/punk/console-999999.0a1.0.tm
Unescape View File

@ -702,14 +702,20 @@ namespace eval punk::console {
-terminal -default {stdin stdout} -type list -help\
"terminal (currently list of in/out channels) (todo - object?)"
-passthrough -default "" -choices {tmux auto} -choicecolumns 1 -choicelabels {
-passthrough -default "none" -choices {none tmux auto} -choicecolumns 1 -choicelabels {
none\
{ ANSI sent without any passthrough wrapping.
A terminal multiplexer such as tmux,screen,zellij may
not pass the request through to the underlying terminal(s)
This is the recommended/normal value for the option.}
tmux\
{ Wrap ANSI sequence with tmux passthrough sequence.
\x1bPtmux\;<originalsequence_with_escapes_doubled>\x1b\\
Note that a tmux session could be connected to multiple
terminals (perhaps of different types) - in which case multiple
responses may be received. Passthrough should generally
be avoided except for debug/test purposes.
responses may be received in a non-deterministic order.
Passthrough should generally be avoided except for debug/test
purposes.
}
auto\
{ Use existence of ::env(TMUX) to detect tmux and
@ -800,7 +806,7 @@ namespace eval punk::console {
set runningid [lindex $queue 0]
if {$runningid ne $callid} {
set ::punk::console::ansi_response_wait($runningid) $::punk::console::ansi_response_wait($runningid)
update ;#REVIEW - probably a bad idea
update ;#REVIEW - possibly a bad idea
after 10
set runningid [lindex $queue 0] ;#jn test
}
@ -874,8 +880,10 @@ namespace eval punk::console {
#we should care more about performance in raw mode - as ultimately that's the one we prefer for full features
#------------------
# 1) faster - races?
#first read will read 3 bytes JJJJ
$this_handler $input $callid $capturingendregex
$this_handler $input $callid $capturingendregex
#JJJJ
#$this_handler $input $callid $capturingendregex
if {$ignoreok || $waitvar($callid) ne "ok"} {
chan event $input readable [list $this_handler $input $callid $capturingendregex]
}
@ -1074,7 +1082,11 @@ namespace eval punk::console {
upvar ::punk::console::ansi_response_tsclock tsclock
#endregex should explicitly have a trailing $
set status [catch {read $chan 1} bytes]
if {[string length $chunks($callid)] == 0} {
set status [catch {read $chan 3} bytes]
} else {
set status [catch {read $chan 1} bytes]
}
if { $status != 0 } {
# Error on the channel
chan event $chan readable {}

18
src/modules/punk/ns-999999.0a1.0.tm
Unescape View File

@ -1355,14 +1355,18 @@ tcl::namespace::eval punk::ns {
set a [a+ bold purple]
set e [a+ bold yellow]
set p [a+ bold white]
set c_nat [a+ web-gray] ;#native
set c_int [a+ web-orange] ;#interps
set c_cor [a+ web-hotpink] ;#coroutines
#set c_nat [a+ web-gray] ;#native
set c_nat [a+ term-silver] ;#native
set c_int [a+ term-orange1] ;#interps
set c_cor [a+ term-hotpink] ;#coroutines
set c_ooo [a+ bold cyan] ;#object
set c_ooc [a+ web-aquamarine] ;#class
set c_ooO [a+ web-dodgerblue] ;#privateObject
set c_ooC [a+ web-lightskyblue] ;#privateClass
set c_zst [a+ web-yellow] ;#zlibstreams
#set c_ooc [a+ web-aquamarine] ;#class
set c_ooc [a+ term-aqua] ;#class
#set c_ooO [a+ web-dodgerblue] ;#privateObject
set c_ooO [a+ term-purple-c] ;#privateObject
#set c_ooC [a+ web-lightskyblue] ;#privateClass
set c_ooC [a+ term-cornflowerblue] ;#privateClass
set c_zst [a+ term-yellow] ;#zlibstreams
set a1 [a][a+ cyan]
foreach ch1 $children1 ch2 $children2 cmd1 $elements1 cmd2 $elements2 cmd3 $elements3 cmd4 $elements4 {

80
src/modules/textblock-999999.0a1.0.tm
Unescape View File

@ -1497,7 +1497,7 @@ tcl::namespace::eval textblock {
} 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]
lset spanview $sidx [a+ term-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
@ -1508,7 +1508,7 @@ tcl::namespace::eval textblock {
} else {
if {$span eq "0"} {
if {$remaining eq "0"} {
lset spanview $sidx [a+ web-red]$span[a]
lset spanview $sidx [a+ term-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
@ -1517,7 +1517,7 @@ tcl::namespace::eval textblock {
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]
lset spanview $sidx [a+ term-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
@ -1525,7 +1525,7 @@ tcl::namespace::eval textblock {
incr remaining -1
}
} else {
lset spanview $sidx [a+ web-red]$span[a]
lset spanview $sidx [a+ term-red]$span[a]
error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require zero value span.[a] $spanview"
}
}
@ -2926,7 +2926,7 @@ tcl::namespace::eval textblock {
$htable add_row [list "$hnum " $h "${width}x${height}" $s]
incr hnum
}
$htable configure_column 0 -ansibase [a+ web-dimgray]
$htable configure_column 0 -ansibase [a+ term-grey]
tcl::dict::set col_header_tables $col $htable
set colwidths [$htable column_widths]
set icol 0
@ -4294,7 +4294,8 @@ tcl::namespace::eval textblock {
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 ansi [a+ {*}$fc web-black Web-gold]
set ansi [a+ {*}$fc term-black Term-gold1]
set val [list ansi $ansi cat alkaline_earth]
foreach e $cat_alkaline_earth {
tcl::dict::set ecat $e $val
@ -4302,7 +4303,7 @@ tcl::namespace::eval textblock {
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 ansi [a+ {*}$fc term-black Term-113]
set val [list ansi $ansi cat reactive_nonmetal]
foreach e $cat_reactive_nonmetal {
tcl::dict::set ecat $e $val
@ -4310,7 +4311,7 @@ tcl::namespace::eval textblock {
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 ansi [a+ {*}$fc term-black Term-lightgoldenrod2]
set val [list ansi $ansi cat alkali_metals]
foreach e $cat {
tcl::dict::set ecat $e $val
@ -4318,14 +4319,16 @@ tcl::namespace::eval textblock {
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 ansi [a+ {*}$fc term-black Term-salmon1]
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 ansi [a+ {*}$fc web-black Web-lightskyblue]
set ansi [a+ {*}$fc term-black Term-lightsteelblue]
set val [list ansi $ansi cat post_transition_metals]
foreach e $cat {
tcl::dict::set ecat $e $val
@ -4333,21 +4336,25 @@ tcl::namespace::eval textblock {
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 ansi [a+ {*}$fc black Brightcyan]
set ansi [a+ {*}$fc term-black Term-skyblue1]
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 ansi [a+ {*}$fc web-black Web-orchid]
set ansi [a+ {*}$fc term-black Term-purple-c]
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 ansi [a+ {*}$fc web-black Web-plum]
set ansi [a+ {*}$fc term-black Term-plum1]
set val [list ansi $ansi cat actinoids]
foreach e $cat {
tcl::dict::set ecat $e $val
@ -4361,7 +4368,8 @@ tcl::namespace::eval textblock {
tcl::dict::set ecat $e $val
}
set ansi [a+ {*}$fc web-black Web-whitesmoke]
#set ansi [a+ {*}$fc web-black Web-whitesmoke]
set ansi [a+ {*}$fc term-black Term-silver]
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
@ -4818,6 +4826,7 @@ tcl::namespace::eval textblock {
the colour stripes will be oriented
in this direction.
"
-noreset -type none
@values -min 0 -max 1
colour -type list -default {} -optional 1 -help\
"List of Ansi colour names
@ -4832,8 +4841,10 @@ tcl::namespace::eval textblock {
proc testblock {args} {
set argd [punk::args::parse $args withid ::textblock::testblock]
set colour [dict get $argd values colour]
set size [dict get $argd opts -size]
lassign [dict values $argd] leaders opts values received
set colour [dict get $values colour]
set size [dict get $opts -size]
set noreset [dict exists $received -noreset]
set rainbow_list [list]
lappend rainbow_list {30 47} ;#black White
@ -4879,7 +4890,7 @@ tcl::namespace::eval textblock {
set longbows [concat {*}[lrepeat $numsets $rainbow_list]]
set rainbow_list [lrange $longbows 0 $size-1]
}
if {"noreset" in $colour} {
if {$noreset} {
set RST ""
} else {
set RST [a]
@ -4896,7 +4907,7 @@ tcl::namespace::eval textblock {
set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi]
lappend clist ${ansicode}$c$RST
}
if {"noreset" in $colour} {
if {$noreset} {
return [textblock::join_basic -ansiresets 0 -- {*}$clist]
} else {
#return [textblock::join_basic -- {*}$clist]
@ -5642,22 +5653,22 @@ tcl::namespace::eval textblock {
set headers [list]
set blocks [list]
lappend blocks "[textblock::testblock 4 rainbow]"
lappend blocks "[textblock::testblock -size 4 rainbow]"
lappend headers "rainbow 4x4\nresets at line extremes\nnothing trailing"
lappend blocks "[textblock::testblock 4 rainbow][a]"
lappend blocks "[textblock::testblock -size 4 rainbow][a]"
lappend headers "rainbow 4x4\nresets at line extremes\ntrailing reset"
lappend blocks "[textblock::testblock 4 rainbow]\n[a+ Web-Green]"
lappend blocks "[textblock::testblock -size 4 rainbow]\n[a+ Term-green]"
lappend headers "rainbow 4x4\nresets at line extremes\ntrailing nl&green bg"
lappend blocks "[textblock::testblock 4 {rainbow noreset}]"
lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}]"
lappend headers "rainbow 4x4\nno line resets\nnothing trailing"
lappend blocks "[textblock::testblock 4 {rainbow noreset}][a]"
lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}][a]"
lappend headers "rainbow 4x4\nno line resets\ntrailing reset"
lappend blocks "[textblock::testblock 4 {rainbow noreset}]\n[a+ Web-Green]"
lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}]\n[a+ Term-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]
@ -5665,13 +5676,13 @@ tcl::namespace::eval textblock {
proc pad_example2 {} {
set headers [list]
set blocks [list]
lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n"
lappend blocks "[a+ term-red Term-cornflowerblue][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 blocks "[a+ term-red Term-cornflowerblue][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 blocks "[a+ term-red Term-cornflowerblue][textblock::block 4 4 x]\n[a+ Term-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]
@ -6113,14 +6124,14 @@ tcl::namespace::eval textblock {
proc welcome_test {} {
package require punk::ansi
package require patternpunk
set ansi [textblock::join -- " " [punk::ansi::ansicat src/testansi/publicdomain/roysac/ROY-WELC.ANS 80x8]]
set ansi [textblock::join -- " " [punk::ansi::ansicat -dimensions 80x8 src/testansi/publicdomain/roysac/ROY-WELC.ANS]]
# 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 punks [a+ term-lime][>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 -size 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]
set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ term-orange1] $contents]
}
@ -8350,13 +8361,14 @@ tcl::namespace::eval textblock {
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]
set cache_key [a+ Term-red term-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]
#set cache_key [a+ Web-steelblue term-black]$cache_key[a]
set cache_key [a+ Term-cornflowerblue term-black]$cache_key[a]
} else {
#actual_contentwidth is narrower than frame - check template's patternwidth
if {[tcl::dict::exists $frame_cache $cache_key]} {
@ -8366,13 +8378,13 @@ tcl::namespace::eval textblock {
}
if {$actual_contentwidth < $cache_patternwidth} {
set usecache 0
set cache_key [a+ Web-orange web-black]$cache_key[a]
set cache_key [a+ Term-orange1 term-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]
set cache_key [a+ Term-red term-black]$cache_key[a]
}
}
}

Write Preview
Loading…
Cancel
Save