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.
547 lines
22 KiB
547 lines
22 KiB
# -*- tcl -*- |
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
|
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm |
|
# |
|
# 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) 2024 |
|
# |
|
# @@ Meta Begin |
|
# Application punk::experiment 999999.0a1.0 |
|
# Meta platform tcl |
|
# Meta license <unspecified> |
|
# @@ Meta End |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# doctools header |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[manpage_begin punkshell_module_punk::experiment 0 999999.0a1.0] |
|
#[copyright "2024"] |
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
|
#[require punk::experiment] |
|
#[keywords module] |
|
#[description] |
|
#[para] - |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section Overview] |
|
#[para] overview of punk::experiment |
|
#[subsection Concepts] |
|
#[para] - |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[subsection dependencies] |
|
#[para] packages used by punk::experiment |
|
#[list_begin itemized] |
|
|
|
package require Tcl 8.6- |
|
#*** !doctools |
|
#[item] [package {Tcl 8.6}] |
|
|
|
# #package require frobz |
|
# #*** !doctools |
|
# #[item] [package {frobz}] |
|
|
|
#*** !doctools |
|
#[list_end] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section API] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# oo::class namespace |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
namespace eval punk::experiment::class { |
|
#*** !doctools |
|
#[subsection {Namespace punk::experiment::class}] |
|
#[para] class definitions |
|
if {[info commands [namespace current]::interface_sample1] eq ""} { |
|
#*** !doctools |
|
#[list_begin enumerated] |
|
|
|
# oo::class create interface_sample1 { |
|
# #*** !doctools |
|
# #[enum] CLASS [class interface_sample1] |
|
# #[list_begin definitions] |
|
|
|
# method test {arg1} { |
|
# #*** !doctools |
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
|
# #[para] test method |
|
# puts "test: $arg1" |
|
# } |
|
|
|
# #*** !doctools |
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
|
# } |
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end class enumeration ---}] |
|
} |
|
} |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# Base namespace |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
namespace eval punk::experiment { |
|
namespace export {[a-z]*} ;# Convention: export all lowercase |
|
#variable xyz |
|
|
|
#*** !doctools |
|
#[subsection {Namespace punk::experiment}] |
|
#[para] Core API functions for punk::experiment |
|
#[list_begin definitions] |
|
|
|
|
|
|
|
#proc sample1 {p1 n args} { |
|
# #*** !doctools |
|
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
|
# #[para]Description of sample1 |
|
# #[para] Arguments: |
|
# # [list_begin arguments] |
|
# # [arg_def tring p1] A description of string argument p1. |
|
# # [arg_def integer n] A description of integer argument n. |
|
# # [list_end] |
|
# return "ok" |
|
#} |
|
|
|
variable o_opts_table [dict create] |
|
variable o_opts_table_defaults [dict create {*}{ |
|
-test 1 |
|
-test2 etc |
|
-test3 333 |
|
-test4 444 |
|
}] |
|
set topt_keys [dict keys $o_opts_table_defaults] |
|
set topt_switchkeys [list -test - -test2 - -test3 - -test4] |
|
|
|
proc configure args [string map [list %topt_keys% $topt_keys %topt_switchkeys% $topt_switchkeys] { |
|
variable o_opts_table |
|
variable o_opts_table_defaults |
|
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 [dict get $o_opts_table $k] |
|
set returndict [dict create option $k value $val ansireset "\x1b\[m"] |
|
set infodict [dict create] |
|
switch -- $k { |
|
-ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder_body - -ansiborder_footer { |
|
dict set infodict debug [ansistring VIEW $val] |
|
} |
|
-framemap_body - -framemap_header - -framelimits_body - -framelimits_header { |
|
dict set returndict effective [dict get $o_opts_table_effective $k] |
|
} |
|
} |
|
dict set returndict info $infodict |
|
return $returndict |
|
#return [dict create option $k value $val ansireset "\x1b\[m" info $infodict] |
|
} else { |
|
error "textblock::table configure - unrecognised option '[lindex $args 0]'. Known values [dict keys $o_opts_table_defaults]" |
|
} |
|
} |
|
if {[llength $args] %2 != 0} { |
|
error "[namespace current]::table configure - unexpected argument count. Require name value pairs" |
|
} |
|
foreach {k v} $args { |
|
switch -- $k { |
|
%topt_switchkeys% {} |
|
default { |
|
error "[namespace current]::table configure - unrecognised option '$k'. Known values [dict keys $o_opts_table_defaults]" |
|
} |
|
} |
|
#if {$k ni [dict keys $o_opts_table_defaults]} { |
|
# error "[namespace current]::table configure - unrecognised option '$k'. Known values [dict keys $o_opts_table_defaults]" |
|
#} |
|
} |
|
set checked_opts [list] |
|
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 [dict get $tdefaults -framemap_body] |
|
#todo - check keys and map |
|
if {[llength $v] == 1} { |
|
if {$v eq "default"} { |
|
upvar ::textblock::class::opts_table_defaults tdefaults |
|
set default_map [dict get $tdefaults $k] |
|
lappend checked_opts $k $default_map |
|
} else { |
|
error "textblock::table::configure invalid $k value $v. Expected the value 'default' or a dict e.g topleft {hl *}" |
|
} |
|
} else { |
|
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}" |
|
} |
|
} |
|
dict for {seg subst} $subv { |
|
switch -- $seg { |
|
hl - hlt - hlb - vl - vll - vlr - trc - tlc - blc - brc {} |
|
default { |
|
error "textblock::table::configure invalid $subk value $seg. Known values {hl hlt hlb vl vll vlr trc tlc blc brc}" |
|
} |
|
} |
|
} |
|
|
|
} |
|
lappend checked_opts $k $v |
|
} |
|
|
|
} |
|
-framelimits_body - -framelimits_header { |
|
set specific_framelimits [list] |
|
foreach fl $v { |
|
switch -- $fl { |
|
"default" { |
|
lappend specific_framelimits trc hlt tlc vll blc hlb brc vlr |
|
} |
|
hl { |
|
lappend specific_framelimits hlt hlb |
|
} |
|
vl { |
|
lappend specific_framelimits vll vlr |
|
} |
|
hlt - hlb - vll - vlr - trc - tlc - blc - brc { |
|
lappend specific_framelimits $fl |
|
} |
|
default { |
|
error "textblock::table::configure invalid $k '$fl'. Known values {hl hlb hlt vl vll vlr trc tlc blc brc} (or default for all)" |
|
} |
|
} |
|
} |
|
lappend checked_opts $k $specific_framelimits |
|
} |
|
-ansireset { |
|
if {$v eq "\uFFEF"} { |
|
set RST "\x1b\[m" ;#[a] |
|
lappend checked_opts $k $RST |
|
} else { |
|
error "textblock::table::configure -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" |
|
} |
|
} |
|
-show_hseps { |
|
if {![string is boolean $v]} { |
|
error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" |
|
} |
|
lappend checked_opts $k $v |
|
#these don't affect column width calculations |
|
} |
|
-show_edge { |
|
if {![string is boolean $v]} { |
|
error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" |
|
} |
|
lappend checked_opts $k $v |
|
#these don't affect column width calculations - except if table -minwidth/-maxwidth come into play |
|
set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed |
|
} |
|
-show_vseps { |
|
#we allow empty string - so don't use -strict boolean check |
|
if {![string is boolean $v]} { |
|
error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" |
|
} |
|
#affects width calculations |
|
set o_calculated_column_widths [list] |
|
lappend checked_opts $k $v |
|
} |
|
-minwidth - -maxwidth { |
|
set o_calculated_column_widths [list] |
|
lappend checked_opts $k $v |
|
} |
|
default { |
|
lappend checked_opts $k $v |
|
} |
|
} |
|
} |
|
#all options checked - ok to update o_opts_table and o_opts_table_effective |
|
|
|
#set o_opts_table [dict merge $o_opts_table $checked_opts] |
|
foreach {k v} $args { |
|
#yes in safe |
|
switch -- $k { |
|
-framemap_header - -framemap_body { |
|
#framemaps don't require setting every key to update. |
|
#e.g configure -framemaps {topleft <map>} |
|
#needs to merge with existing unspecified keys such as topright middleleft etc. |
|
if {$v eq "default"} { |
|
dict set o_opts_table $k default |
|
} else { |
|
if {[dict get $o_opts_table $k] eq "default"} { |
|
dict set o_opts_table $k $v |
|
} else { |
|
dict set o_opts_table $k [dict merge [dict get $o_opts_table $k] $v] |
|
} |
|
} |
|
} |
|
default { |
|
dict set o_opts_table $k $v |
|
} |
|
} |
|
} |
|
#use values from checked_opts for the effective opts |
|
dict for {k v} $checked_opts { |
|
switch -- $k { |
|
-framemap_body - -framemap_header { |
|
set existing [dict get $o_opts_table_effective $k] |
|
#set updated $existing |
|
#dict for {subk subv} $v { |
|
# dict set updated $subk $subv |
|
#} |
|
#dict set o_opts_table_effective $k $updated |
|
dict set o_opts_table_effective $k [dict merge $existing $v] |
|
} |
|
-framelimits_body - -framelimits_header { |
|
#my Set_effective_framelimits |
|
dict set o_opts_table_effective $k $v |
|
} |
|
default { |
|
dict set o_opts_table_effective $k $v |
|
} |
|
} |
|
} |
|
#ansireset exception |
|
dict set o_opts_table -ansireset [dict get $o_opts_table_effective -ansireset] |
|
return $o_opts_table |
|
}] |
|
|
|
|
|
|
|
proc test1 {args} { |
|
set result [list] |
|
dict for {k v} $args { |
|
switch -- $k { |
|
-a - -b - -c - -d - -e - -f - -g - -h - -i - -j - -k - -l - -m - -n - -o - -p - -q - -r - -s - -t - -u - -v - -w - -x - -y - -z { |
|
switch -- $k { |
|
-a - -b - -c { |
|
lappend result "dfor-switcharm1-switcharm1-$k" |
|
} |
|
default { |
|
lappend result "dfor-switcharm1-switchdefault-$k" |
|
} |
|
} |
|
} |
|
default { |
|
switch -- $k { |
|
-1 - -2 - -3 - -4 - -5 - -6 - -7 - -8 - -9 { |
|
lappend result "dfor-switchdefault-switcharm1-$k" |
|
} |
|
default { |
|
lappend result "dfor-switchdefault-switchdefault-$k" |
|
} |
|
} |
|
} |
|
} |
|
} |
|
return $result |
|
} |
|
|
|
proc test2 {args} { |
|
set result [list] |
|
foreach {k v} $args { |
|
switch -- $k { |
|
-a - -b - -c - -d - -e - -f - -g - -h - -i - -j - -k - -l - -m - -n - -o - -p - -q - -r - -s - -t - -u - -v - -w - -x - -y - -z { |
|
switch -- $k { |
|
-a - -b - -c { |
|
lappend result "dfor-switcharm1-switcharm1-$k" |
|
} |
|
default { |
|
lappend result "dfor-switcharm1-switchdefault-$k" |
|
} |
|
} |
|
} |
|
default { |
|
switch -- $k { |
|
-1 - -2 - -3 - -4 - -5 - -6 - -7 - -8 - -9 { |
|
lappend result "dfor-switchdefault-switcharm1-$k" |
|
} |
|
default { |
|
lappend result "dfor-switchdefault-switchdefault-$k" |
|
} |
|
} |
|
} |
|
} |
|
} |
|
return $result |
|
} |
|
|
|
proc test3 {args} { |
|
set result [list] |
|
for {set i 0} {$i < [llength $args]} {incr i} { |
|
set k [lindex $args $i] |
|
switch -- $k { |
|
-a - -b - -c - -d - -e - -f - -g - -h - -i - -j - -k - -l - -m - -n - -o - -p - -q - -r - -s - -t - -u - -v - -w - -x - -y - -z { |
|
switch -- $k { |
|
-a - -b - -c { |
|
lappend result "dfor-switcharm1-switcharm1-$k" |
|
} |
|
default { |
|
lappend result "dfor-switcharm1-switchdefault-$k" |
|
} |
|
} |
|
} |
|
default { |
|
switch -- $k { |
|
-1 - -2 - -3 - -4 - -5 - -6 - -7 - -8 - -9 { |
|
lappend result "dfor-switchdefault-switcharm1-$k" |
|
} |
|
default { |
|
lappend result "dfor-switchdefault-switchdefault-$k" |
|
} |
|
} |
|
} |
|
} |
|
} |
|
return $result |
|
} |
|
|
|
set testblock "a\{\nb" |
|
proc testjoin {{block1 "---\n---"}} { |
|
variable testblock |
|
|
|
textblock::join $block1 [a+ red]$testblock |
|
} |
|
proc testjoin2 {} { |
|
set b1 [textblock::join ---\n--- "[a+ red]a\nb"] |
|
set b2 [textblock::join ---\n--- "[a+ red]a\{\nb"] |
|
set result $b1\n$b2 |
|
} |
|
|
|
|
|
#timings indistinguishable |
|
proc map_var {n str} { |
|
set map [list a AA b B c CC d D e EE f F g GG h H i II j J k KK l L m MM] |
|
set out [list] |
|
for {set i 0} {$i < $n} {incr i} { |
|
lappend out [string map $map $str] |
|
} |
|
return $out |
|
} |
|
proc map_inline {n str} { |
|
set out [list] |
|
for {set i 0} {$i < $n} {incr i} { |
|
lappend out [string map [list a AA b B c CC d D e EE f F g GG h H i II j J k KK l L m MM] $str] |
|
} |
|
return $out |
|
} |
|
|
|
variable b1 |
|
set b1 [textblock::block 12 12 .] |
|
variable b2 |
|
set b2 [textblock::block 12 12 x] |
|
variable b3 |
|
set b3 [textblock::join [textblock::block 6 12 @] $b2] |
|
proc render1 {} { |
|
variable b1 |
|
variable b2 |
|
overtype::renderspace -expand_right 1 -startcolumn 7 $b1 $b2 |
|
} |
|
proc render2 {} { |
|
variable b1 |
|
variable b3 |
|
overtype::renderspace -expand_right 1 -transparent @ $b1 $b3 |
|
} |
|
|
|
oo::class create c1 { |
|
method test1 args [info body ::punk::experiment::test1] |
|
method test2 args [info body ::punk::experiment::test2] |
|
method test3 args [info body ::punk::experiment::test2] |
|
} |
|
c1 create obj1 |
|
|
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace punk::experiment ---}] |
|
} |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# Secondary API namespace |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
namespace eval punk::experiment::lib { |
|
namespace export {[a-z]*} ;# Convention: export all lowercase |
|
namespace path [namespace parent] |
|
#*** !doctools |
|
#[subsection {Namespace punk::experiment::lib}] |
|
#[para] Secondary functions that are part of the API |
|
#[list_begin definitions] |
|
|
|
#proc utility1 {p1 args} { |
|
# #*** !doctools |
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
|
# #[para]Description of utility1 |
|
# return 1 |
|
#} |
|
|
|
|
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace punk::experiment::lib ---}] |
|
} |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[section Internal] |
|
namespace eval punk::experiment::system { |
|
#*** !doctools |
|
#[subsection {Namespace punk::experiment::system}] |
|
#[para] Internal functions that are not part of the API |
|
|
|
|
|
|
|
} |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::experiment [namespace eval punk::experiment { |
|
variable pkg punk::experiment |
|
variable version |
|
set version 999999.0a1.0 |
|
}] |
|
return |
|
|
|
#*** !doctools |
|
#[manpage_end] |
|
|
|
|