mbutterick
/
typesetting
2
1
Fork 0
Code Issues 13 Pull Requests Projects Releases Wiki Activity

renaming

Browse Source
main
Matthew Butterick 9 years ago
parent 904c49b129
commit 591d19580c
11 changed files with 268 additions and 267 deletions
Show Stats Download Patch File Download Diff File

2
quad/quad/breaktester.rkt
Unescape Escape View File

@ -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])

4
quad/quad/lang/buttons.rkt → quad/quad/buttons.rkt
Unescape Escape View File

@ -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]

0
quad/quad/lang/cmd-char.png → quad/quad/cmd-char.png
Unescape Escape View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 163 B

After

Width:  |  Height:  |  Size: 163 B

2
quad/quad/foo.rkt
Unescape Escape View File

@ -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"))

18
quad/quad/lang/quad.rkt
Unescape Escape View File

@ -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)))]))

34
quad/quad/lang/reader.rkt
Unescape Escape View File

@ -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]))

256
quad/quad/main.rkt
Unescape Escape View File

@ -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])))

2
quad/quad/quick-test.rkt
Unescape Escape View File

@ -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")

2
quad/quad/segfault.rkt
Unescape Escape View File

@ -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)])

2
quad/quad/stats.rkt
Unescape Escape View File

@ -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

213
quad/quad/typeset.rkt
Unescape Escape View File

@ -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")))))
Write Preview
Loading…
Cancel
Save