# $Id: stylecodes.tcl 18 2006-10-24 00:38:28Z kostix $

namespace eval stylecodes {
    variable options

    ::custom::defgroup Stylecodes \
	[::msgcat::mc "Handling of \"stylecodes\".\
		       Stylecodes are (groups of) special formatting symbols\
		       used to emphasize parts of the text by setting them\
		       with boldface, italics or underlined styles,\
		       or as combinations of these."] \
	-group {Rich Text} \
	-group Chat

    ::custom::defvar options(emphasize) 1 \
	[::msgcat::mc "Emphasize stylecoded messages using different fonts."] \
	-type boolean -group Stylecodes \
	-command [namespace current]::update_config

    ::custom::defvar options(hide_markup) 1 \
	[::msgcat::mc "Hide characters comprising stylecode markup."] \
	-type boolean -group Stylecodes \
	-command [namespace current]::update_config
}



proc stylecodes::process_stylecodes {atLevel accName} {
    upvar #$atLevel $accName chunks

    set out {}

    foreach {s type tags} $chunks {
	if {$type != "text"} {
	    # pass through
	    lappend out $s $type $tags
	    continue
	}

	foreach elem [scan_stylecodes $s $type $tags {* / _ -}] {
	    lappend out $elem
	}
    }

    set chunks $out
}



proc stylecodes::scan_stylecodes {what type tags stylecodes} {
    set len [string length $what]

    set out {}
    set si 0

    for {set ix 0} {$ix < $len} {incr ix} {
	set startOK true

	set sc [spot_highlight $what $stylecodes ix startOK]

	if {$sc == {}} continue

	lassign $sc ls le ms me rs re pat

	if {$ls - $si > 0} {
	    # dump the text before opening stylecode block:
	    lappend out [string range $what $si [expr {$ls - 1}]] $type $tags
	}

	set sctags [stylecodes->tags $pat]

	# dump opening stylecode block:
	lappend out [string range $what $ls $le] stylecode [lfuse $tags $sctags]

	# dump highlighted text:
	lappend out [string range $what $ms $me] $type [lfuse $tags $sctags]

	# dump closing stylecode block:
	lappend out [string range $what $rs $re] stylecode [lfuse $tags $sctags]

	set si $ix
    }

    if {[string length $what] - $si > 0} {
	lappend out [string range $what $si end] $type $tags
    }

    return $out
}



proc stylecodes::spot_highlight {what stylecodes ixVar startOKVar} {
    upvar 1 $ixVar ix $startOKVar startOK

    set ls $ix
    set pattern {}

    while {[eat_stylecode $what $ix stylecodes pattern startOK]} {
	incr ix
    }
	
    set startOK false

    if {$ix == $ls} return
    if {[is_scbreak [string index $what $ix]]} return ;# stylecode break after stylecode

    # found opening stylecode block.
    # create pattern for ending stylecode block and seek for it:

    set pat [join $pattern ""]
    set rs [string first $pat $what $ix]
    if {$rs == -1} { return {} }

    # found closing stylecode block.

    if {$rs - $ix == 0} { return {} } ;# empty highlight

    if {[is_scbreak [string index $what [expr {$rs - 1}]]]} {
	# stylecode break before
	return
    }

    if {[string first \n [string range $what $ix $rs]] != -1} {
	# intervening newline
	return {}
    }

    set patlen [string length $pat]

    if {![is_scbreak [string index $what [expr {$rs + $patlen}]]]} {
	# no proper break after closing stylecode block
	return {}
    }

    set le [expr {$ls + $patlen - 1}]
    set ms [expr {$ls + $patlen}]
    set me [expr {$rs - 1}]
    set re [expr {$rs + $patlen - 1}]

    # skip past the closing stylecode block
    set ix [expr {$re + 1}]

    return [list $ls $le \
		 $ms $me \
		 $rs $re \
		 $pat]
}

proc stylecodes::eat_stylecode {what at scodesVar patVar startOKVar} {
    upvar 1 $scodesVar scodes $patVar pat $startOKVar startOK

    set ix 0
    set c [string index $what $at]

    foreach sc $scodes {
	if {$c == $sc} {
	    if {!$startOK} { return false }
	    set scodes [lreplace $scodes $ix $ix]
	    set pat [linsert $pat 0 $c]
	    return true
	}

	incr ix
    }

    set startOK [is_scbreak $c]

    return false
}

proc stylecodes::is_scbreak {c} {
    expr {[string is space $c] || [string is punct $c]}
}

proc stylecodes::stylecodes->tags {pattern} {
    set out {}
    array set tags {* bold
		    / italic
		    _ underlined
		    - overstricken}
	
    foreach sc [split $pattern ""] {
	lappend out $tags($sc)
    }

    return $out
}

proc stylecodes::render_stylecode {w type piece tags} {
    $w insert end $piece \
	[richtext::fixup_tags [concat $type $tags] {{bold italic}}]
}

proc stylecodes::configure_richtext_widget {w} {
    variable options

    if {$options(emphasize)} {
	$w tag configure stylecode -elide $options(hide_markup)
	$w tag configure bold -font $::ChatBoldFont
	$w tag configure italic -font $::ChatItalicFont
	$w tag configure bold_italic -font $::ChatBoldItalicFont
	$w tag configure underlined -underline 1
	$w tag configure overstricken -overstrike 1
    } else {
	$w tag configure stylecode -elide 0
	$w tag configure bold -font $::ChatFont
	$w tag configure italic -font $::ChatFont
	$w tag configure bold_italic -font $::ChatFont
	$w tag configure underlined -underline 0
	$w tag configure overstricken -overstrike 0
    }
}

proc stylecodes::update_config {args} {
    foreach w [::richtext::textlist] {
	configure_richtext_widget $w
    }
}

namespace eval stylecodes {
    ::richtext::register_entity stylecode \
	-configurator [namespace current]::configure_richtext_widget \
	-parser [namespace current]::process_stylecodes \
	-renderer [namespace current]::render_stylecode \
	-parser-priority 80

    ::richtext::entity_state stylecode 1
}

# vim:ts=8:sts=4:sw=4:noet
