# <20211029.1209.34>

# fillTextWindow w var_string ?tag?
# tag, if coded is added to each text window insert
# If there are no overstrikes in the string, we just do the insert.
# Otherwise we call the fillTextWindowOverstrike code which normally
# would not be loaded.
# return false if overstrikes are processed
# return true  if no noverstrikes processed

set ESC \u001b
namespace eval ::overstrike {}

proc fillTextWindow {w var_string {tag {}}} {
  upvar $var_string string
  if {[string first "\b" $string] == -1 &&\
	  [string first "${::ESC}\[" $string] == -1} {
    $w insert insert $string [list {*}$tag]
    return 0
  }
  fillTextWindowOverstrike $w string tag $tag
  return 1
}
# first, here is a routine to parse the config(overstrike,*) code.
# The result is a set of bold & italic ops to be combined with the
# font and insert tags when doing overstrike. This code populates the
# overstrike namespace with its results.
#

proc parseConfigOverstrike {} {
  variable ::overstrike::boldOps
  variable ::overstrike::italicOps
  variable ::overstrike::boldItalicOps
  
  if {![info exists boldOps] || ![info exists italicOps]} {
    
    foreach overType {bold italic boldItalic} {
      set ${overType}FontOps {}
      set ${overType}TagOps  {}
      
      foreach {option value} $::config(overstrike,$overType) {
	# frputs option value
	if {$option in {size weight slant underline}} {
	  if {"-$option" ni [set ${overType}FontOps]} {
	    lappend ${overType}FontOps -$option $value
	    # frputs  ${overType}FontOps
	    continue
	  }
	}
	if {$option in {underline background foreground borderwidth relief} &&\
		"-$option" ni [set ${overType}TagOps]} {
	  lappend ${overType}TagOps "-$option" $value
	  # frputs  ${overType}TagOps
	  continue
	}
	# If we get here we have an unrecognized option
	PopWarn "config(overstrike,$overType) option $option unrecognized!"
      }
      set ${overType}Ops [list [set ${overType}FontOps] [set ${overType}TagOps]]
    }
  }
  return [list bold $boldOps italic $italicOps boldItalic $boldItalicOps]
}

# args should be a set of doublets from the following
# all these are optional but see below
#
# tags  tag list to be applied to all inserts
# bold       [list <bold font ops>       <bold tag ops>
# italic     [list <italic font ops>     <italic tag ops>
# boldItalic [list <boldItalic font ops> <boldItalic tag ops>
#
# If only one of bold or italic is supplied and the "string" requests
# the un-supplied one an error is thrown.
# If neither is supplied, the parsed values are used (if they don't
# yet exist, the parse routine is called to build them.

# For histerical reasons we call this encoding 'overstrike', however,
# we also handle terminal ESC encoding as used in man pages (i.e. a
# small subset of the possible ESC codes).
# This is the subset we "handle" with meaning (these are VT102 codes):
#
# ESC[<code><eos>       <code> is one or more integers seperated with {;}
#                              characters (i.e. 10;1}
#                       <eos>  is in [a-zA-z]
# ESC[=<code><eos>
#
# By "handle" we mean that we will remove all such sequences. We "act"
# on a subset of these. Those that do not start with "ESC[=" and which
# contain the following codes:

#   <code>  meaning
#     0     reset or stop all special encoding
#     1     Start Bold
#     4     Start Underline
#     22    normal intensity (or stop Bold)
#     24    Stop Underline
#
# These <code>s may be combined with {;}s between the codes, thus
# ESC[1;4m would start bold and underline
#

proc fillTextWindowOverstrike {w var_string args} {
  variable ::overstrike::boldOps
  variable ::overstrike::italicOps
  variable ::overstrike::boldItalicOps

  lassign {} overOps(tags) overOps(bold) overOps(italic) overOps(boldItalic)
  
  array set overOps $args
  if {$overOps(bold) == {} && $overOps(italic) == {}} {
    array set overOps [parseConfigOverstrike]
  }
  # create the fonts and configure them
  set cfont [$w cget -font]
  foreach overType {bold italic boldItalic} {
    lassign $overOps($overType) ${overType}FontOps ${overType}TagOps
    array set font [font actual $cfont]
    # This is a bit messy, but the font size is to be added to the current, so...
    set fsize $font(-size)
    set font(-size) 0
    array set font [set ${overType}FontOps]
    set font(-size) [expr {$font(-size) + $fsize}]
    if {[catch {font create {*}[array get font] } ${overType}ViewFont] != 0} {
      PopWarn "Error [set ${overType}ViewFont] trying to create \"[array get font] \" "
    }
    # now do the tags
    if {[catch {$w tag configure ${overType}Tag\
		    -font [set ${overType}ViewFont]\
		    {*}[set ${overType}TagOps]} er] != 0} {
      PopWarn "Error $er trying to apply ${overType}TagOps to ${overType}Tag"
    }
    #frputs ${overType}TagOps ${overType}FontOps 
  }
  #
  upvar $var_string string
  set stringLen [string length $string]
  # We will use ESC mode if we find at least one 'ESC['
  if {[string first "${::ESC}\[" $string] == -1} {
    doBackSpaceMode
  } else {
    doEscMode
  }
  # we delete the fonts now but they will live on until the window is deleted
  font delete $boldViewFont $italicViewFont
}

proc doBackSpaceMode {} {
  variable ::overstrike::boldOps
  variable ::overstrike::italicOps
  variable ::overstrike::boldItalicOps

  upvar string string
  upvar stringLen stringLen
  upvar overOps overOps
  upvar w w
  set curSindex 0
  while {$curSindex  < $stringLen} {
    set pos [string first \b $string $curSindex]
    if {$pos == -1} {
      $w insert insert [string range $string $curSindex end] {*}$overOps(tags)
      break
    }
    $w insert insert [string range $string $curSindex $pos-2] {*}$overOps(tags)
    
    $w insert insert [string index $string $pos+1] \
	[list [expr {[string index $string $pos-1] == "_" ? "italicTag" : "boldTag"}]\
	     {*}$overOps(tags)]
    set curSindex [expr {$pos + 2}]
  }
}

proc doEscMode {} {
  variable ::overstrike::boldOps
  variable ::overstrike::italicOps
  variable ::overstrike::boldItalicOps

  upvar string string
  upvar stringLen stringLen
  upvar overOps overOps
  upvar w w
  set curSindex 0
  set bold 0
  set italic 0
  while {$curSindex  < $stringLen} {
    set curTags [list {*}$overOps(tags)]
    switch -exact ${bold}$italic {
      10 {lappend curTags boldTag}
      01 {lappend curTags italicTag}
      11 {lappend curTags boldItalicTag}
    }
    # frputs curTags bold italic
    set pos [string first "${::ESC}\[" $string $curSindex]
    if {$pos == -1} {
      # done, flush the final bit
      $w insert insert [string range $string $curSindex end] $curTags
      break
    }
    $w insert insert [string range $string $curSindex $pos-1] $curTags
    # set up the new tags... first find the end...
    # to speed this up we will restrict the search on the assumption
    # (from the console man page) that there at at most 16 parms
    # each parm may be up to 2 digits and a separator (48 total)
    if {![regexp {([0-9=\;]*)([a-zA-Z]).*} \
	      [string range $string $pos+2 $pos+50] -> code term]} {
      PopWarn "Can not parse '[string range $string $pos $pos+50]'\
               \nStopping the music."
      return
    }
    set curSindex [expr {$pos + 3 + [string length $code]}]
    # frputs code term 
    if {$term != "m"} {continue}
    set codeList [split $code {\;}]
    set bold [set italic 0]
    foreach codeEl $codeList {
      switch -exact $codeEl {
	0   {set bold [set italic 0]}
	1   {set bold 1}
	4   {set italic 1}
	22  {set bold 0}
	24  {set italic 0}
	default {continue}
      }
    }
  }
}
