REBOL [
    Title: "High quality text typesetter"
    File: %typesetter.r
    Purpose: {
        This program implements a high quality text typesetter
        based on the algorithms by Donald E. Knuth, also found in
        the TeX typesetting system.
    }
    Author: "Gabriele Santilli"
    EMail: giesse@rebol.it
    License: {
        Copyright (c) 2006, Gabriele Santilli
        All rights reserved.

        Redistribution and use in source and binary forms, with or without
        modification, are permitted provided that the following conditions
        are met:

        * Redistributions of source code must retain the above copyright
          notice, this list of conditions and the following disclaimer. 
          
        * Redistributions in binary form must reproduce the above
          copyright notice, this list of conditions and the following
          disclaimer in the documentation and/or other materials provided
          with the distribution. 

        * The name of Gabriele Santilli may not be used to endorse or
          promote products derived from this software without specific
          prior written permission.

        THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
        "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
        LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
        FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
        COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
        INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
        BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
        LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
        CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
        LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
        ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
        POSSIBILITY OF SUCH DAMAGE.
    }
    Date: 17-Nov-2006
    Version: 1.49.1
    History: [
        2-Aug-2006 1.1.0 "History start" 
        2-Aug-2006 1.2.0 "Algorithm skeleton" 
        2-Aug-2006 1.3.0 "Implemented some parts" 
        3-Aug-2006 1.4.0 "Finished first test version, testing" 
        3-Aug-2006 1.5.0 "First working version (with problems)" 
        3-Aug-2006 1.6.0 "Test version without optimizations" 
        4-Aug-2006 1.7.0 "Reintroduced optimizations" 
        4-Aug-2006 1.8.0 "More optimizations" 
        7-Aug-2006 1.9.0 "Added kern, added line-width parameter" 
        11-Aug-2006 1.10.0 "Testing typeset-columns" 
        23-Aug-2006 1.11.0 "First working version of typeset-columns" 
        24-Aug-2006 1.12.0 "Fixed bug in typeset-columns" 
        24-Aug-2006 1.13.0 "Fixed another bug in typeset-columns" 
        24-Aug-2006 1.14.0 {Looks like tolerance of 100 is really too much (can run for minutes), set to 10} 
        25-Aug-2006 1.15.0 "Fixed another bug in typeset-columns" 
        29-Aug-2006 1.16.0 {Added orders of infinity, prepared support for bbox calculation} 
        30-Aug-2006 1.17.0 {Added bbox calculation and variable line height version of typeset-columns} 
        30-Aug-2006 1.18.0 {Added support for state-changing commands in typeset-columns (e.g. font setting)} 
        31-Aug-2006 1.19.0 {Better support for state-changing commands in typeset-columns} 
        31-Aug-2006 1.20.0 {Applied total-fit algorithm to breaking lines into columns too, other generalizations} 
        31-Aug-2006 1.21.0 {Added vspace and break paragraph types to typeset-columns} 
        1-Sep-2006 1.22.0 {typeset-colums: minor optimizations, fixes, generalizations} 
        1-Sep-2006 1.23.0 {Changed break-lines so that it always succeeds as long as lines can be broken} 
        2-Sep-2006 1.24.0 "Changed emergency-break logic, it was still broken" 
        2-Sep-2006 1.25.0 "Changed emergency-break logic again" 
        2-Sep-2006 1.26.0 "Finally got emergency-logic right (hopefully...)" 
        2-Sep-2006 1.27.0 "Added penalties for widows and orphans" 
        3-Sep-2006 1.28.0 "Added paragraph margins to typeset-columns" 
        6-Sep-2006 1.29.0 "Fixed bug with break happening before previous one" 
        13-Sep-2006 1.30.0 "First version of typeset-table (not working yet)" 
        14-Sep-2006 1.31.0 "Finished typeset-table" 
        14-Sep-2006 1.32.0 "Fixing typeset-table (incomplete at this point)" 
        15-Sep-2006 1.33.0 "Fixed typeset-table" 
        15-Sep-2006 1.34.0 "Fixed a bug in break-lines" 
        15-Sep-2006 1.35.0 "Fixed a bug in typeset-table" 
        16-Sep-2006 1.36.0 "Added support for embedded tables in text columns" 
        16-Sep-2006 1.37.0 "Fixed a bug in tabvlist-to-pages" 
        18-Sep-2006 1.38.0 {Re-added extra-stretch to break-lines, fixed left/center/right align} 
        19-Sep-2006 1.39.0 "Added support for cell decor (computing box)" 
        19-Sep-2006 1.40.1 "Fixed a bug in typeset-table" 
        21-Sep-2006 1.41.1 "Fixed a bug in table-to-vlist" 
        21-Sep-2006 1.42.1 "Fixed a bug in tabvlist-to-pages" 
        21-Sep-2006 1.43.1 "Fixed a nasty bug in typesetting vlists" 
        22-Sep-2006 1.44.1 {Changed terminate-vlist to fix a bug with typesetting vlists} 
        25-Sep-2006 1.45.1 "Fixed a bug in tabvlist-to-pages" 
        25-Sep-2006 1.46.1 "Allowing emergency breaks with r < -1 too" 
        25-Sep-2006 1.47.1 "Improved find-row-breakpoints" 
        26-Sep-2006 1.48.1 "Added support for graphics embedded into text" 
        17-Nov-2006 1.49.1 {Major optimization in break-lines (discards active nodes that are unlikely to be relevant)}
    ]
]

text-list-node!: context [
    type: 1 width: 2 stretch: 3 shrink: 4 penalty: 5 flag: 6 ratio: 7 ref: 8 
    height: 9 depth: 10
] 
use [tln-proto] [
    tln-proto: make text-list-node! [
        type: 'undefined 
        width: stretch: shrink: penalty: flag: height: depth: 0 
        ratio: ref: none
    ] 
    make-text-list-node: func [spec] [
        get make tln-proto spec
    ]
] 
text-list-node-words: copy next first text-list-node! 
text-list-node-size: length? text-list-node-words 
add*: func [a [number! block!] b [number! block!]] [
    if number? a [a: reduce [a 0]] 
    if number? b [b: reduce [b 0]] 
    case [
        a/2 = b/2 [
            a: reduce [a/1 + b/1 a/2] 
            either zero? a/1 [0] [a]
        ] 
        a/2 > b/2 [a] 
        true [b]
    ]
] 
sub*: func [a [number! block!] b [number! block!]] [
    add* a neg* b
] 
neg*: func [a [number! block!]] [
    either number? a [
        negate a
    ] [
        either zero? a/1 [0] [reduce [negate a/1 a/2]]
    ]
] 
mul*: func [a [number! block!] b [number! block!]] [
    if number? a [a: reduce [a 0]] 
    if number? b [b: reduce [b 0]] 
    a: reduce [a/1 * b/1 a/2 + b/2] 
    either zero? a/1 [0] [a]
] 
div*: func [a [number! block!] b [number! block!]] [
    if number? a [a: reduce [a 0]] 
    if number? b [b: reduce [b 0]] 
    a: either b/1 = 0 [
        reduce [a/1 a/2 + 1]
    ] [
        reduce [a/1 / b/1 a/2 - b/2]
    ] 
    either zero? a/1 [0] [a]
] 
pow*: func [a [number! block!] exp [number!]] [
    either number? a [
        power a exp
    ] [
        a: reduce [power a/1 exp a/2 * exp] 
        either zero? a/1 [0] [a]
    ]
] 
eq*: func [a [number! block!] b [number! block!]] [
    if number? a [a: reduce [a 0]] 
    if number? b [b: reduce [b 0]] 
    if all [zero? a/1 zero? b/1] [return true] 
    a = b
] 
lt*: func [a [number! block!] b [number! block!]] [
    if number? a [a: reduce [a 0]] 
    if number? b [b: reduce [b 0]] 
    case [
        not-equal? sign? a/1 sign? b/1 [a/1 < b/1] 
        a/2 = b/2 [a/1 < b/1] 
        -1 = sign? a/1 [a/2 > b/2] 
        true [a/2 < b/2]
    ]
] 
gt*: func [a [number! block!] b [number! block!]] [
    if number? a [a: reduce [a 0]] 
    if number? b [b: reduce [b 0]] 
    case [
        not-equal? sign? a/1 sign? b/1 [a/1 > b/1] 
        a/2 = b/2 [a/1 > b/1] 
        -1 = sign? a/1 [a/2 < b/2] 
        true [a/2 > b/2]
    ]
] 
lteq*: func [a [number! block!] b [number! block!]] [
    if number? a [a: reduce [a 0]] 
    if number? b [b: reduce [b 0]] 
    case [
        not-equal? sign? a/1 sign? b/1 [a/1 < b/1] 
        a/2 = b/2 [a/1 <= b/1] 
        -1 = sign? a/1 [a/2 > b/2] 
        true [a/2 < b/2]
    ]
] 
gteq*: func [a [number! block!] b [number! block!]] [
    if number? a [a: reduce [a 0]] 
    if number? b [b: reduce [b 0]] 
    case [
        not-equal? sign? a/1 sign? b/1 [a/1 > b/1] 
        a/2 = b/2 [a/1 >= b/1] 
        -1 = sign? a/1 [a/2 < b/2] 
        true [a/2 > b/2]
    ]
] 
inf?: func [a [number! block!]] [
    either number? a [false] [a/2 > 0]
] 
pos-inf?: func [a [number! block!]] [
    either number? a [false] [
        all [a/1 > 0 a/2 > 0]
    ]
] 
neg-inf?: func [a [number! block!]] [
    either number? a [false] [
        all [a/1 < 0 a/2 > 0]
    ]
] 
min*: func [a [number! block!] b [number! block!]] [
    either lt* a b [a] [b]
] 
max*: func [a [number! block!] b [number! block!]] [
    either gt* a b [a] [b]
] 
abs*: func [a [number! block!]] [
    either number? a [
        abs a
    ] [
        reduce [abs a/1 a/2]
    ]
] 
to-num: func [a [number! block!]] [
    if number? a [return a] 
    case [
        pos-inf? a [1E+300] 
        neg-inf? a [-1E+300] 
        a/2 < 0 [0] 
        true [a/1]
    ]
] 
+infty: [1 1] 
+infty2: [1 2] 
+infty3: [1 3] 
-infty: [-1 1] 
context [
    terminate-vlist: func [vlist] [
        vlist: tail vlist 
        while [
            all [
                not head? vlist 
                'box <> pick vlist text-list-node!/type - 1 - text-list-node-size
            ]
        ] [
            vlist: skip vlist negate text-list-node-size
        ] 
        insert vlist make-text-list-node [type: 'penalty penalty: +infty] 
        insert insert tail vlist 
        make-text-list-node [type: 'glue stretch: +infty] 
        make-text-list-node [type: 'penalty penalty: -infty]
    ] 
    paras-to-vlist: func [paragraphs columns repeat-columns /local 
        interline-glue para-margins prev output line-width 
        asw? line-width-func 
        optimum 
        commands 
        word line tmp lineno 
        colw colh
    ] [
        asw?: all-same-width? join columns repeat-columns 
        line-width-func: either asw? [
            func [line column bottom height depth] [
                reduce [asw? - margin para-margins line 1 0]
            ]
        ] [
            func [line column bottom height depth /local colw colh] [
                set [colw colh] pick-column columns repeat-columns column 
                if not colw [
                    set [colw colh] pick-column columns repeat-columns column - 1 
                    colh: 1E+300
                ] 
                bottom: bottom + interline-glue + height + depth 
                either bottom <= colh [
                    reduce [colw - margin para-margins line column bottom]
                ] [
                    if colh: pick-column columns repeat-columns column: column + 1 [
                        set [colw colh] colh
                    ] 
                    reduce [colw - margin para-margins line column height + depth]
                ]
            ]
        ] 
        commands: make block! 16 
        prev: context [type: 'space bottom: 0 column: 1] 
        output: make block! 1024 
        foreach para paragraphs [
            switch para/type [
                paragraph [
                    interline-glue: pick para/interline-glue text-list-node!/width 
                    para-margins: para/margins 
                    line-width: either all [asw? 1 = length? para-margins] [
                        asw? - margin para-margins 1
                    ] [
                        :line-width-func
                    ] 
                    either 
                    optimum: break-lines/verbose para/contents para/tolerance para/extra-stretch para/looseness :line-width 
                    either prev/type = 'line [prev/bottom + interline-glue] [prev/bottom] 
                    prev/column :show-line [
                        lineno: 1 
                        typeset-text-list/rlimit para/contents func [type value] [
                            switch type [
                                box [
                                    either block? value/1 [
                                        repend line ['box line/1 value/2 value/3 value/4 value/1]
                                    ] [
                                        either string? word: pick tail line -1 [
                                            append word value/1
                                        ] [
                                            insert tail line word: make string! 32 
                                            insert word value/1
                                        ]
                                    ] 
                                    line/1: line/1 + value/2 
                                    line/2: max line/2 value/3 
                                    line/3: max line/3 value/4
                                ] 
                                glue [
                                    insert tail line value/1 
                                    line/1: line/1 + value/1
                                ] 
                                cmd [
                                    insert tail line value 
                                    set-cmd commands value
                                ]
                            ]
                        ] does [
                            if line [
                                either asw? [
                                    either optimum/line > 3 [
                                        case [
                                            lineno = 2 [
                                                append output make-text-list-node [type: 'penalty penalty: 500]
                                            ] 
                                            lineno = 3 [
                                                append output make-text-list-node [type: 'penalty penalty: 200]
                                            ] 
                                            optimum/line = lineno [
                                                append output make-text-list-node [type: 'penalty penalty: 500]
                                            ] 
                                            optimum/line - 1 = lineno [
                                                append output make-text-list-node [type: 'penalty penalty: 200]
                                            ]
                                        ]
                                    ] [
                                        switch optimum/line [
                                            2 [
                                                if lineno = 2 [
                                                    append output make-text-list-node [type: 'penalty penalty: 1000]
                                                ]
                                            ] 
                                            3 [
                                                if lineno <> 1 [
                                                    append output make-text-list-node [type: 'penalty penalty: 500]
                                                ]
                                            ]
                                        ]
                                    ] 
                                    switch para/align [
                                        center [line/4: add divide asw? - line/1 - margin para/margins lineno 2 lmargin para/margins lineno] 
                                        right [line/4: asw? - line/1 - rmargin para/margins lineno] 
                                        left [line/4: lmargin para/margins lineno] 
                                        justify [line/4: lmargin para/margins lineno]
                                    ] 
                                    if prev/type = 'line [append output para/interline-glue] 
                                    append output make-text-list-node [
                                        type: 'box 
                                        width: line/2 + line/3 
                                        ref: line
                                    ] 
                                    prev/type: 'line
                                ] [
                                    set [colw colh] pick-column columns repeat-columns prev/column 
                                    if not colw [
                                        set [colw colh] pick-column columns repeat-columns prev/column - 1 
                                        colh: 1E+300
                                    ] 
                                    switch para/align [
                                        center [line/4: add divide colw - line/1 - margin para/margins lineno 2 lmargin para/margins lineno] 
                                        right [line/4: colw - line/1 - rmargin para/margins lineno] 
                                        left [line/4: lmargin para/margins lineno] 
                                        justify [line/4: lmargin para/margins lineno]
                                    ] 
                                    prev/bottom: prev/bottom + line/2 + line/3 
                                    + either prev/type = 'line [interline-glue] [0] 
                                    either prev/bottom > colh [
                                        prev/column: prev/column + 1 
                                        prev/bottom: line/2 + line/3 
                                        either all [
                                            tmp: pick-column columns repeat-columns prev/column 
                                            colw <> tmp/1
                                        ] [
                                            append output make-text-list-node [
                                                type: 'penalty 
                                                penalty: -infty
                                            ]
                                        ] [
                                            if prev/type = 'line [append output para/interline-glue]
                                        ]
                                    ] [
                                        if prev/type = 'line [append output para/interline-glue]
                                    ] 
                                    append output make-text-list-node [
                                        type: 'box 
                                        width: line/2 + line/3 
                                        ref: line
                                    ] 
                                    prev/type: 'line
                                ] 
                                lineno: lineno + 1
                            ] 
                            insert insert line: make block! 256 [0 0 0 0] get-cmd commands
                        ] either para/align = 'justify [+infty] [0] 
                        if line [
                            either asw? [
                                either optimum/line > 3 [
                                    case [
                                        lineno = 2 [
                                            append output make-text-list-node [type: 'penalty penalty: 500]
                                        ] 
                                        lineno = 3 [
                                            append output make-text-list-node [type: 'penalty penalty: 200]
                                        ] 
                                        optimum/line = lineno [
                                            append output make-text-list-node [type: 'penalty penalty: 500]
                                        ] 
                                        optimum/line - 1 = lineno [
                                            append output make-text-list-node [type: 'penalty penalty: 200]
                                        ]
                                    ]
                                ] [
                                    switch optimum/line [
                                        2 [
                                            if lineno = 2 [
                                                append output make-text-list-node [type: 'penalty penalty: 1000]
                                            ]
                                        ] 
                                        3 [
                                            if lineno <> 1 [
                                                append output make-text-list-node [type: 'penalty penalty: 500]
                                            ]
                                        ]
                                    ]
                                ] 
                                switch para/align [
                                    center [line/4: add divide asw? - line/1 - margin para/margins lineno 2 lmargin para/margins lineno] 
                                    right [line/4: asw? - line/1 - rmargin para/margins lineno] 
                                    left [line/4: lmargin para/margins lineno] 
                                    justify [line/4: lmargin para/margins lineno]
                                ] 
                                if prev/type = 'line [append output para/interline-glue] 
                                append output make-text-list-node [
                                    type: 'box 
                                    width: line/2 + line/3 
                                    ref: line
                                ] 
                                prev/type: 'line
                            ] [
                                set [colw colh] pick-column columns repeat-columns prev/column 
                                if not colw [
                                    set [colw colh] pick-column columns repeat-columns prev/column - 1 
                                    colh: 1E+300
                                ] 
                                switch para/align [
                                    center [line/4: add divide colw - line/1 - margin para/margins lineno 2 lmargin para/margins lineno] 
                                    right [line/4: colw - line/1 - rmargin para/margins lineno] 
                                    left [line/4: lmargin para/margins lineno] 
                                    justify [line/4: lmargin para/margins lineno]
                                ] 
                                prev/bottom: prev/bottom + line/2 + line/3 
                                + either prev/type = 'line [interline-glue] [0] 
                                either prev/bottom > colh [
                                    prev/column: prev/column + 1 
                                    prev/bottom: line/2 + line/3 
                                    either all [
                                        tmp: pick-column columns repeat-columns prev/column 
                                        colw <> tmp/1
                                    ] [
                                        append output make-text-list-node [
                                            type: 'penalty 
                                            penalty: -infty
                                        ]
                                    ] [
                                        if prev/type = 'line [append output para/interline-glue]
                                    ]
                                ] [
                                    if prev/type = 'line [append output para/interline-glue]
                                ] 
                                append output make-text-list-node [
                                    type: 'box 
                                    width: line/2 + line/3 
                                    ref: line
                                ] 
                                prev/type: 'line
                            ] 
                            lineno: lineno + 1
                        ] 
                        line: none
                    ] [
                        print "??? Unable to break paragraph into lines ???"
                    ]
                ] 
                vspace [
                    either asw? [
                        append output make-text-list-node [
                            type: 'glue 
                            width: para/height 
                            stretch: para/stretch 
                            shrink: para/shrink
                        ] 
                        prev/type: 'space
                    ] [
                        set [colw colh] pick-column columns repeat-columns prev/column 
                        either inf? para/stretch [
                            either colw [
                                prev/bottom: 0 
                                prev/column: prev/column + 1 
                                prev/type: 'space 
                                append output make-text-list-node [
                                    type: 'glue 
                                    width: para/height 
                                    stretch: para/stretch 
                                    shrink: para/shrink
                                ] 
                                prev/type: 'space 
                                if all [
                                    tmp: pick-column columns repeat-columns prev/column 
                                    colw <> tmp/1
                                ] [
                                    append output make-text-list-node [
                                        type: 'penalty 
                                        penalty: -infty
                                    ]
                                ]
                            ] [
                                append output make-text-list-node [
                                    type: 'glue 
                                    width: para/height 
                                    stretch: para/stretch 
                                    shrink: para/shrink
                                ] 
                                prev/type: 'space
                            ]
                        ] [
                            if not colw [
                                colh: 1E+300
                            ] 
                            prev/bottom: prev/bottom + para/height 
                            either prev/bottom > colh [
                                prev/column: prev/column + 1 
                                prev/bottom: 0 
                                either all [
                                    tmp: pick-column columns repeat-columns prev/column 
                                    colw <> tmp/1
                                ] [
                                    insert insert tail output 
                                    make-text-list-node [type: 'glue stretch: add* para/height para/stretch] 
                                    make-text-list-node [type: 'penalty penalty: -infty] 
                                    prev/type: 'space
                                ] [
                                    append output make-text-list-node [
                                        type: 'glue 
                                        width: para/height 
                                        stretch: para/stretch 
                                        shrink: para/shrink
                                    ] 
                                    prev/type: 'space
                                ]
                            ] [
                                append output make-text-list-node [
                                    type: 'glue 
                                    width: para/height 
                                    stretch: para/stretch 
                                    shrink: para/shrink
                                ] 
                                prev/type: 'space
                            ]
                        ]
                    ]
                ] 
                vpenalty [
                    append output make-text-list-node [
                        type: 'penalty 
                        penalty: para/penalty
                    ] 
                    if neg-inf? para/penalty [
                        prev/bottom: 0 
                        prev/column: prev/column + 1 
                        prev/type: 'space
                    ]
                ] 
                table [
                    insert insert insert tail output 
                    make-text-list-node [type: 'table-start] 
                    tmp: table-to-vlist para/rows 
                    make-text-list-node [type: 'table-end] 
                    if not asw? [
                        print {Warning: using embedded table in variable width columns.} 
                        foreach :text-list-node-words tmp [
                            set [colw colh] pick-column columns repeat-columns prev/column 
                            if not colw [
                                colh: 1E+300
                            ] 
                            prev/bottom: prev/bottom + width 
                            if prev/bottom > colh [
                                prev/column: prev/column + 1 
                                prev/bottom: 0
                            ]
                        ]
                    ] 
                    prev/type: 'space
                ] 
                vbox [
                    either asw? [
                        append output make-text-list-node [
                            type: 'box 
                            width: para/height 
                            ref: reduce ['box asw? para/height para/contents]
                        ]
                    ] [
                        set [colw colh] pick-column columns repeat-columns prev/column 
                        if not colw [
                            colh: 1E+300
                        ] 
                        prev/bottom: prev/bottom + para/height 
                        either prev/bottom > colh [
                            prev/column: prev/column + 1 
                            prev/bottom: para/height 
                            either all [
                                tmp: pick-column columns repeat-columns prev/column 
                                colw <> tmp/1
                            ] [
                                insert insert insert tail output 
                                make-text-list-node [type: 'glue stretch: para/height] 
                                make-text-list-node [type: 'penalty penalty: -infty] 
                                make-text-list-node [
                                    type: 'box width: para/height 
                                    ref: reduce ['box tmp/1 para/height para/contents]
                                ]
                            ] [
                                append output make-text-list-node [
                                    type: 'box 
                                    width: para/height 
                                    ref: reduce ['box colw para/height para/contents]
                                ]
                            ]
                        ] [
                            append output make-text-list-node [
                                type: 'box 
                                width: para/height 
                                ref: reduce ['box colw para/height para/contents]
                            ]
                        ]
                    ] 
                    prev/type: 'line
                ]
            ]
        ] 
        output
    ] 
    vlist-to-columns: func [vlist columns repeat-columns /local 
        result column cols optimum
    ] [
        cols: func [line column bottom height depth /local colw colh] [
            set [colw colh] pick-column columns repeat-columns line 
            either colh [
                reduce [colh 1 0]
            ] [
                reduce [1E+100 1 0]
            ]
        ] 
        optimum: either empty? repeat-columns [
            break-lines/verbose/max-lines vlist 2 0 0 :cols 0 1 :show-col divide length? columns 2
        ] [
            break-lines/verbose vlist 2 0 0 :cols 0 1 :show-col
        ] 
        either optimum [
            result: make block! 16 
            typeset-text-list/rlimit vlist func [type value] [
                switch type [
                    box [
                        insert/only tail column value/1
                    ] 
                    glue [
                        insert tail column value/1
                    ] 
                    cmd [
                        insert tail column value
                    ] 
                    table [
                        foreach page value [
                            insert/only insert tail column 'table page 
                            insert/only tail result column: make block! 256
                        ] 
                        remove back tail result 
                        column: last result
                    ]
                ]
            ] does [
                insert/only tail result column: make block! 256
            ] 1 
            result
        ] [
            print "??? Unable to break lines into columns ???" []
        ]
    ] 
    table-to-vlist: func [rows /local 
        output top-cells fl-height fl-depth first-line row-brkpnts 
        bh bstr bshr last-brkpnt first-row?
    ] [
        output: make block! 10240 
        first-row?: yes 
        foreach row rows [
            append output compose [(make-text-list-node [type: 'row ref: row]) (either first-row? [[]] [row/top-margin]) (make-text-list-node [type: 'box width: 0]) (make-text-list-node [type: 'penalty penalty: +infty]) (row/top-padding)] 
            first-row?: no 
            top-cells: copy [] 
            fl-height: 0 
            fl-depth: 0 
            foreach cell row/contents [
                cell/output: paras-to-vlist cell/contents reduce [cell/width 0] [] 
                if all [cell/valign = 'top 'box = pick cell/output text-list-node!/type] [
                    append top-cells cell 
                    first-line: pick cell/output text-list-node!/ref 
                    fl-height: max fl-height first-line/2 
                    fl-depth: max fl-depth first-line/3
                ]
            ] 
            foreach cell top-cells [
                first-line: pick cell/output text-list-node!/ref 
                first-line/2: fl-height 
                first-line/3: fl-depth 
                poke cell/output text-list-node!/width fl-height + fl-depth
            ] 
            row-brkpnts: make block! 16 
            foreach cell row/contents [
                append/only row-brkpnts calc-cell-height cell
            ] 
            row-brkpnts: find-row-breakpoints row-brkpnts 
            until [
                last-brkpnt: copy skip tail row-brkpnts -5 
                clear skip tail row-brkpnts -5 
                not equal? last-brkpnt/1 pick tail row-brkpnts -5
            ] 
            bh: bstr: bshr: 0 
            foreach [h str shr pen offs] row-brkpnts [
                insert insert insert insert tail output 
                make-text-list-node [type: 'box width: h - bh] 
                make-text-list-node [type: 'penalty penalty: +infty] 
                make-text-list-node [
                    type: 'glue 
                    width: 0 
                    stretch: sub* str bstr 
                    shrink: shr - bshr
                ] 
                make-text-list-node [type: 'penalty penalty: add* row/break-penalty pen] 
                if offs > 0 [
                    insert insert insert insert tail output 
                    make-text-list-node [type: 'glue width: negate offs] 
                    make-text-list-node [type: 'box width: 0] 
                    make-text-list-node [type: 'penalty penalty: +infty] 
                    make-text-list-node [type: 'glue width: offs]
                ] 
                bh: h bstr: str bshr: shr
            ] 
            foreach [h str shr pen offs] last-brkpnt [
                insert insert insert tail output 
                make-text-list-node [type: 'box width: h - bh] 
                make-text-list-node [type: 'penalty penalty: +infty] 
                make-text-list-node [
                    type: 'glue 
                    width: 0 
                    stretch: sub* str bstr 
                    shrink: shr - bshr
                ]
            ] 
            insert insert insert tail output 
            row/bottom-padding 
            make-text-list-node [type: 'box width: 0] 
            row/bottom-margin
        ] 
        clear skip tail output negate text-list-node-size 
        output
    ] 
    tabvlist-to-pages: func [vlist /with sr ss /local 
        result this-row cols rowh spc page roww this-cell curh
    ] [
        result: make block! 16 
        this-row: none 
        typeset-text-list/rlimit/with vlist func [type value] [
            switch type [
                box [
                    if this-row [
                        poke this-row/pages length? this-row/pages 
                        value/2 + pick this-row/pages length? this-row/pages
                    ]
                ] 
                glue [
                    if this-row [
                        either word? value/2 [
                            set in this-row value/2 value/1
                        ] [
                            poke this-row/pages length? this-row/pages 
                            value/1 + pick this-row/pages length? this-row/pages
                        ]
                    ]
                ] 
                row [
                    if this-row [
                        if block? this-row/top-margin [this-row/top-margin: 0] 
                        if block? this-row/bottom-margin [this-row/bottom-margin: 0] 
                        foreach cell this-row/contents [
                            cols: make block! 16 
                            rowh: 0 
                            foreach height this-row/pages [
                                insert insert tail cols cell/width height 
                                rowh: rowh + height
                            ] 
                            unless empty? cell/output [
                                switch cell/valign [
                                    top [
                                        terminate-vlist cell/output
                                    ] 
                                    bottom [
                                        spc: rowh - cell/height 
                                        while [spc > this-row/pages/1] [
                                            cell/output: insert insert cell/output 
                                            make-text-list-node [type: 'glue width: this-row/pages/1] 
                                            make-text-list-node [type: 'penalty penalty: 0] 
                                            spc: spc - this-row/pages/1 
                                            this-row/pages: next this-row/pages
                                        ] 
                                        this-row/pages: head this-row/pages 
                                        cell/output: head insert cell/output make-text-list-node [type: 'glue width: spc] 
                                        insert tail cell/output make-text-list-node [type: 'penalty penalty: -infty]
                                    ] 
                                    middle [
                                        spc: rowh - cell/height / 2 
                                        while [spc > this-row/pages/1] [
                                            cell/output: insert insert cell/output 
                                            make-text-list-node [type: 'glue width: this-row/pages/1] 
                                            make-text-list-node [type: 'penalty penalty: 0] 
                                            spc: spc - this-row/pages/1 
                                            this-row/pages: next this-row/pages
                                        ] 
                                        this-row/pages: head this-row/pages 
                                        cell/output: head insert cell/output make-text-list-node [type: 'glue width: spc] 
                                        terminate-vlist cell/output
                                    ]
                                ] 
                                cell/output: vlist-to-columns cell/output cols []
                            ] 
                            cell/height: rowh
                        ] 
                        curh: 0 
                        while [not tail? this-row/pages] [
                            if all [not head? this-row/pages zero? this-row/pages/1] [break] 
                            page: pick tail result negate length? this-row/pages 
                            rowh: first this-row/pages 
                            roww: 0 
                            if head? this-row/pages [
                                repend page [0 this-row/top-margin + this-row/top-padding]
                            ] 
                            foreach cell this-row/contents [
                                this-cell: pick cell/output index? this-row/pages 
                                roww: roww + cell/margins/1 + cell/padding/1 + cell/width 
                                + cell/padding/2 + cell/margins/2 
                                if not empty? cell/decor [
                                    repend page [
                                        'box 0 
                                        either any [tail? next this-row/pages zero? this-row/pages/2] [
                                            negate rowh + this-row/bottom-padding + this-row/bottom-margin
                                        ] [
                                            negate rowh
                                        ] 
                                        cell/margins/1 + cell/padding/1 + cell/width + cell/padding/2 + cell/margins/2 
                                        either head? this-row/pages [this-row/top-padding + this-row/top-margin] [0] 
                                        bind/copy cell/decor context [
                                            xbl: cell/margins/1 
                                            ybl: negate cell/height + this-row/bottom-padding - curh 
                                            xtr: cell/margins/1 + cell/padding/1 + cell/width + cell/padding/2 
                                            ytr: this-row/top-padding + curh
                                        ]
                                    ]
                                ] 
                                either this-cell [
                                    repend page [
                                        cell/margins/1 + cell/padding/1 0 
                                        this-cell 
                                        cell/width + cell/padding/2 + cell/margins/2 negate rowh
                                    ]
                                ] [
                                    repend page [
                                        cell/margins/1 + cell/padding/1 + cell/width + 
                                        cell/padding/2 + cell/margins/2 0
                                    ]
                                ]
                            ] 
                            this-row/pages: next this-row/pages 
                            curh: curh + rowh
                        ] 
                        repend page [
                            negate roww rowh + this-row/bottom-padding + this-row/bottom-margin
                        ]
                    ] 
                    if this-row: value [this-row/pages: copy [0]]
                ]
            ]
        ] does [
            if this-row [
                append this-row/pages 0
            ] 
            append/only result make block! 256
        ] 1 sr ss 
        if this-row [
            if block? this-row/top-margin [this-row/top-margin: 0] 
            if block? this-row/bottom-margin [this-row/bottom-margin: 0] 
            foreach cell this-row/contents [
                cols: make block! 16 
                rowh: 0 
                foreach height this-row/pages [
                    insert insert tail cols cell/width height 
                    rowh: rowh + height
                ] 
                unless empty? cell/output [
                    switch cell/valign [
                        top [
                            terminate-vlist cell/output
                        ] 
                        bottom [
                            spc: rowh - cell/height 
                            while [spc > this-row/pages/1] [
                                cell/output: insert insert cell/output 
                                make-text-list-node [type: 'glue width: this-row/pages/1] 
                                make-text-list-node [type: 'penalty penalty: 0] 
                                spc: spc - this-row/pages/1 
                                this-row/pages: next this-row/pages
                            ] 
                            this-row/pages: head this-row/pages 
                            cell/output: head insert cell/output make-text-list-node [type: 'glue width: spc] 
                            insert tail cell/output make-text-list-node [type: 'penalty penalty: -infty]
                        ] 
                        middle [
                            spc: rowh - cell/height / 2 
                            while [spc > this-row/pages/1] [
                                cell/output: insert insert cell/output 
                                make-text-list-node [type: 'glue width: this-row/pages/1] 
                                make-text-list-node [type: 'penalty penalty: 0] 
                                spc: spc - this-row/pages/1 
                                this-row/pages: next this-row/pages
                            ] 
                            this-row/pages: head this-row/pages 
                            cell/output: head insert cell/output make-text-list-node [type: 'glue width: spc] 
                            terminate-vlist cell/output
                        ]
                    ] 
                    cell/output: vlist-to-columns cell/output cols []
                ] 
                cell/height: rowh
            ] 
            curh: 0 
            while [not tail? this-row/pages] [
                if all [not head? this-row/pages zero? this-row/pages/1] [break] 
                page: pick tail result negate length? this-row/pages 
                rowh: first this-row/pages 
                roww: 0 
                if head? this-row/pages [
                    repend page [0 this-row/top-margin + this-row/top-padding]
                ] 
                foreach cell this-row/contents [
                    this-cell: pick cell/output index? this-row/pages 
                    roww: roww + cell/margins/1 + cell/padding/1 + cell/width 
                    + cell/padding/2 + cell/margins/2 
                    if not empty? cell/decor [
                        repend page [
                            'box 0 
                            either any [tail? next this-row/pages zero? this-row/pages/2] [
                                negate rowh + this-row/bottom-padding + this-row/bottom-margin
                            ] [
                                negate rowh
                            ] 
                            cell/margins/1 + cell/padding/1 + cell/width + cell/padding/2 + cell/margins/2 
                            either head? this-row/pages [this-row/top-padding + this-row/top-margin] [0] 
                            bind/copy cell/decor context [
                                xbl: cell/margins/1 
                                ybl: negate cell/height + this-row/bottom-padding - curh 
                                xtr: cell/margins/1 + cell/padding/1 + cell/width + cell/padding/2 
                                ytr: this-row/top-padding + curh
                            ]
                        ]
                    ] 
                    either this-cell [
                        repend page [
                            cell/margins/1 + cell/padding/1 0 
                            this-cell 
                            cell/width + cell/padding/2 + cell/margins/2 negate rowh
                        ]
                    ] [
                        repend page [
                            cell/margins/1 + cell/padding/1 + cell/width + 
                            cell/padding/2 + cell/margins/2 0
                        ]
                    ]
                ] 
                this-row/pages: next this-row/pages 
                curh: curh + rowh
            ] 
            repend page [
                negate roww rowh + this-row/bottom-padding + this-row/bottom-margin
            ]
        ] 
        result
    ] 
    typeset-text-list: func [text-list emit newline /rlimit rl /with sr ss /local skip? r tabend table] [
        newline 
        unless rlimit [rl: +infty] 
        if sr [
            r: get sr 
            skip?: get ss
        ] 
        forblock b text-list-node! text-list [
            if not r [r: max* -1 min* b/ratio rl b/ratio: none] 
            switch b/type [
                box [
                    skip?: no 
                    emit 'box reduce [b/ref b/width b/height b/depth]
                ] 
                glue [
                    if not skip? [
                        either b/ratio [
                            r: max* -1 min* b/ratio rl 
                            skip?: yes 
                            newline
                        ] [
                            emit 'glue reduce [
                                b/width + to-num either lt* r 0 [mul* b/shrink r] [mul* b/stretch r] 
                                b/ref
                            ]
                        ]
                    ]
                ] 
                kern [
                    if not skip? [
                        either b/ratio [
                            r: max* -1 min* b/ratio rl 
                            skip?: yes 
                            newline
                        ] [
                            emit 'glue reduce [b/width]
                        ]
                    ]
                ] 
                penalty [
                    if b/ratio [
                        r: max* -1 min* b/ratio rl 
                        if b/ref [
                            emit 'box reduce [b/ref b/width b/height b/depth]
                        ] 
                        skip?: yes 
                        newline
                    ]
                ] 
                cmd [
                    emit 'cmd b/ref
                ] 
                row [
                    emit 'row b/ref
                ] 
                table-start [
                    tabend: find/skip b/self 'table-end text-list-node-size 
                    b/self: skip b/self text-list-node-size 
                    table: copy/part b/self tabend 
                    use [rr ss] copy [
                        rr: r 
                        ss: skip? 
                        emit 'table tabvlist-to-pages/with table 'rr 'ss 
                        r: rr 
                        skip?: ss
                    ] 
                    b/self: tabend
                ]
            ]
        ] 
        if sr [
            set sr r 
            set ss skip?
        ]
    ] 
    active-node!: context [
        ref: none 
        line: 0 
        bottom: 0 
        column: 1 
        fitness: 2 
        totaldemerits: 0 
        nlstart: 1 
        ratio: 0 
        prevbreak: none 
        emergency-break: none 
        has-next?: no
    ] 
    forblock: func [[throw] 
        'name [word!] 
        type [object!] 
        list [block!] 
        body [block!]
    ] [
        type: make type [] 
        name: use reduce [name] reduce [to lit-word! name] 
        set name type 
        type/self: list 
        body: bind/copy body name 
        while [not tail? type/self] [
            set type type/self 
            do body 
            type/self: skip type/self length? next first type
        ]
    ] 
    prev-block: func [
        node [object!]
    ] [
        skip node/self negate length? next first node
    ] 
    next-block: func [
        node [object!]
    ] [
        skip node/self length? next first node
    ] 
    memo-hash: make hash! [] 
    calc-line: func [text-list [block!] start [integer!] end [integer!] /local w str shr h d] [
        if start = end [return [0 0 0 0 0]] 
        if w: select memo-hash as-pair start end [return w] 
        end: end - text-list-node-size 
        set [w str shr h d] calc-line text-list start end 
        text-list: at text-list end 
        switch pick text-list text-list-node!/type [
            box [
                w: w + pick text-list text-list-node!/width 
                h: max h pick text-list text-list-node!/height 
                d: max d pick text-list text-list-node!/depth
            ] 
            kern [w: w + pick text-list text-list-node!/width] 
            glue [
                w: w + pick text-list text-list-node!/width 
                str: add* str pick text-list text-list-node!/stretch 
                shr: shr + pick text-list text-list-node!/shrink
            ]
        ] 
        insert/only insert tail memo-hash as-pair start end + text-list-node-size w: reduce [w str shr h d] 
        w
    ] 
    find-next-line-start: func [pos] [
        forblock i text-list-node! pos [
            switch i/type [
                box [return index? i/self] 
                penalty [
                    if all [neg-inf? i/penalty greater? index? i/self index? pos] [return index? i/self]
                ]
            ]
        ] 
        index? tail pos
    ] 
    better-break?: func [old new] [
        any [
            none? old 
            gt* old/totaldemerits new/totaldemerits 
            all [
                eq* old/totaldemerits new/totaldemerits 
                gt* old/ratio new/ratio
            ]
        ]
    ] 
    all-same-width?: func [columns /local w] [
        w: first columns 
        foreach [width height] skip columns 2 [
            if w <> width [return none]
        ] 
        w
    ] 
    pick-column: func [columns repeat-columns column /local cols rcols] [
        cols: divide length? columns 2 
        rcols: divide length? repeat-columns 2 
        column: column - 1 
        either column >= cols [
            if zero? rcols [return none] 
            column: column - cols // rcols 
            copy/part skip repeat-columns column * 2 2
        ] [
            copy/part skip columns column * 2 2
        ]
    ] 
    make-cols: func [columns repeat-columns cols /local] [
        local: make block! 16 
        foreach [colw colh] columns [
            append local colh 
            cols: cols - 1 
            if zero? cols [return append local 1E+100]
        ] 
        if empty? repeat-columns [return append local 1E+100] 
        forever [
            foreach [colw colh] repeat-columns [
                append local colh 
                cols: cols - 1 
                if zero? cols [return append local 1E+100]
            ]
        ]
    ] 
    set-cmd: func [commands cmd /local] [
        either local: find commands cmd/1 [
            local/2: cmd
        ] [
            insert/only insert tail commands cmd/1 cmd
        ]
    ] 
    get-cmd: func [commands /local res] [
        res: clear [] 
        foreach [name cmd] commands [
            append res cmd
        ] 
        res
    ] 
    show-col: func [start end] [
        while ['box <> pick start text-list-node!/type] [
            start: skip start text-list-node-size
        ] 
        end: skip end negate text-list-node-size 
        while ['box <> pick end text-list-node!/type] [
            end: skip end negate text-list-node-size
        ] 
        start: pick start text-list-node!/ref 
        end: pick end text-list-node!/ref 
        print ["Column from" mold start "to" mold end]
    ] 
    show-line: func [start end /local ln] [
        while ['box <> pick start text-list-node!/type] [
            start: skip start text-list-node-size
        ] 
        ln: clear "" 
        while [lesser? index? start index? end] [
            switch pick start text-list-node!/type [
                box [append ln pick start text-list-node!/ref] 
                glue [append ln " "]
            ] 
            start: skip start text-list-node-size
        ] 
        print ["Line" mold ln]
    ] 
    margins?: func [margins line] [
        any [pick margins line last margins]
    ] 
    lmargin: func [margins line] [
        line: margins? margins line 
        line/1
    ] 
    rmargin: func [margins line] [
        line: margins? margins line 
        line/2
    ] 
    margin: func [margins line] [
        line: margins? margins line 
        line/1 + line/2
    ] 
    calc-cell-height: func [cell /local breakpoints brk-shr brk-str pen pos] [
        cell/height: 0 
        brk-shr: brk-str: 0 
        breakpoints: make block! 32 
        insert breakpoints cell/valign 
        forblock b text-list-node! cell/output [
            pen: 0 
            switch b/type [
                box [
                    cell/height: cell/height + b/width
                ] 
                kern [
                    if (
                        pos: next-block b 
                        forever [
                            if tail? pos [break/return false] 
                            switch pick pos text-list-node!/type [
                                glue [break/return true] 
                                box [break/return false] 
                                penalty [break/return false] 
                                kern [break/return false]
                            ] 
                            pos: skip pos text-list-node-size
                        ]
                    ) [
                        repend breakpoints [
                            cell/height brk-str brk-shr pen
                        ]
                    ] 
                    cell/height: cell/height + b/width
                ] 
                glue [
                    if (
                        pos: prev-block b 
                        forever [
                            if head? pos [break/return false] 
                            switch pick pos text-list-node!/type [
                                box [break/return true] 
                                glue [break/return false] 
                                penalty [break/return false] 
                                kern [break/return false]
                            ] 
                            pos: skip pos negate text-list-node-size
                        ]
                    ) [
                        repend breakpoints [
                            cell/height brk-str brk-shr pen
                        ]
                    ] 
                    cell/height: cell/height + b/width 
                    brk-str: add* brk-str b/stretch 
                    brk-shr: brk-shr + b/shrink
                ] 
                penalty [
                    if not pos-inf? b/penalty [
                        pen: b/penalty 
                        repend breakpoints [
                            cell/height brk-str brk-shr pen
                        ]
                    ]
                ]
            ]
        ] 
        pen: 0 
        repend breakpoints [
            cell/height brk-str brk-shr pen
        ] 
        breakpoints
    ] 
    pick-page: func [pages repeat-pages page] [
        either page > length? pages [
            if empty? repeat-pages [return none] 
            page: page - 1 - (length? pages) // length? repeat-pages 
            pick repeat-pages page + 1
        ] [
            pick pages page
        ]
    ] 
    find-row-breakpoints: func [
        cells 
        /local biggest heights breakpoints chosen penalty offs 
        ch cstr cshr cpen bh bhmax bhmin cpen' roff alignments 
        ch' cstr' cshr'
    ] [
        breakpoints: make block! 32 
        penalty: -infty 
        offs: 0 
        heights: make block! 2 + length? cells 
        offs: make block! 2 + length? cells 
        alignments: make block! 2 + length? cells 
        biggest: 1 
        foreach cell cells [
            append alignments cell/1 
            remove cell 
            cell: skip tail cell -4 
            append heights cell/1 
            if cell/1 > heights/:biggest [
                biggest: length? heights
            ]
        ] 
        forever [
            chosen: 1 
            repeat i length? cells [
                if any [
                    tail? cells/:chosen 
                    all [
                        not tail? cells/:i 
                        cells/:i/1 < cells/:chosen/1
                    ]
                ] [
                    chosen: i
                ]
            ] 
            set [bh bhmax bhmin penalty] cells/:chosen 
            bhmax: add* bh bhmax 
            bhmin: bh - bhmin 
            change/dup offs 0 length? cells 
            repeat i length? cells [
                if i <> chosen [
                    calc-cpen cells/:i alignments/:i bh [ch cstr cshr cpen] 
                    if all [
                        not head? cells/:i 
                        gt* cpen calc-cpen skip cells/:i -4 alignments/:i bh [ch' cstr' cshr' cpen']
                    ] [
                        cpen: cpen' 
                        ch: ch' cstr: cstr' cshr: cshr'
                    ] 
                    if all [
                        not tail? skip cells/:i 4 
                        gt* cpen calc-cpen skip cells/:i 4 alignments/:i bh [ch' cstr' cshr' cpen']
                    ] [
                        cpen: cpen' 
                        ch: ch' cstr: cstr' cshr: cshr'
                    ] 
                    penalty: max* penalty cpen 
                    bhmax: max* bh min* bhmax add* ch cstr 
                    bhmin: min bh max bhmin ch - cshr 
                    offs/:i: bh - ch
                ]
            ] 
            unless pos-inf? penalty [
                roff: 0 
                repeat i length? cells [
                    if heights/:i + offs/:i > heights/:biggest [
                        roff: max roff offs/:i
                    ]
                ] 
                repend breakpoints [
                    bh sub* bhmax bh bh - bhmin penalty roff
                ]
            ] 
            cells/:chosen: skip cells/:chosen 4 
            if foreach cell cells [if not tail? cell [break/return false] true] [
                break
            ]
        ] 
        breakpoints
    ] 
    calc-cpen: func [cell alignment bh words /local extra-str ch cstr cshr cpen r] [
        extra-str: either find [middle bottom] alignment [
            +infty
        ] [
            either tail? cell [+infty] [0]
        ] 
        if tail? cell [cell: skip cell -4] 
        set [ch cstr cshr cpen] cell 
        cstr: add* cstr extra-str 
        r: div* bh - ch either bh < ch [cshr] [cstr] 
        cpen: case [
            lt* r -1 [+infty] 
            pos-inf? r [+infty] 
            true [add* cpen mul* 100 pow* min* 1E+15 abs* r 3]
        ] 
        set words reduce [ch cstr cshr cpen] 
        cpen
    ] 
    system/words/break-lines: func [
        {Break a paragraph into lines with the total-fit algorithm} 
        text-list [block!] "Paragraph contents" 
        tolerance [number!] "Line stretch tolerance" 
        extra-stretch [number!] "Add extra stretchability to each line" 
        q [integer!] {Create this more lines with respect to the optimum solution} 
        line-width [function! block! number!] "Width of lines" 
        start-pos [number!] "Starting position" 
        start-col [integer!] "Starting column" 
        /max-lines ml [integer!] {Try to keep number of lines less than the given number} 
        /verbose show-line [function!] "Be verbose (print warnings)" 
        /local 
        valid-break? active-nodes r last-dmin next-dmin 
        feasible-breaks fb-noline fbnl-dmin 
        fitness-mismatch-demerits double-hyphen-demerits equal-lines 
        over-tolerance-demerits non-justifiable-demerits 
        overfull-demerits 
        pos 
        l j lj stretch shrink height depth newcol newbott 
        a new nlidx 
        d c 
        i add-emergency? 
        feasible-break dmin 
        optimum 
        s delta lines 
        tmp
    ] [
        active-nodes: append make block! 32 make active-node! [
            ref: text-list 
            column: start-col 
            bottom: start-pos
        ] 
        feasible-breaks: make block! 1024 
        fb-noline: reduce [none none none none] 
        fbnl-dmin: +infty 
        fitness-mismatch-demerits: 10000 
        double-hyphen-demerits: 20000 
        over-tolerance-demerits: 10000000000.0 
        non-justifiable-demerits: 1E+15 
        overfull-demerits: 100000000000.0 
        equal-lines: no 
        case [
            number? :line-width [
                equal-lines: yes 
                line-width: func [lineno column bottom height depth] compose/deep [[(line-width) 1 0]]
            ] 
            block? :line-width [
                line-width: func [lineno column bottom height depth] compose/deep/only [reduce [pick (line-width) lineno 1 0]]
            ]
        ] 
        last-dmin: 0 
        clear memo-hash 
        forblock b text-list-node! text-list [
            valid-break?: switch/default b/type [
                glue [
                    pos: prev-block b 
                    forever [
                        if head? pos [break/return false] 
                        switch pick pos text-list-node!/type [
                            box [break/return true] 
                            glue [break/return false] 
                            penalty [break/return false] 
                            kern [break/return false]
                        ] 
                        pos: skip pos negate text-list-node-size
                    ]
                ] 
                penalty [not pos-inf? b/penalty] 
                kern [
                    pos: next-block b 
                    forever [
                        if tail? pos [break/return false] 
                        switch pick pos text-list-node!/type [
                            glue [break/return true] 
                            box [break/return false] 
                            penalty [break/return false] 
                            kern [break/return false]
                        ] 
                        pos: skip pos text-list-node-size
                    ]
                ]
            ] [no] 
            if valid-break? [
                if 15 < length? active-nodes [
                    sort/compare active-nodes func [a b] [lt* a/totaldemerits b/totaldemerits] 
                    clear skip active-nodes 15
                ] 
                next-dmin: +infty 
                remove-each active-node active-nodes [
                    active-node/totaldemerits: sub* active-node/totaldemerits last-dmin 
                    next-dmin: min* active-node/totaldemerits next-dmin 
                    if active-node/nlstart < index? b/self [
                        set [l stretch shrink height depth] calc-line text-list active-node/nlstart index? b/self 
                        if b/type = 'penalty [
                            l: l + b/width 
                            height: max height b/height 
                            depth: max depth b/depth
                        ] 
                        j: active-node/line + 1 
                        set [lj newcol newbott] line-width j active-node/column active-node/bottom height depth 
                        stretch: add* stretch mul* extra-stretch lj 
                        case [
                            l < lj [
                                r: div* lj - l stretch
                            ] 
                            l > lj [
                                r: div* lj - l shrink
                            ] 
                            true [r: 0]
                        ] 
                        either gteq* r -1 [
                            case [
                                gteq* b/penalty 0 [
                                    d: add* mul* b/penalty b/penalty pow* add* mul* 100 pow* min* 1E+15 abs* r 3 10 2
                                ] 
                                not neg-inf? b/penalty [
                                    d: sub* pow* add* mul* 100 pow* min* 1E+15 abs* r 3 10 2 mul* b/penalty b/penalty
                                ] 
                                true [
                                    d: pow* add* mul* 100 pow* min* 1E+15 abs* r 3 10 2
                                ]
                            ] 
                            d: min* d 1E+15 
                            if gteq* r tolerance [d: add* d over-tolerance-demerits] 
                            if pos-inf? r [d: add* d non-justifiable-demerits] 
                            if lt* r -1 [d: add* d overfull-demerits] 
                            d: add* d double-hyphen-demerits * b/flag * pick active-node/ref text-list-node!/flag 
                            c: case [
                                lteq* r -0.5 [1] 
                                lteq* r 0.5 [2] 
                                lteq* r 1 [3] 
                                true [4]
                            ] 
                            if 1 < abs c - active-node/fitness [d: add* d fitness-mismatch-demerits] 
                            d: add* d active-node/totaldemerits 
                            either any [lt* r tolerance neg-inf? b/penalty] [
                                new: make active-node! [
                                    ref: b/self nlstart: find-next-line-start b/self 
                                    line: j fitness: c 
                                    column: newcol bottom: newbott 
                                    totaldemerits: d prevbreak: active-node 
                                    ratio: r
                                ] 
                                active-node/has-next?: yes 
                                either all [equal-lines q = 0 not ml] [
                                    a: pick fb-noline c 
                                    fbnl-dmin: min* fbnl-dmin d 
                                    if better-break? a new [
                                        poke fb-noline c new
                                    ]
                                ] [
                                    pos: active-node/line * 4 + c 
                                    if pos > length? feasible-breaks [
                                        insert/dup tail feasible-breaks none pos - length? feasible-breaks
                                    ] 
                                    a: pick feasible-breaks pos 
                                    if better-break? a new [
                                        poke feasible-breaks pos new
                                    ]
                                ]
                            ] [
                                new: make active-node! [
                                    ref: b/self 
                                    line: j fitness: c 
                                    column: newcol bottom: newbott 
                                    totaldemerits: d prevbreak: active-node 
                                    ratio: r
                                ] 
                                if better-break? active-node/emergency-break new [
                                    active-node/emergency-break: new
                                ]
                            ] 
                            neg-inf? b/penalty
                        ] [
                            if all [not active-node/emergency-break not active-node/has-next?] [
                                case [
                                    gteq* b/penalty 0 [
                                        d: add* mul* b/penalty b/penalty pow* add* mul* 100 pow* min* 1E+15 abs* r 3 10 2
                                    ] 
                                    not neg-inf? b/penalty [
                                        d: sub* pow* add* mul* 100 pow* min* 1E+15 abs* r 3 10 2 mul* b/penalty b/penalty
                                    ] 
                                    true [
                                        d: pow* add* mul* 100 pow* min* 1E+15 abs* r 3 10 2
                                    ]
                                ] 
                                d: min* d 1E+15 
                                if gteq* r tolerance [d: add* d over-tolerance-demerits] 
                                if pos-inf? r [d: add* d non-justifiable-demerits] 
                                if lt* r -1 [d: add* d overfull-demerits] 
                                d: add* d double-hyphen-demerits * b/flag * pick active-node/ref text-list-node!/flag 
                                c: case [
                                    lteq* r -0.5 [1] 
                                    lteq* r 0.5 [2] 
                                    lteq* r 1 [3] 
                                    true [4]
                                ] 
                                if 1 < abs c - active-node/fitness [d: add* d fitness-mismatch-demerits] 
                                d: add* d active-node/totaldemerits 
                                active-node/emergency-break: make active-node! [
                                    ref: b/self 
                                    line: j fitness: c 
                                    column: newcol bottom: newbott 
                                    totaldemerits: d prevbreak: active-node 
                                    ratio: r
                                ]
                            ] 
                            if not active-node/has-next? [
                                active-node/emergency-break/nlstart: 
                                find-next-line-start active-node/emergency-break/ref 
                                active-node: active-node/emergency-break 
                                add-emergency?: yes 
                                i: b 
                                forblock b text-list-node! skip active-node/ref text-list-node-size [
                                    valid-break?: switch/default b/type [
                                        glue [
                                            pos: prev-block b 
                                            forever [
                                                if head? pos [break/return false] 
                                                switch pick pos text-list-node!/type [
                                                    box [break/return true] 
                                                    glue [break/return false] 
                                                    penalty [break/return false] 
                                                    kern [break/return false]
                                                ] 
                                                pos: skip pos negate text-list-node-size
                                            ]
                                        ] 
                                        penalty [not pos-inf? b/penalty] 
                                        kern [
                                            pos: next-block b 
                                            forever [
                                                if tail? pos [break/return false] 
                                                switch pick pos text-list-node!/type [
                                                    glue [break/return true] 
                                                    box [break/return false] 
                                                    penalty [break/return false] 
                                                    kern [break/return false]
                                                ] 
                                                pos: skip pos text-list-node-size
                                            ]
                                        ]
                                    ] [no] 
                                    if all [valid-break? active-node/nlstart < index? b/self] [
                                        set [l stretch shrink height depth] calc-line text-list active-node/nlstart index? b/self 
                                        if b/type = 'penalty [
                                            l: l + b/width 
                                            height: max height b/height 
                                            depth: max depth b/depth
                                        ] 
                                        j: active-node/line + 1 
                                        set [lj newcol newbott] line-width j active-node/column active-node/bottom height depth 
                                        stretch: add* stretch mul* extra-stretch lj 
                                        case [
                                            l < lj [
                                                r: div* lj - l stretch
                                            ] 
                                            l > lj [
                                                r: div* lj - l shrink
                                            ] 
                                            true [r: 0]
                                        ] 
                                        if all [
                                            gteq* r -1 
                                            any [lt* r tolerance neg-inf? b/penalty]
                                        ] [
                                            case [
                                                gteq* b/penalty 0 [
                                                    d: add* mul* b/penalty b/penalty pow* add* mul* 100 pow* min* 1E+15 abs* r 3 10 2
                                                ] 
                                                not neg-inf? b/penalty [
                                                    d: sub* pow* add* mul* 100 pow* min* 1E+15 abs* r 3 10 2 mul* b/penalty b/penalty
                                                ] 
                                                true [
                                                    d: pow* add* mul* 100 pow* min* 1E+15 abs* r 3 10 2
                                                ]
                                            ] 
                                            d: min* d 1E+15 
                                            if gteq* r tolerance [d: add* d over-tolerance-demerits] 
                                            if pos-inf? r [d: add* d non-justifiable-demerits] 
                                            if lt* r -1 [d: add* d overfull-demerits] 
                                            d: add* d double-hyphen-demerits * b/flag * pick active-node/ref text-list-node!/flag 
                                            c: case [
                                                lteq* r -0.5 [1] 
                                                lteq* r 0.5 [2] 
                                                lteq* r 1 [3] 
                                                true [4]
                                            ] 
                                            if 1 < abs c - active-node/fitness [d: add* d fitness-mismatch-demerits] 
                                            d: add* d active-node/totaldemerits 
                                            new: make active-node! [
                                                ref: b/self nlstart: find-next-line-start b/self 
                                                line: j fitness: c 
                                                column: newcol bottom: newbott 
                                                totaldemerits: d prevbreak: active-node 
                                                ratio: r
                                            ] 
                                            active-node/has-next?: yes 
                                            either all [equal-lines q = 0 not ml] [
                                                a: pick fb-noline c 
                                                fbnl-dmin: min* fbnl-dmin d 
                                                if better-break? a new [
                                                    poke fb-noline c new
                                                ]
                                            ] [
                                                pos: active-node/line * 4 + c 
                                                if pos > length? feasible-breaks [
                                                    insert/dup tail feasible-breaks none pos - length? feasible-breaks
                                                ] 
                                                a: pick feasible-breaks pos 
                                                if better-break? a new [
                                                    poke feasible-breaks pos new
                                                ]
                                            ]
                                        ] 
                                        if any [neg-inf? b/penalty lt* r -1] [add-emergency?: no]
                                    ] 
                                    if equal? index? b/self index? i/self [break]
                                ] 
                                if add-emergency? [
                                    either all [equal-lines q = 0 not ml] [
                                        a: pick fb-noline active-node/fitness 
                                        fbnl-dmin: min* fbnl-dmin active-node/totaldemerits 
                                        if better-break? a active-node [
                                            poke fb-noline active-node/fitness active-node
                                        ]
                                    ] [
                                        pos: active-node/line - 1 * 4 + active-node/fitness 
                                        if pos > length? feasible-breaks [
                                            insert/dup tail feasible-breaks none pos - length? feasible-breaks
                                        ] 
                                        a: pick feasible-breaks pos 
                                        if better-break? a active-node [
                                            poke feasible-breaks pos active-node
                                        ]
                                    ]
                                ]
                            ] 
                            true
                        ]
                    ]
                ] 
                last-dmin: next-dmin 
                either all [equal-lines q = 0 not ml] [
                    parse fb-noline [some [
                            none! 
                            | 
                            feasible-break: object! (
                                if gt* add* fbnl-dmin fitness-mismatch-demerits feasible-break/1/totaldemerits [
                                    append active-nodes feasible-break/1
                                ] 
                                feasible-break/1: none
                            )
                        ]] 
                    fbnl-dmin: +infty
                ] [
                    dmin: +infty 
                    parse feasible-breaks [some [
                            4 none! 
                            | 
                            pos: 1 4 [
                                none! 
                                | 
                                set feasible-break object! (dmin: min* feasible-break/totaldemerits dmin)
                            ] 
                            :pos 1 4 [
                                none! 
                                | 
                                feasible-break: object! (
                                    if gt* add* dmin fitness-mismatch-demerits feasible-break/1/totaldemerits [
                                        append active-nodes feasible-break/1
                                    ] 
                                    feasible-break/1: none
                                )
                            ] (dmin: +infty)
                        ]]
                ]
            ]
        ] 
        d: +infty 
        optimum: none 
        foreach final-node active-nodes [
            if lt* final-node/totaldemerits d [
                d: final-node/totaldemerits 
                optimum: final-node
            ]
        ] 
        if all [ml ml < optimum/line] [
            q: ml - optimum/line
        ] 
        if q <> 0 [
            s: 0 
            lines: optimum/line 
            foreach final-node active-nodes [
                delta: final-node/line - lines 
                case [
                    any [
                        all [q <= delta delta < s] 
                        all [s < delta delta <= q]
                    ] [
                        s: delta 
                        d: final-node/totaldemerits 
                        optimum: final-node
                    ] 
                    all [delta = s lt* final-node/totaldemerits d] [
                        d: final-node/totaldemerits 
                        optimum: final-node
                    ]
                ]
            ]
        ] 
        if tmp: optimum [
            until [
                either tmp/prevbreak [
                    if all [
                        any [
                            gteq* tmp/ratio tolerance 
                            lt* tmp/ratio -1
                        ] 
                        verbose
                    ] [
                        case [
                            inf? tmp/ratio [
                                print {Warning: line/column is not stretchable, cannot justify.}
                            ] 
                            lt* tmp/ratio -1 [
                                print ["Warning: overfull line/column."]
                            ] 
                            true [
                                print [
                                    "Warning: line/column above tolerance (ratio:" 
                                    to-num tmp/ratio ", tolerance:" tolerance ")."
                                ]
                            ]
                        ] 
                        show-line tmp/prevbreak/ref tmp/ref
                    ] 
                    poke tmp/prevbreak/ref text-list-node!/ratio tmp/ratio 
                    tmp: tmp/prevbreak 
                    false
                ] [
                    true
                ]
            ]
        ] 
        optimum
    ] 
    system/words/typeset-columns: func [
        "Typeset text into a number of columns" 
        paragraphs [block!] "List of paragraphs" 
        columns [block!] "List of columns" 
        repeat-columns [block!] "List of columns to repeat" 
        /local vlist
    ] [
        vlist: paras-to-vlist paragraphs columns repeat-columns 
        terminate-vlist vlist 
        vlist-to-columns vlist columns repeat-columns
    ] 
    system/words/typeset-table: func [
        {Typeset a table of text cells into a number of pages} 
        rows [block!] "List of rows" 
        pages [block!] "List of pages" 
        repeat-pages [block!] "List of pages to repeat" 
        /local vlist 
        page-height
    ] [
        vlist: table-to-vlist rows 
        append vlist make-text-list-node [type: 'row ref: none] 
        terminate-vlist vlist 
        page-height: func [page column bottom height depth] [
            height: pick-page pages repeat-pages page 
            either height [
                reduce [height 1 0]
            ] [
                reduce [1E+100 1 0]
            ]
        ] 
        either break-lines vlist 2 0 0 :page-height 0 1 [
            tabvlist-to-pages vlist
        ] [
            print "??? Unable to break table into pages ???" []
        ]
    ]
]