From 2e6f84565134da0ee8c149947a3463601e67f81d Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sat, 20 Feb 2016 17:40:18 -0800 Subject: [PATCH] sick burns --- quad/quad/foo2.rkt | 2 +- quad/quad/lang/buttons.rkt | 9 +++++++-- quad/quad/lang/quad.rkt | 11 ++++++---- quad/quad/lang/zam.rkt | 1 + quad/quad/main.rkt | 41 ++++++++++++++++++++------------------ quad/quad/render.rkt | 3 ++- quad/quad/utils.rkt | 7 ++++--- 7 files changed, 44 insertions(+), 30 deletions(-) create mode 100644 quad/quad/lang/zam.rkt diff --git a/quad/quad/foo2.rkt b/quad/quad/foo2.rkt index 94855f29..1510f843 100644 --- a/quad/quad/foo2.rkt +++ b/quad/quad/foo2.rkt @@ -1,3 +1,3 @@ #lang quad -Hello @block-break[] world @block-break[] galaxy \ No newline at end of file +match-select specifies the collected results. The default of car means that the result is the list of matches without returning parenthesized sub-patterns. It can be given as a ‘selector’ function which chooses an item from a list, or it can choose a list of items. For example, you can use cdr to get a list of lists of parenthesized sub-patterns matches, or values (as an identity function) to get the full matches as well. (Note that the selector must choose an element of its input list or a list of elements, but it must not inspect its input as they can be either a list of strings or a list of position pairs. Furthermore, the selector must be consistent in its choice(s).) \ No newline at end of file diff --git a/quad/quad/lang/buttons.rkt b/quad/quad/lang/buttons.rkt index 9c551c9f..fe09d522 100644 --- a/quad/quad/lang/buttons.rkt +++ b/quad/quad/lang/buttons.rkt @@ -27,11 +27,16 @@ http://pkg-build.racket-lang.org/doc/tools/drracket_module-language-tools.html#% (define pdfn (path-replace-suffix fn #".pdf")) (define fn-out (parameterize ([current-namespace (make-base-namespace)]) (namespace-attach-module (namespace-anchor->namespace cache-module-ns) 'quad) - (dynamic-require fn 'out))) + (dynamic-require `(submod ,fn outy) 'out))) (when fn-out (define-values (fn-dir name dir?) (split-path fn)) (parameterize ([current-directory fn-dir]) - (send (new pdf-renderer%) render-to-file (typeset fn-out) pdfn)) + (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] + [world:paper-height-default 700]) + (send (new pdf-renderer%) render-to-file (typeset fn-out) pdfn))) (parameterize ([current-input-port (open-input-string "")]) (system (format "open \"~a\"" (path->string pdfn))))))] [number 99]) diff --git a/quad/quad/lang/quad.rkt b/quad/quad/lang/quad.rkt index 8144c679..39e279a1 100644 --- a/quad/quad/lang/quad.rkt +++ b/quad/quad/lang/quad.rkt @@ -9,7 +9,10 @@ [(_ expr ...) (replace-context #'(expr ...) #'(#%module-begin - - (define out (block '(measure 200.0 font "Times New Roman" leading 16.0 vmeasure 300.0 size 13.5) expr ...)) - (provide out)))])) - + (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/zam.rkt b/quad/quad/lang/zam.rkt new file mode 100644 index 00000000..6f1f7b4d --- /dev/null +++ b/quad/quad/lang/zam.rkt @@ -0,0 +1 @@ +#lang racket diff --git a/quad/quad/main.rkt b/quad/quad/main.rkt index 699e118e..60ada1f7 100644 --- a/quad/quad/main.rkt +++ b/quad/quad/main.rkt @@ -2,12 +2,12 @@ (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))]) + ([q (in-list (report (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)] @@ -33,10 +33,10 @@ (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)))) + (format "~a/~a: ~v ~a" idx + (length lines) + (quad->string line) + (quad-attr-ref line world:line-looseness-key)))) (require racket/trace) @@ -71,13 +71,13 @@ (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))))) + (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)))) + (quad (quad-name p) (merge-attrs (quad-attrs p) `(page ,i)) (quad-list p)))) (define+provide (pages->doc ps) (pages? . -> . doc?) @@ -172,10 +172,10 @@ (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)))) + (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))) @@ -190,21 +190,24 @@ (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)))))))))) + (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 +(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 (jude0)) - (define to (begin (time (typeset sample)))) - (time (send (new pdf-renderer%) render-to-file to "foo.pdf")))) + #;(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"))))) diff --git a/quad/quad/render.rkt b/quad/quad/render.rkt index f5d62000..096f3cec 100644 --- a/quad/quad/render.rkt +++ b/quad/quad/render.rkt @@ -49,6 +49,7 @@ (define-syntax-rule (map/send method xs) (map (λ(x) (method x)) xs)) + (define pdf-renderer% (class abstract-renderer% (super-new) @@ -70,7 +71,7 @@ (define/caching (make-font/caching font size style weight) (make-font #:face font #:size size #:style style #:weight weight)) - + (define/override-final (render-word w) (define word-font (quad-attr-ref/parameter w world:font-name-key)) (define word-size (quad-attr-ref/parameter w world:font-size-key)) diff --git a/quad/quad/utils.rkt b/quad/quad/utils.rkt index 221042c6..0f9022fd 100644 --- a/quad/quad/utils.rkt +++ b/quad/quad/utils.rkt @@ -78,7 +78,6 @@ ;; pushes attributes down from parent quads to children, ;; resulting in a flat list of quads. (provide flatten-quad) -(require sugar/debug) (define (flatten-quad q) ; (quad? . -> . quads?) (flatten @@ -93,9 +92,10 @@ (map (λ(xi) (loop xi x-with-parent-attrs)) (quad-list x))))] ; replace quad with its elements [(string? x) (quad (quad-name parent) (quad-attrs parent) (list x))])))) +(require sugar/debug) ;; flatten quad as above, ;; then dissolve it into individual character quads while copying attributes -;; input is often large, so macro allows us to avoid allocation + (define+provide (split-quad q) ;(quad? . -> . quads?) (letrec ([do-explode (λ(x [parent #f]) @@ -104,7 +104,8 @@ (if (empty? (quad-list x)) x ; no subelements, so stop here (map (λ(xi) (do-explode xi x)) (quad-list x)))] ; replace quad with its elements, exploded - [else (map (λ(xc) (quad 'word (quad-attrs parent) (list xc))) (regexp-match* #px"." x))]))]) + ;; todo: figure out why newlines foul up the input stream. Does it suffice to ignore them? + [else (map (λ(xc) (quad 'word (quad-attrs parent) (list xc))) (report (regexp-match* #px"[^\r\n]" x)))]))]) (flatten (map do-explode (flatten-quad q)))))