_text.tcl

Go to the documentation of this file.

/*  -*- tcl -*-*/
/* */
/*  _text.tcl -- Core support for text engines.*/


/* */

if {0} {
    catch {rename ret  proc__} msg ; puts_stderr >>$msg
    proc__ proc (type cmd , type argl , type body) {
    puts_stderr "proc $cmd $argl ..."
    uplevel [list proc__ $cmd $argl $body]
    }
}

dt_package textutil::string ; /*  for adjust*/
dt_package textutil::repeat
dt_package textutil::adjust

if {0} {
    puts_stderr ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    rename ret  {}
    rename proc__ proc
    puts_stderr ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
}


################################################################
# Formatting constants ... Might be engine variables in the future.

global lmarginIncrement ; set lmarginIncrement 4
global rmarginThreshold ; set rmarginThreshold 20
global bulleting        ; set bulleting        (* - # @ ~ %)
global enumeration      ; set enumeration      {[%] (%) <%>}

ret  Bullet (type ivar) {
    global bulleting ; upvar $ivar i
    set res [lindex $bulleting $i]
    set i [expr {($i + 1) % [llength $bulleting]}]
    return $res
}

ret  EnumBullet (type ivar) {
    global enumeration ; upvar $ivar i
    set res [lindex $enumeration $i]
    set i [expr {($i + 1) % [llength $enumeration]}]
    return $res
}

/* */

/* */
/*  The engine maintains several data structures per document and pass.*/
/*  Most important is an internal representation of the text better*/
/*  suited to perform the final layouting, the display list. Elements of*/
/*  the display list are lists containing 2 elements, an operation, and*/
/*  its arguments, in this order. The arguments are a list again, its*/
/*  contents are specific to the operation.*/
/* */
/*  The operations are:*/
/* */
/*  - SECT  Section.    Title.*/
/*  - SUBSECT     Subsection. Title.*/
/*  - PARA  Paragraph.  Environment reference and text.*/
/* */
/*  The PARA operation is the workhorse of the engine, dooing all the*/
/*  formatting, using the information in an "environment" as the guide*/
/*  for doing so. The environments themselves are generated during the*/
/*  second pass through the contents. They contain the information about*/
/*  nesting (i.e. indentation), bulleting and the like.*/
/* */

global cmds ;  cmds =  [list]   ; /*  Display list*/
global pEnv ; array  pEnv =  {} ; /*  Defined paragraph environments (bulleting, indentation, other).*/
global para ;  para =  ""       ; /*  Text buffer for paragraphs.*/

global nextId     ;        nextId =      0      ; /*  Counter for environment generation.*/
global currentId  ;        currentId =   {}     ; /*  Id of current environment in 'pEnv'*/
global currentEnv ; array  currentEnv =  {}     ; /*  Current environment, expanded form.*/
global contexts   ;        contexts =    [list] ; /*  Stack of saved environments.*/
global off        ;  off =    1                 ; /*  Supression of plain text in some places.*/

/* */
/*  Management of the current context.*/

ret  Text  (type text)    {global para ; append para $text ; return}
ret  Store (type op , type args) {global cmds ; lappend cmds [list $op $args] ; return}
ret  Off   ()        {global off ; set off 1 ; return}
ret  On    ()        {global off para ; set off 0 ; set para "" ; return}
ret  IsOff ()        {global off ; return [expr {$off == 1}]}

/*  Debugging ...*/
/* proc Text  {text}    {puts_stderr "TXT \{$text\}"; global para; append para $text ; return}*/
/* proc Store {op args} {puts_stderr "STO $op $args"; global cmds; lappend cmds [list $op $args]; return}*/
/* proc Off   {}        {puts_stderr OFF ; global off ; set off 1 ; return}*/
/* proc On    {}        {puts_stderr ON_ ; global off para ; set off 0 ; set para "" ; return}*/


ret  NewEnv (type name , type script) {
    global currentId  nextId currentEnv

    #puts_stderr "NewEnv ($name)"

    set    parentId  $currentId
    set    currentId $nextId
    incr              nextId

    append currentEnv(NAME) -$parentId-$name
    set currentEnv(parent) $parentId
    set currentEnv(id)     $currentId

    # Always squash a verbatim environment inherited from the previous
    # environment ...
    catch {unset currentEnv(verbenv)}

    uplevel $script
    SaveEnv
    return $currentId
}

/* */

ret  TextInitialize () {
    global off  ; set off 1
    global cmds ; set cmds [list]   ; # Display list
    global pEnv ; array set pEnv {} ; # Defined paragraph environments (bulleting, indentation, other).
    global para ; set para ""       ; # Text buffer for paragraphs.

    global nextId     ; set       nextId     0      ; # Counter for environment generation.
    global currentId  ; set       currentId  {}     ; # Id of current environment in 'pEnv'
    global currentEnv ; array set currentEnv {}     ; # Current environment, expanded form.
    global contexts   ; set       contexts   [list] ; # Stack of saved environments.

    # lmargin  = location of left margin for text.
    # prefix   = prefix string to use for all lines.
    # wspfx    = whitespace prefix for all but the first line
    # listtype = type of list, if any
    # bullet   = bullet to use for unordered, bullet template for ordered.
    # verbatim = flag if verbatim formatting requested.
    # next     = if present the environment to use after closing the paragraph using this one.

    NewEnv Base {
    array set currentEnv {
        lmargin     0
        prefix      {}
        wspfx       {}
        listtype    {}
        bullet      {}
        verbatim    0
        bulleting   0
        enumeration 0
    }
    }
    return
}

/* */

ret  Section    (type name) {Store SECT    $name ; return}
ret  Subsection (type name) {Store SUBSECT $name ; return}

ret  CloseParagraph (optional id ={)} {
    global para currentId
    if {$para != {}} {
    if {$id == {}} { id =  $currentId}
    Store PARA $id $para
    /* puts_stderr "CloseParagraph $id"*/
    }
     para =  ""
    return
} 

ret  SaveContext () {
    global  contexts  currentId
    lappend contexts $currentId

    #global currentEnv ; puts_stderr "Save>> $currentId ($currentEnv(NAME))"
    return
}

ret  RestoreContext () {
    global                contexts
    SetContext   [lindex $contexts end]
    set contexts [lrange $contexts 0 end-1]

    #global currentId currentEnv ; puts_stderr "<<Restored $currentId ($currentEnv(NAME))"
    return
}

ret  SetContext (type id) {
    global    currentId currentEnv pEnv
    set       currentId $id

    # Ensure that array is clean before setting hte new block of
    # information.
    unset     currentEnv
    array set currentEnv $pEnv($currentId)

    #puts_stderr "--Set $currentId ($currentEnv(NAME))"
    return
}

ret  SaveEnv () {
    global pEnv  currentId             currentEnv
    set    pEnv($currentId) [array get currentEnv]
    return
}

/* */

ret  NewVerbatim () {
    global currentEnv
    return [NewEnv Verbatim {set currentEnv(verbatim) 1}]
}

ret  Verbatim () {
    global currentEnv
    if {![info exists currentEnv(verbenv)]} {
    SaveContext
    set verb [NewVerbatim]
    RestoreContext

    # Remember verbatim mode in the base environment
    set currentEnv(verbenv) $verb
    SaveEnv
    }
    return $currentEnv(verbenv)
}

/* */

ret  text_plain_text (type text) {
    #puts_stderr "<<text_plain_text>>"

    if  {[IsOff]} {return}

    # Note: Whenever we get plain text it is possible that a macro for
    # visual markup actually generated output before the expander got
    # to the current text. This output was captured by the expander in
    # its current context. Given the current organization of the
    # engine we have to retrieve this formatted text from the expander
    # or it will be lost. This is the purpose of the 'ctopandclear',
    # which retrieves the data and also clears the capture buffer. The
    # latter to prevent us from retrieving it again later, after the
    # next macro added more data.

    set text [ex_ctopandclear]$text

    # ... TODO ... Handling of example => verbatim

    if {[string length [string trim $text]] == 0} return

    Text $text
    return
}

/* */

ret  text_postprocess (type text) {

    #puts_stderr XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    #puts_stderr <<$text>>
    #puts_stderr XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

    global cmds
    # The argument is not relevant. Access the display list, perform
    # the final layouting and return its result.

    set linebuffer [list]
    array set state {lmargin 0 rmargin 0}
    foreach cmd $cmds {
    foreach {op arguments} $cmd break
    $op $arguments
    }

    #puts_stderr XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

    return [join $linebuffer \n]
}


ret  SECT (type text) {
    upvar linebuffer linebuffer

    # text is actually the list of arguments, having one element, the text.
    set text [lindex $text 0]
    #puts_stderr "SECT $text"
    #puts_stderr ""

    # Write section title, underline it

    lappend linebuffer ""
    lappend linebuffer $text
    lappend linebuffer [textutil::repeat::strRepeat = [string length $text]]
    return
}

ret  SUBSECT (type text) {
    upvar linebuffer linebuffer

    # text is actually the list of arguments, having one element, the text.
    set text [lindex $text 0]
    #puts_stderr "SUBSECT $text"
    #puts_stderr ""

    # Write subsection title, underline it (with less emphasis)

    lappend linebuffer ""
    lappend linebuffer $text
    lappend linebuffer [textutil::repeat::strRepeat - [string length $text]]
    return
}

ret  PARA (type arguments) {
    global pEnv
    upvar linebuffer linebuffer

    foreach {env text} $arguments break
    array set para $pEnv($env)

    #puts_stderr "PARA $env"
    #parray_stderr para
    #puts_stderr "     \{$text\}"
    #puts_stderr ""

    # Use the information in the referenced environment to format the paragraph.

    if {$para(verbatim)} {
    set text [textutil::adjust::undent $text]
    } else {
    # The size is determined through the set left and right margins
    # right margin is fixed at 80, left margin is variable. Size
    # is at least 20. I.e. when left margin > 60 right margin is
    # shifted out to the right.

    set size [expr {80 - $para(lmargin)}]
    if {$size < 20} {set size 20}

    set text [textutil::adjust::adjust $text -length $size]
    }

    # Now apply prefixes, (ws prefixes bulleting), at last indentation.

    if {[string length $para(prefix)] > 0} {
    set text [textutil::adjust::indent $text $para(prefix)]
    }

    if {$para(listtype) != {}} {
    switch -exact $para(listtype) {
        bullet {
        # Indent for bullet, but not the first line. This is
        # prefixed by the bullet itself.

        set thebullet $para(bullet)
        }
        enum {
        # Handling the enumeration counter. Special case: An
        # example as first paragraph in an item has to use the
        # counter in environment it is derived from to prevent
        # miscounting.

        if {[info exists para(example)]} {
            set parent $para(parent)
            array set __ $pEnv($parent)
            if {![info exists __(counter)]} {
            set __(counter) 1
            } else {
            incr __(counter)
            }
            set pEnv($parent) [array get __] ; # Save context change ...
            set n $__(counter)
        } else {
            if {![info exists para(counter)]} {
            set para(counter) 1
            } else {
            incr para(counter)
            }
            set pEnv($env) [array get para] ; # Save context change ...
            set n $para(counter)
        }

        set thebullet [string map [list % $n] $para(bullet)]
        }
    }

    set blen [string length $thebullet]
    if {$blen >= [string length $para(wspfx)]} {
        set text    "$thebullet\n[textutil::adjust::indent $text $para(wspfx)]"
    } else {
        set fprefix $thebullet[string range $para(wspfx) $blen end]
        set text    "${fprefix}[textutil::adjust::indent $text $para(wspfx) 1]"
    }
    }

    if {$para(lmargin) > 0} {
    set text [textutil::adjust::indent $text \
              [textutil::repeat::strRepeat " " $para(lmargin)]]
    }

    lappend linebuffer ""
    lappend linebuffer $text
    return
}

/* */

ret  strong      (type text) {return *${text}*}
ret  em          (type text) {return _${text}_}

/* */

ret  parray_stderr (type a , optional pattern =*) {
    upvar 1 $a array
    if {![array exists array]} {
        error "\"$a\" isn't an array"
    }
    set maxl 0
    foreach name [lsort [array names array $pattern]] {
        if {[string length $name] > $maxl} {
            set maxl [string length $name]
        }
    }
    set maxl [expr {$maxl + [string length $a] + 2}]
    foreach name [lsort [array names array $pattern]] {
        set nameString [format %s(%s) $a $name]
        puts_stderr "    [format "%-*s = {%s}" $maxl $nameString $array($name)]"
    }
}

/* */