Version 5 of Canvas microjustification

Updated 2003-07-03 15:13:29

http://mini.net/files/mjtext.jpg


set docu(mjtext) {Richard Suchenwirth 2002-07-28 - Microjustification is a typesetting technique where small gaps are inserted between words to make lines fully justified (flush left and right). Donald Knuth has done extensive research on the topic (which I didn't have handy over weekend ;-), so here's only my Tk experiments.

The text widget does not support full justification, so I use a canvas instead - it can display text at pixel-precise positions, and also produce Postscript. I could not use its text editing features, because then "a space is a space" of font-dependent constant width.

In this design, a sort of "mega-item" mjtext is created on the canvas, which first just is a rectangle. The returned handle however accepts text input with $mj insert end.. like a text widget. The words are rendered as separate text items and wrap around, except at newlines. For the resulting "raw lines", the number of missing pixels to flush-right is determined, and the rightmost word is shifted right by that amount, then the others by decreasing amounts to make them approximately evenly distributed.

That's all - still a far cry from real DTP (rather like 1970's IBM Composer); but it let me cross another horizon of what's all possible with Tcl/Tk - hyphenation might be the next target..}

 proc mjtext {c x0 y0 x1 y1 args} {
        array set opt {-bg white  -font {Times 11}}
        array set opt $args
        set _self mj[$c create rect $x0 $y0 $x1 $y1 \
            -fill $opt(-bg) -outline $opt(-bg)]
        upvar #0 $_self self
        array set self [list x $x0 x0 $x0 y $y0 x1 $x1 y1 $y1 c $c]
        set self(-font) $opt(-font)
        set self(dy) [font metrics $opt(-font) -linespace]
        interp alias {} $_self {} mjtext'do $_self
 }
 proc mjtext'do {_self cmd cmd2 args} {
    upvar #0 $_self self
    if {$cmd=="insert" && $cmd2=="end"} {
        foreach {text tag} $args {
            foreach line [split $text \n] {
                set ids {}
                foreach word [split $line] {
                    if {$word==""} continue
                    set id [$self(c) create text $self(x) $self(y) \
                      -anchor nw -text $word -font $self(-font)]
                    foreach {x0 y0 x1 y1} [$self(c) bbox $id] break
                    if {$x1 > $self(x1)} {
                        set dx [expr {$self(x0) - $x0}]
                        $self(c) move $id $dx $self(dy)
                        foreach {x0 y0 x1 y1} [$self(c) bbox $id] break
                        mjtext'justify $self(c) $ids $self(x1)
                        set ids {}
                    } else {lappend ids $id}
                    set self(x) [expr {$x1 + 1}]
                    set self(y) $y0
                }
                set self(x) $self(x0)
                set self(y) [expr {$self(y) + 2 * $self(dy)}]
            }
        }
    } else {error "usage: $self insert end text"}
 }
 proc mjtext'justify {c ids x1} {
    set last [lindex $ids end]
    set diff [expr {$x1 - [lindex [$c bbox $last] 2]}]
    set step [expr {double($diff)/([llength $ids]-1)}]
    for {set i [llength $ids]} {$i>1} {} {
        $c move [lindex $ids [incr i -1]] $diff 0
        set diff [expr {$diff-$step}]
    }
 }

#----------- Test:

 proc nl2flowtext s {
    # turn multiline text into flowtext, \n only on empty lines
    regsub -all {\n *\n} $s \x81 s ;# dummy char
    string map {\n " " \x81 \n} $s
 }
 pack [canvas .c -width 400 -height 410] -expand 1
 set mj [mjtext .c 5 5 390 400]
 $mj insert end [nl2flowtext $docu(mjtext)]

Disclaimer: Due to differing font metrics, Postscript output is produced, but not exactly flush right - mildly ragged instead. Hm - to reinvent TEX in a few hours is not that simple ;-)


Donal Fellows has an implementation for text widgets which uses blank images as spacers - : http://www.man.ac.uk/~zzcgudf/tcl/wordwrap.tcl


Arts and crafts of Tcl-Tk programming