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

5370 lines
303 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) Julian Noble 2003-2023
#
# @@ Meta Begin
# Application overtype 999999.0a1.0
# Meta platform tcl
# Meta license BSD
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin overtype_module_overtype 0 999999.0a1.0]
#[copyright "2024"]
#[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}]
#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}]
#[require overtype]
#[keywords module text ansi]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of overtype
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by overtype
#[list_begin itemized]
package require Tcl 8.6-
package require textutil
package require punk::lib ;#required for lines_as_list
package require punk::ansi ;#required to detect, split, strip and calculate lengths
package require punk::char ;#box drawing - and also unicode character width determination for proper layout of text with double-column-width chars
package require punk::assertion
#*** !doctools
#[item] [package {Tcl 8.6}]
#[item] [package textutil]
#[item] [package punk::ansi]
#[para] - required to detect, split, strip and calculate lengths of text possibly containing ansi codes
#[item] [package punk::char]
#[para] - box drawing - and also unicode character width determination for proper layout of text with double-column-width chars
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
#PERFORMANCE notes
#overtype is very performance sensitive - used in ansi output all over the place ie needs to be optimised
#NOTE use of tcl::dict::for tcl::string::range etc instead of ensemble versions. This is for the many tcl 8.6/8.7 interps which don't compile ensemble commands when in safe interps
#similar for tcl::namespace::eval - but this is at least on some versions of Tcl - faster even in a normal interp. Review to see if that holds for Tcl 9.
#for string map: when there are exactly 2 elements - it is faster to use a literal which has a special case optimisation in the c code
#ie use tcl::string::map {\n ""} ... instead of tcl::string::map [list \n ""] ...
#note that we can use unicode (e.g \uFF31) and other escapes such as \t within these curly braces - we don't have to use double quotes
#generally using 'list' is preferred for the map as less error prone.
#can also use: tcl::string::map "token $var" .. but be careful regarding quoting and whitespace in var. This should be used sparingly if at all.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
#Julian Noble <julian@precisium.com.au> - 2003
#Released under standard 'BSD license' conditions.
#
#todo - ellipsis truncation indicator for center,right
#v1.4 2023-07 - naive ansi color handling - todo - fix tcl::string::range
# - need to extract and replace ansi codes?
tcl::namespace::eval overtype {
namespace import ::punk::assertion::assert
punk::assertion::active true
namespace path ::punk::lib
namespace export *
variable default_ellipsis_horizontal "..." ;#fallback
variable default_ellipsis_vertical "..."
tcl::namespace::eval priv {
proc _init {} {
upvar ::overtype::default_ellipsis_horizontal e_h
upvar ::overtype::default_ellipsis_vertical e_v
set e_h [format %c 0x2026] ;#Unicode Horizontal Ellipsis
set e_v [format %c 0x22EE]
#The unicode ellipsis looks more natural than triple-dash which is centred vertically whereas ellipsis is at floorline of text
#Also - unicode ellipsis has semantic meaning that other processors can interpret
#unicode does also provide a midline horizontal ellipsis 0x22EF
#set e [format %c 0x2504] ;#punk::char::charshort boxd_ltdshhz - Box Drawings Light Triple Dash Horizontal
#if {![catch {package require punk::char}]} {
# set e [punk::char::charshort boxd_ltdshhz]
#}
}
}
priv::_init
}
proc overtype::about {} {
return "ANSI capable text formatting. Author JMN. BSD-License"
}
tcl::namespace::eval overtype {
variable grapheme_widths [tcl::dict::create]
variable escape_terminals
#single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~).
tcl::dict::set escape_terminals CSI [list @ \\ ^ _ ` | ~ 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 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 "\{" "\}"]
#tcl::dict::set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic
tcl::dict::set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals
#self-contained 2 byte ansi escape sequences - review more?
variable ansi_2byte_codes_dict
set ansi_2byte_codes_dict [tcl::dict::create\
"reset_terminal" "\u001bc"\
"save_cursor_posn" "\u001b7"\
"restore_cursor_posn" "\u001b8"\
"cursor_up_one" "\u001bM"\
"NEL - Next Line" "\u001bE"\
"IND - Down one line" "\u001bD"\
"HTS - Set Tab Stop" "\u001bH"\
]
#debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway.
# "PM - Privacy Message" "\u001b^somethinghidden\033\\"\
}
proc overtype::string_columns {text} {
if {[punk::ansi::ta::detect $text]} {
#error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::ansistrip. Alternatively try punk::ansi::printing_length"
set text [punk::ansi::ansistrip $text]
}
return [punk::char::ansifreestring_width $text]
}
#todo - consider a way to merge overtype::left/centre/right
#These have similar algorithms/requirements - and should be refactored to be argument-wrappers over a function called something like overtype::renderblock
#overtype::renderblock could render the input to a defined (possibly overflowing in x or y) rectangle overlapping the underlay.
#(i.e not even necessariy having it's top left within the underlay)
tcl::namespace::eval overtype::priv {
}
#could return larger than renderwidth
proc _get_row_append_column {row} {
#obsolete?
upvar outputlines outputlines
set idx [expr {$row -1}]
if {$row <= 1 || $row > [llength $outputlines]} {
return 1
} else {
upvar opt_expand_right expand_right
upvar renderwidth renderwidth
set existinglen [punk::ansi::printing_length [lindex $outputlines $idx]]
set endpos [expr {$existinglen +1}]
if {$expand_right} {
return $endpos
} else {
if {$endpos > $renderwidth} {
return [expr {$renderwidth + 1}]
} else {
return $endpos
}
}
}
}
tcl::namespace::eval overtype {
#*** !doctools
#[subsection {Namespace overtype}]
#[para] Core API functions for overtype
#[list_begin definitions]
namespace eval argdoc {
variable PUNKARGS
#non-colour SGR codes
set I "\x1b\[3m" ;# [a+ italic]
set NI "\x1b\[23m" ;# [a+ noitalic]
set B "\x1b\[1m" ;# [a+ bold]
set N "\x1b\[22m" ;# [a+ normal]
set T "\x1b\[1\;4m" ;# [a+ bold underline]
set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline]
interp alias "" ::overtype::example "" ::punk::args::helpers::example
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::overtype::renderspace
@cmd -name overtype::renderspace\
-summary\
{}\
-help\
{}
@opts
#because underblocks value is optional - restrict opts to flag pairs (no solos)
#We don't use punk::args::parse in the actual function to parse args - so keep it simpler.
-bias -default left -type string -choices {left right} -help ignored
-width -default \uFFEF -type integer
-height -default \uFFEF -type integer
-startcolumn -default 1 -type integer
-startrow -default 1 -type integer
-ellipsis -default 0 -type boolean
-ellipsistext -default ${$::overtype::default_ellipsis_horizontal} -type char
-ellipsiswhitespace -default 0 -type boolean
-expand_right -default 0 -type boolean
-appendlines -default 1 -type boolean
-transparent -default 0 -type {literal(0)|literal(1)|regexp} -help\
"0 to disable transparency processing
1 to enable space characters in the
overlay to be transparent, or a regex
to match the character(s) required to be
transparent in the overlay."
-exposed1 -default \uFFFD -type char -help\
{A character of single terminal column width to use
as replacement when first-half of an underlying char
is exposed due to overlay positioning/transparency
which obscures the second-half of the char. May be ANSI
coloured as this doesn't affect the display width.
Default is \uFFFD - the unicode replacement char.}
-exposed2 -default \uFFFD -type char -help\
{A character of single terminal column width to use
as replacement when second-half of an underlying char
is exposed due to overlay positioning/transparency
which obscures the first-half of the char. May be ANSI
coloured as this doesn't affect the display width.
Default is \uFFFD - the unicode replacement char.}
-experimental -default 0
-cp437 -default 0 -type boolean
-looplimit -default \uFFEF\ -type integer -help\
"internal failsafe - experimental"
-crm_mode -default 0 -type boolean
-reverse_mode -default 0 -type boolean
-insert_mode -default 1 -type boolean
-wrap -default 0 -type boolean
-info -default 0 -type boolean -help\
"When set to 1, return a dictionary (experimental)"
-binarytext -default "" -type string -choices {"" bios ice}
-console -default {stdin stdout stderr} -type list
@values -min 1 -max 2
underblock -type string -optional 1
overblock -type string -optional 0
}]
}
#tcl::string::range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r
#render onto an already-rendered (ansi already processed) 'underlay' string, a possibly ansi-laden 'overlay' string.
#The underlay and overlay can be multiline blocks of text of varying line lengths.
#The overlay may just be an ansi-colourised block - or may contain ansi cursor movements and cursor save/restore calls - in which case the apparent length and width of the overlay can't be determined as if it was a block of text.
#This is a single-shot rendering of strings - ie there is no way to chain another call containing a cursor-restore to previously rendered output and have it know about any cursor-saves in the first call.
# a cursor start position other than top-left is a possible addition to consider.
#see editbuf in punk::repl for a more stateful ansi-processor. Both systems use loops over overtype::renderline
proc renderspace {args} {
#*** !doctools
#[call [fun overtype::renderspace] [arg args] ]
#[para] usage: ?-transparent [lb]0|1[rb]? ?-expand_right [lb]1|0[rb]? ?-ellipsis [lb]1|0[rb]? ?-ellipsistext ...? undertext overtext
# @c overtype starting at left (overstrike)
# @c can/should we use something like this?: 'format "%-*s" $len $overtext
variable default_ellipsis_horizontal
if {[llength $args] < 1} {
error {usage: ?-width <int>? ?-startcolumn <int>? ?-transparent [0|1|<char>]? ?-expand_right [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext}
}
set optargs [lrange $args 0 end-2]
if {[llength $optargs] % 2 == 0} {
set overblock [lindex $args end]
set underblock [lindex $args end-1]
#lassign [lrange $args end-1 end] underblock overblock
set argsflags [lrange $args 0 end-2]
} else {
#no solo flags - so we assume only an overblock was supplied
set overblock [lindex $args end]
set underblock ""
set argsflags [lrange $args 0 end-1]
#set optargs [lrange $args 0 end-1]
#if {[llength $optargs] %2 == 0} {
# set overblock [lindex $args end]
# set underblock ""
# set argsflags [lrange $args 0 end-1]
#} else {
# error "renderspace expects opt-val pairs followed by: <underblock> <overblock> or just <overblock>"
#}
}
set opts [tcl::dict::create\
-bias ignored\
-width \uFFEF\
-height \uFFEF\
-startcolumn 1\
-startrow 1\
-ellipsis 0\
-ellipsistext $default_ellipsis_horizontal\
-ellipsiswhitespace 0\
-expand_right 0\
-appendlines 1\
-transparent 0\
-exposed1 \uFFFD\
-exposed2 \uFFFD\
-experimental 0\
-cp437 0\
-looplimit \uFFEF\
-crm_mode 0\
-reverse_mode 0\
-insert_mode 0\
-wrap 0\
-info 0\
-binarytext ""\
-console {stdin stdout stderr}\
]
#expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally..
# it does not necessarily mean the viewport grows. (which further implies need for horizontal scrolling)
# - it does need to be within some concept of terminal width - as columns must be addressable by ansi sequences.
# - This implies the -width option value must grow if it is tied to the concept of renderspace terminal width! REVIEW.
# - further implication is that if expand_right grows the virtual renderspace terminal width -
# then some sort of reflow/rerender needs to be done for preceeding lines?
# possibly not - as expand_right is distinct from a normal terminal-width change event,
# expand_right being primarily to support other operations such as textblock::table
#todo - viewport width/height as separate concept to terminal width/height?
#-ellipsis args not used if -wrap is true
foreach {k v} $argsflags {
switch -- $k {
-looplimit - -width - -height - -startcolumn - -startrow - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace
- -transparent - -exposed1 - -exposed2 - -experimental
- -expand_right - -appendlines
- -reverse_mode - -crm_mode - -insert_mode
- -cp437
- -info - -binarytext - -console {
tcl::dict::set opts $k $v
}
-wrap - -autowrap_mode {
#temp alias -autowrap_mode for consistency with renderline
#todo -
tcl::dict::set opts -wrap $v
}
default {
error "overtype::renderspace unknown option '$k'. Known options: [tcl::dict::keys $opts]"
}
}
}
#set opts [tcl::dict::merge $defaults $argsflags]
# -- --- --- --- --- ---
#review - expand_left for RTL text?
set opt_expand_right [tcl::dict::get $opts -expand_right]
#for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line.
set opt_width [tcl::dict::get $opts -width]
set opt_height [tcl::dict::get $opts -height]
set opt_startcolumn [tcl::dict::get $opts -startcolumn]
set opt_startrow [tcl::dict::get $opts -startrow]
set opt_appendlines [tcl::dict::get $opts -appendlines]
set opt_transparent [tcl::dict::get $opts -transparent]
set opt_ellipsistext [tcl::dict::get $opts -ellipsistext]
set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace]
set opt_exposed1 [tcl::dict::get $opts -exposed1] ;#widechar_exposed_left - todo
set opt_exposed2 [tcl::dict::get $opts -exposed2] ;#widechar_exposed_right - todo
# -- --- --- --- --- ---
set opt_crm_mode [tcl::dict::get $opts -crm_mode]
set opt_reverse_mode [tcl::dict::get $opts -reverse_mode]
set opt_insert_mode [tcl::dict::get $opts -insert_mode]
#####
# review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?.
set opt_autowrap_mode [tcl::dict::get $opts -wrap]
#??? wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo)
#####
# -- --- --- --- --- ---
set opt_cp437 [tcl::dict::get $opts -cp437]
set opt_info [tcl::dict::get $opts -info]
set opt_binarytext [tcl::dict::get $opts -binarytext]
# ----------------------------
# -experimental dev flag to set flags etc
# ----------------------------
set data_mode 0
set edit_mode 0
set opt_experimental [tcl::dict::get $opts -experimental]
foreach o $opt_experimental {
switch -- $o {
data_mode {
set data_mode 1
}
edit_mode {
set edit_mode 1
}
}
}
# ----------------------------
set underblock [tcl::string::map {\r\n \n} $underblock]
set overblock [tcl::string::map {\r\n \n} $overblock]
if {$opt_startrow > 1} {
set down [expr {$opt_startrow -1}]
set overblock [punk::ansi::move_down $down]$overblock
}
#set underlines [split $underblock \n]
#underblock is a 'rendered' block - so width height make sense
#only non-cursor affecting and non-width occupying ANSI codes should be present.
#ie SGR codes and perhaps things such as PM - although generally those should have been pushed to the application already
#renderwidth & renderheight were originally used with reference to rendering into a 'column' of output e.g a table column - before cursor row/col was implemented.
if {$opt_width eq "\uFFEF" || $opt_height eq "\uFFEF"} {
lassign [blocksize $underblock] _w renderwidth _h renderheight
if {$opt_width ne "\uFFEF"} {
set renderwidth $opt_width
}
if {$opt_height ne "\uFFEF"} {
set renderheight $opt_height
}
} else {
set renderwidth $opt_width
set renderheight $opt_height
}
#initial state for renderspace 'terminal' reset
set initial_state [dict create\
renderwidth $renderwidth\
renderheight $renderheight\
crm_mode $opt_crm_mode\
reverse_mode $opt_reverse_mode\
insert_mode $opt_insert_mode\
autowrap_mode $opt_autowrap_mode\
cp437 $opt_cp437\
]
#modes
#e.g insert_mode can be toggled by insert key or ansi IRM sequence CSI 4 h|l
#opt_startcolumn ?? - DECSLRM ?
set vtstate $initial_state
# -- --- --- ---
#REVIEW - do we need ansi resets in the underblock?
if {$underblock eq ""} {
set underlines [lrepeat $renderheight ""]
} else {
set underblock [textblock::join_basic -- $underblock] ;#ensure properly rendered - ansi per-line resets & replays
set underlines [split $underblock \n]
}
#if {$underblock eq ""} {
# set blank "\x1b\[0m\x1b\[0m"
# #set underlines [list "\x1b\[0m\x1b\[0m"]
# set underlines [lrepeat $renderheight $blank]
#} else {
# #lines_as_list -ansiresets 1 will do nothing if -ansiresets 1 isn't specified - REVIEW
# set underlines [lines_as_list -ansiresets 1 $underblock]
#}
# -- --- --- ---
#todo - reconsider the 'line' as the natural chunking mechanism for the overlay.
#In practice an overlay ANSI stream can be a single line with ansi moves/restores etc - or even have no moves or newlines, just relying on wrapping at the output renderwidth
#In such cases - we process the whole shebazzle for the first output line - only reducing by the applied amount at the head each time, reprocessing the long tail each time.
#(in cases where there are interline moves or cursor jumps anyway)
#This works - but doesn't seem efficient.
#On the other hand.. maybe it depends on the data. For simpler files it's more efficient than splitting first
#a hack until we work out how to avoid infinite loops...
#
set looplimit [tcl::dict::get $opts -looplimit]
if {$looplimit eq "\uFFEF"} {
#looping for each char is worst case (all newlines?) - anything over that is an indication of something broken?
#do we need any margin above the length? (telnet mapscii.me test)
set looplimit [expr {[tcl::string::length $overblock] + 10}]
}
#overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height
#lassign [blocksize $overblock] _w overblock_width _h overblock_height
set scheme 4
switch -- $scheme {
0 {
#one big chunk
set inputchunks [list mixed $overblock]
}
1 {
#todo
set inputchunks [punk::ansi::ta::split_codes $overblock]
}
2 {
#todo
#split into lines if possible first - then into plaintext/ansi-sequence chunks ?
set inputchunks [list ""] ;#put an empty plaintext split in for starters
set i 1
set lines [split $overblock \n]
foreach ln $lines {
if {$i < [llength $lines]} {
append ln \n
}
set sequence_split [punk::ansi::ta::split_codes_single $ln] ;#use split_codes Not split_codes_single?
set lastpt [lindex $inputchunks end]
lset inputchunks end [tcl::string::cat $lastpt [lindex $sequence_split 0]]
lappend inputchunks {*}[lrange $sequence_split 1 end]
incr i
}
}
3 {
#todo
#it turns out line based chunks are faster than the above.. probably because some of those end up doing the regex splitting twice
set lflines [list]
set inputchunks [split $overblock \n]
foreach ln $inputchunks {
append ln \n
lappend lflines $ln
}
if {[llength $lflines]} {
lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1]
}
#set inputchunks $lflines[unset lflines]
set inputchunks [lindex [list $lflines [unset lflines]] 0]
}
4 {
set inputchunks [list]
switch -- $opt_binarytext {
"" {
foreach ln [split $overblock \n] {
lappend inputchunks [list mixed $ln\n]
}
if {[llength $inputchunks]} {
lset inputchunks end 1 [tcl::string::range [lindex $inputchunks end 1] 0 end-1]
}
}
bios {
#16 fg, 8 fg + possible blink
set input ""
set ansisplit [list ""]
set charpair 0
foreach {ch at} [split $overblock ""] {
#review - does binarytext only apply to cp437??? we need to know the original encoding
set at [encoding convertto cp437 $at]
if {[catch {punk::ansi::colour::byteAnsi $at} code]} {
puts stderr "renderspace err at charpair: $charpair [punk::ansi::ansistring VIEW ${ch}${at}]"
#append input [punk::ansi::a+ brightred White] \uFFef
set code [punk::ansi::a+ brightred White]
set ch \uFFeF
}
append input $code $ch
lappend ansisplit $code $ch
incr charpair
}
#lappend inputchunks [list mixed $input]
lappend inputchunks [list ansisplit $ansisplit]
}
ice {
#16 fg, 16 bg (no blink)
set input ""
foreach {ch at} [split $overblock ""] {
set at [encoding convertto cp437 $at]
append input [punk::ansi::colour::byteAnsiIce $at]$ch
}
lappend inputchunks [list mixed $input]
}
}
}
}
set replay_codes_underlay [tcl::dict::create 1 ""]
#lappend replay_codes_overlay ""
set replay_codes_overlay "[punk::ansi::a]"
set unapplied ""
set cursor_saved_position [tcl::dict::create]
set cursor_saved_attributes ""
set outputlines $underlines
set overidx 0
#underlines are not necessarily processed in order - depending on cursor-moves applied from overtext
set row 1
#if {$data_mode} {
# set col [_get_row_append_column $row]
#} else {
set col $opt_startcolumn
#}
set instruction_stats [tcl::dict::create]
set loop 0
#while {$overidx < [llength $inputchunks]} { }
set renderedrow ""
while {[llength $inputchunks]} {
#set overtext [lpop inputchunks 0] ;#could be a list 'ansisplit' or text 'plain|mixed'
lassign [lpop inputchunks 0] overtext_type overtext
#use eq test with emptystring instead of 'string length' - test for emptiness shouldn't cause shimmering if popped inputchunks member if an 'ansisplit' list
if {$overtext eq ""} {
incr loop
continue
}
#puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----"
set undertext [lindex $outputlines [expr {$row -1}]]
#renderline pads each underaly line to width with spaces and should track where end of data is
switch -- $overtext_type {
mixed {
set overtext $replay_codes_overlay$overtext
}
ansisplit {
ledit overtext -1 -1 "" $replay_codes_overlay
}
default {
error "renderspace unsupported overtext type: $overtext_type overtext: $overtext"
}
}
######################
#debug
#set partinfo ""
#if {$overtext_type eq "ansisplit"} {
# set partinfo [llength $overtext]
#} else {
# set partinfo [string length $overtext]
#}
#if {$renderedrow eq $row} {
# puts -nonewline stderr <$row>$overtext_type$partinfo
#} else {
# puts -nonewline stderr \n<$row>$overtext_type$partinfo
#}
#if {$overtext_type eq "mixed"} {
# puts -nonewline stderr "\n[ansistring VIEW $overtext]\n"
#}
######################
set renderedrow $row
if {[tcl::dict::exists $replay_codes_underlay $row]} {
set undertext [tcl::dict::get $replay_codes_underlay $row]$undertext
}
#review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary -
#but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l
set renderopts [list -experimental $opt_experimental\
-cp437 $opt_cp437\
-info 1\
-crm_mode [tcl::dict::get $vtstate crm_mode]\
-insert_mode [tcl::dict::get $vtstate insert_mode]\
-autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\
-reverse_mode [tcl::dict::get $vtstate reverse_mode]\
-cursor_restore_attributes $cursor_saved_attributes\
-transparent $opt_transparent\
-width [tcl::dict::get $vtstate renderwidth]\
-exposed1 $opt_exposed1\
-exposed2 $opt_exposed2\
-expand_right $opt_expand_right\
-cursor_column $col\
-cursor_row $row\
-overtext_type $overtext_type\
]
set rinfo [renderline {*}$renderopts $undertext $overtext]
set instruction [tcl::dict::get $rinfo instruction]
tcl::dict::set vtstate crm_mode [tcl::dict::get $rinfo crm_mode]
tcl::dict::set vtstate insert_mode [tcl::dict::get $rinfo insert_mode]
tcl::dict::set vtstate autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;#
tcl::dict::set vtstate reverse_mode [tcl::dict::get $rinfo reverse_mode]
#how to support reverse_mode in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack?
# - review - the answer is probably that we don't need to - it is set/reset only during application of overtext
#Note carefully the difference betw overflow_right and unapplied.
#overflow_right may need to be included in next run before the unapplied data
#overflow_right most commonly has data when in insert_mode
set rendered [tcl::dict::get $rinfo result]
set overflow_right [tcl::dict::get $rinfo overflow_right]
set overflow_right_column [tcl::dict::get $rinfo overflow_right_column]
set unapplied [tcl::dict::get $rinfo unapplied]
set unapplied_list [tcl::dict::get $rinfo unapplied_list]
set unapplied_ansisplit [tcl::dict::get $rinfo unapplied_ansisplit]
set post_render_col [tcl::dict::get $rinfo cursor_column]
set post_render_row [tcl::dict::get $rinfo cursor_row]
set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position]
set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes]
set visualwidth [tcl::dict::get $rinfo visualwidth] ;#column width of what is 'rendered' for the line
set insert_lines_above [tcl::dict::get $rinfo insert_lines_above]
set insert_lines_below [tcl::dict::get $rinfo insert_lines_below]
tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay]
#lset replay_codes_overlay [expr $overidx+1] [tcl::dict::get $rinfo replay_codes_overlay]
set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]
if {0 && [tcl::dict::get $vtstate reverse_mode]} {
#test branch - todo - prune
puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered"
#review
#JMN3
set existing_reverse_state 0
#split_codes_single is single esc sequence - but could have multiple sgr codes within one esc sequence
#e.g \x1b\[0;31;7m has a reset,colour red and reverse
set codeinfo [punk::ansi::codetype::sgr_merge [list $replay_codes_overlay] -info 1]
set codestate_reverse [dict get $codeinfo codestate reverse]
switch -- $codestate_reverse {
7 {
set existing_reverse_state 1
}
27 {
set existing_reverse_state 0
}
"" {
}
}
if {$existing_reverse_state == 0} {
set rflip [a+ reverse]
} else {
#reverse of reverse
set rflip [a+ noreverse]
}
#note that mergeresult can have multiple esc (due to unmergeables or non sgr codes)
set replay_codes_overlay [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]]
puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered"
}
#-- todo - detect looping properly
if {$row > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == $row && $instruction eq ""} {
puts stderr "overtype::renderspace loop?"
puts [ansistring VIEW $rinfo]
break
}
#--
if {[tcl::dict::size $c_saved_pos] >= 1} {
set cursor_saved_position $c_saved_pos
set cursor_saved_attributes $c_saved_attributes
}
set overflow_handled 0
set nextprefix_list [list]
#todo - handle potential insertion mode as above for cursor restore?
#keeping separate branches for debugging - review and merge as appropriate when stable
set instruction_type [lindex $instruction 0] ;#some instructions have params
tcl::dict::incr instruction_stats $instruction_type
switch -- $instruction_type {
reset {
#reset the 'renderspace terminal' (not underlying terminal)
set row 1
set col 1
set vtstate [tcl::dict::merge $vtstate $initial_state]
#todo - clear screen
}
{} {
#end of supplied line input
#lf included in data
set row $post_render_row
set col $post_render_col
if {![llength $unapplied_list]} {
if {$overflow_right ne ""} {
incr row
}
} else {
puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)"
}
set col $opt_startcolumn
}
up {
#renderline knows it's own line number, and knows not to go above row l
#it knows that a move whilst 1-beyond the width conflicts with the linefeed and reduces the move by one accordingly.
#row returned should be correct.
#column may be the overflow column - as it likes to report that to the caller.
#Note that an ansi up sequence after last column going up to a previous line and also beyond the last column, will result in the next grapheme going onto the following line.
#this seems correct - as the column remains beyond the right margin so subsequent chars wrap (?) review
#puts stderr "up $post_render_row"
#puts stderr "$rinfo"
#puts stdout "1 row:$row col $col"
set row $post_render_row
#data_mode (naming?) determines if we move to end of existing data or not.
#data_mode 0 means ignore existing line length and go to exact column
#set by -experimental flag
if {$data_mode == 0} {
set col $post_render_col
} else {
#This doesn't really work if columns are pre-filled with spaces..we can't distinguish them from data
#we need renderline to return the number of the maximum column filled (or min if we ever do r-to-l)
set existingdata [lindex $outputlines [expr {$post_render_row -1}]]
set lastdatacol [punk::ansi::printing_length $existingdata]
if {$lastdatacol < $renderwidth} {
set col [expr {$lastdatacol+1}]
} else {
set col $renderwidth
}
}
#puts stdout "2 row:$row col $col"
#puts stdout "-----------------------"
#puts stdout $rinfo
#flush stdout
}
down {
if {$data_mode == 0} {
#renderline doesn't know how far down we can go..
if {$post_render_row > [llength $outputlines]} {
if {$opt_appendlines} {
set diff [expr {$post_render_row - [llength $outputlines]}]
if {$diff > 0} {
lappend outputlines {*}[lrepeat $diff ""]
}
lappend outputlines ""
}
}
set row $post_render_row
set col $post_render_col
} else {
if {$post_render_row > [llength $outputlines]} {
if {$opt_appendlines} {
set diff [expr {$post_render_row - [llength $outputlines]}]
if {$diff > 0} {
lappend outputlines {*}[lrepeat $diff ""]
}
lappend outputlines ""
}
}
# ----
# review
set col $post_render_col
#just because it's out of range of the renderwidth - doesn't mean a move down should jump to witin the range - 2025
#----
#set existingdata [lindex $outputlines [expr {$post_render_row -1}]]
#set lastdatacol [punk::ansi::printing_length $existingdata]
#set col [expr {$lastdatacol+1}]
#if {$lastdatacol < $renderwidth} {
# set col [expr {$lastdatacol+1}]
#} else {
# set col $renderwidth
#}
}
}
restore_cursor {
#testfile belinda.ans uses this
#puts stdout "[a+ blue bold]CURSOR_RESTORE[a]"
if {[tcl::dict::exists $cursor_saved_position row]} {
set row [tcl::dict::get $cursor_saved_position row]
set col [tcl::dict::get $cursor_saved_position column]
#puts stdout "restoring: row $row col $col [ansistring VIEW $cursor_saved_attributes] [a] unapplied [ansistring VIEWCODES $unapplied]"
#set nextprefix $cursor_saved_attributes
#lset replay_codes_overlay [expr $overidx+1] $cursor_saved_attributes
set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]$cursor_saved_attributes
#set replay_codes_overlay $cursor_saved_attributes
set cursor_saved_position [tcl::dict::create]
set cursor_saved_attributes ""
} else {
#TODO
#?restore without save?
#should move to home position and reset ansi SGR?
#puts stderr "overtype::renderspace cursor_restore without save data available"
}
#If we were inserting prior to hitting the cursor_restore - there could be overflow_right data - generally the overtype functions aren't for inserting - but ansi can enable it
#if we were already in overflow when cursor_restore was hit - it shouldn't have been processed as an action - just stored.
if {!$overflow_handled && $overflow_right ne ""} {
#wrap before restore? - possible effect on saved cursor position
#this overflow data has previously been rendered so has no cursor movements or further save/restore operations etc
#we can just insert another call to renderline to solve this.. ?
#It would perhaps be more properly handled as a queue of instructions from our initial renderline call
#we don't need to worry about overflow next call (?)- but we should carry forward our gx and ansi stacks
puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]"
set sub_info [overtype::renderline\
-info 1\
-width [tcl::dict::get $vtstate renderwidth]\
-insert_mode [tcl::dict::get $vtstate insert_mode]\
-autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\
-expand_right [tcl::dict::get $opts -expand_right]\
""\
$overflow_right\
]
set foldline [tcl::dict::get $sub_info result]
tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..?
tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this..
#todo!!!
# 2025 fix - this does nothing - so what uses it?? create a test!
linsert outputlines $renderedrow $foldline
#review - row & col set by restore - but not if there was no save..
}
set overflow_handled 1
}
move {
########
if {$post_render_row > [llength $outputlines]} {
#Ansi moves need to create new lines ?
#if {$opt_appendlines} {
# set diff [expr {$post_render_row - [llength $outputlines]}]
# if {$diff > 0} {
# lappend outputlines {*}[lrepeat $diff ""]
# }
# set row $post_render_row
#} else {
set row [llength $outputlines]
#}
} else {
set row $post_render_row
}
#######
set col $post_render_col
#overflow + unapplied?
}
clear_and_move {
#e.g 2J
if {$post_render_row > [llength $outputlines]} {
set row [llength $outputlines]
} else {
set row $post_render_row
}
set col $post_render_col
set overflow_right "" ;#if we're clearing - any overflow due to insert_mode is irrelevant
set clearedlines [list]
foreach ln $outputlines {
lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $renderwidth]\x1b\[0m
if 0 {
set lineparts [punk::ansi::ta::split_codes $ln]
set numcells 0
foreach {pt _code} $lineparts {
if {$pt ne ""} {
foreach grapheme [punk::char::grapheme_split $pt] {
switch -- $grapheme {
" " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? -
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 - 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 - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 {
incr numcells 1
}
default {
if {$grapheme eq "\u0000"} {
incr numcells 1
} else {
incr numcells [grapheme_width_cached $grapheme]
}
}
}
}
}
}
#replays/resets each line
lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $numcells]\x1b\[0m
}
}
set outputlines $clearedlines
#todo - determine background/default to be in effect - DECECM ?
puts stderr "replay_codes_overlay: [ansistring VIEW $replay_codes_overlay]"
#lset outputlines 0 $replay_codes_overlay[lindex $outputlines 0]
}
lf_start {
#raw newlines
# ----------------------
#test with fruit.ans
#test - treating as newline below...
#append rendered $overflow_right
#set overflow_right ""
set row $renderedrow
incr row
if {$row > [llength $outputlines]} {
lappend outputlines ""
}
set col $opt_startcolumn
# ----------------------
}
lf_mid {
set edit_mode 0
if {$edit_mode} {
#set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied]
#JMN
#ledit inputchunks -1 -1 $overflow_right$unapplied
set pt_ansi_pt [punk::ansi::ta::split_codes_single $overflow_right]
#join the trailing and leading pt parts of the 2 lists
ledit pt_ansi_pt end end "[lindex $pt_ansi_pt end][lindex $unapplied_ansisplit 0]"
lappend pt_ansi_pt [lrange $unapplied_ansisplit 1 end]
ledit inputchunks -1 -1 [list ansisplit $pt_ansi_pt] ;#combined overflow_right and unapplied - in ansisplit form
set overflow_right ""
set unapplied ""
set unapplied_list [list]
set unapplied_ansisplit [list]
set row $post_render_row
#set col $post_render_col
set col $opt_startcolumn
if {$row > [llength $outputlines]} {
lappend outputlines {*}[lrepeat 1 ""]
}
} else {
if 1 {
if {$overflow_right ne ""} {
if {$opt_expand_right} {
append rendered $overflow_right
set overflow_right ""
} else {
#review - we should really make renderline do the work...?
set overflow_width [punk::ansi::printing_length $overflow_right]
if {$visualwidth + $overflow_width <= $renderwidth} {
append rendered $overflow_right
set overflow_right ""
} else {
if {[tcl::dict::get $vtstate autowrap_mode]} {
set outputlines [linsert $outputlines $renderedrow $overflow_right]
set overflow_right ""
set row [expr {$renderedrow + 2}]
} else {
set overflow_right "" ;#abandon
}
if {0 && $visualwidth < $renderwidth} {
puts stderr "visualwidth: $visualwidth < renderwidth:$renderwidth"
error "incomplete - abandon?"
set overflowparts [punk::ansi::ta::split_codes $overflow_right]
set remaining_overflow $overflowparts
set filled 0
foreach {pt code} $overflowparts {
lpop remaining_overflow 0
if {$pt ne ""} {
set graphemes [punk::char::grapheme_split $pt]
set add ""
set addlen $visualwidth
foreach g $graphemes {
set w [overtype::grapheme_width_cached $g]
if {$addlen + $w <= $renderwidth} {
append add $g
incr addlen $w
} else {
set filled 1
break
}
}
append rendered $add
}
if {!$filled} {
lpop remaining_overflow 0 ;#pop code
}
}
set overflow_right [join $remaining_overflow ""]
}
}
}
}
set row $post_render_row
set col $opt_startcolumn
if {$row > [llength $outputlines]} {
lappend outputlines {*}[lrepeat 1 ""]
}
} else {
#old version - known to work with various ansi graphics - e.g fruit.ans
# - but fails to limit lines to renderwidth when expand_right == 0
append rendered $overflow_right
set overflow_right ""
set row $post_render_row
set col $opt_startcolumn
if {$row > [llength $outputlines]} {
lappend outputlines {*}[lrepeat 1 ""]
}
}
}
}
lf_overflow {
#linefeed after renderwidth e.g at column 81 for an 80 col width
#we may also have other control sequences that came after col 80 e.g cursor save
if 0 {
set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]]
set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs]
set rhs ""
#assertion - there should be no overflow..
puts $lhs
}
if {![tcl::dict::get $vtstate insert_mode]} {
assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode
}
set row $post_render_row
#set row $renderedrow
#incr row
#only add newline if we're at the bottom
if {$row > [llength $outputlines]} {
lappend outputlines {*}[lrepeat 1 ""]
}
set col $opt_startcolumn
}
newlines_above {
#we get a newlines_above instruction when <lf> received at column 1
#In some cases we want to treat that as request to insert a new blank line above, and move our row 1 down (staying with the data)
#in other cases - we want to treat <lf> at column 1 the same as any other <lf>
puts "--->newlines_above"
puts "rinfo: $rinfo"
#renderline doesn't advance the row for us - the caller has the choice to implement or not
set row $post_render_row
set col $post_render_col
if {$insert_lines_above > 0} {
set row $renderedrow
#set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]]
ledit outputlines $renderedrow-1 $renderedrow-2 {*}[lrepeat $insert_lines_above ""]
incr row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above
#? set row $post_render_row #can renderline tell us?
}
}
newlines_below {
#obsolete? - use for ANSI insert lines sequence
if {$data_mode == 0} {
puts --->nl_below
set row $post_render_row
set col $post_render_col
if {$insert_lines_below == 1} {
#set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]]
#set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs]
#set rhs ""
#if {$overflow_right ne ""} {
# set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]]
# set rhs [textblock::frame -title overflow_right $rhs]
#}
#puts [textblock::join $lhs $rhs]
#rendered
append rendered $overflow_right
#
set overflow_right ""
set row $renderedrow
#only add newline if we're at the bottom
if {$row > [llength $outputlines]} {
lappend outputlines {*}[lrepeat $insert_lines_below ""]
}
incr row $insert_lines_below
set col $opt_startcolumn
}
} else {
set row $post_render_row
if {$post_render_row > [llength $outputlines]} {
if {$opt_appendlines} {
set diff [expr {$post_render_row - [llength $outputlines]}]
if {$diff > 0} {
lappend outputlines {*}[lrepeat $diff ""]
}
lappend outputlines ""
}
} else {
set existingdata [lindex $outputlines [expr {$post_render_row -1}]]
set lastdatacol [punk::ansi::printing_length $existingdata]
if {$lastdatacol < $renderwidth} {
set col [expr {$lastdatacol+1}]
} else {
set col $renderwidth
}
}
}
}
wrapmoveforward {
#doesn't seem to be used by fruit.ans testfile
#used by dzds.ans
#note that cursor_forward may move deep into the next line - or even span multiple lines !TODO
set c $renderwidth
set r $post_render_row
if {$post_render_col > $renderwidth} {
set i $c
while {$i <= $post_render_col} {
if {$c == $renderwidth+1} {
incr r
if {$opt_appendlines} {
if {$r < [llength $outputlines]} {
lappend outputlines ""
}
}
set c $opt_startcolumn
} else {
incr c
}
incr i
}
set col $c
} else {
#why are we getting this instruction then?
puts stderr "wrapmoveforward - test"
set r [expr {$post_render_row +1}]
set c $post_render_col
}
set row $r
set col $c
}
wrapmovebackward {
set c $renderwidth
set r $post_render_row
if {$post_render_col < 1} {
set c 1
set i $c
while {$i >= $post_render_col} {
if {$c == 0} {
if {$r > 1} {
incr r -1
set c $renderwidth
} else {
#leave r at 1 set c 1
#testfile besthpav.ans first line top left border alignment
set c 1
break
}
} else {
incr c -1
}
incr i -1
}
set col $c
} else {
puts stderr "Wrapmovebackward - but postrendercol >= 1???"
}
set row $r
set col $c
}
overflow {
#normal single-width grapheme overflow
#puts stderr "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]"
#renderspace gives us an overflow when there is a grapheme followed by a non-grapheme
#This gives us some possible(probable) leading ANSI (which is probably SGR, or it would have triggered something else)
#followed by a sequence of 1 or more graphemes and some more unprocessed ANSI (which could be anything: SGR,movement etc)
#we want to strip out this leading run of graphemes
#NOTE: 2025 - comment is obsolete/inaccurate. We only ever get 1 grapheme - as prior were consumed/ignored by renderline
#REVIEW!!!
#example trigger: textblock::frame -width 80 [ansicat us-pump_up_the_jam-355.ans 355x100]
set row $post_render_row ;#renderline will not advance row when reporting overflow char
if {[tcl::dict::get $vtstate autowrap_mode]} {
incr row
set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ??
} else {
set col $post_render_col
#The overflow can only be triggered by a grapheme (todo cluster?) - but our unapplied could contain SGR codes prior to the grapheme that triggered overflow - so we need to skip beyond any SGRs
#There may be more than one, because although the stack leading up to overflow may have been merged - codes between the last column and the overflowing grapheme will remain separate
#We don't expect any movement or other ANSI codes - as if they came before the grapheme, they would have triggered a different instruction to 'overflow'
set drop_graphemes [list] ;#list of contiguous grapheme indices
set new_unapplied_list [list]
set unapplied_ansisplit [list ""]
set idx 0
foreach u $unapplied_list {
if {![punk::ansi::ta::detect $u]} {
#puts stderr "g$idx:$u"
if {![llength $drop_graphemes] || $idx == [lindex $drop_graphemes end]+1} {
#we are in the first run of uninterrupted graphemes
#drop by doing nothing with it here
lappend drop_graphemes $idx
} else {
lappend new_unapplied_list $u
ledit unapplied_ansisplit end end "[lindex $unapplied_ansisplit end]$u"
}
} else {
lappend new_unapplied_list $u
lappend unapplied_ansisplit $u ""
}
incr idx
}
#debug
if {[llength $drop_graphemes]} {
set idx0 [lindex $drop_graphemes 0]
set dbg ""
if {$idx0 > 0} {
for {set i 0} {$i < $idx0} {incr i} {
#leading SGR
append dbg [lindex $unapplied_list $i]
}
}
foreach idx $drop_graphemes {
append dbg [lindex $unapplied_list $idx]
}
puts stderr "dropped[llength $drop_graphemes]:$dbg\x1b\[m"
}
set unapplied [join $new_unapplied_list ""]
if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} {
set unapplied_ansisplit [list]
}
set unapplied_list $new_unapplied_list
#we need to run the reduced unapplied on the same line - further graphemes will just overflow again, but codes or control chars could trigger jumps to other lines
set overflow_handled 1
#handled by dropping overflow if any
}
}
overflow_splitchar {
set row $post_render_row ;#renderline will not advance row when reporting overflow char
#2nd half of grapheme would overflow - treggering grapheme is returned in unapplied. There may also be overflow_right from earlier inserts
#todo - consider various options .. re-render a single trailing space or placeholder on same output line, etc
if {[tcl::dict::get $vtstate autowrap_mode]} {
if {$renderwidth < 2} {
#edge case of rendering to a single column output - any 2w char will just cause a loop if we don't substitute with something, or drop the character
set idx 0
set triggering_grapheme_index -1
foreach u $unapplied_list {
if {![punk::ansi::ta::detect $u]} {
set triggering_grapheme_index $idx
break
}
incr idx
}
#set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""]
ledit unapplied_list $triggering_grapheme_index $triggering_grapheme_index
set unapplied [join $unapplied_list ""]
#review - inefficient to re-split (return unapplied_tagged instead of unapplied_ansisplit?)
set unapplied_ansisplit [punk::ansi::ta::split_codes_single $unapplied]
} else {
set col $opt_startcolumn
incr row
}
} else {
set overflow_handled 1
#handled by dropping entire overflow if any
if {$renderwidth < 2} {
set idx 0
set triggering_grapheme_index -1
foreach u $unapplied_list {
if {![punk::ansi::ta::detect $u]} {
set triggering_grapheme_index $idx
break
}
incr idx
}
#set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""]
ledit unapplied_list $triggering_grapheme_index $triggering_grapheme_index
set unapplied [join $unapplied_list ""]
#review - inefficient
puts -nonewline stderr .
set unapplied_ansisplit [punk::ansi::ta::split_codes_single $unapplied]
}
}
}
vt {
#can vt add a line like a linefeed can?
set row $post_render_row
set col $post_render_col
}
set_window_title {
set newtitle [lindex $instruction 1]
puts stderr "overtype::renderspace set_window_title [ansistring VIEW $newtitle] instruction '$instruction'"
#
}
reset_colour_palette {
puts stderr "overtype::renderspace instruction '$instruction' unimplemented"
}
default {
puts stderr "overtype::renderspace unhandled renderline instruction '$instruction'"
}
}
if {!$opt_expand_right && ![tcl::dict::get $vtstate autowrap_mode]} {
#not allowed to overflow column or wrap therefore we get overflow data to truncate
if {[tcl::dict::get $opts -ellipsis]} {
set show_ellipsis 1
if {!$opt_ellipsiswhitespace} {
#we don't want ellipsis if only whitespace was lost
set lostdata ""
if {$overflow_right ne ""} {
append lostdata $overflow_right
}
if {$unapplied ne ""} {
append lostdata $unapplied
}
if {[tcl::string::trim $lostdata] eq ""} {
set show_ellipsis 0
}
#set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end]
if {[tcl::string::trim [punk::ansi::ansistrip $lostdata]] eq ""} {
set show_ellipsis 0
}
}
if {$show_ellipsis} {
set rendered [overtype::right $rendered $opt_ellipsistext]
}
set overflow_handled 1
} else {
#no wrap - no ellipsis - silently truncate
set overflow_handled 1
}
}
if {$renderedrow <= [llength $outputlines]} {
lset outputlines [expr {$renderedrow-1}] $rendered
} else {
if {$opt_appendlines} {
lappend outputlines $rendered
} else {
#?
lset outputlines [expr {$renderedrow-1}] $rendered
}
}
if {!$overflow_handled} {
#append nextprefix $overflow_right
set overflow_right_pt_code_pt [punk::ansi::ta::split_codes_single $overflow_right]
if {![llength $nextprefix_list]} {
set nextprefix_list $overflow_right_pt_code_pt
} else {
#merge tail and head
ledit nextprefix_list end end "[lindex $nextprefix_list end][lindex $overflow_right_pt_code_pt 0]"
lappend nextprefix_list {*}[lrange $overflow_right_pt_code_pt 1 end]
}
}
#append nextprefix $unapplied
if {![llength $nextprefix_list]} {
set nextprefix_list $unapplied_ansisplit
} else {
#merge tail and head
ledit nextprefix_list end end "[lindex $nextprefix_list end][lindex $unapplied_ansisplit 0]"
lappend nextprefix_list {*}[lrange $unapplied_ansisplit 1 end]
}
if 0 {
if {$nextprefix ne ""} {
set nextoveridx [expr {$overidx+1}]
if {$nextoveridx >= [llength $inputchunks]} {
lappend inputchunks $nextprefix
} else {
#lset overlines $nextoveridx $nextprefix[lindex $overlines $nextoveridx]
set inputchunks [linsert $inputchunks $nextoveridx $nextprefix]
}
}
}
if {[llength $nextprefix_list]} {
#set inputchunks [linsert $inputchunks 0 $nextprefix]
#JMN - assume backwards compat ledit available from punk::lib (for tcl <9)
ledit inputchunks -1 -1 [list ansisplit $nextprefix_list]
}
incr overidx
incr loop
if {$loop >= $looplimit} {
puts stderr "overtype::renderspace looplimit reached ($looplimit)"
lappend outputlines "[a+ red bold]<truncated> - looplimit $looplimit reached[a]"
set Y [a+ yellow bold]
set RST [a]
set sep_header ----DEBUG-----
set debugmsg ""
append debugmsg "${Y}${sep_header}${RST}" \n
append debugmsg "looplimit $looplimit reached\n"
append debugmsg "data_mode:$data_mode\n"
append debugmsg "opt_appendlines:$opt_appendlines\n"
append debugmsg "prev_row :[tcl::dict::get $renderopts -cursor_row]\n"
append debugmsg "prev_col :[tcl::dict::get $renderopts -cursor_column]\n"
tcl::dict::for {k v} $rinfo {
append debugmsg "${Y}$k [ansistring VIEW -lf 1 -vt 1 $v]$RST" \n
}
append debugmsg "${Y}[string repeat - [string length $sep_header]]$RST" \n
puts stdout $debugmsg
#todo - config regarding error dumps rather than just dumping in working dir
set fd [open [pwd]/error_overtype.txt w]
puts $fd $debugmsg
close $fd
error $debugmsg
break
}
}
set result [join $outputlines \n]
if {!$opt_info} {
return $result
} else {
#emit to debug window like basictelnet does? make debug configurable as syslog or even a telnet server to allow on 2nd window?
#append result \n$instruction_stats\n
set inforesult [dict create\
result $result\
last_instruction $instruction\
instruction_stats $instruction_stats\
]
if {$opt_info == 2} {
return [pdict -channel none inforesult]
} else {
return $inforesult
}
}
}
#todo - left-right ellipsis ?
proc centre {args} {
variable default_ellipsis_horizontal
if {[llength $args] < 2} {
error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext}
}
foreach {underblock overblock} [lrange $args end-1 end] break
#todo - vertical vs horizontal overflow for blocks
set opts [tcl::dict::create\
-bias left\
-ellipsis 0\
-ellipsistext $default_ellipsis_horizontal\
-ellipsiswhitespace 0\
-overflow 0\
-transparent 0\
-exposed1 \uFFFD\
-exposed2 \uFFFD\
]
set argsflags [lrange $args 0 end-2]
foreach {k v} $argsflags {
switch -- $k {
-bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 {
tcl::dict::set opts $k $v
}
default {
set known_opts [tcl::dict::keys $opts]
error "overtype::centre unknown option '$k'. Known options: $known_opts"
}
}
}
#set opts [tcl::dict::merge $defaults $argsflags]
# -- --- --- --- --- ---
set opt_transparent [tcl::dict::get $opts -transparent]
set opt_ellipsis [tcl::dict::get $opts -ellipsis]
set opt_ellipsistext [tcl::dict::get $opts -ellipsistext]
set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace]
set opt_exposed1 [tcl::dict::get $opts -exposed1]
set opt_exposed2 [tcl::dict::get $opts -exposed2]
# -- --- --- --- --- ---
set underblock [tcl::string::map {\r\n \n} $underblock]
set overblock [tcl::string::map {\r\n \n} $overblock]
set underlines [split $underblock \n]
#set renderwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]]
lassign [blocksize $underblock] _w renderwidth _h renderheight
set overlines [split $overblock \n]
lassign [blocksize $overblock] _w overblock_width _h overblock_height
set under_exposed_max [expr {$renderwidth - $overblock_width}]
if {$under_exposed_max > 0} {
#background block is wider
if {$under_exposed_max % 2 == 0} {
#even left/right exposure
set left_exposed [expr {$under_exposed_max / 2}]
} else {
set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division
if {[tcl::string::tolower [tcl::dict::get $opts -bias]] eq "left"} {
set left_exposed $beforehalf
} else {
#bias to the right
set left_exposed [expr {$beforehalf + 1}]
}
}
} else {
set left_exposed 0
}
set outputlines [list]
if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} {
set replay_codes "[punk::ansi::a]"
} else {
set replay_codes ""
}
set replay_codes_underlay ""
set replay_codes_overlay ""
foreach undertext $underlines overtext $overlines {
set overtext_datalen [punk::ansi::printing_length $overtext]
set ulen [punk::ansi::printing_length $undertext]
if {$ulen < $renderwidth} {
set udiff [expr {$renderwidth - $ulen}]
set undertext "$undertext[string repeat { } $udiff]"
}
set undertext $replay_codes_underlay$undertext
set overtext $replay_codes_overlay$overtext
set overflowlength [expr {$overtext_datalen - $renderwidth}]
#review - right-to-left langs should elide on left! - extra option required
if {$overflowlength > 0} {
#overlay line wider or equal
#review - we still expand_right for centred for now.. possibly should do something like -expand_leftright with ellipsis each end?
set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext]
set rendered [tcl::dict::get $rinfo result]
set overflow_right [tcl::dict::get $rinfo overflow_right]
set unapplied [tcl::dict::get $rinfo unapplied]
#todo - get replay_codes from overflow_right instead of wherever it was truncated?
#overlay line data is wider - trim if overflow not specified in opts - and overtype an ellipsis at right if it was specified
if {![tcl::dict::get $opts -overflow]} {
#lappend outputlines [tcl::string::range $overtext 0 [expr {$renderwidth - 1}]]
#set overtext [tcl::string::range $overtext 0 $renderwidth-1 ]
if {$opt_ellipsis} {
set show_ellipsis 1
if {!$opt_ellipsiswhitespace} {
#we don't want ellipsis if only whitespace was lost
#don't use tcl::string::range on ANSI data
#set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end]
set lostdata ""
if {$overflow_right ne ""} {
append lostdata $overflow_right
}
if {$unapplied ne ""} {
append lostdata $unapplied
}
if {[tcl::string::trim $lostdata] eq ""} {
set show_ellipsis 0
}
}
if {$show_ellipsis} {
set rendered [overtype::right $rendered $opt_ellipsistext]
}
}
}
lappend outputlines $rendered
#lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent $undertext $overtext]
} else {
#background block is wider than or equal to data for this line
#lappend outputlines [renderline -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext]
set rinfo [renderline -info 1 -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext]
lappend outputlines [tcl::dict::get $rinfo result]
}
set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay]
set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]
}
return [join $outputlines \n]
}
#overtype::right is for a rendered ragged underblock and a rendered ragged overblock
#ie we can determine the block width for bost by examining the lines and picking the longest.
#
proc right {args} {
#NOT the same as align-right - which should be done to the overblock first if required
variable default_ellipsis_horizontal
# @d !todo - implement overflow, length checks etc
if {[llength $args] < 2} {
error {usage: ?-overflow [1|0]? ?-transparent 0|<char>? undertext overtext}
}
foreach {underblock overblock} [lrange $args end-1 end] break
set opts [tcl::dict::create\
-bias ignored\
-ellipsis 0\
-ellipsistext $default_ellipsis_horizontal\
-ellipsiswhitespace 0\
-overflow 0\
-transparent 0\
-exposed1 \uFFFD\
-exposed2 \uFFFD\
-align "left"\
]
set argsflags [lrange $args 0 end-2]
tcl::dict::for {k v} $argsflags {
switch -- $k {
-bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -align {
tcl::dict::set opts $k $v
}
default {
set known_opts [tcl::dict::keys $opts]
error "overtype::centre unknown option '$k'. Known options: $known_opts"
}
}
}
#set opts [tcl::dict::merge $defaults $argsflags]
# -- --- --- --- --- ---
set opt_transparent [tcl::dict::get $opts -transparent]
set opt_ellipsis [tcl::dict::get $opts -ellipsis]
set opt_ellipsistext [tcl::dict::get $opts -ellipsistext]
set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace]
set opt_overflow [tcl::dict::get $opts -overflow]
set opt_exposed1 [tcl::dict::get $opts -exposed1]
set opt_exposed2 [tcl::dict::get $opts -exposed2]
set opt_align [tcl::dict::get $opts -align]
# -- --- --- --- --- ---
set underblock [tcl::string::map {\r\n \n} $underblock]
set overblock [tcl::string::map {\r\n \n} $overblock]
set underlines [split $underblock \n]
lassign [blocksize $underblock] _w renderwidth _h renderheight
set overlines [split $overblock \n]
#set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]]
lassign [blocksize $overblock] _w overblock_width _h overblock_height
set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}]
set left_exposed $under_exposed_max
set outputlines [list]
if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} {
set replay_codes "[punk::ansi::a]"
} else {
set replay_codes ""
}
set replay_codes_underlay ""
set replay_codes_overlay ""
foreach undertext $underlines overtext $overlines {
set overtext_datalen [punk::ansi::printing_length $overtext]
set ulen [punk::ansi::printing_length $undertext]
if {$ulen < $renderwidth} {
set udiff [expr {$renderwidth - $ulen}]
#puts xxx
append undertext [string repeat { } $udiff]
}
if {$overtext_datalen < $overblock_width} {
set odiff [expr {$overblock_width - $overtext_datalen}]
switch -- $opt_align {
left {
set startoffset 0
}
right {
set startoffset $odiff
}
default {
set half [expr {$odiff / 2}]
#set lhs [string repeat { } $half]
#set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left
#set rhs [string repeat { } $righthalf]
set startoffset $half
}
}
} else {
set startoffset 0 ;#negative?
}
set undertext $replay_codes_underlay$undertext
set overtext $replay_codes_overlay$overtext
set overflowlength [expr {$overtext_datalen - $renderwidth}]
if {$overflowlength > 0} {
#raw overtext wider than undertext column
set rinfo [renderline\
-info 1\
-insert_mode 0\
-transparent $opt_transparent\
-exposed1 $opt_exposed1 -exposed2 $opt_exposed2\
-overflow $opt_overflow\
-startcolumn [expr {1 + $startoffset}]\
$undertext $overtext]
set replay_codes [tcl::dict::get $rinfo replay_codes]
set rendered [tcl::dict::get $rinfo result]
if {!$opt_overflow} {
if {$opt_ellipsis} {
set show_ellipsis 1
if {!$opt_ellipsiswhitespace} {
#we don't want ellipsis if only whitespace was lost
set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end]
if {[tcl::string::trim $lostdata] eq ""} {
set show_ellipsis 0
}
}
if {$show_ellipsis} {
set ellipsis $replay_codes$opt_ellipsistext
#todo - overflow on left if allign = right??
set rendered [overtype::right $rendered $ellipsis]
}
}
}
lappend outputlines $rendered
} else {
#padded overtext
#lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext]
#Note - we still need overflow(exapnd_right) here - as although the overtext is short - it may oveflow due to the startoffset
set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext]
lappend outputlines [tcl::dict::get $rinfo result]
}
set replay_codes [tcl::dict::get $rinfo replay_codes]
set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay]
set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]
}
return [join $outputlines \n]
}
proc left {args} {
overtype::block -blockalign left {*}$args
}
#overtype a (possibly ragged) underblock with a (possibly ragged) overblock
proc block {args} {
variable default_ellipsis_horizontal
# @d !todo - implement overflow, length checks etc
if {[llength $args] < 2} {
error {usage: ?-blockalign left|centre|right? ?-textalign left|centre|right? ?-overflow [1|0]? ?-transparent 0|<char>? undertext overtext}
}
#foreach {underblock overblock} [lrange $args end-1 end] break
lassign [lrange $args end-1 end] underblock overblock
set opts [tcl::dict::create\
-ellipsis 0\
-ellipsistext $default_ellipsis_horizontal\
-ellipsiswhitespace 0\
-overflow 0\
-transparent 0\
-exposed1 \uFFFD\
-exposed2 \uFFFD\
-textalign "left"\
-textvertical "top"\
-blockalign "left"\
-blockalignbias left\
-blockvertical "top"\
]
set argsflags [lrange $args 0 end-2]
tcl::dict::for {k v} $argsflags {
switch -- $k {
-blockalignbias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -textalign - -blockalign - -blockvertical {
tcl::dict::set opts $k $v
}
default {
error "overtype::block unknown option '$k'. Known options: [tcl::dict::keys $opts]"
}
}
}
# -- --- --- --- --- ---
set opt_transparent [tcl::dict::get $opts -transparent]
set opt_ellipsis [tcl::dict::get $opts -ellipsis]
set opt_ellipsistext [tcl::dict::get $opts -ellipsistext]
set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace]
set opt_overflow [tcl::dict::get $opts -overflow]
set opt_exposed1 [tcl::dict::get $opts -exposed1]
set opt_exposed2 [tcl::dict::get $opts -exposed2]
set opt_textalign [tcl::dict::get $opts -textalign]
set opt_blockalign [tcl::dict::get $opts -blockalign]
if {$opt_blockalign eq "center"} {
set opt_blockalign "centre"
}
# -- --- --- --- --- ---
set underblock [tcl::string::map {\r\n \n} $underblock]
set overblock [tcl::string::map {\r\n \n} $overblock]
set underlines [split $underblock \n]
lassign [blocksize $underblock] _w renderwidth _h renderheight
set overlines [split $overblock \n]
#set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]]
lassign [blocksize $overblock] _w overblock_width _h overblock_height
set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}]
switch -- $opt_blockalign {
left {
set left_exposed 0
}
right {
set left_exposed $under_exposed_max
}
centre {
if {$under_exposed_max > 0} {
#background block is wider
if {$under_exposed_max % 2 == 0} {
#even left/right exposure
set left_exposed [expr {$under_exposed_max / 2}]
} else {
set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division
if {[tcl::string::tolower [tcl::dict::get $opts -blockalignbias]] eq "left"} {
set left_exposed $beforehalf
} else {
#bias to the right
set left_exposed [expr {$beforehalf + 1}]
}
}
} else {
set left_exposed 0
}
}
default {
set left_exposed 0
}
}
set outputlines [list]
if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} {
set replay_codes "[punk::ansi::a]"
} else {
set replay_codes ""
}
set replay_codes_underlay ""
set replay_codes_overlay ""
foreach undertext $underlines overtext $overlines {
set overtext_datalen [punk::ansi::printing_length $overtext]
set ulen [punk::ansi::printing_length $undertext]
if {$ulen < $renderwidth} {
set udiff [expr {$renderwidth - $ulen}]
#puts xxx
append undertext [string repeat { } $udiff]
}
if {$overtext_datalen < $overblock_width} {
set odiff [expr {$overblock_width - $overtext_datalen}]
switch -- $opt_textalign {
left {
set startoffset 0
}
right {
set startoffset $odiff
}
default {
set half [expr {$odiff / 2}]
#set lhs [string repeat { } $half]
#set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left
#set rhs [string repeat { } $righthalf]
set startoffset $half
}
}
} else {
set startoffset 0 ;#negative?
}
set undertext $replay_codes_underlay$undertext
set overtext $replay_codes_overlay$overtext
set overflowlength [expr {$overtext_datalen - $renderwidth}]
if {$overflowlength > 0} {
#raw overtext wider than undertext column
set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -expand_right $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext]
set replay_codes [tcl::dict::get $rinfo replay_codes]
set rendered [tcl::dict::get $rinfo result]
set overflow_right [tcl::dict::get $rinfo overflow_right]
set unapplied [tcl::dict::get $rinfo unapplied]
if {!$opt_overflow} {
if {$opt_ellipsis} {
set show_ellipsis 1
if {!$opt_ellipsiswhitespace} {
#we don't want ellipsis if only whitespace was lost
#don't use tcl::string::range on ANSI data
#set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end]
set lostdata ""
if {$overflow_right ne ""} {
append lostdata $overflow_right
}
if {$unapplied ne ""} {
append lostdata $unapplied
}
if {[tcl::string::trim $lostdata] eq ""} {
set show_ellipsis 0
}
}
if {$show_ellipsis} {
set rendered [overtype::block -blockalign right $rendered $opt_ellipsistext]
}
}
#if {$opt_ellipsis} {
# set show_ellipsis 1
# if {!$opt_ellipsiswhitespace} {
# #we don't want ellipsis if only whitespace was lost
# set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end]
# if {[tcl::string::trim $lostdata] eq ""} {
# set show_ellipsis 0
# }
# }
# if {$show_ellipsis} {
# set ellipsis [tcl::string::cat $replay_codes $opt_ellipsistext]
# #todo - overflow on left if allign = right??
# set rendered [overtype::right $rendered $ellipsis]
# }
#}
}
lappend outputlines $rendered
} else {
#padded overtext
#lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext]
#Note - we still need expand_right here - as although the overtext is short - it may oveflow due to the startoffset
set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext]
#puts stderr "--> [ansistring VIEW -lf 1 -nul 1 $rinfo] <--"
set overflow_right [tcl::dict::get $rinfo overflow_right]
set unapplied [tcl::dict::get $rinfo unapplied]
lappend outputlines [tcl::dict::get $rinfo result]
}
set replay_codes [tcl::dict::get $rinfo replay_codes]
set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay]
set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]
}
return [join $outputlines \n]
}
#variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches
variable optimise_ptruns 5
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::overtype::renderline
@cmd -name overtype::renderline\
-summary\
{Render a line of text/ANSI input over a line of text.}\
-help\
{renderline is the core engine for overtype string processing (frames & textblocks), and the raw mode
commandline repl for the Tcl Punk Shell.
It is also a central part of an ansi (micro) virtual terminal-emulator of sorts.
This system does a half decent job at rendering 90's ANSI art to manipulable colour text blocks that
can be joined & framed for layout display within a unix or windows terminal.
Renderline helps maintain ANSI text styling reset/replay codes so that the styling of one block doesn't
affect another.
Calling on the punk::ansi library - it can coalesce codes to keep the size down.
It is a giant mess of doing exactly what common wisdom says not to do... lots at once.
Renderline is part of the Unicode and ANSI aware Overtype system which 'renders' a block of text onto a
static underlay.
The underlay is generally expected to be an ordered set of lines or a rectangular text block analogous
to a terminal screen - but it can also be ragged in line length, or just blank.
The overlay couuld be similar - in which case it may often be used to overwrite a column or section of
the underlay.
The overlay could however be a sequence of ANSI-laden text that jumps all over the place.
Renderline itself only deals with a single line - or sometimes a single character. It is generally
called from a loop that does further terminal-like or textblock processing.
By suppyling the ${$B}-info${$N} 1 option - it can return various fields indicating the state of the render.
The main 3 are: result, overflow_right, and unapplied.
Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the
aforementioned loop will need to be in place to manage the set of lines under manipulation.
}
@opts
-etabs -default 0 -type boolean
-width -default \uFFEF -type integer
-expand_right -default 0 -type boolean
-transparent -default 0 -type {literal(0)|literal(1)|regexp} -help\
"0 to disable transparency processing
1 to enable space characters in the
overlay to be transparent, or a regex
to match the character(s) required to be
transparent in the overlay."
-startcolumn -default 1 -type integer
-cursor_column -default 1 -type integer -help\
{First column is 1. Cursor column can be zero or negative}
-cursor_row -default "" -type integer
-insert_mode -default 1 -type boolean
-crm_mode -default 0 -type boolean
-autowrap_mode -default 1 -type boolean
-reverse_mode -default 0 -type boolean
-info -default 0 -type boolean -help\
"When set to 1, return a dictionary of settings useful for
processing ANSI input in a loop. When zero, the resulting
string will contain the updated line, but not all the
overtext may have been applied."
-exposed1 -default \uFFFD -help\
{A character of single terminal column width to use
as replacement when first-half of an underlying char
is exposed due to overlay positioning/transparency
which obscures the second-half of the char. May be ANSI
coloured as this doesn't affect the display width.
Default is \uFFFD - the unicode replacement char.}
-exposed2 -default \uFFFD -help\
{A character of single terminal column width to use
as replacement when second-half of an underlying char
is exposed due to overlay positioning/transparency
which obscures the first-half of the char. May be ANSI
coloured as this doesn't affect the display width.
Default is \uFFFD - the unicode replacement char.}
-cursor_restore_attributes -default ""
-cp437 -default 0 -type boolean
-experimental -default {}
-overtext_type -type string -choices {mixed plain ansisplit} -default mixed
@values -min 2 -max 2
undertext -type string -help\
"A single line of text which may contain pre-rendered ANSI.
'pre-rendered' in this context means that it may contain
various static ANSI codes such as SGR colours and attributes
but not motion-control or more complex ANSI sequences.
It is an error to supply a newline (lf) character in the
undertext."
overtext -type string -help\
"ANSI (or plain text) to overlay onto the undertext.
May contain ANSI movement codes even if they would move the
cursor to another line. If -info is zero, the output will
only display up to the point where the cursor moved off-line.
If -info is 1, the line moved to may be reflected in the
cursor_row element of the result. Overtext may contain an lf
which is effectively a form of 'movement control' to increment
the row.
Other ANSI codes may perform operations such as changing the
insert_mode or reverse_mode - and these are reflected in the
result dictionary when '-info 1' is used, so that the state
can then be applied to subsequent lines."
}]
}
proc renderline {args} {
#todo - fix 'unapplied' mechanism.This is particularly inefficient for long lines, or data such as binarytext which is not line-based.
#All unapplied data is re-split/reprocessed repeatedly for each line! This is very wasteful and slow.
# ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
# renderline written from a left-right line orientation perspective as a first-shot at getting something useful.
# ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed.
# ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
#
#
#-returnextra enables returning of overflow and length
#review - use punk::ansi::ta::detect to short-circuit processing and do simpler string calcs as an optimisation?
#review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements
#(could render it by faking it with sixels and a lot of work - find/make a sixel font and ensure it's exactly 2 cols per char?
# This would probably be impractical to support for different fonts)
#todo - review transparency issues with single/double width characters
#bidi - need a base direction and concept of directional runs for RTL vs LTR - may be best handled at another layer?
#*** !doctools
#[call [fun overtype::renderline] [arg args] ]
#[para] renderline is the core engine for overtype string processing (frames & textblocks), and the raw mode commandline repl for the Tcl Punk Shell
#[para] It is also a central part of an ansi (micro) virtual terminal-emulator of sorts
#[para] This system does a half decent job at rendering 90's ANSI art to manipulable colour text blocks that can be joined & framed for layout display within a unix or windows terminal
#[para] Renderline helps maintain ANSI text styling reset/replay codes so that the styling of one block doesn't affect another.
#[para] Calling on the punk::ansi library - it can coalesce codes to keep the size down.
#[para] It is a giant mess of doing exactly what common wisdom says not to do... lots at once.
#[para] renderline is part of the Unicode and ANSI aware Overtype system which 'renders' a block of text onto a static underlay
#[para] The underlay is generally expected to be an ordered set of lines or a rectangular text block analogous to a terminal screen - but it can also be ragged in line length, or just blank.
#[para] The overlay couuld be similar - in which case it may often be used to overwrite a column or section of the underlay.
#[para] The overlay could however be a sequence of ANSI-laden text that jumps all over the place.
#
#[para] renderline itself only deals with a single line - or sometimes a single character. It is generally called from a loop that does further terminal-like or textblock processing.
#[para] By suppyling the -info 1 option - it can return various fields indicating the state of the render.
#[para] The main 3 are the result, overflow_right, and unapplied.
#[para] Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the aforementioned loop will need to be in place to manage the set of lines under manipulation.
#puts stderr "renderline '$args'"
variable optimise_ptruns
if {[llength $args] < 2} {
error {usage: ?-info 0|1? ?-startcolumn <int>? ?-cursor_column <int>? ?-cursor_row <int>|""? ?-transparent [0|1|<regexp>]? ?-expand_right [1|0]? undertext overtext}
}
set under [lindex $args end-1]
set over [lindex $args end]
#lassign [lrange $args end-1 end] under over
if {[string last \n $under] >= 0} {
error "overtype::renderline not allowed to contain newlines in undertext"
}
#if {[string first \n $over] >=0 || [string first \n $under] >= 0} {
# error "overtype::renderline not allowed to contain newlines"
#}
#generally faster to create a new dict in the proc than to use a namespace variable to create dict once and link to variable (2024 8.6/8.7)
set opts [tcl::dict::create\
-etabs 0\
-width \uFFEF\
-expand_right 0\
-transparent 0\
-startcolumn 1\
-cursor_column 1\
-cursor_row ""\
-insert_mode 1\
-crm_mode 0\
-autowrap_mode 1\
-reverse_mode 0\
-info 0\
-exposed1 \uFFFD\
-exposed2 \uFFFD\
-cursor_restore_attributes ""\
-cp437 0\
-experimental {}\
-overtext_type mixed\
]
#-overtext_type plain|mixed|ansisplit
#-cursor_restore_attributes only - for replay stack - position and actual setting/restoring handled by throwback to caller
#cursor_row, when numeric will allow detection of certain row moves that are still within our row - allowing us to avoid an early return
#An empty string for cursor_row tells us we have no info about our own row context, and to return with an unapplied string if any row move occurs
#exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency, currsor movements to 2nd charcol, or overflow/expand_right
#todo - return info about such grapheme 'cuts' in -info structure and/or create option to raise an error
set argsflags [lrange $args 0 end-2]
tcl::dict::for {k v} $argsflags {
switch -- $k {
-experimental - -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row
- -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode
- -info - -exposed1 - -exposed2 - -cursor_restore_attributes - -overtext_type {
tcl::dict::set opts $k $v
}
default {
error "overtype::renderline unknown option '$k'. Known options: [tcl::dict::keys $opts]"
}
}
}
# -- --- --- --- --- --- --- --- --- --- --- ---
set opt_width [tcl::dict::get $opts -width]
set opt_etabs [tcl::dict::get $opts -etabs]
set opt_expand_right [tcl::dict::get $opts -expand_right]
set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay
set opt_colcursor [tcl::dict::get $opts -cursor_column];#start cursor column relative to overlay
set opt_row_context [tcl::dict::get $opts -cursor_row]
set opt_overtext_type [tcl::dict::get $opts -overtext_type]
if {[string length $opt_row_context]} {
if {![tcl::string::is integer -strict $opt_row_context] || $opt_row_context <1 } {
error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'"
}
}
# -- --- --- --- --- --- --- --- --- --- --- ---
#The _mode flags correspond to terminal modes that can be set/reset via escape sequences (e.g DECAWM wraparound mode)
set opt_insert_mode [tcl::dict::get $opts -insert_mode];#should usually be 1 for each new line in editor mode but must be initialised to 1 externally (review)
#default is for overtype
# -- --- --- --- --- --- --- --- --- --- --- ---
set opt_autowrap_mode [tcl::dict::get $opts -autowrap_mode] ;#DECAWM - char or movement can go beyond leftmost/rightmost col to prev/next line
set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] ;#DECSNM
set opt_crm_mode [tcl::dict::get $opts -crm_mode];# CRM - show control character mode
# -- --- --- --- --- --- --- --- --- --- --- ---
set temp_cursor_saved [tcl::dict::get $opts -cursor_restore_attributes]
set cp437_glyphs [tcl::dict::get $opts -cp437]
set cp437_map [tcl::dict::create]
if {$cp437_glyphs} {
set cp437_map [set ::punk::ansi::cp437_map]
#for cp437 images we need to map these *after* splitting ansi
#some old files might use newline for its glyph.. but we can't easily support that.
#Not sure how old files did it.. maybe cr lf in sequence was newline and any lone cr or lf were displayed as glyphs?
tcl::dict::unset cp437_map \n
}
set opt_transparent [tcl::dict::get $opts -transparent]
if {$opt_transparent eq "0"} {
set do_transparency 0
} else {
set do_transparency 1
if {$opt_transparent eq "1"} {
set opt_transparent {[\s]}
}
}
# -- --- --- --- --- --- --- --- --- --- --- ---
set opt_returnextra [tcl::dict::get $opts -info]
# -- --- --- --- --- --- --- --- --- --- --- ---
set opt_exposed1 [tcl::dict::get $opts -exposed1]
set opt_exposed2 [tcl::dict::get $opts -exposed2]
# -- --- --- --- --- --- --- --- --- --- --- ---
if {$opt_row_context eq ""} {
set cursor_row 1
} else {
set cursor_row $opt_row_context
}
set insert_mode $opt_insert_mode ;#default 1
set autowrap_mode $opt_autowrap_mode ;#default 1
set crm_mode $opt_crm_mode ;#default 0 (Show Control Character mode)
set reverse_mode $opt_reverse_mode
#-----
#
if {[info exists punk::console::tabwidth]} {
#punk console is updated if punk::console::set_tabstop_width is used or rep is started/restarted
#It is way too slow to test the current width by querying the terminal here - so it could conceivably get out of sync
#todo - we also need to handle the new threaded repl where console config is in a different thread.
# - also - concept of sub-regions being mini-consoles with their own settings - 'id' for console, or use in/out channels as id?
set tw $::punk::console::tabwidth
} else {
set tw 8
}
set overdata $over
if {!$cp437_glyphs} {
#REVIEW! tabify will give different answers for an ANSI colourised string vs plain text
if {!$opt_etabs} {
if {[string first \t $under] >= 0} {
#set under [textutil::tabify::untabify2 $under]
set under [textutil::tabify::untabifyLine $under $tw]
}
#review - is untabifying sensible at this point??
if {$opt_overtext_type eq "ansisplit"} {
#todo - something for each pt part?
} else {
#plain|mixed
if {[string first \t $over] >= 0} {
#set overdata [textutil::tabify::untabify2 $over]
set overdata [textutil::tabify::untabifyLine $over $tw]
}
}
}
}
#-------
#ta_detect ansi and do simpler processing?
#we repeat tests for grapheme width in different loops - rather than create another datastructure to store widths based on column,
#we'll use the grapheme_width_cached function as a lookup table of all graphemes encountered - as there will often be repeats in different positions anyway.
# -- --- --- --- --- --- --- ---
if {$under ne ""} {
if {[punk::ansi::ta::detect $under]} {
set undermap [punk::ansi::ta::split_codes_single $under]
} else {
#single plaintext part
set undermap [list $under]
}
} else {
set undermap [list]
}
set understacks [list]
set understacks_gx [list]
set pm_list [list]
set i_u -1 ;#underlay may legitimately be empty
set undercols [list]
set u_codestack [list]
#-------------
#u_gx_stack probably isn't really a stack - I don't know if g0 g1 can stack or not - for now we support only g0 anyway
set u_gx_stack [list] ;#separate stack for g0 (g1 g2 g3?) graphics on and off (DEC special graphics)
#
#-------------
#set pt_underchars "" ;#for string_columns length calculation for expand_right 0 truncation
set remainder [list] ;#for returnextra
foreach {pt code} $undermap {
#pt = plain text
#append pt_underchars $pt
if {$pt ne ""} {
if {$cp437_glyphs} {
set pt [tcl::string::map $cp437_map $pt]
}
set is_ptrun 0
if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} {
set p1 [tcl::string::index $pt 0]
set hex [format %x [scan $p1 %c]] ;#punk::char::char_hex
set re [tcl::string::cat {^[} \\U$hex {]+$}]
set is_ptrun [regexp $re $pt]
}
if {$is_ptrun} {
set width [grapheme_width_cached $p1] ;# when zero???
set ptlen [string length $pt]
#puts -nonewline stderr !$ptlen!
if {$width <= 1} {
#review - 0 and 1?
incr i_u $ptlen
lappend understacks {*}[lrepeat $ptlen $u_codestack]
#we need to store the gx0 state per column - as characters with or without gx0 can be overlayed anywhere
lappend understacks_gx {*}[lrepeat $ptlen $u_gx_stack]
lappend undercols {*}[lrepeat $ptlen $p1]
} else {
incr i_u $ptlen ;#2nd col empty str - so same as above
set 2ptlen [expr {$ptlen * 2}]
lappend understacks {*}[lrepeat $2ptlen $u_codestack]
lappend understacks_gx {*}[lrepeat $2ptlen $u_gx_stack]
set l [concat {*}[lrepeat $ptlen [list $p1 ""]]]
lappend undercols {*}$l
unset l
}
} else {
foreach grapheme [punk::char::grapheme_split $pt] {
#an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty.
#.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together.
#todo - test decimal value instead, compare performance
switch -- $grapheme {
" " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? -
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 - 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 - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 {
set width 1
}
default {
if {$grapheme eq "\u0000"} {
#use null as empty cell representation - review
#use of this will probably collide with some application at some point
#consider an option to set the empty cell character
set width 1
} else {
#zero width still acts as 1 below??? review what should happen
set width [grapheme_width_cached $grapheme]
#we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length
#we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI
#todo - default to off and add a flag (?) to enable this substitution
set sub_stray_escapes 0
if {$sub_stray_escapes && $width == 0} {
if {$grapheme eq "\x1b"} {
set gvis [ansistring VIEW $grapheme] ;#can only use with graphemes that have a single replacement char..
set grapheme $gvis
set width 1
}
}
}
}
}
#set width [grapheme_width_cached $grapheme]
incr i_u
lappend understacks $u_codestack
lappend understacks_gx $u_gx_stack
lappend undercols $grapheme
if {$width > 1} {
#presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?)
#but what about emoji combinations etc - can they be wider than 2?
#todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop
incr i_u
lappend understacks $u_codestack
lappend understacks_gx $u_gx_stack
lappend undercols ""
}
}
}
}
#underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here
#only stack SGR (graphics rendition) codes - not title sets, cursor moves etc
#keep any remaining PMs in place
if {$code ne ""} {
set c1c2 [tcl::string::range $code 0 1]
set leadernorm [tcl::string::range [tcl::string::map [list\
\x1b\[ 7CSI\
\x9b 8CSI\
\x1b\( 7GFX\
\x1b^ 7PMX\
\x1bX 7SOS\
] $c1c2] 0 3];# leadernorm is 1st 2 chars mapped to normalised indicator - or is original 2 chars
switch -- $leadernorm {
7CSI - 8CSI {
#need to exclude certain leaders after the lb e.g < for SGR 1006 mouse
#REVIEW - what else could end in m but be mistaken as a normal SGR code here?
set maybemouse ""
if {[tcl::string::index $c1c2 0] eq "\x1b"} {
set maybemouse [tcl::string::index $code 2]
}
if {$maybemouse ne "<" && [tcl::string::index $code end] eq "m"} {
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set u_codestack [list "\x1b\[m"]
} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
set u_codestack [list $code]
} else {
#basic simplification first.. straight dups
set dup_posns [lsearch -all -exact $u_codestack $code] ;#-exact because of square-bracket glob chars
set u_codestack [lremove $u_codestack {*}$dup_posns]
lappend u_codestack $code
}
}
}
7GFX {
switch -- [tcl::string::index $code 2] {
"0" {
set u_gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess
}
B {
set u_gx_stack [list]
}
}
}
7PMX - 7SOS {
#we can have PMs or SOS (start of string) in the underlay - though mostly the PMs should have been processed..
#attach the PM/SOS (entire ANSI sequence) to the previous grapheme!
#It should not affect the size - but terminal display may get thrown out if terminal doesn't support them.
#note that there may in theory already be ANSI stored - we don't assume it was a pure grapheme string
set graphemeplus [lindex $undercols end]
if {$graphemeplus ne "\0"} {
append graphemeplus $code
} else {
set graphemeplus $code
}
lset undercols end $graphemeplus
#The grapheme_width_cached function will be called on this later - and doesn't account for ansi.
#we need to manually cache the item with it's proper width
variable grapheme_widths
#stripped and plus version keys pointing to same length
dict set grapheme_widths $graphemeplus [grapheme_width_cached [::punk::ansi::ansistrip $graphemeplus]]
}
default {
}
}
#if {[punk::ansi::codetype::is_sgr_reset $code]} {
# #set u_codestack [list]
#} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
#} elseif {[punk::ansi::codetype::is_sgr $code]} {
#} else {
# #leave SGR stack as is
# if {[punk::ansi::codetype::is_gx_open $code]} {
# } elseif {[punk::ansi::codetype::is_gx_close $code]} {
# }
#}
}
#consider also if there are other codes that should be stacked..?
}
#NULL empty cell indicator
if {$opt_width ne "\uFFEF"} {
if {[llength $understacks]} {
set cs $u_codestack
set gs $u_gx_stack
} else {
set cs [list]
set gs [list]
}
if {[llength $undercols]< $opt_width} {
set diff [expr {$opt_width- [llength $undercols]}]
if {$diff > 0} {
#set undercols [list {*}$undercols {*}[lrepeat $diff "\u0000"]] ;#2024 - much slower
lappend undercols {*}[lrepeat $diff "\u0000"]
lappend understacks {*}[lrepeat $diff $cs]
lappend understacks_gx {*}[lrepeat $diff $gs]
}
}
}
if {$opt_width ne "\uFFEF"} {
set renderwidth $opt_width
} else {
set renderwidth [llength $undercols]
}
#trailing codes in effect for underlay
if {[llength $u_codestack]} {
#set replay_codes_underlay [join $u_codestack ""]
set replay_codes_underlay [punk::ansi::codetype::sgr_merge_list {*}$u_codestack]
} else {
set replay_codes_underlay ""
}
# -- --- --- --- --- --- --- ---
####
#if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left containing the right number of columns.
#this will be processed as transparent - and handle doublewidth underlay characters appropriately
set startpadding [string repeat " " [expr {$opt_colstart -1}]]
#overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency
if {$startpadding ne "" || $overdata ne ""} {
if {$opt_overtext_type eq "ansisplit"} {
set overmap $overdata
lset overmap 0 "$startpadding[lindex $overmap 0]"
} else {
if {[punk::ansi::ta::detect $overdata]} {
#TODO!! rework this.
#e.g 200K+ input file with no newlines - we are wastefully calling split_codes_single repeatedly on mostly the same data.
#set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata]
set overmap [punk::ansi::ta::split_codes_single $overdata]
lset overmap 0 "$startpadding[lindex $overmap 0]"
} else {
#single plaintext part
set overmap [list $startpadding$overdata]
}
}
} else {
set overmap [list]
}
####
#todo - detect plain ascii no-ansi input line (aside from leading ansi reset)
#will that allow some optimisations?
#todo - detect repeated transparent char in overlay
#regexp {^(.)\1+$} ;#backtracking regexp - relatively slow.
# - try set c [string index $data 0]; regexp [string map [list %c% $c] {^[%c%]+$}] $data
#we should be able to optimize to pass through the underlay??
#???
set colcursor $opt_colstart
#TODO - make a little virtual column object
#we need to refer to column1 or columnmin? or columnmax without calculating offsets due to to startcolumn
#need to lock-down what start column means from perspective of ANSI codes moving around - the offset perspective is unclear and a mess.
#set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+}
#as at 2024-02 punk::char::grapheme_split uses these - not aware of more complex graphemes
set overstacks [list]
set overstacks_gx [list]
set o_codestack [list]; #SGR codestack (not other codes such as movement,insert key etc)
set o_gxstack [list]
set pt_overchars ""
set i_o 0
set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use
set overlay_grapheme_control_stacks [list]
#REVIEW - even if we pass in a pre-split overtext (-overtext_type ansisplit)
#we are re-generating the overlay_grapheme_control_stacks list each time
#this is a big issue when overtext is not broken into lines, but is just a big long ansi and/or plain text string.
#todo - return also the unapplied portion of the overlay_grapheme_control_stacks list??
foreach {pt code} $overmap {
if {$pt ne ""} {
#todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between)
if {$cp437_glyphs} {
set pt [tcl::string::map $cp437_map $pt]
}
append pt_overchars $pt
#will get empty pt between adjacent codes
if {!$crm_mode} {
set is_ptrun 0
if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} {
set p1 [tcl::string::index $pt 0]
set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+$}]
set is_ptrun [regexp $re $pt]
#leading only? we would have to check for graphemes at the trailing boundary?
#set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+}]
#set is_ptrun [regexp -indices $re $pt runrange]
#if {$is_ptrun && 1} {
#}
}
if {$is_ptrun} {
#review - in theory a run over a certain length won't be part of some grapheme combo (graphemes can be long e.g 44?, but not as runs(?))
#could be edge cases for runs at line end? (should be ok as we include trailing \n in our data)
set len [string length $pt]
set g_element [list g $p1]
#puts -nonewline stderr "!$len!"
#lappend overstacks {*}[lrepeat $len $o_codestack]
#lappend overstacks_gx {*}[lrepeat $len $o_gxstack]
#incr i_o $len
#lappend overlay_grapheme_control_list {*}[lrepeat $len [list g $p1]]
#lappend overlay_grapheme_control_stacks {*}[lrepeat $len $o_codestack]
set pi 0
incr i_o $len
while {$pi < $len} {
lappend overstacks $o_codestack
lappend overstacks_gx $o_gxstack
lappend overlay_grapheme_control_list $g_element
lappend overlay_grapheme_control_stacks $o_codestack
incr pi
}
} else {
foreach grapheme [punk::char::grapheme_split $pt] {
lappend overstacks $o_codestack
lappend overstacks_gx $o_gxstack
incr i_o
lappend overlay_grapheme_control_list [list g $grapheme]
lappend overlay_grapheme_control_stacks $o_codestack
}
}
} else {
set tsbegin [clock micros]
foreach grapheme_original [punk::char::grapheme_split $pt] {
set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original]
#puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm"
foreach grapheme [punk::char::grapheme_split $pt_crm] {
if {$grapheme eq "\n"} {
lappend overlay_grapheme_control_stacks $o_codestack
lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"]
} else {
lappend overstacks $o_codestack
lappend overstacks_gx $o_gxstack
incr i_o
lappend overlay_grapheme_control_list [list g $grapheme]
lappend overlay_grapheme_control_stacks $o_codestack
}
}
}
set elapsed [expr {[clock micros] - $tsbegin}]
puts stderr "ptlen [string length $pt] elapsedus:$elapsed"
}
}
#only stack SGR (graphics rendition) codes - not title sets, cursor moves etc
#order of if-else based on assumptions:
# that pure resets are fairly common - more so than leading resets with other info
# that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all.
if {$code ne ""} {
#we need to immediately set crm_mode here if \x1b\[3h received
if {$code eq "\x1b\[3h"} {
set crm_mode 1
} elseif {$code eq "\x1b\[3l"} {
set crm_mode 0
}
#else crm_mode could be set either way from options
if {$crm_mode && $code ne "\x1b\[00001E"} {
#treat the code as type 'g' like above - only allow through codes to reset mode REVIEW for now just \x1b\[3l ?
#we need to somehow convert further \n in the graphical rep to an instruction for newline that will bypass further crm_mode processing or we would loop.
set code_as_pt [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $code]
#split using standard split for first foreach loop - grapheme based split when processing 2nd foreach loop
set chars [split $code_as_pt ""]
set codeparts [list] ;#list of 2-el lists each element {crmcontrol <ansi>} or {g <text>}
foreach c $chars {
if {$c eq "\n"} {
#use CNL (cursor next line) \x1b\[00001E ;#leading zeroes ok for this processor - used as debugging aid to distinguish
lappend codeparts [list crmcontrol "\x1b\[00001E"]
} else {
if {[llength $codeparts] > 0 && [lindex $codeparts end 0] eq "g"} {
set existing [lindex $codeparts end 1]
lset codeparts end [list g [string cat $existing $c]]
} else {
lappend codeparts [list g $c]
}
}
}
set partidx 0
foreach record $codeparts {
lassign $record rtype rval
switch -exact -- $rtype {
g {
append pt_overchars $rval
foreach grapheme [punk::char::grapheme_split $rval] {
lappend overstacks $o_codestack
lappend overstacks_gx $o_gxstack
incr i_o
lappend overlay_grapheme_control_list [list g $grapheme]
lappend overlay_grapheme_control_stacks $o_codestack
}
}
crmcontrol {
#leave o_codestack
lappend overlay_grapheme_control_stacks $o_codestack
lappend overlay_grapheme_control_list [list crmcontrol $rval]
}
}
}
} else {
lappend overlay_grapheme_control_stacks $o_codestack
#there will always be an empty code at end due to foreach on 2 vars with odd-sized list ending with pt (overmap coming from perlish split)
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set o_codestack [list "\x1b\[m"] ;#reset better than empty list - fixes some ansi art issues
lappend overlay_grapheme_control_list [list sgr $code]
} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
set o_codestack [list $code]
lappend overlay_grapheme_control_list [list sgr $code]
} elseif {[priv::is_sgr $code]} {
#basic simplification first - remove straight dupes
set dup_posns [lsearch -all -exact $o_codestack $code] ;#must be -exact because of square-bracket glob chars
set o_codestack [lremove $o_codestack {*}$dup_posns]
lappend o_codestack $code
lappend overlay_grapheme_control_list [list sgr $code]
} elseif {[regexp {\x1b\[[0-1];[0-9][0-9]?[0-9]?;[0-9][0-9]?[0-9]?;[0-9][0-9]?[0-9]?t} $code]} {
#pablodraw 24bit color - convert to standard sgr RGB code
#we could do a more precise 000-255 regexp for each r g b, something like: ((?:[0-1]?[0-9]?[0-9])|(?:2[0-4][0-9])|(?:25[0-5]))
#but that seems more expensive for little likely use (?) review
lassign [regexp -all -inline {\x1b\[([0-1]);([0-9][0-9]?[0-9]?);([0-9][0-9]?[0-9]?);([0-9][0-9]?[0-9]?)t} $code] _ isfg pablo_r pablo_g pablo_b
#todo - if any r g b value > 255 - add as [list other $code]
if {$isfg} {
set rgbcode "\x1b\[38\;2\;$pablo_r\;$pablo_g\;${pablo_b}m"
} else {
set rgbcode "\x1b\[48\;2\;$pablo_r\;$pablo_g\;${pablo_b}m"
}
set dup_posns [lsearch -all -exact $o_codestack $rgbcode] ;#must be -exact because of square-bracket glob chars
set o_codestack [lremove $o_codestack {*}$dup_posns]
lappend o_codestack $rgbcode
lappend overlay_grapheme_control_list [list sgr $rgbcode]
} elseif {[regexp {\x1b7|\x1b\[s} $code]} {
#experiment
#cursor_save - for the replays review.
#jmn
#set temp_cursor_saved [punk::ansi::codetype::sgr_merge_list {*}$o_codestack]
lappend overlay_grapheme_control_list [list other $code]
} elseif {[regexp {\x1b8|\x1b\[u} $code]} {
#experiment
#cursor_restore - for the replays
set o_codestack [list $temp_cursor_saved]
lappend overlay_grapheme_control_list [list other $code]
} else {
#review - gx0 should just be a flag like autowrap_mode and insert_mode?
if {[punk::ansi::codetype::is_gx_open $code]} {
set o_gxstack [list "gx0_on"]
lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets
} elseif {[punk::ansi::codetype::is_gx_close $code]} {
set o_gxstack [list]
lappend overlay_grapheme_control_list [list gx0 gx0_off] ;#don't store code - will complicate debugging if we spit it out and jump character sets
} else {
lappend overlay_grapheme_control_list [list other $code]
}
}
}
}
}
#replay code for last overlay position in input line - should take account of possible trailing sgr code after last grapheme
set max_overlay_grapheme_index [expr {$i_o -1}]
lappend overstacks $o_codestack
lappend overstacks_gx $o_gxstack
#set replay_codes_overlay [join $o_codestack ""]
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}$o_codestack]
#if {[tcl::dict::exists $overstacks $max_overlay_grapheme_index]} {
# set replay_codes_overlay [join [tcl::dict::get $overstacks $max_overlay_grapheme_index] ""]
#} else {
# set replay_codes_overlay ""
#}
# -- --- --- --- --- --- --- ---
#potential problem - combinining diacritics directly following control chars like \r \b
# -- --- ---
#we need to initialise overflow_idx before any potential row-movements - as they need to perform a loop break and force in_excess to 1
if {$opt_expand_right} {
#expand_right true means we can have lines as long as we want, but either way there can be excess data that needs to be thrown back to the calling loop.
#we currently only support horizontal expansion to the right (review regarding RTL text!)
set overflow_idx -1
} else {
#expand_right zero - we can't grow beyond our column width - so we get ellipsis or truncation
if {$opt_width ne "\uFFEF"} {
set overflow_idx [expr {$opt_width}]
} else {
#review - this is also the cursor position when adding a char at end of line?
set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it
}
}
# -- --- ---
set outcols $undercols ;#leave undercols as is, outcols can potentially be appended to.
set unapplied "" ;#if we break for move row (but not for /v ?)
set unapplied_list [list]
set unapplied_ansisplit [list ""] ;#pt code ... pt
set insert_lines_above 0 ;#return key
set insert_lines_below 0
set instruction ""
# -- --- ---
#cursor_save_dec, cursor_restore_dec etc
set cursor_restore_required 0
set cursor_saved_attributes ""
set cursor_saved_position ""
# -- --- ---
#set idx 0 ;# line index (cursor - 1)
#set idx [expr {$opt_colstart + $opt_colcursor} -1]
#idx is the per column output index
set idx [expr {$opt_colcursor -1}] ;#don't use opt_colstart here - we have padded and won't start emitting until idx reaches opt_colstart-1
#cursor_column is usually one above idx - but we have opt_colstart which is like a margin - todo: remove cursor_column from the following loop and calculate it's offset when breaking or at end.
#(for now we are incrementing/decrementing both in sync - which is a bit silly)
set cursor_column $opt_colcursor
#idx_over is the per grapheme overlay index
set idx_over -1
#movements only occur within the overlay range.
#an underlay is however not necessary.. e.g
#renderline -expand_right 1 "" data
#set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM
#set re_col_move {\x1b\[([0-9]*)(C|D|G)$}
#set re_row_move {\x1b\[([0-9]*)(A|B)$}
#set re_both_move {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)H$} ;# or "f" ?
#set re_vt_sequence {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)~$}
#set re_cursor_save {\x1b\[s$} ;#note probable incompatibility with DECSLRM (set left right margin)!
#set re_cursor_restore {\x1b\[u$}
#set re_cursor_save_dec {\x1b7$}
#set re_cursor_restore_dec {\x1b8$}
#set re_other_single {\x1b(D|M|E)$}
#set re_decstbm {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)r$} ;#DECSTBM set top and bottom margins
#puts "-->$overlay_grapheme_control_list<--"
#puts "-->overflow_idx: $overflow_idx"
for {set gci 0} {$gci < [llength $overlay_grapheme_control_list]} {incr gci} {
set gc [lindex $overlay_grapheme_control_list $gci]
lassign $gc type item
#emit plaintext chars first using existing SGR codes from under/over stack as appropriate
#then check if the following code is a cursor movement within the line and adjust index if so
#foreach ch $overlay_graphemes {}
switch -- $type {
g {
set ch $item
#crm_mode affects both graphic and control
if {0 && $crm_mode} {
set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $ch]
set chars [string map [list \n "\x1b\[00001E"] $chars]
if {[llength [split $chars ""]] > 1} {
priv::render_to_unapplied $overlay_grapheme_control_list $gci
#prefix the unapplied controls with the string version of this control
#set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]]
#JMN - backwards compat ledit from punk::lib for tcl <9
ledit unapplied_list -1 -1 {*}[split $chars ""]
set unapplied [join $unapplied_list ""]
lset unapplied_ansisplit 0 $chars ;#no existing ?
#incr idx_over
break
} else {
set ch $chars
}
}
incr idx_over; #idx_over (until unapplied reached anyway) is per *grapheme* in the overlay - not per col.
if {($idx < ($opt_colstart -1))} {
incr idx [grapheme_width_cached $ch]
continue
}
#set within_undercols [expr {$idx <= [llength $undercols]-1}] ;#within our active data width
set within_undercols [expr {$idx <= $renderwidth-1}]
#https://www.enigma.com/resources/blog/the-secret-world-of-newline-characters
#\x85 NEL in the c1 control set is treated by some terminal emulators (e.g Hyper) as a newline,
#on some it's invisble but doesn't change the line, on some it's a visible glyph of width 1.
#This is hard to process in any standard manner - but I think the Hyper behaviour of doing what it was intended is perhaps most reasonable
#We will map it to the same behaviour as lf here for now... but we need also to consider the equivalent ANSI sequence: \x1bE
set chtest [tcl::string::map [list \n <lf> \x85 <lf> \b <bs> \r <cr> \v <vt> \x7f <del>] $ch]
#puts --->chtest:$chtest
#specials - each shoud have it's own test of what to do if it happens after overflow_idx reached
switch -- $chtest {
"<lf>" {
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
if {$idx == 0} {
#puts "---a <lf> at col 1"
#linefeed at column 1
#leave the overflow_idx ;#? review
set instruction lf_start ;#specific instruction for newline at column 1
priv::render_to_unapplied $overlay_grapheme_control_list $gci
break
} elseif {$overflow_idx != -1 && $idx == $overflow_idx} {
#linefeed after final column
#puts "---c <lf> at overflow_idx=$overflow_idx"
incr cursor_row
set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1
set instruction lf_overflow ;#only special treatment is to give it it's own instruction in case caller needs to handle differently
priv::render_to_unapplied $overlay_grapheme_control_list $gci
break
} else {
#linefeed occurred in middle or at end of text
#puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx"
if {$insert_mode == 0} {
incr cursor_row
if {$idx == -1 || $overflow_idx > $idx} {
#don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow
set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1
}
set instruction lf_mid
priv::render_to_unapplied $overlay_grapheme_control_list $gci
break
} else {
incr cursor_row
#don't adjust the overflow_idx
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction lf_mid
break ;# could have overdata following the \n - don't keep processing
}
}
}
"<cr>" {
#will we want/need to use raw <cr> for keypresses in terminal? (terminal with LNM in standard reset mode means enter=<cr> this is the usual config for terminals)
#So far we are assuming the caller has translated to <lf> and handle above.. REVIEW.
#consider also the old space-carriagereturn softwrap convention used in some terminals.
#In the context of rendering to a block of text - this works similarly in that the space gets eaten so programs emitting space-cr at the terminal width col will pretty much get what they expect.
set idx [expr {$opt_colstart -1}]
set cursor_column $opt_colstart ;#?
}
"<bs>" {
#literal backspace char - not necessarily from keyboard
#review - backspace effect on double-width chars - we are taking a column-editing perspective in overtype
#(important for -transparent option - hence replacement chars for half-exposed etc)
#review - overstrike support as per nroff/less (generally considered an old technology replaced by unicode mechanisms and/or ansi SGR)
if {$idx > ($opt_colstart -1)} {
incr idx -1
incr cursor_column -1
} else {
set flag 0
if $flag {
#review - conflicting requirements? Need a different sequence for destructive interactive backspace?
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction backspace_at_start
break
}
}
}
"<del>" {
#literal del character - some terminals send just this for what is generally expected to be a destructive backspace
#We instead treat this as a pure delete at current cursor position - it is up to the repl or terminal to remap backspace key to a sequence that has the desired effect.
priv::render_delchar $idx
}
"<vt>" {
#end processing this overline. rest of line is remainder. cursor for column as is.
#REVIEW - this theoretically depends on terminal's vertical tabulation setting (name?)
#e.g it could be configured to jump down 6 rows.
#On the other hand I've seen indications that some modern terminal emulators treat it pretty much as a linefeed.
#todo?
incr cursor_row
set overflow_idx $idx
#idx_over has already been incremented as this is both a movement-control and in some sense a grapheme
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction vt
break
}
default {
if {$overflow_idx != -1} {
#review - how to check arbitrary length item such as tab is going to overflow .. before we get to overflow_idx?
#call grapheme_width_cached on each ch, or look for tab specifically as it's currently the only known reason to have a grapheme width > 2?
#we need to decide what a tab spanning the overflow_idx means and how it affects wrap etc etc
if {$idx == $overflow_idx-1} {
set owidth [grapheme_width_cached $ch]
if {$owidth == 2} {
#review split 2w overflow?
#we don't want to make the decision here to split a 2w into replacement characters at end of line and beginning of next line
#better to consider the overlay char as unable to be applied to the line
#render empty column(?) - and reduce overlay grapheme index by one so that the current ch goes into unapplied
#throwing back to caller with instruction complicates its job - but is necessary to avoid making decsions for it here.
priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode
#change the overflow_idx
set overflow_idx $idx
incr idx
incr idx_over -1 ;#set overlay grapheme index back one so that sgr stack from previous overlay grapheme used
priv::render_to_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#note $gci-1 instead of just gci
#throw back to caller's loop - add instruction to caller as this is not the usual case
#caller may for example choose to render a single replacement char to this line and omit the grapheme, or wrap it to the next line
set instruction overflow_splitchar
break
} elseif {$owidth > 2} {
#? tab?
#TODO!
puts stderr "overtype::renderline long overtext grapheme '[ansistring VIEW -lf 1 -vt 1 $ch]' not handled"
#tab of some length dependent on tabstops/elastic tabstop settings?
}
} elseif {$idx >= $overflow_idx} {
#REVIEW
set next_gc [lindex $overlay_grapheme_control_list $gci+1] ;#next grapheme or control
lassign $next_gc next_type next_item
if {$autowrap_mode} {
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci-1]]
#set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
#don't incr idx beyond the overflow_idx
#idx_over already incremented - decrement so current overlay grapheme stacks go to unapplied
incr idx_over -1
#priv::render_to_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#back one index here too
priv::render_this_unapplied $overlay_grapheme_control_list $gci ;#
set instruction overflow
break
} elseif {0 && $next_type ne "g"} {
incr idx_over -1
priv::render_this_unapplied $overlay_grapheme_control_list $gci ;#
set instruction overflow
break
} else {
#no point throwing back to caller for each grapheme that is overflowing
#without this branch - renderline would be called with overtext reducing only by one grapheme per call
#processing a potentially long overtext each time (ie - very slow)
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
#JMN4
}
}
} else {
#review.
#overflow_idx = -1
#This corresponds to expand_right being true (at least until overflow_idx is in some cases forced to a value when throwing back to calling loop)
}
if {($do_transparency && [regexp $opt_transparent $ch])} {
#pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay)
if {$idx > [llength $outcols]-1} {
lappend outcols " "
#tcl::dict::set understacks $idx [list] ;#review - use idx-1 codestack?
#lset understacks $idx [list] ;#will get index $i out of range error
lappend understacks [list] ;#REVIEW
incr idx
incr cursor_column
} else {
#todo - punk::char::char_width
set g [lindex $outcols $idx]
#JMN
set uwidth [grapheme_width_cached $g]
if {[lindex $outcols $idx] eq ""} {
#2nd col of 2-wide char in underlay
incr idx
incr cursor_column
} elseif {$uwidth == 0} {
#e.g control char ? combining diacritic ?
incr idx
incr cursor_column
} elseif {$uwidth == 1} {
set owidth [grapheme_width_cached $ch]
incr idx
incr cursor_column
if {$owidth > 1} {
incr idx
incr cursor_column
}
} elseif {$uwidth > 1} {
if {[grapheme_width_cached $ch] == 1} {
if {!$insert_mode} {
#normal singlewide transparent overlay onto double-wide underlay
set next_pt_overchar [tcl::string::index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay
if {$next_pt_overchar eq ""} {
#special-case trailing transparent - no next_pt_overchar
incr idx
incr cursor_column
} else {
if {[regexp $opt_transparent $next_pt_overchar]} {
incr idx
incr cursor_column
} else {
#next overlay char is not transparent.. first-half of underlying 2wide char is exposed
#priv::render_addchar $idx $opt_exposed1 [tcl::dict::get $overstacks $idx_over] [tcl::dict::get $overstacks_gx $idx_over] $insert_mode
priv::render_addchar $idx $opt_exposed1 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode
incr idx
incr cursor_column
}
}
} else {
#? todo - decide what transparency even means for insert mode
incr idx
incr cursor_column
}
} else {
#2wide transparency over 2wide in underlay - review
incr idx
incr cursor_column
}
}
}
} else {
set idxchar [lindex $outcols $idx]
#non-transparent char in overlay or empty cell
if {$idxchar eq "\u0000"} {
#empty/erased cell indicator
set uwidth 1
} else {
set uwidth [grapheme_width_cached $idxchar]
}
if {$within_undercols} {
if {$idxchar eq ""} {
#2nd col of 2wide char in underlay
if {!$insert_mode} {
priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0
#JMN - this has to expose if our startposn chopped an underlay - but not if we already overwrote the first half of the widechar underlay grapheme
#e.g renderline \uFF21\uFF21--- a\uFF23\uFF23
#vs
# renderline -startcolumn 2 \uFF21---- \uFF23
if {[lindex $outcols $idx-1] != ""} {
#verified it's an empty following a filled - so it's a legit underlay remnant (REVIEW - when would it not be??)
#reset previous to an exposed 1st-half - but leave understacks code as is
priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0
}
incr idx
} else {
set prevcolinfo [lindex $outcols $idx-1]
#for insert mode - first replace the empty 2ndhalf char with exposed2 before shifting it right
#REVIEW - this leaves a replacement character permanently in our columns.. but it is consistent regarding length (?)
#The alternative is to disallow insertion at a column cursor that is at 2nd half of 2wide char
#perhaps by inserting after the char - this may be worthwhile - but may cause other surprises
#It is perhaps best avoided at another level and try to make renderline do exactly as it's told
#the advantage of this 2w splitting method is that the inserted character ends up in exactly the column we expect.
priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 ;#replace not insert
priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 1 ;#insert - same index
if {$prevcolinfo ne ""} {
#we've split the 2wide - it may already have been rendered as an exposed1 - but not for example if our startcolumn was current idx
priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 ;#replace not insert
} ;# else??
incr idx
}
if {$cursor_column < [llength $outcols] || $overflow_idx == -1} {
incr cursor_column
}
} elseif {$uwidth == 0} {
#what if this is some other c0/c1 control we haven't handled specifically?
#by emitting a preceding empty-string column - we associate whatever this char is with the preceeding non-zero-length character and any existing zero-lengths that follow it
#e.g combining diacritic - increment before over char REVIEW
#arguably the previous overchar should have done this - ie lookahead for combiners?
#if we can get a proper grapheme_split function - this should be easier to tidy up.
priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode
incr idx
priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode
incr idx
incr cursor_column 2
if {$cursor_column > [llength $outcols] && $overflow_idx != -1} {
set cursor_column [llength $outcols]
}
} elseif {$uwidth == 1} {
#includes null empty cells
set owidth [grapheme_width_cached $ch]
if {$owidth == 1} {
priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode
incr idx
} else {
priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode
incr idx
priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode
#if next column in underlay empty - we've overwritten first half of underlying 2wide grapheme
#replace with rhs exposure in case there are no more overlay graphemes coming - use underlay's stack
if {([llength $outcols] >= $idx +2) && [lindex $outcols $idx+1] eq ""} {
priv::render_addchar [expr {$idx+1}] $opt_exposed2 [lindex $understacks $idx+1] [lindex $understacks_gx $idx+1] $insert_mode
}
incr idx
}
if {($cursor_column < [llength $outcols]) || $overflow_idx == -1} {
incr cursor_column
}
} elseif {$uwidth > 1} {
set owidth [grapheme_width_cached $ch]
if {$owidth == 1} {
#1wide over 2wide in underlay
if {!$insert_mode} {
priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode
incr idx
incr cursor_column
priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode
#don't incr idx - we are just putting a broken-indication in the underlay - which may get overwritten by next overlay char
} else {
#insert mode just pushes all to right - no exposition char here
priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode
incr idx
incr cursor_column
}
} else {
#2wide over 2wide
priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode
incr idx 2
incr cursor_column 2
}
if {$cursor_column > [llength $outcols] && $overflow_idx != -1} {
set cursor_column [llength $outcols]
}
}
} else {
priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode
incr idx
incr cursor_column
}
}
}
} ;# end switch
}
other - crmcontrol {
if {$crm_mode && $type ne "crmcontrol" && $item ne "\x1b\[00001E"} {
if {$item eq "\x1b\[3l"} {
set crm_mode 0
} else {
#When our initial overlay split was done - we weren't in crm_mode - so there are codes that weren't mapped to unicode control character representations
#set within_undercols [expr {$idx <= $renderwidth-1}]
#set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $item]
set chars [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $item]
priv::render_to_unapplied $overlay_grapheme_control_list $gci
#prefix the unapplied controls with the string version of this control
#set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]]
#JMN
ledit unapplied_list -1 -1 {*}[split $chars ""]
set unapplied [join $unapplied_list ""]
#ledit unapplied_ansisplit -1 -1 $chars
lset unapplied_ansisplit 0 $chars ;#??
break
}
}
#todo - consider CSI s DECSLRM vs ansi.sys \x1b\[s - we need \x1b\[s for oldschool ansi art - but may have to enable only for that.
#we should possibly therefore reverse this mapping so that x1b7 x1b8 are the primary codes for save/restore?
set code [tcl::string::map [list \x1b7 \x1b\[s \x1b8 \x1b\[u ] $item]
#since this element isn't a grapheme - advance idx_over to next grapheme overlay when about to fill 'unapplied'
#remap of DEC cursor_save/cursor_restore from ESC sequence to equivalent CSI
#probably not ideal - consider putting cursor_save/cursor_restore in functions so they can be called from the appropriate switch branch instead of using this mapping
#review - cost/benefit of function calls within these switch-arms instead of inline code?
set c1 [tcl::string::index $code 0]
set c1c2c3 [tcl::string::range $code 0 2]
#set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)}
#tcl 8.7 - faster to use inline list than to store it in a local var outside of loop.
#(somewhat surprising)
set leadernorm [tcl::string::range [tcl::string::map [list\
\x1b\[< 1006\
\x1b\[ 7CSI\
\x1bY 7MAP\
\x1bP 7DCS\
\x90 8DCS\
\x9b 8CSI\
\x1b\] 7OSC\
\x9d 8OSC\
\x1b 7ESC\
] $c1c2c3] 0 3] ;#leadernorm is 1st 1,2 or 3 chars mapped to 4char normalised indicator - or is original first chars (1,2 or 3 len)
#we leave the tail of the code unmapped for now
switch -- $leadernorm {
1006 {
#https://invisible-island.net/xterm/ctlseqs/ctlseqs.html
#SGR (1006) CSI < followed by colon separated encoded-button-value,px,py ordinates and final M for button press m for button release
set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 3 end]]
}
7CSI - 7OSC {
#set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]]
set codenorm $leadernorm[tcl::string::range $code 2 end]
}
7DCS {
#ESC P
#e.g sixel
#Device Control String https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h4-Controls-beginning-with-ESC:ESC-F.C74
set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]]
}
8DCS {
#e.g sixel
#8-bit Device Control String
set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]]
}
7MAP {
#map to another type of code to share implementation branch
set codenorm $leadernorm[tcl::string::range $code 1 end]
}
7ESC {
#set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]]
set codenorm $leadernorm[tcl::string::range $code 1 end]
}
8CSI - 8OSC {
set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]]
}
default {
#JMN
puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. leadernorm: [ansistring VIEW -lf 1 $leadernorm] code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
puts stderr "ARGS:"
foreach a $args {
puts stderr " $a"
}
puts stderr -----
foreach {xpt ycode} $overmap {
puts stderr "t:'$xpt'"
puts stderr "c:[ansistring VIEW $ycode]"
}
#we haven't made a mapping for this
#could in theory be 1,2 or 3 in len
#although we shouldn't be getting here if the regexp for ansi codes is kept in sync with our switch branches
set codenorm $code
}
}
switch -- $leadernorm {
7MAP {
switch -- [lindex $codenorm 4] {
Y {
#vt52 movement. we expect 2 chars representing position (limited range)
set params [tcl::string::range $codenorm 5 end]
if {[tcl::string::length $params] != 2} {
#shouldn't really get here or need this branch if ansi splitting was done correctly
puts stderr "overtype::renderline ESC Y recognised as vt52 move, but incorrect parameters length ([string length $params] vs expected 2) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]"
}
set line [tcl::string::index $params 5]
set column [tcl::string::index $params 1]
set r [expr {[scan $line %c] -31}]
set c [expr {[scan $column %c] -31}]
#MAP to:
#CSI n;m H - CUP - Cursor Position
set leadernorm 7CSI
set codenorm "$leadernorm${r}\;${c}H"
}
}
}
}
#we've mapped 7 and 8bit escapes to values we can handle as literals in switch statements to take advantange of jump tables.
switch -- $leadernorm {
1006 {
#TODO
#
switch -- [tcl::string::index $codenorm end] {
M {
puts stderr "mousedown $codenorm"
}
m {
puts stderr "mouseup $codenorm"
}
}
}
{7CSI} - {8CSI} {
set param [tcl::string::range $codenorm 4 end-1]
#puts stdout "--> CSI [tcl::string::index $leadernorm 0] bit param:$param"
set code_end [tcl::string::index $codenorm end] ;#used for e.g h|l set/unset mode
switch -exact -- $code_end {
A {
#Row move - up
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
#todo
lassign [split $param {;}] num modifierkey
if {$modifierkey ne ""} {
puts stderr "modifierkey:$modifierkey"
}
if {$num eq ""} {set num 1}
incr cursor_row -$num
if {$cursor_row < 1} {
set cursor_row 1
}
#ensure rest of *overlay* is emitted to remainder
incr idx_over
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction up
#retain cursor_column
break
}
B {
#CUD - Cursor Down
#Row move - down
lassign [split $param {;}] num modifierkey
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
#move down
if {$modifierkey ne ""} {
puts stderr "modifierkey:$modifierkey"
}
if {$num eq ""} {set num 1}
incr cursor_row $num
incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction down
#retain cursor_column
break
}
C {
#CUF - Cursor Forward
#Col move
#puts stdout "->forward"
#todo - consider right-to-left cursor mode (e.g Hebrew).. some day.
#cursor forward
#right-arrow/move forward
lassign [split $param {;}] num modifierkey
if {$modifierkey ne ""} {
puts stderr "modifierkey:$modifierkey"
}
if {$num eq ""} {set num 1}
#todo - retrict to moving 1 position past datalen? restrict to column width?
#should ideally wrap to next line when interactive and not on last row
#(some ansi art seems to expect this behaviour)
#This presumably depends on the terminal's wrap mode
#e.g DECAWM autowrap mode
# CSI ? 7 h - set: autowrap (also tput smam)
# CSI ? 7 l - reset: no autowrap (also tput rmam)
set version 2
if {$version eq "2"} {
set max [llength $outcols]
if {$overflow_idx == -1} {
incr max
}
if {$cursor_column == $max+1} {
#move_forward while in overflow
incr cursor_column -1
}
if {($cursor_column + $num) <= $max} {
incr idx $num
incr cursor_column $num
} else {
if {$autowrap_mode} {
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
#jmn
if {$idx == $overflow_idx} {
incr num
}
#horizontal movement beyond line extent needs to wrap - throw back to caller
#we may have both overflow_right and unapplied data
#(can have overflow_right if we were in insert_mode and processed chars prior to this movement)
#leave row as is - caller will need to determine how many rows the column-movement has consumed
incr cursor_column $num ;#give our caller the necessary info as columns from start of row
#incr idx_over
#should be gci following last one applied
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction wrapmoveforward
break
} else {
set cursor_column $max
set idx [expr {$cursor_column -1}]
}
}
} else {
#review - dead branch
if {!$expand_right || ($cursor_column + $num) <= [llength $outcols+1]} {
incr idx $num
incr cursor_column $num
} else {
if {!$insert_mode} {
#block editing style with arrow keys
#overtype mode
set idxstart $idx
set idxend [llength $outcols]
set moveend [expr {$idxend - $idxstart}]
if {$moveend < 0} {set moveend 0} ;#sanity?
#puts "idxstart:$idxstart idxend:$idxend outcols[llength $outcols] undercols:[llength $undercols]"
incr idx $moveend
incr cursor_column $moveend
#if {[tcl::dict::exists $understacks $idx]} {
# set stackinfo [tcl::dict::get $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext
#} else {
# set stackinfo [list]
#}
if {$idx < [llength $understacks]} {
set stackinfo [lindex $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext
} else {
set stackinfo [list]
}
if {$idx < [llength $understacks_gx]} {
#set gxstackinfo [tcl::dict::get $understacks_gx $idx]
set gxstackinfo [lindex $understacks_gx $idx]
} else {
set gxstackinfo [list]
}
#pad outcols
set movemore [expr {$num - $moveend}]
#assert movemore always at least 1 or we wouldn't be in this branch
for {set m 1} {$m <= $movemore} {incr m} {
incr idx
incr cursor_column
priv::render_addchar $idx " " $stackinfo $gxstackinfo $insert_mode
}
} else {
#normal - insert
incr idx $num
incr cursor_column $num
if {$idx > [llength $outcols]} {
set idx [llength $outcols];#allow one beyond - for adding character at end of line
set cursor_column [expr {[llength $outcols]+1}]
}
}
}
}
}
D {
#Col move
#puts stdout "<-back"
#cursor back
#left-arrow/move-back when ltr mode
lassign [split $param {;}] num modifierkey
if {$modifierkey ne ""} {
puts stderr "modifierkey:$modifierkey"
}
if {$num eq ""} {set num 1}
set version 2
if {$version eq "2"} {
#todo - startcolumn offset!
if {$cursor_column - $num >= 1} {
incr idx -$num
incr cursor_column -$num
} else {
if {!$autowrap_mode} {
set cursor_column 1
set idx 0
} else {
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
incr cursor_column -$num
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction wrapmovebackward
break
}
}
} else {
incr idx -$num
incr cursor_column -$num
if {$idx < $opt_colstart-1} {
#wrap to previous line and position cursor at end of data
set idx [expr {$opt_colstart-1}]
set cursor_column $opt_colstart
}
}
}
E {
#CNL - Cursor Next Line
if {$param eq ""} {
set downmove 1
} else {
set downmove [expr {$param}]
}
puts stderr "renderline CNL down-by-$downmove"
set cursor_column 1
set cursor_row [expr {$cursor_row + $downmove}]
set idx [expr {$cursor_column -1}]
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
incr idx_over
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction move
break
}
F {
#CPL - Cursor Previous Line
if {$param eq ""} {
set upmove 1
} else {
set upmove [expr {$param}]
}
puts stderr "renderline CPL up-by-$upmove"
set cursor_column 1
set cursor_row [expr {$cursor_row -$upmove}]
if {$cursor_row < 1} {
set cursor_row 1
}
set idx [expr {$cursor_column - 1}]
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
incr idx_over
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction move
break
}
G {
#CHA - Cursor Horizontal Absolute (move to absolute column no)
if {$param eq ""} {
set targetcol 1
} else {
set targetcol $param
if {![string is integer -strict $targetcol]} {
puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Unrecognised parameter '$param'"
}
set targetcol [expr {$param}]
set max [llength $outcols]
if {$overflow_idx == -1} {
incr max
}
if {$targetcol > $max} {
puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Param '$param' > max: $max"
set targetcol $max
}
}
#adjust to colstart - as column 1 is within overlay
#??? REVIEW
set idx [expr {($targetcol -1) + $opt_colstart -1}]
set cursor_column $targetcol
#puts stderr "renderline absolute col move ESC G (TEST)"
}
H - f {
#CSI n;m H - CUP - Cursor Position
#CSI n;m f - HVP - Horizontal Vertical Position REVIEW - same as CUP with differences (what?) in some terminal modes
# - 'counts as effector format function (like CR or LF) rather than an editor function (like CUD or CNL)'
# - REVIEW
#see Annex A at: https://www.ecma-international.org/wp-content/uploads/ECMA-48_5th_edition_june_1991.pdf
#test e.g ansicat face_2.ans
#$re_both_move
lassign [split $param {;}] paramrow paramcol
#missing defaults to 1
#CSI ;5H = CSI 1;5H -> row 1 col 5
#CSI 17;H = CSI 17H = CSI 17;1H -> row 17 col 1
if {$paramcol eq ""} {set paramcol 1}
if {$paramrow eq ""} {set paramrow 1}
if {![string is integer -strict $paramcol] || ![string is integer -strict $paramrow]} {
puts stderr "renderline CUP (CSI <param> H) unrecognised param $param"
#ignore?
} else {
set max [llength $outcols]
if {$overflow_idx == -1} {
incr max
}
if {$paramcol > $max} {
set target_column $max
} else {
set target_column [expr {$paramcol}]
}
if {$paramrow < 1} {
puts stderr "renderline CUP (CSI <param> H) bad row target 0. Assuming 1"
set target_row 1
} else {
set target_row [expr {$paramrow}]
}
if {$target_row == $cursor_row} {
#col move only - no need for break and move
#puts stderr "renderline CUP col move only to col $target_column param:$param"
set cursor_column $target_column
set idx [expr {$cursor_column -1}]
} else {
set cursor_row $target_row
set cursor_column $target_column
set idx [expr {$cursor_column -1}]
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
incr idx_over
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction move
break
}
}
}
J {
set modegroup [tcl::string::index $codenorm 4] ;#e.g ?
switch -exact -- $modegroup {
? {
#CSI ? Pn J - selective erase
puts stderr "overtype::renderline ED - SELECTIVE ERASE IN DISPLAY (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
default {
puts stderr "overtype::renderline ED - ERASE IN DISPLAY (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
if {$param eq ""} {set param 0}
switch -exact -- $param {
0 {
#clear from cursor to end of screen
}
1 {
#clear from cursor to beginning of screen
}
2 {
#clear entire screen
#ansi.sys - move cursor to upper left REVIEW
set cursor_row 1
set cursor_column 1
set idx [expr {$cursor_column -1}]
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
incr idx_over
if {[llength $outcols]} {
priv::render_erasechar 0 [llength $outcols]
}
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction clear_and_move
break
}
3 {
#clear entire screen. presumably cursor doesn't move - otherwise it would be same as 2J ?
}
default {
}
}
}
}
}
K {
#see DECECM regarding background colour
set modegroup [tcl::string::index $codenorm 4] ;#e.g ?
switch -exact -- $modegroup {
? {
puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
set param [string range $param 1 end] ;#chop qmark
if {$param eq ""} {set param 0}
switch -exact -- $param {
0 {
#clear from cursor to end of line - depending on DECSCA
}
1 {
#clear from cursor to beginning of line - depending on DECSCA
}
2 {
#clear entire line - depending on DECSCA
}
default {
puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
}
default {
puts stderr "overtype::renderline EL - ERASE IN LINE (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
if {$param eq ""} {set param 0}
switch -exact -- $param {
0 {
#clear from cursor to end of line
}
1 {
#clear from cursor to beginning of line
}
2 {
#clear entire line
}
default {
puts stderr "overtype::renderline EL - ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
}
}
}
L {
puts stderr "overtype::renderline IL - Insert Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
M {
#CSI Pn M - DL - Delete Line
puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
T {
#CSI Pn T - SD Pan Up (empty lines introduced at top)
#CSI Pn+T - kitty extension (lines at top come from scrollback buffer)
#Pn new lines appear at top of the display, Pn old lines disappear at the bottom of the display
if {$param eq "" || $param eq "0"} {set param 1}
if {[string index $param end] eq "+"} {
puts stderr "overtype::renderline CSI Pn + T - kitty Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
} else {
puts stderr "overtype::renderline CSI Pn T - SD Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
X {
puts stderr "overtype::renderline X ECH ERASE CHARACTER - $param"
#ECH - erase character
if {$param eq "" || $param eq "0"} {set param 1}; #param=count of chars to erase
priv::render_erasechar $idx $param
#cursor position doesn't change.
}
q {
set code_secondlast [tcl::string::index $codenorm end-1]
switch -exact -- $code_secondlast {
{"} {
#DECSCA - Select Character Protection Attribute
#(for use with selective erase: DECSED and DECSEL)
set param [tcl::string::range $codenorm 4 end-2]
if {$param eq ""} {set param 0}
#TODO - store like SGR in stacks - replays?
switch -exact -- $param {
0 - 2 {
#canerase
puts stderr "overtype::renderline - DECSCA canerase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
1 {
#cannoterase
puts stderr "overtype::renderline - DECSCA cannoterase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
default {
puts stderr "overtype::renderline DECSCA param '$param' not understood [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
}
default {
puts stderr "overtype::renderline - CSI ... q not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
}
r {
#$re_decstbm
#https://www.vt100.net/docs/vt510-rm/DECSTBM.html
#This control function sets the top and bottom margins for the current page. You cannot perform scrolling outside the margins
lassign [split $param {;}] margin_top margin_bottom
#todo - return these for the caller to process..
puts stderr "overtype::renderline DECSTBM set top and bottom margin not implemented"
#Also moves the cursor to col 1 line 1 of the page
set cursor_column 1
set cursor_row 1
incr idx_over
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction move ;#own instruction? decstbm?
break
}
s {
#code conflict between ansi emulation and DECSLRM - REVIEW
#ANSISYSSC (when no parameters) - like other terminals - essentially treat same as DECSC
# todo - when parameters - support DECSLRM instead
if {$param ne ""} {
#DECSLRM - should only be recognised if DECLRMM is set (vertical split screen mode)
lassign [split $param {;}] margin_left margin_right
puts stderr "overtype DECSLRM not yet supported - got [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
if {$margin_left eq ""} {
set margin_left 1
}
set columns_per_page 80 ;#todo - set to 'page width (DECSCPP set columns per page)' - could be 132 or??
if {$margin_right eq ""} {
set margin_right $columns_per_page
}
puts stderr "DECSLRM margin left: $margin_left margin right: $margin_right"
if {![string is integer -strict $margin_left] || $margin_left < 0} {
puts stderr "DECSLRM invalid margin_left"
}
if {![string is integer -strict $margin_right] || $margin_right < 0} {
puts stderr "DECSLRM invalid margin_right"
}
set scrolling_region_size [expr {$margin_right - $margin_left}]
if {$scrolling_region_size < 2 || $scrolling_region_size > $columns_per_page} {
puts stderr "DECSLRM region size '$scrolling_regsion_size' must be between 1 and $columns_per_page"
}
#todo
} else {
#DECSC
#//notes on expected behaviour:
#DECSC - saves following items in terminal's memory
#cursor position
#character attributes set by the SGR command
#character sets (G0,G1,G2 or G3) currently in GL and GR
#Wrap flag (autowrap or no autowrap)
#State of origin mode (DECOM)
#selective erase attribute
#any single shift 2 (SS2) or single shift 3(SSD) functions sent
#$re_cursor_save
#cursor save could come after last column
if {$overflow_idx != -1 && $idx == $overflow_idx} {
#bartman2.ans test file - fixes misalignment at bottom of dialog bubble
#incr cursor_row
#set cursor_column 1
#bwings1.ans test file - breaks if we actually incr cursor (has repeated saves)
set cursor_saved_position [list row [expr {$cursor_row+1}] column 1]
} else {
set cursor_saved_position [list row $cursor_row column $cursor_column]
}
#there may be overlay stackable codes emitted that aren't in the understacks because they come between the last emmited character and the cursor_save control.
#we need the SGR and gx overlay codes prior to the cursor_save
#a real terminal would not be able to know the state of the underlay.. so we should probably ignore it.
#set sgr_stack [lindex $understacks $idx]
#set gx_stack [lindex $understacks_gx $idx] ;#not actually a stack - just a boolean state (for now?)
set sgr_stack [list]
set gx_stack [list]
#we shouldn't need to scan for intermediate cursor save/restores - as restores would throw-back to the calling loop - so our overlay 'line' is since those.
#The overlay_grapheme_control_list had leading resets from previous lines - so we go back to the beginning not just the first grapheme.
foreach gc [lrange $overlay_grapheme_control_list 0 $gci-1] {
lassign $gc type code
#types g other sgr gx0
switch -- $type {
gx0 {
#code is actually a stand-in for the graphics on/off code - not the raw code
#It is either gx0_on or gx0_off
set gx_stack [list $code]
}
sgr {
#code is the raw code
if {[punk::ansi::codetype::is_sgr_reset $code]} {
#jmn
set sgr_stack [list "\x1b\[m"]
} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
set sgr_stack [list $code]
lappend overlay_grapheme_control_list [list sgr $code]
} elseif {[priv::is_sgr $code]} {
#often we don't get resets - and codes just pile up.
#as a first step to simplifying - at least remove earlier straight up dupes
set dup_posns [lsearch -all -exact $sgr_stack $code] ;#needs -exact - codes have square-brackets (glob chars)
set sgr_stack [lremove $sgr_stack {*}$dup_posns]
lappend sgr_stack $code
}
}
}
}
set cursor_saved_attributes ""
switch -- [lindex $gx_stack 0] {
gx0_on {
append cursor_saved_attributes "\x1b(0"
}
gx0_off {
append cursor_saved_attributes "\x1b(B"
}
}
#append cursor_saved_attributes [join $sgr_stack ""]
append cursor_saved_attributes [punk::ansi::codetype::sgr_merge_list {*}$sgr_stack]
#as there is apparently only one cursor storage element we don't need to throw back to the calling loop for a save.
#don't incr index - or the save will cause cursor to move to the right
#carry on
}
}
u {
#ANSISYSRC save cursor (when no parameters) (DECSC)
#$re_cursor_restore
#we are going to jump somewhere.. for now we will assume another line, and process accordingly.
#The caller has the cursor_saved_position/cursor_saved_attributes if any (?review - if we always pass it back it, we could save some calls for moves in same line)
#don't set overflow at this point. The existing underlay to the right must be preserved.
#we only want to jump and render the unapplied at the new location.
#lset overstacks $idx_over [list]
#set replay_codes_overlay ""
#if {$cursor_saved_attributes ne ""} {
# set replay_codes_overlay $cursor_saved_attributes ;#empty - or last save if it happend in this input chunk
#} else {
#jj
#set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
set replay_codes_overlay ""
#}
#like priv::render_to_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code
incr idx_over
set unapplied ""
set unapplied_list [list]
set unapplied_ansisplit [list ""] ;#remove below if nothing added
foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] {
lassign $gc type item
switch -- $type {
g {
lappend unapplied_list $item
ledit unapplied_ansisplit end end [string cat [lindex $unapplied_ansisplit end] $item]
}
gx0 {
if {$item eq "gx0_on"} {
lappend unapplied_list "\x1b(0"
lappend unapplied_ansisplit "\x1b(0" ""
} elseif {$item eq "gx0_off"} {
lappend unapplied_list "\x1b(B"
lappend unapplied_ansisplit "\x1b(B" ""
}
}
default {
lappend unapplied_list $item
lappend unapplied_ansisplit $item ""
}
}
#incr idx_over
}
set unapplied [join $unapplied_list ""]
if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} {
set unapplied_ansisplit [list]
}
#if the save occured within this line - that's ok - it's in the return value list and caller can prepend for the next loop.
set instruction restore_cursor
break
}
"{" {
puts stderr "renderline warning - CSI..<leftcurly> - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]"
}
"}" {
set code_secondlast [tcl::string::index $codenorm end-1]
switch -exact -- $code_secondlast {
' {
puts stderr "renderline warning - DECIC - Insert Column - CSI...'<rightcurly> - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]"
}
default {
puts stderr "renderline warning - CSI..<rightcurly> - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]"
}
}
}
~ {
set code_secondlast [tcl::string::index $codenorm end-1] ;#used for e.g CSI x '~
switch -exact -- $code_secondlast {
' {
#DECDC - editing sequence - Delete Column
puts stderr "renderline warning - DECDC - unimplemented"
}
default {
#$re_vt_sequence
lassign [split $param {;}] key mod
#Note that f1 to f4 show as ESCOP|Q|R|S (VT220?) but f5+ show as ESC\[15~
#
#e.g esc \[2~ insert esc \[2;2~ shift-insert
#mod - subtract 1, and then use bitmask
#shift = 1, (left)Alt = 2, control=4, meta=8 (meta seems to do nothing on many terminals on windows? Intercepted by windows?)
#puts stderr "vt key:$key mod:$mod code:[ansistring VIEW $code]"
if {$key eq "1"} {
#home
} elseif {$key eq "2"} {
#Insert
if {$mod eq ""} {
#no modifier key
set insert_mode [expr {!$insert_mode}]
#rather than set the cursor - we return the insert mode state so the caller can decide
}
} elseif {$key eq "3"} {
#Delete - presumably this shifts other chars in the line, with empty cells coming in from the end
switch -- $mod {
"" {
priv::render_delchar $idx
}
"5" {
#ctrl-del - delete to end of word (pwsh) - possibly word on next line if current line empty(?)
}
}
} elseif {$key eq "4"} {
#End
} elseif {$key eq "5"} {
#pgup
} elseif {$key eq "6"} {
#pgDn
} elseif {$key eq "7"} {
#Home
#??
set idx [expr {$opt_colstart -1}]
set cursor_column 1
} elseif {$key eq "8"} {
#End
} elseif {$key eq "11"} {
#F1 - or ESCOP or e.g shift F1 ESC\[1;2P
} elseif {$key eq "12"} {
#F2 - or ESCOQ
} elseif {$key eq "13"} {
#F3 - or ESCOR
} elseif {$key eq "14"} {
#F4 - or ESCOS
} elseif {$key eq "15"} {
#F5 or shift F5 ESC\[15;2~
} elseif {$key eq "17"} {
#F6
} elseif {$key eq "18"} {
#F7
} elseif {$key eq "19"} {
#F8
} elseif {$key eq "20"} {
#F9
} elseif {$key eq "21"} {
#F10
} elseif {$key eq "23"} {
#F11
} elseif {$key eq "24"} {
#F12
}
}
}
}
h - l {
#set mode unset mode
#we are matching only last char to get to this arm - but are there other sequences ending in h|l we need to handle?
#$re_mode if first after CSI is "?"
#some docs mention ESC=<mode>h|l - not seen on windows terminals.. review
#e.g https://www2.math.upenn.edu/~kazdan/210/computer/ansi.html
set modegroup [tcl::string::index $codenorm 4] ;#e.g ? =
switch -exact -- $modegroup {
? {
set smparams [tcl::string::range $codenorm 5 end-1] ;#params between ? and h|l
#one or more modes can be set
set smparam_list [split $smparams {;}]
foreach num $smparam_list {
switch -- $num {
"" {
#ignore empties e.g extra/trailing semicolon in params
}
5 {
#DECSNM - reverse video
#How we simulate this to render within a block of text is an open question.
#track all SGR stacks and constantly flip based on the current SGR reverse state?
#It is the job of the calling loop to do this - so at this stage we'll just set the states
if {$code_end eq "h"} {
#set (enable)
set reverse_mode 1
} else {
#reset (disable)
set reverse_mode 0
}
}
7 {
#DECAWM autowrap
if {$code_end eq "h"} {
#set (enable)
set autowrap_mode 1
if {$opt_width ne "\uFFEF"} {
set overflow_idx $opt_width
} else {
#review - this is also the cursor position when adding a char at end of line?
set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it
}
#review - can idx ever be beyond overflow_idx limit when we change e.g with a width setting and cursor movements?
# presume not usually - but sanity check with warning for now.
if {$idx >= $overflow_idx} {
puts stderr "renderline warning - idx '$idx' >= overflow_idx '$overflow_idx' - unexpected"
}
} else {
#reset (disable)
set autowrap_mode 0
#REVIEW!
set overflow_idx -1
}
}
25 {
if {$code_end eq "h"} {
#visible cursor
} else {
#invisible cursor
}
}
117 {
#DECECM - Erase Color Mode
#https://invisible-island.net/ncurses/ncurses.faq.html
#The Erase color selection controls the background color used when text is erased or new
#text is scrolled on to the screen. Screen background causes newly erased areas or
#scrolled text to be written using color index zero, the screen background. This is VT
#and DECterm compatible. Text background causes erased areas or scrolled text to be
#written using the current text background color. This is PC console compatible and is
#the factory default.
#see also: https://unix.stackexchange.com/questions/251726/clear-to-end-of-line-uses-the-wrong-background-color-in-screen
}
}
}
}
= {
set num [tcl::string::range $codenorm 5 end-1] ;#param between = and h|l
puts stderr "overtype::renderline CSI=...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented"
}
default {
#e.g CSI 4 h
set num [tcl::string::range $codenorm 4 end-1] ;#param before h|l
switch -exact -- $num {
3 {
puts stderr "CRM MODE $code_end"
#CRM - Show control character mode
# 'No control functions are executed except LF,FF and VT which are represented in the CRM FONT before a CRLF(new line) is executed'
#
#use ansistring VIEW -nul 1 -lf 2 -ff 2 -vt 2
#https://vt100.net/docs/vt510-rm/CRM.html
#NOTE - vt100 CRM always does auto-wrap at right margin.
#disabling auto-wrap in set-up or by sequence is disabled.
#We should default to turning off auto-wrap when crm_mode enabled.. but
#displaying truncated (on rhs) crm can still be very useful - and we have optimisation in overflow to avoid excess renderline calls (per grapheme)
#we therefore could reasonably put in an exception to allow auto_wrap to be disabled after crm_mode is engaged,
#although this would be potentially an annoying difference to some.. REVIEW
if {$code_end eq "h"} {
set crm_mode 1
set autowrap_mode 1
if {$opt_width ne "\uFFEF"} {
set overflow_idx $opt_width
} else {
#review - this is also the cursor position when adding a char at end of line?
set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it
}
} else {
set crm_mode 0
}
}
4 {
#IRM - Insert/Replace Mode
if {$code_end eq "h"} {
#CSI 4 h
set insert_mode 1
} else {
#CSI 4 l
#replace mode
set insert_mode 0
}
}
default {
puts stderr "overtype::renderline CSI...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented"
}
}
}
}
}
| {
switch -- [tcl::string::index $codenorm end-1] {
{$} {
#CSI ... $ | DECSCPP set columns per page- (recommended in vt510 docs as preferable to DECCOLM)
#real terminals generally only supported 80/132
#some other virtuals support any where from 2 to 65,536?
#we will allow arbitrary widths >= 2 .. to some as yet undetermined limit.
#CSI <param> $ |
#empty or 0 param is 80 for compatibility - other numbers > 2 accepted
set page_width -1 ;#flag as unset
if {$param eq ""} {
set page_width 80
} elseif {[string is integer -strict $param] && $param >=2} {
set page_width [expr {$param}] ;#we should allow leading zeros in the number - but lets normalize using expr
} else {
puts stderr "overtype::renderline unacceptable DECSPP value '$param'"
}
if {$page_width > 2} {
puts stderr "overtype::renderline DECSCPP - not implemented - but selected width '$page_width' looks ok"
#if cursor already beyond new page_width - will move to right colum - otherwise no cursor movement
}
}
default {
puts stderr "overtype::renderline unrecognised CSI code ending in pipe (|) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented"
}
}
}
t {
set params [split $param {;}]
if {[llength $params] == 4} {
#pablodraw 24bit color
#see also: https://github.com/ansilove/libansilove/blob/master/src/loaders/ansi.c
lassign $params isfg pablo_r pablo_g pablo_b
#e.g esc\[0\;171\;87\;0t
set stack [lindex $overlay_grapheme_control_stacks $gci]
puts stderr "pablodraw debug [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
#foreach s $stack {
# puts stderr " - [ansistring VIEW -lf 1 -vt 1 -nul 1 $s]"
#}
#we expect first param to be 0 for background, 1 for foreground
if {$isfg} {
set rgbcode "\x1b\[38\;2\;$pablo_r\;$pablo_g\;${pablo_b}m"
} else {
set rgbcode "\x1b\[48\;2\;$pablo_r\;$pablo_g\;${pablo_b}m"
}
#too late here !!
#lappend stack $rgbcode
#lset overlay_grapheme_control_stacks $gci $stack
} else {
puts stderr "overtype::renderline unrecognised custom CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented"
}
}
default {
puts stderr "overtype::renderline CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented"
}
}
}
7ESC {
#
#re_other_single {\x1b(D|M|E)$}
#also vt52 Y..
#also PM \x1b^...(ST)
switch -- [tcl::string::index $codenorm 4] {
c {
#RIS - reset terminal to initial state - where 'terminal' in this case is the renderspace - not the underlying terminal!
puts stderr "renderline reset"
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction reset
break
}
D {
#\x84
#index (IND)
#vt102-docs: "Moves cursor down one line in same column. If cursor is at bottom margin, screen performs a scroll-up"
puts stderr "renderline ESC D not fully implemented"
incr cursor_row
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction down
#retain cursor_column
break
}
E {
#\x85
#review - is behaviour different to lf?
#todo - possibly(?) same logic as <lf> handling above. i.e return instruction depends on where column_cursor is at the time we get NEL
#leave implementation until logic for <lf> is set in stone... still under review
#It's arguable NEL is a pure cursor movement as opposed to the semantic meaning of crlf or lf in a file.
#
#Next Line (NEL) "Move the cursor to the left margin on the next line. If the cursor is at the bottom margin, scroll the page up"
puts stderr "overtype::renderline ESC E unimplemented"
}
H {
#\x88
#Tab Set
puts stderr "overtype::renderline ESC H tab set unimplemented"
}
M {
#\x8D
#Reverse Index (RI)
#vt102-docs: "Moves cursor up one line in same column. If cursor is at top margin, screen performs a scroll-down"
puts stderr "overtype::renderline ESC M not fully implemented"
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
#move up
incr cursor_row -1
if {$cursor_row < 1} {
set cursor_row 1
}
#ensure rest of *overlay* is emitted to remainder
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction up ;#need instruction for scroll-down?
#retain cursor_column
break
}
N {
#\x8e - affects next character only
puts stderr "overtype::renderline single shift select G2 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
O {
#\x8f - affects next character only
puts stderr "overtype::renderline single shift select G3 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
P {
#\x90
#DCS - shouldn't get here - handled in 7DCS branch
#similarly \] OSC (\x9d) and \\ (\x9c) ST
}
V {
#\x96
}
W {
#\x97
}
X {
#\x98
#SOS
if {[string index $code end] eq "\007"} {
set sos_content [string range $code 2 end-1] ;#ST is \007
} else {
set sos_content [string range $code 2 end-2] ;#ST is \x1b\\
}
#return in some useful form to the caller
#TODO!
lappend sos_list [list string $sos_content row $cursor_row column $cursor_column]
puts stderr "overtype::renderline ESCX SOS UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
^ {
#puts stderr "renderline PM"
#Privacy Message.
if {[string index $code end] eq "\007"} {
set pm_content [string range $code 2 end-1] ;#ST is \007
} else {
set pm_content [string range $code 2 end-2] ;#ST is \x1b\\
}
#We don't want to render it - but we need to make it available to the application
#see the textblock library in punk, for the exception we make here for single backspace.
#It is unlikely to be encountered as a useful PM - so we hack to pass it through as a fix
#for spacing issues on old terminals which miscalculate the single-width 'Symbols for Legacy Computing'
if {$pm_content eq "\b"} {
#puts stderr "renderline PM sole backspace special handling for \U1FB00 - \U1FBFF"
#esc^\b\007 or esc^\besc\\
#HACKY pass-through - targeting terminals that both mis-space legacy symbols *and* don't support PMs
#The result is repair of the extra space. If the terminal is a modern one and does support PM - the \b should be hidden anyway.
#If the terminal has the space problem AND does support PMs - then this just won't fix it.
#The fix relies on the symbol-supplier to cooperate by appending esc^\b\esc\\ to the problematic symbols.
#priv::render_addchar $idx $code [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode
#idx has been incremented after last grapheme added
priv::render_append_to_char [expr {$idx -1}] $code
}
#lappend to a dict element in the result for application-specific processing
lappend pm_list $pm_content
}
_ {
#APC Application Program Command
#just warn for now..
puts stderr "overtype::renderline ESC_ APC command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
default {
puts stderr "overtype::renderline ESC<x> code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]"
}
}
}
7DCS - 8DCS {
#match 'DCS P1 ; P2 ; P3' (without spaces)
# where Ps1,P2,P3 are all optional and P1,P2 are single digit and P3 can *technically* be any positive integer but is usually ignored (commonly set to zero)
# Our regexp isn't precise as we will validate number of params and values after matching - but we will assume P3 should be small (review for micrometres - could be 4 digits? more?)
# (limit to 10 chars to avoid insane values?)
#https://github.com/hackerb9/vt340test/blob/main/physicalsixels.md
# P1P2P3q - "Protocol Selector"
# P1 - Pixel Aspect Ratio (Vertical:Horizontal)
# P2 - background control
# P3 - horizontal grid size (default units decipoints 1/720 inch - but theoretically controlled by ANSI SSU sequence)
# P1P2P3 commonly omitted - with subsequent <DQ>P4;P5;P6;P7 "Raster Attributes (DECGRA)" being used for:
# Aspect Ratio (P4,P5)
set sixelstart [tcl::string::range $codenorm 4 13]
set sixelmatch [regexp -all -inline {^((?:[0-9]*;){0,2}(?:[0-9]*))q} $sixelstart]
if {[llength $sixelmatch] == 2} {
#sixel
#note sixel data can have newlines before ST
set sixelparams [lindex $sixelmatch 1]
set params [split $sixelparams {;}]
set badsixelparams 0
if {[llength $params] > 3} {
set badsixelparams 1
}
lassign $params P1 P2 P3
if {[string length $P1] > 1 || [string length $P2] > 1 || [string length $P3] > 3} {
set badsixelparams 1
}
if {$badsixelparams} {
puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING looks like sixel, but bad params. sixelstart [ansistring VIEW -lf 1 -vt 1 -nul 1 $sixelstart]"
} else {
#todo - move to punk::sixel library
#P1 - Pixel Aspect Ratio
# round(10/P1):1 if 2<= P1 <= 9) 2:1 otherwise
# omitted 2:1 (default)
# 0,1 2:1
# 2 5:1
# 3,4 3:1
# 5,6 2:1
# 7,8,9 1:1
switch -- $P1 {
"" - 0 - 1 {
#omitted (default)
set sixel_pixel_aspect "2:1"
}
2 {
set sixel_pixel_aspect "5:1"
}
3 - 4 {
set sixel_pixel_aspect "3:1"
}
5 - 6 {
set sixel_pixel_aspect "2:1"
}
7 - 8 - 9 {
set sixel_pixel_aspect "1:1"
}
default {
set sixel_pixel_aspect "invalid"
puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING looks like sixel, but unrecognised P1 (pixel aspect ratio). sixelstart [ansistring VIEW -lf 1 -vt 1 -nul 1 $sixelstart]"
}
}
#P2 - background colour
# 0,2 (default) pixel positions specified as 0 are set to current bg colour
# 1 pixel positions specified as 0 remain at current colour
switch -- $P2 {
"" - 0 - 2 {
set sixel_background "current_background"
}
1 {
set sixel_background "transparent"
}
default {
set sixel_background "invalid"
puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING looks like sixel, but unrecognised P2 (background control). sixelstart [ansistring VIEW -lf 1 -vt 1 -nul 1 $sixelstart]"
}
}
#P3 horizontal grid size - ignored on VT300 - commonly set to zero
# ECMA-48 SSU (ESC Ps <sp> I)
# 0 - CHARACTER
# 1 - MILLIMETRE
# 2 - COMPUTER DECIPOINT 0.03528mm 1/720 of 25.4mm)
# 3 - DECIDIDOT 0.03759mm (10/266mm)
# 4 - MIL 0.0254mm (1/1000 of 25.4mm)
# 5 - BASIC MEASURING UNIT (BMU) 0.02117mm (1/1200 of 25.4mm)
# 6 - MICROMETRE 0.001mm
# 7 - PIXEL - the smallest increment that can be specified in a device
# 8 - DECIPOINT - 0.03514mm (35/996mm)
set sixel_horizontal_grid $P3
set sixel_ssu "decipoint" ;#todo?
#todo - look for and parse DECGRA introduced by double quote
puts stderr "overtype::renderline SIXEL aspect: $sixel_pixel_aspect bg: $sixel_background hgrid: $sixel_horizontal_grid. sixelstart [ansistring VIEW -lf 1 -vt 1 -nul 1 $sixelstart]"
#todo
}
} else {
puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
#ST (string terminator) \x9c or \x1b\\
if {[tcl::string::index $codenorm end] eq "\x9c"} {
set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is 8-bit 0x9c
} else {
set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\
}
}
}
7OSC - 8OSC {
# OSCs are terminated with ST of either \007 or \x1b\\ - we allow either whether code was 7 or 8 bit
if {[tcl::string::index $codenorm end] eq "\007"} {
set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is \007
} else {
set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\
}
set first_colon [tcl::string::first {;} $code_content]
if {$first_colon == -1} {
#there probably should always be a colon - but we'll try to make sense of it without
set osc_code $code_content ;#e.g \x1b\]104\007 vs \x1b\]104\;\007
} else {
set osc_code [tcl::string::range $code_content 0 $first_colon-1]
}
switch -exact -- $osc_code {
2 {
set newtitle [tcl::string::range $code_content 2 end]
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction [list set_window_title $newtitle]
break
}
4 {
#OSC 4 - set colour palette
#can take multiple params
#e.g \x1b\]4\;1\;red\;2\;green\x1b\\
set params [tcl::string::range $code_content 2 end] ;#strip 4 and first semicolon
set cmap [dict create]
foreach {cnum spec} [split $params {;}] {
if {$cnum >= 0 && $cnum <= 255} {
#todo - parse spec from names like 'red' to RGB
#todo - accept rgb:ab/cd/ef as well as rgb:/a/b/c (as alias for aa/bb/cc)
#also - what about rgb:abcd/defg/hijk and 12-bit abc/def/ghi ?
dict set cmap $cnum $spec
} else {
#todo - log
puts stderr "overtype::renderline OSC 4 set colour palette - bad color number: $cnum must be from 0 to 255. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
10 - 11 - 12 - 13 - 14 - 15 - 16 - 17 {
#OSC 10 through 17 - so called 'dynamic colours'
#can take multiple params - each successive parameter changes the next colour in the list
#- e.g if code started at 11 - next param is for 12. 17 takes only one param because there are no more
#10 change text foreground colour
#11 change text background colour
#12 change text cursor colour
#13 change mouse foreground colour
#14 change mouse background colour
#15 change tektronix foreground colour
#16 change tektronix background colour
#17 change highlight colour
set params [tcl::string::range $code_content 2 end]
puts stderr "overtype::renderline OSC $osc_code set dynamic colours unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
18 {
#why is this not considered one of the dynamic colours above?
#https://www.xfree86.org/current/ctlseqs.html
#tektronix cursor color
puts stderr "overtype::renderline OSC 18 - set tektronix cursor color unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
99 {
#kitty desktop notifications
#https://sw.kovidgoyal.net/kitty/desktop-notifications/
#<OSC> 99 ; metadata ; payload <terminator>
puts stderr "overtype::renderline OSC 99 kitty desktop notification unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
104 {
#reset colour palette
#we want to do it for the current rendering context only (vvt) - not just pass through to underlying vt
puts stderr "overtype::renderline OSC 104 reset colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction [list reset_colour_palette]
break
}
1337 {
#iterm2 graphics and file transfer
puts stderr "overtype::renderline OSC 1337 iterm2 graphics/file_transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]"
}
5113 {
puts stderr "overtype::renderline OSC 5113 kitty file transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]"
}
default {
puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
}
default {
}
}
}
default {
#don't need to handle sgr or gx0 types
#we have our sgr gx0 codes already in stacks for each overlay grapheme
}
}
}
#--------
if {$opt_expand_right == 0} {
#need to truncate to the width of the original undertext
#review - string_width vs printing_length here. undertext requirement to be already rendered therefore punk::char::string_width ok?
#set num_under_columns [punk::char::string_width $pt_underchars] ;#plaintext underchars
}
if {$overflow_idx == -1} {
#overflow was initially unlimited and hasn't been overridden
} else {
}
#--------
#coalesce and replay codestacks for outcols grapheme list
set outstring "" ;#output prior to overflow
set overflow_right "" ;#remainder after overflow point reached
set i 0
set cstack [list]
set prevstack [list]
set prev_g0 [list]
#note overflow_idx may already have been set lower if we had a row move above due to \v or ANSI moves
set in_overflow 0 ;#used to stop char-width scanning once in overflow
if {$overflow_idx == 0} {
#how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW
set in_overflow 1
}
set trailing_nulls 0
foreach ch [lreverse $outcols] {
if {$ch eq "\u0000"} {
incr trailing_nulls
} else {
break
}
}
if {$trailing_nulls} {
set first_tail_null_posn [expr {[llength $outcols] - $trailing_nulls}]
} else {
set first_tail_null_posn -1
}
#puts stderr "first_tail_null_posn: $first_tail_null_posn"
#puts stderr "colview: [ansistring VIEW $outcols]"
foreach ch $outcols {
#puts "---- [ansistring VIEW $ch]"
set gxleader ""
if {$i < [llength $understacks_gx]} {
#set g0 [tcl::dict::get $understacks_gx $i]
set g0 [lindex $understacks_gx $i]
if {$g0 ne $prev_g0} {
if {$g0 eq [list "gx0_on"]} {
set gxleader "\x1b(0"
} else {
set gxleader "\x1b(B"
}
}
set prev_g0 $g0
} else {
set prev_g0 [list]
}
set sgrleader ""
if {$i < [llength $understacks]} {
#set cstack [tcl::dict::get $understacks $i]
set cstack [lindex $understacks $i]
if {$cstack ne $prevstack} {
if {[llength $prevstack] && ![llength $cstack]} {
#This reset is important e.g testfile fruit.ans - we get overhang on rhs without it. But why is cstack empty?
append sgrleader \033\[m
} else {
append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack]
}
}
set prevstack $cstack
} else {
set prevstack [list]
}
if {$in_overflow} {
if {$i == $overflow_idx} {
set 0 [lindex $understacks_gx $i]
set gxleader ""
if {$g0 eq [list "gx0_on"]} {
set gxleader "\x1b(0"
} elseif {$g0 eq [list "gx0_off"]} {
set gxleader "\x1b(B"
}
append overflow_right $gxleader
set cstack [lindex $understacks $i]
set sgrleader ""
#whether cstack is same or differs from previous char's stack - we must have an output at the start of the overflow_right
#if {[llength $prevstack] && ![llength $cstack]} {
# append sgrleader \033\[m
#}
append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack]
append overflow_right $sgrleader
append overflow_right $ch
} else {
append overflow_right $gxleader
append overflow_right $sgrleader
append overflow_right $ch
}
} else {
if {$overflow_idx != -1 && $i+1 == $overflow_idx} {
#one before overflow
#will be in overflow in next iteration
set in_overflow 1
if {[grapheme_width_cached $ch]> 1} {
#we overflowed with second-half of a double-width char - replace first-half with user-supplied exposition char (should be 1 wide)
set ch $opt_exposed1
}
}
append outstring $gxleader
append outstring $sgrleader
if {$ch eq "\u0000"} {
if {$cp437_glyphs} {
#map all nulls including at tail to space
append outstring " "
} else {
if {$trailing_nulls && $i < $first_tail_null_posn} {
append outstring " " ;#map inner nulls to space
} else {
append outstring \u0000
}
}
} else {
append outstring $ch
}
}
incr i
}
#flower.ans good test for null handling - reverse line building
#review - presence of overflow_right doesn't indicate line's trailing nulls should remain.
#The cells could have been erased?
#if {!$cp437_glyphs} {
# #if {![ansistring length $overflow_right]} {
# # set outstring [tcl::string::trimright $outstring "\u0000"]
# #}
# set outstring [tcl::string::trimright $outstring "\u0000"]
# set outstring [tcl::string::map {\u0000 " "} $outstring]
#}
#REVIEW
#set overflow_right [tcl::string::trimright $overflow_right "\u0000"]
#set overflow_right [tcl::string::map {\u0000 " "} $overflow_right]
set replay_codes ""
if {[llength $understacks] > 0} {
if {$overflow_idx == -1} {
#set tail_idx [tcl::dict::size $understacks]
set tail_idx [llength $understacks]
} else {
set tail_idx [llength $undercols]
}
if {$tail_idx-1 < [llength $understacks]} {
#set replay_codes [join [lindex $understacks $tail_idx-1] ""] ;#tail replay codes
set replay_codes [punk::ansi::codetype::sgr_merge_list {*}[lindex $understacks $tail_idx-1]] ;#tail replay codes
}
if {$tail_idx-1 < [llength $understacks_gx]} {
set gx0 [lindex $understacks_gx $tail_idx-1]
if {$gx0 eq [list "gx0_on"]} {
#if it was on, turn gx0 off at the point we stop processing overlay
append outstring "\x1b(B"
}
}
}
if {[string length $overflow_right]} {
#puts stderr "remainder:$overflow_right"
}
#pdict $understacks
if {[punk::ansi::ta::detect_sgr $outstring]} {
append outstring [punk::ansi::a] ;#without this - we would get for example, trailing backgrounds after rightmost column
#close off any open gx?
#probably should - and overflow_right reopen?
}
if {$opt_returnextra} {
#replay_codes is the codestack at the boundary - used for ellipsis colouring to match elided text - review
#replay_codes_underlay is the set of codes in effect at the very end of the original underlay
#review
#replay_codes_overlay is the set of codes in effect at the very end of the original overlay (even if not all overlay was applied)
#todo - replay_codes for gx0 mode
#overflow_idx may change during ansi & character processing
if {$overflow_idx == -1} {
set overflow_right_column ""
} else {
set overflow_right_column [expr {$overflow_idx+1}]
}
if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} {
set unapplied_ansisplit [list]
}
set result [tcl::dict::create\
result $outstring\
visualwidth [punk::ansi::printing_length $outstring]\
instruction $instruction\
stringlen [string length $outstring]\
overflow_right_column $overflow_right_column\
overflow_right $overflow_right\
unapplied $unapplied\
unapplied_list $unapplied_list\
unapplied_ansisplit $unapplied_ansisplit\
insert_mode $insert_mode\
autowrap_mode $autowrap_mode\
crm_mode $crm_mode\
reverse_mode $reverse_mode\
insert_lines_above $insert_lines_above\
insert_lines_below $insert_lines_below\
cursor_saved_position $cursor_saved_position\
cursor_saved_attributes $cursor_saved_attributes\
cursor_column $cursor_column\
cursor_row $cursor_row\
expand_right $opt_expand_right\
replay_codes $replay_codes\
replay_codes_underlay $replay_codes_underlay\
replay_codes_overlay $replay_codes_overlay\
pm_list $pm_list\
]
if {$opt_returnextra == 1} {
#puts stderr "renderline: $result"
return $result
} else {
#human/debug - map special chars to visual glyphs
set viewop VIEW
switch -- $opt_returnextra {
2 {
#codes and character data
set viewop VIEWCODES ;#ansi colorisation of codes - green for SGR, blue/blue reverse for cursor_save/cursor_restore, cyan for movements, orange for others
}
3 {
set viewop VIEWSTYLE ;#ansi colorise the characters within the output with preceding codes, stacking codes only within each dict value - may not be same SGR effect as the effect in-situ.
}
}
tcl::dict::set result result [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result result]]
tcl::dict::set result overflow_right [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result overflow_right]]
tcl::dict::set result unapplied [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied]]
tcl::dict::set result unapplied_list [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_list]]
tcl::dict::set result unapplied_ansisplit [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_ansisplit]]
tcl::dict::set result replay_codes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes]]
tcl::dict::set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_underlay]]
tcl::dict::set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_overlay]]
tcl::dict::set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result cursor_saved_attributes]]
return $result
}
} else {
#puts stderr "renderline returning: result $outstring instruction $instruction unapplied $unapplied overflow_right $overflow_right"
return $outstring
}
#return [join $out ""]
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace overtype ---}]
}
tcl::namespace::eval overtype::piper {
proc overcentre {args} {
if {[llength $args] < 2} {
error {usage: ?-bias left|right? ?-transparent [0|1|<regexp>]? ?-exposed1 <char>? ?-exposed2 <char>? ?-overflow [1|0]? overtext pipelinedata}
}
lassign [lrange $args end-1 end] over under
set argsflags [lrange $args 0 end-2]
tailcall overtype::centre {*}$argsflags $under $over
}
proc overleft {args} {
if {[llength $args] < 2} {
error {usage: ?-startcolumn <column>? ?-transparent [0|1|<regexp>]? ?-exposed1 <char>? ?-exposed2 <char>? ?-overflow [1|0]? overtext pipelinedata}
}
lassign [lrange $args end-1 end] over under
set argsflags [lrange $args 0 end-2]
tailcall overtype::left {*}$argsflags $under $over
}
}
# -- --- --- --- --- --- --- --- --- --- ---
proc overtype::renderline_transparent {args} {
foreach {under over} [lrange $args end-1 end] break
set argsflags [lrange $args 0 end-2]
set defaults [tcl::dict::create\
-transparent 1\
-exposed 1 " "\
-exposed 2 " "\
]
set newargs [tcl::dict::merge $defaults $argsflags]
tailcall overtype::renderline {*}$newargs $under $over
}
#renderline may not make sense as it is in the long run for blocks of text - but is handy in the single-line-handling form anyway.
# We are trying to handle ansi codes in a block of text which is acting like a mini-terminal in some sense.
#We can process standard cursor moves such as \b \r - but no way to respond to other cursor movements e.g moving to other lines.
#
tcl::namespace::eval overtype::piper {
proc renderline {args} {
if {[llength $args] < 2} {
error {usage: ?-start <int>? ?-transparent [0|1|<regexp>]? ?-overflow [1|0]? overtext pipelinedata}
}
foreach {over under} [lrange $args end-1 end] break
set argsflags [lrange $args 0 end-2]
tailcall overtype::renderline {*}$argsflags $under $over
}
}
interp alias "" piper_renderline "" overtype::piper::renderline
#intended primarily for single grapheme - but will work for multiple
#WARNING: query CAN contain ansi or newlines - but if cache was not already set manually,the answer will be incorrect!
#We deliberately allow this for PM/SOS attached within a column
#(a cache of ansifreestring_width calls - as these are quite regex heavy)
proc overtype::grapheme_width_cached {ch} {
variable grapheme_widths
if {[tcl::dict::exists $grapheme_widths $ch]} {
return [tcl::dict::get $grapheme_widths $ch]
}
set width [punk::char::ansifreestring_width $ch]
tcl::dict::set grapheme_widths $ch $width
return $width
}
proc overtype::test_renderline {} {
set t \uFF5E ;#2-wide tilde
set u \uFF3F ;#2-wide underscore
set missing \uFFFD
return [list $t $u A${t}B]
}
#maintenance warning
#same as textblock::size - but we don't want that circular dependency
#block width and height can be tricky. e.g \v handled differently on different terminal emulators and can affect both
proc overtype::blocksize {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
}
if {[tcl::string::first \t $textblock] >= 0} {
if {[info exists punk::console::tabwidth]} {
set tw $::punk::console::tabwidth
} else {
set tw 8
}
set textblock [textutil::tabify::untabify2 $textblock $tw]
}
#ansistrip on entire block in one go rather than line by line - result should be the same - review - make tests
if {[punk::ansi::ta::detect $textblock]} {
set textblock [punk::ansi::ansistrip $textblock]
}
if {[tcl::string::last \n $textblock] >= 0} {
set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map {\n {}} $textblock]]}] ;#faster than splitting into single-char list
set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]]
} else {
set num_le 0
set width [punk::char::ansifreestring_width $textblock]
}
#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 [dict values [blocksize <data>]] width height
}
tcl::namespace::eval overtype::priv {
variable cache_is_sgr [tcl::dict::create]
#we are likely to be asking the same question of the same ansi codes repeatedly
#caching the answer saves some regex expense - possibly a few uS to lookup vs under 1uS
#todo - test if still worthwhile after a large cache is built up. (limit cache size?)
proc is_sgr {code} {
variable cache_is_sgr
if {[tcl::dict::exists $cache_is_sgr $code]} {
return [tcl::dict::get $cache_is_sgr $code]
}
set answer [punk::ansi::codetype::is_sgr $code]
tcl::dict::set cache_is_sgr $code $answer
return $answer
}
proc render_to_unapplied {overlay_grapheme_control_list gci} {
upvar idx_over idx_over
#-----------------------------------------
#review - this is a lot of copies of the same thing.
# ultimately we want to reduce expensive things like redundant grapheme-splits
# perhaps unapplied_tagged of some sort e.g - {g <grapheme> g <grapheme> code <ansi> pt <text>} ??
upvar unapplied unapplied
upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split
upvar unapplied_ansisplit unapplied_ansisplit ;# pt ?code pt...?
#-----------------------------------------
upvar overstacks overstacks
upvar overstacks_gx overstacks_gx
upvar overlay_grapheme_control_stacks og_stacks
#set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]]
set unapplied ""
set unapplied_list [list]
set unapplied_ansisplit [list ""]
#append unapplied [join [lindex $overstacks $idx_over] ""]
#append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $overstacks $idx_over]]
set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]]
if {$sgr_merged ne ""} {
lappend unapplied_list $sgr_merged
lappend unapplied_ansisplit $sgr_merged ""
}
switch -- [lindex $overstacks_gx $idx_over] {
"gx0_on" {
lappend unapplied_list "\x1b(0"
lappend unapplied_ansisplit "\x1b(0" ""
}
"gx0_off" {
lappend unapplied_list "\x1b(B"
lappend unapplied_ansisplit "\x1b(B" ""
}
}
foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] {
lassign $gc type item
#types g other sgr gx0
switch -- $type {
g {
lappend unapplied_list $item
lset unapplied_ansisplit end [string cat [lindex $unapplied_ansisplit end] $item]
}
gx0 {
if {$item eq "gx0_on"} {
lappend unapplied_list "\x1b(0"
lappend unapplied_ansisplit "\x1b(0" ""
} elseif {$item eq "gx0_off"} {
lappend unapplied_list "\x1b(B"
lappend unapplied_ansisplit "\x1b(B" ""
}
}
default {
lappend unapplied_list $item
lappend unapplied_ansisplit $item ""
}
}
}
if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} {
set unapplied_ansisplit [list]
}
set unapplied [join $unapplied_list ""]
}
#clearer - renders the specific gci forward as unapplied - prefixed with it's merged sgr stack
proc render_this_unapplied {overlay_grapheme_control_list gci} {
upvar idx_over idx_over
#--------------
upvar unapplied unapplied
upvar unapplied_list unapplied_list
upvar unapplied_ansisplit unapplied_ansisplit
#--------------
upvar overstacks overstacks
upvar overstacks_gx overstacks_gx
upvar overlay_grapheme_control_stacks og_stacks
#set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]]
set unapplied ""
set unapplied_list [list]
set unapplied_ansisplit [list ""] ;#remove empty entry at end if nothing added
set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]]
if {$sgr_merged ne ""} {
lappend unapplied_list $sgr_merged
lappend unapplied_ansisplit $sgr_merged ""
}
switch -- [lindex $overstacks_gx $idx_over] {
"gx0_on" {
lappend unapplied_list "\x1b(0"
lappend unapplied_ansisplit "\x1b(0" ""
}
"gx0_off" {
lappend unapplied_list "\x1b(B"
lappend unapplied_ansisplit "\x1b(B" ""
}
}
foreach gc [lrange $overlay_grapheme_control_list $gci end] {
lassign $gc type item
#types g other sgr gx0
switch -- $type {
g {
lappend unapplied_list $item
lset unapplied_ansisplit end [string cat [lindex $unapplied_ansisplit end] $item]
}
gx0 {
if {$item eq "gx0_on"} {
lappend unapplied_list "\x1b(0"
lappend unapplied_ansisplit "\x1b(0" ""
} elseif {$item eq "gx0_off"} {
lappend unapplied_list "\x1b(B"
lappend unapplied_ansisplit "\x1b(B" ""
}
}
default {
lappend unapplied_list $item
lappend unapplied_ansisplit $item ""
}
}
}
if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} {
set unapplied_ansisplit [list]
}
set unapplied [join $unapplied_list ""]
}
proc render_delchar {i} {
upvar outcols o
upvar understacks ustacks
upvar understacks_gx gxstacks
set nxt [llength $o]
if {$i < $nxt} {
set o [lreplace $o $i $i]
set ustacks [lreplace $ustacks $i $i]
set gxstacks [lreplace $gxstacks $i $i]
} elseif {$i == 0 || $i == $nxt} {
#nothing to do
} else {
puts stderr "render_delchar - attempt to delchar at index $i >= number of outcols $nxt - shouldn't happen"
}
}
proc render_erasechar {i count} {
upvar outcols o
upvar understacks ustacks
upvar understacks_gx gxstacks
upvar replay_codes_overlay replay
#ECH clears character attributes from erased character positions
#ECH accepts 0 or empty parameter, which is equivalent to 1. Caller of render_erasechar should do that mapping and only supply 1 or greater.
if {![tcl::string::is integer -strict $count] || $count < 1} {
error "render_erasechar count must be integer >= 1"
}
set start $i
set end [expr {$i + $count -1}]
#we restrict ECH to current line - as some terminals do - review - is that the only way it's implemented?
if {$i > [llength $o]-1} {
return
}
if {$end > [llength $o]-1} {
set end [expr {[llength $o]-1}]
}
set num [expr {$end - $start + 1}]
set o [lreplace $o $start $end {*}[lrepeat $num \u0000]] ;#or space?
#DECECM ???
set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list $replay]]]
set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] ;# ??? review
return
}
proc render_setchar {i c } {
upvar outcols o
lset o $i $c
}
#Initial usecase is for old-terminal hack to add PM-wrapped \b
#review - can be used for other multibyte sequences that occupy one column?
#combiners? diacritics?
proc render_append_to_char {i c} {
upvar outcols o
if {$i > [llength $o]-1} {
error "render_append_to_char cannot append [ansistring VIEW -lf 1 -nul 1 $c] to existing char at index $i while $i >= llength outcols [llength $o]"
}
set existing [lindex $o $i]
if {$existing eq "\0"} {
lset o $i $c
} else {
lset o $i $existing$c
}
}
#is actually addgrapheme?
proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} {
upvar outcols o
upvar understacks ustacks
upvar understacks_gx gxstacks
# -- --- ---
#this is somewhat of a hack.. probably not really the equivalent of proper reverse video? review
#we should ideally be able to reverse the video of a sequence that already includes SGR reverse/noreverse attributes
upvar reverse_mode do_reverse
#if {$do_reverse} {
# lappend sgrstack [a+ reverse]
#} else {
# lappend sgrstack [a+ noreverse]
#}
#JMN3
if {$do_reverse} {
#note we can't just look for \x1b\[7m or \x1b\[27m
# it may be a more complex sequence like \x1b\[0\;\;7\;31m etc
set existing_reverse_state 0
set codeinfo [punk::ansi::codetype::sgr_merge $sgrstack -info 1]
set codestate_reverse [dict get $codeinfo codestate reverse]
switch -- $codestate_reverse {
7 {
set existing_reverse_state 1
}
27 {
set existing_reverse_state 0
}
"" {
}
}
if {$existing_reverse_state == 0} {
set rflip [a+ reverse]
} else {
#reverse of reverse
set rflip [a+ noreverse]
}
#note that mergeresult can have multiple esc (due to unmergeables or non sgr codes)
set sgrstack [list [dict get $codeinfo mergeresult] $rflip]
#set sgrstack [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]]
}
# -- --- ---
set nxt [llength $o]
if {!$insert_mode} {
if {$i < $nxt} {
#These lists must always be in sync
lset o $i $c
} else {
lappend o $c
}
if {$i < [llength $ustacks]} {
lset ustacks $i $sgrstack
lset gxstacks $i $gx0stack
} else {
lappend ustacks $sgrstack
lappend gxstacks $gx0stack
}
} else {
#insert of single-width vs double-width when underlying is double-width?
if {$i < $nxt} {
#set o [linsert $o $i $c]
#JMN insert via ledit
ledit o $i $i-1 $c
} else {
lappend o $c
}
if {$i < [llength $ustacks]} {
#set ustacks [linsert $ustacks $i $sgrstack]
#set gxstacks [linsert $gxstacks $i $gx0stack]
#insert via ledit
ledit ustacks $i $i-1 $sgrstack
ledit gxstacks $i $i-1 $gx0stack
} else {
lappend ustacks $sgrstack
lappend gxstacks $gx0stack
}
}
}
}
# -- --- --- --- --- --- --- --- --- --- ---
tcl::namespace::eval overtype {
interp alias {} ::overtype::center {} ::overtype::centre
}
namespace eval ::punk::args::register {
#use fully qualified so 8.6 doesn't find existing var in global namespace
lappend ::punk::args::register::NAMESPACES ::overtype ::overtype::argdoc
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide overtype [tcl::namespace::eval overtype {
variable version
set version 999999.0a1.0
}]
return
#*** !doctools
#[manpage_end]