From 781cef728d5f100eefc7853bdc7301d8ddacee02 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Thu, 13 Feb 2020 13:53:47 -0800 Subject: [PATCH] start query --- quad/quad/qexpr.rkt | 4 +- quad/quad/quad.rkt | 5 +- quad/quadwriter/debug.rkt | 2 +- quad/quadwriter/render.rkt | 137 ++++++++++++++++++++++--------------- 4 files changed, 88 insertions(+), 60 deletions(-) diff --git a/quad/quad/qexpr.rkt b/quad/quad/qexpr.rkt index 60b487ff..1f1cf3cf 100644 --- a/quad/quad/qexpr.rkt +++ b/quad/quad/qexpr.rkt @@ -40,7 +40,7 @@ (check-true (qexpr? '(quad "Hello world"))) (check-true (qexpr? `(quad "Hello " ,(q "world"))))) -(define (quad-name q) (string->symbol (string-trim (symbol->string (object-name q)) "$"))) +(define (quad-qexpr-name q) (string->symbol (string-trim (symbol->string (object-name q)) "$"))) (define (qexpr #:clean-attrs? [clean-attrs? #f] #:name [name 'q] @@ -67,7 +67,7 @@ (define (quad->qexpr q) (let loop ([x q]) (cond - [(quad? x) (apply qexpr #:name (quad-name x) #:clean-attrs? #t (hash->qattrs (quad-attrs x)) (map loop (quad-elems x)))] + [(quad? x) (apply qexpr #:name (quad-qexpr-name x) #:clean-attrs? #t (hash->qattrs (quad-attrs x)) (map loop (quad-elems x)))] [else x]))) (define (qexpr->quad x) diff --git a/quad/quad/quad.rkt b/quad/quad/quad.rkt index e3d9774f..d8244ada 100644 --- a/quad/quad/quad.rkt +++ b/quad/quad/quad.rkt @@ -74,6 +74,7 @@ draw-start ; func called at the beginning of every draw event (for setup ops) draw ; func called in the middle of every daw event draw-end ; func called at the end of every draw event (for teardown ops) + name ; for anchor resolution tag) ; from q-expr, maybe #:mutable #:transparent @@ -166,6 +167,7 @@ #:draw-start [draw-start void] #:draw [draw default-draw] #:draw-end [draw-end void] + #:name [name #f] . args) (unless (andmap (λ (x) (not (pair? x))) elems) (raise-argument-error 'make-quad "elements that are not lists" elems)) @@ -188,7 +190,8 @@ printable draw-start draw - draw-end)) + draw-end + name)) (apply type (append args (list (or tag (string->symbol (~r (eq-hash-code args) #:base 36))))))])) diff --git a/quad/quadwriter/debug.rkt b/quad/quadwriter/debug.rkt index 962202fd..258bf1e3 100644 --- a/quad/quadwriter/debug.rkt +++ b/quad/quadwriter/debug.rkt @@ -26,7 +26,7 @@ (define debug-column-gap (make-parameter 36)))] [else '(begin - (define draw-debug? (make-parameter #false)) + (define draw-debug? (make-parameter #true)) (define draw-debug-line? (make-parameter #true)) (define draw-debug-block? (make-parameter #true)) (define draw-debug-string? (make-parameter #true)) diff --git a/quad/quadwriter/render.rkt b/quad/quadwriter/render.rkt index c67a3633..25ab73d0 100644 --- a/quad/quadwriter/render.rkt +++ b/quad/quadwriter/render.rkt @@ -57,7 +57,7 @@ #:min-left-length 3 #:min-right-length 3))] [substr (in-list (regexp-match* (regexp (string hyphen-char)) hstr #:gap-select? #t))]) - (struct-copy quad q [elems (list substr)]))] + (struct-copy quad q [elems (list substr)]))] [else (list q)])) @@ -66,12 +66,12 @@ (unless (even? (length pcs)) (raise-argument-error 'string->feature-list "even number of tags and values" pcs)) (for/list ([kv (in-slice 2 pcs)]) - (cons (match (first kv) - [(? string? k) (string->bytes/utf-8 k)] - [k (raise-argument-error 'string->feature-list "string" k)]) - (match (string->number (second kv)) - [(? number? num) num] - [v (raise-argument-error 'string->feature-list "number string" v)])))) + (cons (match (first kv) + [(? string? k) (string->bytes/utf-8 k)] + [k (raise-argument-error 'string->feature-list "string" k)]) + (match (string->number (second kv)) + [(? number? num) num] + [v (raise-argument-error 'string->feature-list "number string" v)])))) (define (parse-font-features! attrs) ;; `font-features` are OpenType font feature specifiers. @@ -106,7 +106,7 @@ ;; we parse them into the equivalent measurement in points. (for ([k (in-hash-keys attrs)] #:when (takes-dimension-string? k)) - (hash-update! attrs k (λ (val) (parse-dimension val attrs)))) + (hash-update! attrs k (λ (val) (parse-dimension val attrs)))) attrs) (define (downcase-values! attrs) @@ -114,9 +114,9 @@ ;; so we can check them more easily later. (for ([k (in-hash-keys attrs)] #:unless (has-case-sensitive-value? k)) - (hash-update! attrs k (λ (val) (match val - [(? string? str) (string-downcase str)] - [_ val])))) + (hash-update! attrs k (λ (val) (match val + [(? string? str) (string-downcase str)] + [_ val])))) attrs) (define (complete-every-path! attrs) @@ -125,7 +125,7 @@ ;; relies on `current-directory` being parameterized to source file's dir (for ([k (in-hash-keys attrs)] #:when (takes-path? k)) - (hash-update! attrs k (compose1 path->string path->complete-path))) + (hash-update! attrs k (compose1 path->string path->complete-path))) attrs) (define (handle-cascading-attrs attrs) @@ -138,7 +138,7 @@ ;; because they can be denoted relative to em size parse-dimension-strings! parse-font-features!))]) - (proc attrs))) + (proc attrs))) (define (drop-leading-breaks qs) ;; any leading breaks are pointless at the start of the doc, so drop them. @@ -160,11 +160,11 @@ [else (convert-string-quad q)])) #;(define (extract-defined-quads qs) - (define (get-define-val q) (quad-ref q 'define)) - (define-values (dqs not-dqs) (partition get-define-val qs)) - (for ([dq-group (in-list (group-by get-define-val dqs))]) - (hash-set! (current-named-quads) (get-define-val (car dq-group)) dq-group)) - not-dqs) + (define (get-define-val q) (quad-ref q 'define)) + (define-values (dqs not-dqs) (partition get-define-val qs)) + (for ([dq-group (in-list (group-by get-define-val dqs))]) + (hash-set! (current-named-quads) (get-define-val (car dq-group)) dq-group)) + not-dqs) (define default-line-height-multiplier 1.42) (define (setup-qs qx-arg base-dir) @@ -256,9 +256,9 @@ (cons :pdf-keywords 'Keywords)))] [str (in-value (and (pair? qs) (quad-ref (car qs) k)))] #:when str) - (cons pdf-k str)))) + (cons pdf-k str)))) (for ([(k v) (in-dict kv-dict)]) - (hash-set! (pdf-info pdf) k v))) + (hash-set! (pdf-info pdf) k v))) (define (footnote-flow? q) (equal? (quad-ref q 'flow) "footnote")) @@ -292,19 +292,19 @@ (for ([page (in-list (for*/list ([sec (in-list secs)] [elem (in-list (quad-elems sec))] #:when (page-quad? elem)) - elem))] + elem))] [page-num (in-naturals 1)] [page-side (in-cycle '(right left))]) - (define repeaters-for-this-page - (for/list ([repeater (in-list repeaters)] - #:when (let* ([val (quad-ref repeater :page-repeat)] - [sym (string->symbol val)]) - (or (eq? sym 'all) - (eq? sym page-side) - (eq? sym (if (= page-num 1) 'first 'rest))))) - repeater)) - (when (pair? repeaters-for-this-page) - (set-quad-elems! page (append repeaters-for-this-page (quad-elems page))))) + (define repeaters-for-this-page + (for/list ([repeater (in-list repeaters)] + #:when (let* ([val (quad-ref repeater :page-repeat)] + [sym (string->symbol val)]) + (or (eq? sym 'all) + (eq? sym page-side) + (eq? sym (if (= page-num 1) 'first 'rest))))) + repeater)) + (when (pair? repeaters-for-this-page) + (set-quad-elems! page (append repeaters-for-this-page (quad-elems page))))) secs) (define (make-sections all-qs) @@ -355,20 +355,20 @@ (for/list ([page (in-list section-pages-without-repeaters)] [page-num (in-naturals 1)] [page-side (in-cycle ((if (eq? section-starting-side 'right) values reverse) '(right left)))]) - (define section-repeaters-for-this-page - (for/list ([repeater (in-list section-repeaters)] - #:when (let* ([val (quad-ref repeater :page-repeat)] - [sym (string->symbol (string-trim val #px"section\\s"))]) - (or (eq? sym 'section) - (eq? sym 'all) - (eq? sym page-side) - (eq? sym (if (= page-num 1) 'first 'rest))))) - repeater)) - (cond - [(null? section-repeaters-for-this-page) page] - [else - (quad-copy page-quad page - [elems (append section-repeaters-for-this-page (quad-elems page))])]))) + (define section-repeaters-for-this-page + (for/list ([repeater (in-list section-repeaters)] + #:when (let* ([val (quad-ref repeater :page-repeat)] + [sym (string->symbol (string-trim val #px"section\\s"))]) + (or (eq? sym 'section) + (eq? sym 'all) + (eq? sym page-side) + (eq? sym (if (= page-num 1) 'first 'rest))))) + repeater)) + (cond + [(null? section-repeaters-for-this-page) page] + [else + (quad-copy page-quad page + [elems (append section-repeaters-for-this-page (quad-elems page))])]))) (begin0 (cond @@ -400,6 +400,28 @@ (cons new-section sections-acc)]) (section-pages-used (+ (section-pages-used) (length section-pages)))))) +(define (resolve-parents doc) + ;; resolve location of any quad with a dynamic anchor-parent attribute like @line:1 + (for* ([section (in-list (quad-elems doc))] + [(page page-idx) (in-indexed (quad-elems section))] + #:when (page-quad? page)) + (define unresolved-qs + (let loop ([x page]) + (match x + [(? quad?) ((if (quad-ref x :anchor-parent) + (λ (tail) (cons x tail)) + values) (append-map loop (quad-elems x)))] + [_ null]))) + (for ([line (in-list (quad-elems page))] + [line-num (in-naturals 1)] + #:when (line-quad? line)) + (define line-key (format "@line:~a" line-num)) + #R line-key + (for ([uq (in-list unresolved-qs)] + #:when (equal? (quad-ref uq :anchor-parent) line-key)) + (quad-update! line [elems (append (quad-elems line) (list uq))])))) + doc) + (define (correct-line-alignment doc) ;; correct lines with inner / outer alignment ;; all inner / outer lines are initially filled as if they were right-aligned @@ -407,16 +429,16 @@ (for* ([section (in-list (quad-elems doc))] [(page page-idx) (in-indexed (quad-elems section))] #:when (page-quad? page)) - (define right-side? (odd? (add1 page-idx))) - (define zero-filler-side (if right-side? "inner" "outer")) - (let loop ([x page]) - (cond - [(and (line-quad? x) - (equal? zero-filler-side (quad-ref x :line-align)) - (filler-quad? (car (quad-elems x)))) - ;; collapse the filler quad by setting size to 0 - (set-quad-size! (car (quad-elems x)) (pt 0 0))] - [(quad? x) (for-each loop (quad-elems x))]))) + (define right-side? (odd? (add1 page-idx))) + (define zero-filler-side (if right-side? "inner" "outer")) + (let loop ([x page]) + (cond + [(and (line-quad? x) + (equal? zero-filler-side (quad-ref x :line-align)) + (filler-quad? (car (quad-elems x)))) + ;; collapse the filler quad by setting size to 0 + (set-quad-size! (car (quad-elems x)) (pt 0 0))] + [(quad? x) (for-each loop (quad-elems x))]))) doc) (define/contract (render-pdf qx-arg @@ -474,7 +496,10 @@ (setup-pdf-metadata! qs (current-pdf)) ;; all the heavy lifting happens inside `make-sections` ;; which calls out to `make-pages`, `make-columns`, and so on. - (define doc (correct-line-alignment (quad-update! q:doc [elems (make-sections qs)]))) + (define doc (let* ([doc (quad-update! q:doc [elems (make-sections qs)])] + [doc (correct-line-alignment doc)] + [doc (resolve-parents doc)]) + doc)) ;; call `position` and `draw` separately so we can print a timer for each (define positioned-doc (time-log position (position doc))) ;; drawing implies that a PDF is written to disk