diff --git a/quad/quad/breaktester.rkt b/quad/quad/breaktester.rkt index fc95310b..da218a5f 100644 --- a/quad/quad/breaktester.rkt +++ b/quad/quad/breaktester.rkt @@ -1,5 +1,5 @@ #lang racket -(require hyphenate "quads.rkt" "world.rkt" "render.rkt" "main.rkt" "utils.rkt") +(require hyphenate "quads.rkt" "world.rkt" "render.rkt" "typeset.rkt" "utils.rkt") (define (make-test-blocks string) (let ([string string]) diff --git a/quad/quad/lang/buttons.rkt b/quad/quad/buttons.rkt similarity index 93% rename from quad/quad/lang/buttons.rkt rename to quad/quad/buttons.rkt index fe09d522..c3be24f1 100644 --- a/quad/quad/lang/buttons.rkt +++ b/quad/quad/buttons.rkt @@ -3,7 +3,7 @@ racket/gui/base racket/class quad/render - quad + quad/typeset racket/system) (provide make-drracket-buttons) @@ -31,7 +31,7 @@ http://pkg-build.racket-lang.org/doc/tools/drracket_module-language-tools.html#% (when fn-out (define-values (fn-dir name dir?) (split-path fn)) (parameterize ([current-directory fn-dir]) - (local-require "../render.rkt" racket/class profile sugar/debug quad/logger quad/world) + (local-require "render.rkt" racket/class profile sugar/debug quad/logger quad/world) (activate-logger quad-logger) (parameterize ([world:quality-default world:max-quality] [world:paper-width-default 600] diff --git a/quad/quad/lang/cmd-char.png b/quad/quad/cmd-char.png similarity index 100% rename from quad/quad/lang/cmd-char.png rename to quad/quad/cmd-char.png diff --git a/quad/quad/foo.rkt b/quad/quad/foo.rkt index 5ff13a3f..95c45ef2 100644 --- a/quad/quad/foo.rkt +++ b/quad/quad/foo.rkt @@ -3,7 +3,7 @@ (define 1-out (block '(measure 240.0 font "Times New Roman" leading 16.0 vmeasure 300.0 size 13.5 x-align justify x-align-last-line left) (box '(width 15.0)) (block '() (block '(weight bold) "Hot " (word '(size 22.0) "D") "ang, My Fellow Americans.") " This " (block '(no-break #t) "is some truly") " nonsense generated from my typesetting system, which is called Quad. I’m writing this in a source file in DrRacket. When I click [Run], a PDF pops out. Not bad\u200a—\u200aand no LaTeX needed. Quad, however, does use the fancy linebreaking algorithm developed for TeX. (It also includes a faster linebreaking algorithm for when speed is more important than quality.) Of course, it can also handle " (block '(font "Courier") "different fonts,") (block '(style italic) " styles, ") (word '(size 14.0 weight bold) "and sizes-") " within the same line. As you can see, it can also justify paragraphs."))) -(require quad quad/quads quad/render) +(require quad/typeset quad/quads quad/render) ;(time (send (new pdf-renderer%) render-to-file (typeset 1-out) "f1-test.pdf")) diff --git a/quad/quad/lang/quad.rkt b/quad/quad/lang/quad.rkt deleted file mode 100644 index 39e279a1..00000000 --- a/quad/quad/lang/quad.rkt +++ /dev/null @@ -1,18 +0,0 @@ -#lang racket/base -(provide (except-out (all-from-out racket/base) #%module-begin) - (rename-out [quad-module-begin #%module-begin])) -(require (for-syntax racket/base syntax/strip-context)) -(require quad/quads quad/main quad/world quad/render racket/class) - -(define-syntax (quad-module-begin stx) - (syntax-case stx () - [(_ expr ...) - (replace-context #'(expr ...) - #'(#%module-begin - (module outy racket/base - (require quad/quads) - (define out (block '(font "Times New Roman" measure 360.0 leading 14.0 column-count 1 column-gutter 10.0 size 11.5 x-align justify x-align-last-line left) expr ...)) - (provide out)) - (require 'outy) - (provide (all-from-out 'outy)) - (displayln out)))])) diff --git a/quad/quad/lang/reader.rkt b/quad/quad/lang/reader.rkt deleted file mode 100644 index 17260d0d..00000000 --- a/quad/quad/lang/reader.rkt +++ /dev/null @@ -1,34 +0,0 @@ -#lang s-exp syntax/module-reader -quad/lang/quad -#:read quad-read -#:read-syntax quad-read-syntax -#:whole-body-readers? #t ;; need this to make at-reader work -#:info custom-get-info -(require scribble/reader) - -(define (quad-read p) - (syntax->datum (quad-read-syntax (object-name p) p))) - -(define quad-command-char #\@) - -(define (quad-read-syntax path-string p) - (define quad-at-reader (make-at-reader - #:command-char quad-command-char - #:syntax? #t - #:inside? #t)) - (define source-stx (quad-at-reader path-string p)) - source-stx) - -(define (custom-get-info key default [proc (λ _ #f)]) - (displayln 'yay) - (case key - [(color-lexer) - (define my-make-scribble-inside-lexer - (dynamic-require 'syntax-color/scribble-lexer 'make-scribble-inside-lexer (λ () #f))) - (cond [my-make-scribble-inside-lexer - (my-make-scribble-inside-lexer #:command-char quad-command-char)] - [else default])] - [(drracket:toolbar-buttons) - (define my-make-drracket-buttons (dynamic-require 'quad/lang/buttons 'make-drracket-buttons)) - (my-make-drracket-buttons)] - [else default])) \ No newline at end of file diff --git a/quad/quad/main.rkt b/quad/quad/main.rkt index f4902431..1aa8d7ac 100644 --- a/quad/quad/main.rkt +++ b/quad/quad/main.rkt @@ -1,213 +1,53 @@ #lang racket/base -(require racket/list sugar racket/contract racket/function math/flonum) -(require "quads.rkt" "utils.rkt" "wrap.rkt" "measure.rkt" "world.rkt" "logger.rkt") -(provide typeset) -(require sugar/debug) -(define (input->nested-blocks i) - (define-syntax-rule (cons-reverse x y) (cons (reverse x) y)) - (define-values (mps mcs bs b) - (for/fold ([multipages empty][multicolumns empty][blocks empty][block-acc empty]) - ([q (in-list (split-quad i))]) - (cond - [(page-break? q) (values (cons-reverse (cons-reverse (cons-reverse block-acc blocks) multicolumns) multipages) empty empty empty)] - [(column-break? q) (values multipages (cons-reverse (cons-reverse block-acc blocks) multicolumns) empty empty)] - [(block-break? q) (values multipages multicolumns (cons-reverse block-acc blocks) empty)] - [else (values multipages multicolumns blocks (cons q block-acc))]))) - (reverse (cons-reverse (cons-reverse (cons-reverse b bs) mcs) mps))) - -(define (merge-adjacent-within q) - (quad (quad-name q) (quad-attrs q) (join-quads (quad-list q)))) - -(define (hyphenate-quad-except-last-word q) - (log-quad-debug "last word will not be hyphenated") - (define-values (first-quads last-quad) (split-last (quad-list q))) - (quad (quad-name q) (quad-attrs q) (snoc (map hyphenate-quad first-quads) last-quad))) - -(define+provide (average-looseness lines) - (if (<= (length lines) 1) - 0.0 - (let ([lines-to-measure (drop-right lines 1)]) ; exclude last line from looseness calculation - (round-float (fl/ (fold-fl+ (map (λ(line) (quad-attr-ref line world:line-looseness-key 0.0)) lines-to-measure)) (fl- (fl (length lines)) 1.0)))))) - - -(define (log-debug-lines lines) - (log-quad-debug "line report:") - (for/list ([(line idx) (in-indexed lines)]) - (format "~a/~a: ~v ~a" idx - (length lines) - (quad->string line) - (quad-attr-ref line world:line-looseness-key)))) - - -(require racket/trace) -(define (block->lines b) - (define quality (quad-attr-ref/parameter b world:quality-key)) - (define (wrap-quads qs) - (define wrap-proc (cond - [(>= quality world:max-quality) wrap-best] - [(<= quality world:draft-quality) wrap-first] - [else wrap-adaptive])) - (wrap-proc qs)) - (log-quad-debug "wrapping lines") - (log-quad-debug "quality = ~a" quality) - (log-quad-debug "looseness tolerance = ~a" world:line-looseness-tolerance) - (define wrapped-lines-without-hyphens (wrap-quads (quad-list b))) ; 100/150 - (log-quad-debug* (log-debug-lines wrapped-lines-without-hyphens)) - (define avg-looseness (average-looseness wrapped-lines-without-hyphens)) - (define gets-hyphenation? (and world:use-hyphenation? - (fl> avg-looseness world:line-looseness-tolerance))) - (log-quad-debug "average looseness = ~a" avg-looseness) - (log-quad-debug (if gets-hyphenation? "hyphenating" "no hyphenation needed")) +(provide (except-out (all-from-out racket/base) #%module-begin) + (rename-out [quad-module-begin #%module-begin])) +(require (for-syntax racket/base syntax/strip-context)) +(require quad/quads quad/typeset quad/world quad/render racket/class) + +(define-syntax (quad-module-begin stx) + (syntax-case stx () + [(_ expr ...) + (replace-context #'(expr ...) + #'(#%module-begin + (module outy racket/base + (require quad/quads) + (define out (block '(font "Times New Roman" measure 360.0 leading 14.0 column-count 1 column-gutter 10.0 size 11.5 x-align justify x-align-last-line left) expr ...)) + (provide out)) + (require 'outy) + (provide (all-from-out 'outy)) + (displayln out)))])) + +(module reader syntax/module-reader + quad/main + #:read quad-read + #:read-syntax quad-read-syntax + #:whole-body-readers? #t ;; need this to make at-reader work + #:info custom-get-info + (require scribble/reader) - (define wrapped-lines (if gets-hyphenation? - (wrap-quads (split-quad ((if world:allow-hyphenated-last-word-in-paragraph - hyphenate-quad - hyphenate-quad-except-last-word) (merge-adjacent-within b)))) - wrapped-lines-without-hyphens)) + (define (quad-read p) + (syntax->datum (quad-read-syntax (object-name p) p))) - (when gets-hyphenation? (log-quad-debug* (log-debug-lines wrapped-lines))) + (define quad-command-char #\@) + (define (quad-read-syntax path-string p) + (define quad-at-reader (make-at-reader + #:command-char quad-command-char + #:syntax? #t + #:inside? #t)) + (define source-stx (quad-at-reader path-string p)) + source-stx) - (log-quad-debug "final looseness = ~a" (average-looseness wrapped-lines)) - (map insert-spacers-in-line - (for/list ([line-idx (in-naturals)][line (in-list wrapped-lines)]) - (quad-attr-set* line 'line-idx line-idx 'lines (length wrapped-lines))))) - - -(define+provide (number-pages ps) - (pages? . -> . pages?) - (for/list ([i (in-naturals)][p (in-list ps)]) - (quad (quad-name p) (merge-attrs (quad-attrs p) `(page ,i)) (quad-list p)))) - -(define+provide (pages->doc ps) - (pages? . -> . doc?) - ;; todo: resolve xrefs and other last-minute tasks - ;; todo: generalize computation of widths and heights, recursively - (define (columns-mapper page) - (quad-map (compose1 add-vert-positions (curry quad-map (compose1 compute-line-height add-horiz-positions fill))) page)) - (define mapped-pages (map columns-mapper (number-pages ps))) - (define doc (quads->doc mapped-pages)) - doc) - -(require racket/class csp) -(define+provide (lines->columns lines) - (lines? . -> . columns?) - (define prob (new problem%)) - (define max-column-lines world:default-lines-per-column) - (define-values (columns ignored-return-value) - (for/fold ([columns null][lines-remaining lines])([col-idx (in-naturals)] #:break (empty? lines-remaining)) - (log-quad-info "making column ~a" (add1 col-idx)) - ;; domain constraint is best way to simplify csp, because it limits the search space. - ;; search from largest possible value to smallest. - ;; largest possible is the minimum of the max column lines, or - ;; the number of lines left (modulo minimum page lines) ... - (define viable-column-range - (range (min max-column-lines (max - (length lines-remaining) - (- (length lines-remaining) world:minimum-lines-per-column))) - ;; ... and the smallest possible is 1, or the current minimum lines. - ;; (sub1 insures that range is inclusive of last value.) - (sub1 (min 1 world:minimum-lines-per-column)) -1)) - - (log-quad-debug "viable number of lines for this column to start =\n~a" viable-column-range) - (send prob add-variable "column-lines" viable-column-range) - - - ;; greediness constraint: leave enough lines for next page, or take all - (define (greediness-constraint pl) - (define leftover (- (length lines-remaining) pl)) - (or (= leftover 0) (>= leftover world:minimum-lines-per-column))) - (send prob add-constraint greediness-constraint '("column-lines")) - - (log-quad-debug "viable number of lines after greediness constraint =\n~a" (map (curryr hash-ref "column-lines") (send prob get-solutions))) - - ;; last lines constraint: don't take page that will end with too few lines of last paragraph. - (define (last-lines-constraint pl) - (define last-line-of-page (list-ref lines-remaining (sub1 pl))) - (define lines-in-this-paragraph (quad-attr-ref last-line-of-page world:total-lines-key)) - (define line-index-of-last-line (quad-attr-ref last-line-of-page world:line-index-key)) - (define (paragraph-too-short-to-meet-constraint?) - (< lines-in-this-paragraph world:min-last-lines)) - (or (paragraph-too-short-to-meet-constraint?) - (>= (add1 line-index-of-last-line) world:min-last-lines))) - (send prob add-constraint last-lines-constraint '("column-lines")) - - (log-quad-debug "viable number of lines after last-lines constraint =\n~a" (map (curryr hash-ref "column-lines") (send prob get-solutions))) - - ;; first lines constraint: don't take page that will leave too few lines at top of next page - (define (first-lines-constraint pl lines-remaining) - (define last-line-of-page (list-ref lines-remaining (sub1 pl))) - (define lines-in-this-paragraph (quad-attr-ref last-line-of-page world:total-lines-key)) - (define line-index-of-last-line (quad-attr-ref last-line-of-page world:line-index-key)) - (define lines-that-will-remain (- lines-in-this-paragraph (add1 line-index-of-last-line))) - (define (paragraph-too-short-to-meet-constraint?) - (< lines-in-this-paragraph world:min-first-lines)) - (or (paragraph-too-short-to-meet-constraint?) - (= 0 lines-that-will-remain) ; ok to use all lines ... - (>= lines-that-will-remain world:min-first-lines))) ; but if any remain, must be minimum number. - (send prob add-constraint (curryr first-lines-constraint lines-remaining) '("column-lines")) - - (log-quad-debug "viable number of lines after first-lines constraint =\n~a" (map (curryr hash-ref "column-lines") (send prob get-solutions))) - - - (define s (send prob get-solution)) - (define how-many-lines-to-take (hash-ref s "column-lines")) - (define-values (lines-to-take lines-to-leave) (split-at lines-remaining how-many-lines-to-take)) - (log-quad-debug "taking ~a lines for column ~a:" how-many-lines-to-take (add1 col-idx)) - (map (λ(idx line) (log-quad-debug "~a:~a ~v" (add1 col-idx) (add1 idx) (quad->string line))) (range how-many-lines-to-take) lines-to-take) - (send prob reset) - (values (cons (quad-attr-set (quads->column lines-to-take) world:column-index-key col-idx) columns) lines-to-leave))) - (reverse columns)) - -(define (columns->pages cols) - (columns? . -> . pages?) - (define columns-per-page (quad-attr-ref/parameter (car cols) world:column-count-key)) - (define column-gutter (quad-attr-ref/parameter (car cols) world:column-gutter-key)) - ;; don't use default value here. If the col doesn't have a measure key, - ;; it deserves to be an error, because that means the line was composed incorrectly. - (when (not (quad-has-attr? (car cols) world:measure-key)) - (error 'columns->pages "column attrs contain no measure key: ~a ~a" (quad-attrs (car cols)) (quad-car (car cols)))) - (define column-width (quad-attr-ref (car cols) world:measure-key)) - (define width-of-printed-area (+ (* columns-per-page column-width) (* (sub1 columns-per-page) column-gutter))) - (define result-pages - (map (λ(cols) (quads->page cols)) - (for/list ([page-cols (in-list (slice-at cols columns-per-page))]) - (define-values (last-x cols) - (for/fold ([current-x (/ (- (world:paper-width-default) width-of-printed-area) 2)][cols empty]) ([col (in-list page-cols)][idx (in-naturals)]) - (values (+ current-x column-width column-gutter) (cons (quad-attr-set* col 'x current-x 'y 40 world:column-index-key idx) cols)))) - (reverse cols)))) - result-pages) - -(define current-eof (make-parameter (gensym))) -(define (eof? x) (equal? x (current-eof))) - - - -(define (block-quads->lines qs) - (block->lines (quads->block qs))) - -(define (typeset x) - (coerce/input? . -> . doc?) - (load-text-cache-file) - (define pages (append* (for/list ([multipage (in-list (input->nested-blocks x))]) - (columns->pages (append* (for/list ([multicolumn (in-list multipage)]) - (lines->columns (append* (for/list ([block-quads (in-list multicolumn)]) - (block-quads->lines block-quads)))))))))) - (define doc (pages->doc pages)) - (update-text-cache-file) - doc) - - -(module+ main - (require "render.rkt" racket/class profile sugar/debug) - (require "samples.rkt") - (activate-logger quad-logger) - (parameterize ([world:quality-default world:draft-quality] - [world:paper-width-default 600] - [world:paper-height-default 700]) - #;(define sample (block '(measure 54.0 leading 18.0) "\n" "\n" "Meg is an ally.")) - (let ([toa (begin (time (typeset (dynamic-require "foo2.rkt" 'out))))] - [tob (typeset (block '(measure 54.0 leading 18.0) "Meg \nis an ally."))]) - (report* toa tob (equal? toa tob)) - (time (send (new pdf-renderer%) render-to-file toa "foo-a.pdf")) - (time (send (new pdf-renderer%) render-to-file tob "foo-b.pdf"))))) + (define (custom-get-info key default [proc (λ _ #f)]) + (displayln 'yay) + (case key + [(color-lexer) + (define my-make-scribble-inside-lexer + (dynamic-require 'syntax-color/scribble-lexer 'make-scribble-inside-lexer (λ () #f))) + (cond [my-make-scribble-inside-lexer + (my-make-scribble-inside-lexer #:command-char quad-command-char)] + [else default])] + [(drracket:toolbar-buttons) + (define my-make-drracket-buttons (dynamic-require 'quad/buttons 'make-drracket-buttons)) + (my-make-drracket-buttons)] + [else default]))) \ No newline at end of file diff --git a/quad/quad/quick-test.rkt b/quad/quad/quick-test.rkt index 7db06835..91a97fc2 100644 --- a/quad/quad/quick-test.rkt +++ b/quad/quad/quick-test.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require "main.rkt" "world.rkt" "quick-sample.rkt" +(require "typeset.rkt" "world.rkt" "quick-sample.rkt" "render.rkt" racket/class quad/quads) (parameterize ([world:quality-default world:draft-quality]) (displayln "Untyped Quad") diff --git a/quad/quad/segfault.rkt b/quad/quad/segfault.rkt index c2770fd9..a4ea156c 100644 --- a/quad/quad/segfault.rkt +++ b/quad/quad/segfault.rkt @@ -1,5 +1,5 @@ #lang racket/base -(require "main.rkt" "samples.rkt" "render.rkt" "world.rkt" racket/class "logger.rkt") +(require "typeset.rkt" "samples.rkt" "render.rkt" "world.rkt" racket/class "logger.rkt") (module+ main (define line-limit (with-handlers ([exn:fail? (λ(exn) #f)]) diff --git a/quad/quad/stats.rkt b/quad/quad/stats.rkt index 2941acc9..49e89acb 100644 --- a/quad/quad/stats.rkt +++ b/quad/quad/stats.rkt @@ -1,6 +1,6 @@ #lang racket (require math/statistics sugar racket/serialize plot) -(require (except-in "quads.rkt" line) "utils.rkt" "wrap.rkt" "world.rkt" "measure.rkt" "logger.rkt" "main.rkt") +(require (except-in "quads.rkt" line) "utils.rkt" "wrap.rkt" "world.rkt" "measure.rkt" "logger.rkt" "typeset.rkt") (define+provide (make-wrap-proc-bps #:make-pieces-proc make-pieces-proc diff --git a/quad/quad/typeset.rkt b/quad/quad/typeset.rkt new file mode 100644 index 00000000..f4902431 --- /dev/null +++ b/quad/quad/typeset.rkt @@ -0,0 +1,213 @@ +#lang racket/base +(require racket/list sugar racket/contract racket/function math/flonum) +(require "quads.rkt" "utils.rkt" "wrap.rkt" "measure.rkt" "world.rkt" "logger.rkt") +(provide typeset) +(require sugar/debug) +(define (input->nested-blocks i) + (define-syntax-rule (cons-reverse x y) (cons (reverse x) y)) + (define-values (mps mcs bs b) + (for/fold ([multipages empty][multicolumns empty][blocks empty][block-acc empty]) + ([q (in-list (split-quad i))]) + (cond + [(page-break? q) (values (cons-reverse (cons-reverse (cons-reverse block-acc blocks) multicolumns) multipages) empty empty empty)] + [(column-break? q) (values multipages (cons-reverse (cons-reverse block-acc blocks) multicolumns) empty empty)] + [(block-break? q) (values multipages multicolumns (cons-reverse block-acc blocks) empty)] + [else (values multipages multicolumns blocks (cons q block-acc))]))) + (reverse (cons-reverse (cons-reverse (cons-reverse b bs) mcs) mps))) + +(define (merge-adjacent-within q) + (quad (quad-name q) (quad-attrs q) (join-quads (quad-list q)))) + +(define (hyphenate-quad-except-last-word q) + (log-quad-debug "last word will not be hyphenated") + (define-values (first-quads last-quad) (split-last (quad-list q))) + (quad (quad-name q) (quad-attrs q) (snoc (map hyphenate-quad first-quads) last-quad))) + +(define+provide (average-looseness lines) + (if (<= (length lines) 1) + 0.0 + (let ([lines-to-measure (drop-right lines 1)]) ; exclude last line from looseness calculation + (round-float (fl/ (fold-fl+ (map (λ(line) (quad-attr-ref line world:line-looseness-key 0.0)) lines-to-measure)) (fl- (fl (length lines)) 1.0)))))) + + +(define (log-debug-lines lines) + (log-quad-debug "line report:") + (for/list ([(line idx) (in-indexed lines)]) + (format "~a/~a: ~v ~a" idx + (length lines) + (quad->string line) + (quad-attr-ref line world:line-looseness-key)))) + + +(require racket/trace) +(define (block->lines b) + (define quality (quad-attr-ref/parameter b world:quality-key)) + (define (wrap-quads qs) + (define wrap-proc (cond + [(>= quality world:max-quality) wrap-best] + [(<= quality world:draft-quality) wrap-first] + [else wrap-adaptive])) + (wrap-proc qs)) + (log-quad-debug "wrapping lines") + (log-quad-debug "quality = ~a" quality) + (log-quad-debug "looseness tolerance = ~a" world:line-looseness-tolerance) + (define wrapped-lines-without-hyphens (wrap-quads (quad-list b))) ; 100/150 + (log-quad-debug* (log-debug-lines wrapped-lines-without-hyphens)) + (define avg-looseness (average-looseness wrapped-lines-without-hyphens)) + (define gets-hyphenation? (and world:use-hyphenation? + (fl> avg-looseness world:line-looseness-tolerance))) + (log-quad-debug "average looseness = ~a" avg-looseness) + (log-quad-debug (if gets-hyphenation? "hyphenating" "no hyphenation needed")) + + (define wrapped-lines (if gets-hyphenation? + (wrap-quads (split-quad ((if world:allow-hyphenated-last-word-in-paragraph + hyphenate-quad + hyphenate-quad-except-last-word) (merge-adjacent-within b)))) + wrapped-lines-without-hyphens)) + + (when gets-hyphenation? (log-quad-debug* (log-debug-lines wrapped-lines))) + + + (log-quad-debug "final looseness = ~a" (average-looseness wrapped-lines)) + (map insert-spacers-in-line + (for/list ([line-idx (in-naturals)][line (in-list wrapped-lines)]) + (quad-attr-set* line 'line-idx line-idx 'lines (length wrapped-lines))))) + + +(define+provide (number-pages ps) + (pages? . -> . pages?) + (for/list ([i (in-naturals)][p (in-list ps)]) + (quad (quad-name p) (merge-attrs (quad-attrs p) `(page ,i)) (quad-list p)))) + +(define+provide (pages->doc ps) + (pages? . -> . doc?) + ;; todo: resolve xrefs and other last-minute tasks + ;; todo: generalize computation of widths and heights, recursively + (define (columns-mapper page) + (quad-map (compose1 add-vert-positions (curry quad-map (compose1 compute-line-height add-horiz-positions fill))) page)) + (define mapped-pages (map columns-mapper (number-pages ps))) + (define doc (quads->doc mapped-pages)) + doc) + +(require racket/class csp) +(define+provide (lines->columns lines) + (lines? . -> . columns?) + (define prob (new problem%)) + (define max-column-lines world:default-lines-per-column) + (define-values (columns ignored-return-value) + (for/fold ([columns null][lines-remaining lines])([col-idx (in-naturals)] #:break (empty? lines-remaining)) + (log-quad-info "making column ~a" (add1 col-idx)) + ;; domain constraint is best way to simplify csp, because it limits the search space. + ;; search from largest possible value to smallest. + ;; largest possible is the minimum of the max column lines, or + ;; the number of lines left (modulo minimum page lines) ... + (define viable-column-range + (range (min max-column-lines (max + (length lines-remaining) + (- (length lines-remaining) world:minimum-lines-per-column))) + ;; ... and the smallest possible is 1, or the current minimum lines. + ;; (sub1 insures that range is inclusive of last value.) + (sub1 (min 1 world:minimum-lines-per-column)) -1)) + + (log-quad-debug "viable number of lines for this column to start =\n~a" viable-column-range) + (send prob add-variable "column-lines" viable-column-range) + + + ;; greediness constraint: leave enough lines for next page, or take all + (define (greediness-constraint pl) + (define leftover (- (length lines-remaining) pl)) + (or (= leftover 0) (>= leftover world:minimum-lines-per-column))) + (send prob add-constraint greediness-constraint '("column-lines")) + + (log-quad-debug "viable number of lines after greediness constraint =\n~a" (map (curryr hash-ref "column-lines") (send prob get-solutions))) + + ;; last lines constraint: don't take page that will end with too few lines of last paragraph. + (define (last-lines-constraint pl) + (define last-line-of-page (list-ref lines-remaining (sub1 pl))) + (define lines-in-this-paragraph (quad-attr-ref last-line-of-page world:total-lines-key)) + (define line-index-of-last-line (quad-attr-ref last-line-of-page world:line-index-key)) + (define (paragraph-too-short-to-meet-constraint?) + (< lines-in-this-paragraph world:min-last-lines)) + (or (paragraph-too-short-to-meet-constraint?) + (>= (add1 line-index-of-last-line) world:min-last-lines))) + (send prob add-constraint last-lines-constraint '("column-lines")) + + (log-quad-debug "viable number of lines after last-lines constraint =\n~a" (map (curryr hash-ref "column-lines") (send prob get-solutions))) + + ;; first lines constraint: don't take page that will leave too few lines at top of next page + (define (first-lines-constraint pl lines-remaining) + (define last-line-of-page (list-ref lines-remaining (sub1 pl))) + (define lines-in-this-paragraph (quad-attr-ref last-line-of-page world:total-lines-key)) + (define line-index-of-last-line (quad-attr-ref last-line-of-page world:line-index-key)) + (define lines-that-will-remain (- lines-in-this-paragraph (add1 line-index-of-last-line))) + (define (paragraph-too-short-to-meet-constraint?) + (< lines-in-this-paragraph world:min-first-lines)) + (or (paragraph-too-short-to-meet-constraint?) + (= 0 lines-that-will-remain) ; ok to use all lines ... + (>= lines-that-will-remain world:min-first-lines))) ; but if any remain, must be minimum number. + (send prob add-constraint (curryr first-lines-constraint lines-remaining) '("column-lines")) + + (log-quad-debug "viable number of lines after first-lines constraint =\n~a" (map (curryr hash-ref "column-lines") (send prob get-solutions))) + + + (define s (send prob get-solution)) + (define how-many-lines-to-take (hash-ref s "column-lines")) + (define-values (lines-to-take lines-to-leave) (split-at lines-remaining how-many-lines-to-take)) + (log-quad-debug "taking ~a lines for column ~a:" how-many-lines-to-take (add1 col-idx)) + (map (λ(idx line) (log-quad-debug "~a:~a ~v" (add1 col-idx) (add1 idx) (quad->string line))) (range how-many-lines-to-take) lines-to-take) + (send prob reset) + (values (cons (quad-attr-set (quads->column lines-to-take) world:column-index-key col-idx) columns) lines-to-leave))) + (reverse columns)) + +(define (columns->pages cols) + (columns? . -> . pages?) + (define columns-per-page (quad-attr-ref/parameter (car cols) world:column-count-key)) + (define column-gutter (quad-attr-ref/parameter (car cols) world:column-gutter-key)) + ;; don't use default value here. If the col doesn't have a measure key, + ;; it deserves to be an error, because that means the line was composed incorrectly. + (when (not (quad-has-attr? (car cols) world:measure-key)) + (error 'columns->pages "column attrs contain no measure key: ~a ~a" (quad-attrs (car cols)) (quad-car (car cols)))) + (define column-width (quad-attr-ref (car cols) world:measure-key)) + (define width-of-printed-area (+ (* columns-per-page column-width) (* (sub1 columns-per-page) column-gutter))) + (define result-pages + (map (λ(cols) (quads->page cols)) + (for/list ([page-cols (in-list (slice-at cols columns-per-page))]) + (define-values (last-x cols) + (for/fold ([current-x (/ (- (world:paper-width-default) width-of-printed-area) 2)][cols empty]) ([col (in-list page-cols)][idx (in-naturals)]) + (values (+ current-x column-width column-gutter) (cons (quad-attr-set* col 'x current-x 'y 40 world:column-index-key idx) cols)))) + (reverse cols)))) + result-pages) + +(define current-eof (make-parameter (gensym))) +(define (eof? x) (equal? x (current-eof))) + + + +(define (block-quads->lines qs) + (block->lines (quads->block qs))) + +(define (typeset x) + (coerce/input? . -> . doc?) + (load-text-cache-file) + (define pages (append* (for/list ([multipage (in-list (input->nested-blocks x))]) + (columns->pages (append* (for/list ([multicolumn (in-list multipage)]) + (lines->columns (append* (for/list ([block-quads (in-list multicolumn)]) + (block-quads->lines block-quads)))))))))) + (define doc (pages->doc pages)) + (update-text-cache-file) + doc) + + +(module+ main + (require "render.rkt" racket/class profile sugar/debug) + (require "samples.rkt") + (activate-logger quad-logger) + (parameterize ([world:quality-default world:draft-quality] + [world:paper-width-default 600] + [world:paper-height-default 700]) + #;(define sample (block '(measure 54.0 leading 18.0) "\n" "\n" "Meg is an ally.")) + (let ([toa (begin (time (typeset (dynamic-require "foo2.rkt" 'out))))] + [tob (typeset (block '(measure 54.0 leading 18.0) "Meg \nis an ally."))]) + (report* toa tob (equal? toa tob)) + (time (send (new pdf-renderer%) render-to-file toa "foo-a.pdf")) + (time (send (new pdf-renderer%) render-to-file tob "foo-b.pdf")))))