1# -*- tcl -*- 2# 3# _text.tcl -- Core support for text engines. 4 5 6################################################################ 7 8if {0} { 9 catch {rename proc proc__} msg ; puts_stderr >>$msg 10 proc__ proc {cmd argl body} { 11 puts_stderr "proc $cmd $argl ..." 12 uplevel [list proc__ $cmd $argl $body] 13 } 14} 15 16dt_package textutil::string ; # for adjust 17dt_package textutil::repeat 18dt_package textutil::adjust 19 20if {0} { 21 puts_stderr ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 22 rename proc {} 23 rename proc__ proc 24 puts_stderr ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 25} 26 27 28################################################################ 29# Formatting constants ... Might be engine variables in the future. 30 31global lmarginIncrement ; set lmarginIncrement 4 32global rmarginThreshold ; set rmarginThreshold 20 33global bulleting ; set bulleting {* - # @ ~ %} 34global enumeration ; set enumeration {[%] (%) <%>} 35 36proc Bullet {ivar} { 37 global bulleting ; upvar $ivar i 38 set res [lindex $bulleting $i] 39 set i [expr {($i + 1) % [llength $bulleting]}] 40 return $res 41} 42 43proc EnumBullet {ivar} { 44 global enumeration ; upvar $ivar i 45 set res [lindex $enumeration $i] 46 set i [expr {($i + 1) % [llength $enumeration]}] 47 return $res 48} 49 50################################################################ 51 52# 53# The engine maintains several data structures per document and pass. 54# Most important is an internal representation of the text better 55# suited to perform the final layouting, the display list. Elements of 56# the display list are lists containing 2 elements, an operation, and 57# its arguments, in this order. The arguments are a list again, its 58# contents are specific to the operation. 59# 60# The operations are: 61# 62# - SECT Section. Title. 63# - SUBSECT Subsection. Title. 64# - PARA Paragraph. Environment reference and text. 65# 66# The PARA operation is the workhorse of the engine, dooing all the 67# formatting, using the information in an "environment" as the guide 68# for doing so. The environments themselves are generated during the 69# second pass through the contents. They contain the information about 70# nesting (i.e. indentation), bulleting and the like. 71# 72 73global cmds ; set cmds [list] ; # Display list 74global pEnv ; array set pEnv {} ; # Defined paragraph environments (bulleting, indentation, other). 75global para ; set para "" ; # Text buffer for paragraphs. 76 77global nextId ; set nextId 0 ; # Counter for environment generation. 78global currentId ; set currentId {} ; # Id of current environment in 'pEnv' 79global currentEnv ; array set currentEnv {} ; # Current environment, expanded form. 80global contexts ; set contexts [list] ; # Stack of saved environments. 81global off ; set off 1 ; # Supression of plain text in some places. 82 83################################################################ 84# Management of the current context. 85 86proc Text {text} {global para ; append para $text ; return} 87proc Store {op args} {global cmds ; lappend cmds [list $op $args] ; return} 88proc Off {} {global off ; set off 1 ; return} 89proc On {} {global off para ; set off 0 ; set para "" ; return} 90proc IsOff {} {global off ; return [expr {$off == 1}]} 91 92# Debugging ... 93#proc Text {text} {puts_stderr "TXT \{$text\}"; global para; append para $text ; return} 94#proc Store {op args} {puts_stderr "STO $op $args"; global cmds; lappend cmds [list $op $args]; return} 95#proc Off {} {puts_stderr OFF ; global off ; set off 1 ; return} 96#proc On {} {puts_stderr ON_ ; global off para ; set off 0 ; set para "" ; return} 97 98 99proc NewEnv {name script} { 100 global currentId nextId currentEnv 101 102 #puts_stderr "NewEnv ($name)" 103 104 set parentId $currentId 105 set currentId $nextId 106 incr nextId 107 108 append currentEnv(NAME) -$parentId-$name 109 set currentEnv(parent) $parentId 110 set currentEnv(id) $currentId 111 112 # Always squash a verbatim environment inherited from the previous 113 # environment ... 114 catch {unset currentEnv(verbenv)} 115 116 uplevel $script 117 SaveEnv 118 return $currentId 119} 120 121################################################################ 122 123proc TextInitialize {} { 124 global off ; set off 1 125 global cmds ; set cmds [list] ; # Display list 126 global pEnv ; array set pEnv {} ; # Defined paragraph environments (bulleting, indentation, other). 127 global para ; set para "" ; # Text buffer for paragraphs. 128 129 global nextId ; set nextId 0 ; # Counter for environment generation. 130 global currentId ; set currentId {} ; # Id of current environment in 'pEnv' 131 global currentEnv ; array set currentEnv {} ; # Current environment, expanded form. 132 global contexts ; set contexts [list] ; # Stack of saved environments. 133 134 # lmargin = location of left margin for text. 135 # prefix = prefix string to use for all lines. 136 # wspfx = whitespace prefix for all but the first line 137 # listtype = type of list, if any 138 # bullet = bullet to use for unordered, bullet template for ordered. 139 # verbatim = flag if verbatim formatting requested. 140 # next = if present the environment to use after closing the paragraph using this one. 141 142 NewEnv Base { 143 array set currentEnv { 144 lmargin 0 145 prefix {} 146 wspfx {} 147 listtype {} 148 bullet {} 149 verbatim 0 150 bulleting 0 151 enumeration 0 152 } 153 } 154 return 155} 156 157################################################################ 158 159proc Section {name} {Store SECT $name ; return} 160proc Subsection {name} {Store SUBSECT $name ; return} 161 162proc CloseParagraph {{id {}}} { 163 global para currentId 164 if {$para != {}} { 165 if {$id == {}} {set id $currentId} 166 Store PARA $id $para 167 #puts_stderr "CloseParagraph $id" 168 } 169 set para "" 170 return 171} 172 173proc SaveContext {} { 174 global contexts currentId 175 lappend contexts $currentId 176 177 #global currentEnv ; puts_stderr "Save>> $currentId ($currentEnv(NAME))" 178 return 179} 180 181proc RestoreContext {} { 182 global contexts 183 SetContext [lindex $contexts end] 184 set contexts [lrange $contexts 0 end-1] 185 186 #global currentId currentEnv ; puts_stderr "<<Restored $currentId ($currentEnv(NAME))" 187 return 188} 189 190proc SetContext {id} { 191 global currentId currentEnv pEnv 192 set currentId $id 193 194 # Ensure that array is clean before setting hte new block of 195 # information. 196 unset currentEnv 197 array set currentEnv $pEnv($currentId) 198 199 #puts_stderr "--Set $currentId ($currentEnv(NAME))" 200 return 201} 202 203proc SaveEnv {} { 204 global pEnv currentId currentEnv 205 set pEnv($currentId) [array get currentEnv] 206 return 207} 208 209################################################################ 210 211proc NewVerbatim {} { 212 global currentEnv 213 return [NewEnv Verbatim {set currentEnv(verbatim) 1}] 214} 215 216proc Verbatim {} { 217 global currentEnv 218 if {![info exists currentEnv(verbenv)]} { 219 SaveContext 220 set verb [NewVerbatim] 221 RestoreContext 222 223 # Remember verbatim mode in the base environment 224 set currentEnv(verbenv) $verb 225 SaveEnv 226 } 227 return $currentEnv(verbenv) 228} 229 230################################################################ 231 232proc text_plain_text {text} { 233 #puts_stderr "<<text_plain_text>>" 234 235 if {[IsOff]} {return} 236 237 # Note: Whenever we get plain text it is possible that a macro for 238 # visual markup actually generated output before the expander got 239 # to the current text. This output was captured by the expander in 240 # its current context. Given the current organization of the 241 # engine we have to retrieve this formatted text from the expander 242 # or it will be lost. This is the purpose of the 'ctopandclear', 243 # which retrieves the data and also clears the capture buffer. The 244 # latter to prevent us from retrieving it again later, after the 245 # next macro added more data. 246 247 set text [ex_ctopandclear]$text 248 249 # ... TODO ... Handling of example => verbatim 250 251 if {[string length [string trim $text]] == 0} return 252 253 Text $text 254 return 255} 256 257################################################################ 258 259proc text_postprocess {text} { 260 261 #puts_stderr XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 262 #puts_stderr <<$text>> 263 #puts_stderr XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 264 265 global cmds 266 # The argument is not relevant. Access the display list, perform 267 # the final layouting and return its result. 268 269 set linebuffer [list] 270 array set state {lmargin 0 rmargin 0} 271 foreach cmd $cmds { 272 foreach {op arguments} $cmd break 273 $op $arguments 274 } 275 276 #puts_stderr XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 277 278 return [join $linebuffer \n] 279} 280 281 282proc SECT {text} { 283 upvar linebuffer linebuffer 284 285 # text is actually the list of arguments, having one element, the text. 286 set text [lindex $text 0] 287 #puts_stderr "SECT $text" 288 #puts_stderr "" 289 290 # Write section title, underline it 291 292 lappend linebuffer "" 293 lappend linebuffer $text 294 lappend linebuffer [textutil::repeat::strRepeat = [string length $text]] 295 return 296} 297 298proc SUBSECT {text} { 299 upvar linebuffer linebuffer 300 301 # text is actually the list of arguments, having one element, the text. 302 set text [lindex $text 0] 303 #puts_stderr "SUBSECT $text" 304 #puts_stderr "" 305 306 # Write subsection title, underline it (with less emphasis) 307 308 lappend linebuffer "" 309 lappend linebuffer $text 310 lappend linebuffer [textutil::repeat::strRepeat - [string length $text]] 311 return 312} 313 314proc PARA {arguments} { 315 global pEnv 316 upvar linebuffer linebuffer 317 318 foreach {env text} $arguments break 319 array set para $pEnv($env) 320 321 #puts_stderr "PARA $env" 322 #parray_stderr para 323 #puts_stderr " \{$text\}" 324 #puts_stderr "" 325 326 # Use the information in the referenced environment to format the paragraph. 327 328 if {$para(verbatim)} { 329 set text [textutil::adjust::undent $text] 330 } else { 331 # The size is determined through the set left and right margins 332 # right margin is fixed at 80, left margin is variable. Size 333 # is at least 20. I.e. when left margin > 60 right margin is 334 # shifted out to the right. 335 336 set size [expr {80 - $para(lmargin)}] 337 if {$size < 20} {set size 20} 338 339 set text [textutil::adjust::adjust $text -length $size] 340 } 341 342 # Now apply prefixes, (ws prefixes bulleting), at last indentation. 343 344 if {[string length $para(prefix)] > 0} { 345 set text [textutil::adjust::indent $text $para(prefix)] 346 } 347 348 if {$para(listtype) != {}} { 349 switch -exact $para(listtype) { 350 bullet { 351 # Indent for bullet, but not the first line. This is 352 # prefixed by the bullet itself. 353 354 set thebullet $para(bullet) 355 } 356 enum { 357 # Handling the enumeration counter. Special case: An 358 # example as first paragraph in an item has to use the 359 # counter in environment it is derived from to prevent 360 # miscounting. 361 362 if {[info exists para(example)]} { 363 set parent $para(parent) 364 array set __ $pEnv($parent) 365 if {![info exists __(counter)]} { 366 set __(counter) 1 367 } else { 368 incr __(counter) 369 } 370 set pEnv($parent) [array get __] ; # Save context change ... 371 set n $__(counter) 372 } else { 373 if {![info exists para(counter)]} { 374 set para(counter) 1 375 } else { 376 incr para(counter) 377 } 378 set pEnv($env) [array get para] ; # Save context change ... 379 set n $para(counter) 380 } 381 382 set thebullet [string map [list % $n] $para(bullet)] 383 } 384 } 385 386 set blen [string length $thebullet] 387 if {$blen >= [string length $para(wspfx)]} { 388 set text "$thebullet\n[textutil::adjust::indent $text $para(wspfx)]" 389 } else { 390 set fprefix $thebullet[string range $para(wspfx) $blen end] 391 set text "${fprefix}[textutil::adjust::indent $text $para(wspfx) 1]" 392 } 393 } 394 395 if {$para(lmargin) > 0} { 396 set text [textutil::adjust::indent $text \ 397 [textutil::repeat::strRepeat " " $para(lmargin)]] 398 } 399 400 lappend linebuffer "" 401 lappend linebuffer $text 402 return 403} 404 405################################################################ 406 407proc strong {text} {return *${text}*} 408proc em {text} {return _${text}_} 409 410################################################################ 411 412proc parray_stderr {a {pattern *}} { 413 upvar 1 $a array 414 if {![array exists array]} { 415 error "\"$a\" isn't an array" 416 } 417 set maxl 0 418 foreach name [lsort [array names array $pattern]] { 419 if {[string length $name] > $maxl} { 420 set maxl [string length $name] 421 } 422 } 423 set maxl [expr {$maxl + [string length $a] + 2}] 424 foreach name [lsort [array names array $pattern]] { 425 set nameString [format %s(%s) $a $name] 426 puts_stderr " [format "%-*s = {%s}" $maxl $nameString $array($name)]" 427 } 428} 429 430################################################################ 431