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.
281 Commits
1 Branch
1 Tag
197 MiB
 
 
 
 
 
 
Tree: e85481ad8c
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from 'e85481ad8c'
${ noResults }
punkshell/src/vfs/_vfscommon.vfs/modules/punk/blockletter-0.1.0.tm

360 lines
13 KiB
Raw Blame History

# -*- 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.3.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::blockletter 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::blockletter 0 0.1.0]
#[copyright "2024"]
#[titledesc {punk::blockletter frame-based large lettering test/logo}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require punk::blockletter]
#[keywords module]
#[description]
#[para] This is primarily designed to test large lettering using the block2 frametype which requires the right font support
#[para] More reasonably sized block-lettering could be obtained using unicode half-blocks instead - but that doesn't allow the frame outline effect that block2 gives.
#[para] Individual blocks have a minimum width of 4 columns and a minimum height of 2 rows (smallest element that can be fully framed)
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::blockletter
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::blockletter
#[list_begin itemized]
package require Tcl 8.6-
package require textblock
#*** !doctools
#[item] [package {Tcl 8.6}]
#[item] [package {textblock}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval punk::blockletter::class {
#*** !doctools
#[subsection {Namespace punk::blockletter::class}]
#[para] class definitions
#if {[tcl::info::commands [tcl::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
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::blockletter {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
#variable xyz
#*** !doctools
#[subsection {Namespace punk::blockletter}]
#[para] Core API functions for punk::blockletter
#[list_begin definitions]
#A 3x4 block font
variable default_frametype
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 Red Green Blue Purple Yellow]
proc logo {args} {
variable logo_letter_colours
variable default_frametype
set argd [punk::args::get_dict [tstr -return string {
-frametype -default {${$default_frametype}}
-outlinecolour -default "web-white"
-backgroundcolour -default {} -help "e.g Web-white
This argument is the name as accepted by punk::ansi::a+"
*values -min 0 -max 0
}] $args]
set f [dict get $argd opts -frametype]
set bd [dict get $argd opts -outlinecolour]
set bgansi [dict get $argd opts -backgroundcolour] ;#we use ta::detect to see if already ansi and apply as necessary
#standard red green blue purple yellow
lassign $logo_letter_colours c_0 c_1 c_2 c_3 c_4
set tc [merge_left_block [T -bg $c_0 -border $bd -frametype $f] [c -bg $c_1 -border $bd -frametype $f]]
set tk [merge_left_block [T -bg $c_3 -border $bd -frametype $f] [k_short -bg $c_4 -border $bd -frametype $f]]
set logo [textblock::join_basic -- $tc [l -bg $c_2 -border $bd -frametype $f] [textblock::block 2 8 " "] $tk]
if {$bgansi ne ""} {
lassign [textblock::size_as_list $logo] lwidth lheight
set w [expr {$lwidth + 2}]
set h [expr {$lheight + 2}]
if {![punk::ansi::ta::detect $bgansi]} {
set bgansi [punk::ansi::a+ $bgansi]
}
set logobg $bgansi[textblock::block $w $h " "][punk::ansi::a]
set topmargin [string repeat " " $w]
set lmargin [textblock::block 1 [expr {$h + 1}] " "]
set logo [overtype::left -transparent " " $logobg [textblock::join_basic -- $lmargin $topmargin\n$logo]]
}
return $logo
}
#for characters where it makes sense - offset left by 4 (1 'block' width)
proc merge_left {charleft textright} {
if {[string length $charleft] != 1} {
error "merge_left requires a single character as the charleft argument"
}
if {[textblock::height $charleft$textright] > 1} {
error "merge_left only operates on a plain char and a plain string with no newlines"
}
set rhs [textblock::join_basic -- [textblock::block 8 8 " "] [text $textright]]
#important to explicitly use -transparent " " (ordinary space) rather than -transparent 1 (any space?)
#This is because our frames have NBSP as filler to be non-transparent
return [overtype::left -transparent " " -overflow 1 [text $charleft] $rhs]
}
proc merge_left_block {blockleft blockright} {
set rhs [textblock::join_basic -- [textblock::block 8 8 " "] $blockright]
return [overtype::left -transparent " " -overflow 1 $blockleft $rhs]
}
proc T {args} {
set args [dict remove $args -width -height]
append out [lib::hbar {*}$args]\n
append out [textblock::join -- " " [lib::vbar {*}$args] " "]
}
proc c {args} {
set args [dict remove $args -width -height]
append out [textblock::block 12 2 " "]\n
append out [lib::hbar {*}$args]\n
append out [textblock::join -- [lib::block {*}$args] " "]\n
append out [lib::hbar {*}$args]
}
proc l {args} {
set args [dict remove $args -width -height]
append out [lib::vbar {*}[dict merge {-height 8} $args]]
}
#full height lower k
proc k {args} {
set args [dict remove $args -width -height]
set left [lib::vbar {*}[dict merge {-height 8} $args]]
set centre [textblock::block 4 4 " "]\n
append centre [lib::block {*}$args]\n
append centre [textblock::block 4 2 " "]
set right [textblock::block 4 2 " "]\n
append right [lib::block {*}$args]\n
append right [textblock::block 4 2 " "]\n
append right [lib::block {*}$args]
append out [textblock::join_basic -- $left $centre $right]
}
proc k_short {args} {
set args [dict remove $args -width -height]
append left [textblock::block 4 2 " "]\n
append left [lib::vbar {*}[dict merge {-height 6} $args]]
append centre [textblock::block 4 4 " "]\n
append centre [lib::block {*}$args]\n
append centre [textblock::block 4 2 " "]
append right [textblock::block 4 2 " "]\n
append right [lib::block {*}$args]\n
append right [textblock::block 4 2 " "]\n
append right [lib::block {*}$args]
append out [textblock::join_basic -- $left $centre $right]
}
proc text {args} {
variable default_frametype
set argd [punk::args::get_dict [tstr -return string {
-bgcolour -default "Web-red"
-bordercolour -default "web-white"
-frametype -default {${$default_frametype}}
*values -min 1 -max 1
str -help "Text to convert to blockletters
Requires terminal font to support relevant block characters"
"
}] $args]
set opts [dict get $argd opts]
set str [dict get $argd values str]
set str [string map {\r\n \n} $str]
set outblocks [list]
set literals [list \n]
foreach char [split $str ""] {
if {$char in $literals} {
lappend outblocks $char
continue
}
if {$char in [list \t \r]} {
lappend outblocks [textblock::block 1 8 $char]
continue
}
if {[info commands ::punk::blockletter::$char] ne ""} {
lappend outblocks [::punk::blockletter::$char {*}$opts]
} else {
lappend outblocks [textblock::block 12 8 $char]
}
}
return [textblock::join_basic -- {*}$outblocks]
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::blockletter ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::blockletter::lib {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace punk::blockletter::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
#}
proc block {args} {
upvar ::punk::blockletter::default_frametype ft
set argd [punk::args::get_dict [tstr -return string {
-height -default 2
-width -default 4
-frametype -default {${$ft}}
-bgcolour -default "Web-red"
-bordercolour -default "web-white"
*values -min 0 -max 0
}] $args]
set bg [dict get $argd opts -bgcolour]
set bd [dict get $argd opts -bordercolour]
set h [dict get $argd opts -height]
set w [dict get $argd opts -width]
set f [dict get $argd opts -frametype]
#a frame will usually be filled with empty spaces if content not specified
#fill the frame with a non-space so we can do transparent overtypes using ordinary space as the transparency character
set w_in [expr {$w -2}]
set h_in [expr {$h -2}]
if {$w_in > 0 && $h_in > 0} {
set inner [textblock::block $w_in $h_in \u00a0] ;#NBSP
textblock::frame -checkargs 0 -type $f -height $h -width $w -ansiborder [a+ $bd $bg] -ansibase [a+ $bg] $inner
} else {
#important to use no content arg - as empty string has 'height' of 1 in the textblock context (min height of any string is 1 row in the console)
textblock::frame -checkargs 0 -type $f -height $h -width $w -ansiborder [a+ $bd $bg] -ansibase [a+ $bg]
}
}
proc hbar {args} {
upvar ::punk::blockletter::default_frametype ft
set defaults [dict create\
-height 2\
-width 12\
-frametype $ft\
]
set opts [dict merge $defaults $args]
block {*}$opts
}
proc vbar {args} {
upvar ::punk::blockletter::default_frametype ft
#default height a multiple of default hbar/block height
set defaults [dict create\
-height 6\
-width 4\
-frametype $ft\
]
set opts [dict merge $defaults $args]
[namespace current]::block {*}$opts
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::blockletter::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
#tcl::namespace::eval punk::blockletter::system {
#*** !doctools
#[subsection {Namespace punk::blockletter::system}]
#[para] Internal functions that are not part of the API
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::blockletter [tcl::namespace::eval punk::blockletter {
variable pkg punk::blockletter
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]