diff --git a/quad/quad/position.rkt b/quad/quad/position.rkt index 09c0a3b5..b342529e 100644 --- a/quad/quad/position.rkt +++ b/quad/quad/position.rkt @@ -49,12 +49,12 @@ [(nw) '(0 0 )] [(n) '(0.5 0 )] [(ne) '(1 0 )] [( w) '(0 0.5)] [(c) '(0.5 0.5)] [( e) '(1 0.5)] [(sw) '(0 1 )] [(s) '(0.5 1 )] [(se) '(1 1 )] - [(bi) '(0 0 )] [(bo) '(1 0 )] + [(baseline-in bi) '(0 0 )] [(baseline-out bo) '(1 0 )] [else (raise-argument-error 'anchor->local-point (format "anchor value in ~v" valid-anchors) anchor)])) (match-define (list x y) (size q)) (pt (coerce-int (* x x-fac)) (coerce-int (+ (* y y-fac) (match anchor - [(or 'bi 'bo) (vertical-baseline-offset q)] + [(or 'bi 'bo 'baseline-in 'baseline-out) (vertical-baseline-offset q)] [_ 0]))))) (define (inner-point q) diff --git a/quad/quadwriter/attrs.rkt b/quad/quadwriter/attrs.rkt new file mode 100644 index 00000000..0d2d3d94 --- /dev/null +++ b/quad/quadwriter/attrs.rkt @@ -0,0 +1,29 @@ +#lang debug racket/base +(provide (all-defined-out)) +(define block-attrs '(display + inset-top + inset-bottom + inset-left + inset-right + border-inset-top + border-inset-bottom + border-inset-left + border-inset-right + border-width-left + border-width-right + border-width-top + border-width-bottom + border-color-left + border-color-right + border-color-top + border-color-bottom + background-color + keep-lines + keep-first + keep-last + keep-all + keep-with-next + line-align + line-align-last + first-line-indent + line-wrap)) \ No newline at end of file diff --git a/quad/quadwriter/core.rkt b/quad/quadwriter/core.rkt index 94f6833f..31f0dd46 100644 --- a/quad/quadwriter/core.rkt +++ b/quad/quadwriter/core.rkt @@ -10,46 +10,45 @@ sugar/debug racket/unsafe/ops hyphenate + "attrs.rkt" "param.rkt" "font.rkt") - -(provide hrbr lbr pbr run default-font-size default-font-face) - -(define draw-debug? #f) -(define draw-debug-line? #t) -(define draw-debug-block? #t) -(define draw-debug-string? #t) +(provide hrbr lbr pbr run) (define-quad string-quad quad ()) -(define q:string (q #:type string-quad - #:in 'bi - #:out 'bo ;; align to baseline - ;; printable unless single space, which is not printable at start or end - #:printable (λ (q [sig #f]) - (match (quad-elems q) - [(cons elem _) - (case elem - [(" " #\space) (not (memq sig '(start end)))] - [else #true])] - [_ #true])) - ;; draw with pdf text routine - #:draw (λ (q doc) - (when (pair? (quad-elems q)) - (font doc (path->string (quad-ref q font-path-key default-font-face))) - (font-size doc (quad-ref q 'font-size 12)) - (fill-color doc (quad-ref q 'color "black")) - (define str (unsafe-car (quad-elems q))) - (match-define (list x y) (quad-origin q)) - (text doc str x y - #:tracking (quad-ref q 'character-tracking 0) - #:bg (quad-ref q 'bg) - #:features (list (cons #"tnum" 1)) - #:link (quad-ref q 'link)))) - #:draw-end (if draw-debug-string? - (λ (q doc) (draw-debug q doc "#99f" "#ccf")) - void))) - + +(define (q:string-draw q doc) + ;; draw with pdf text routine (when (pair? (quad-elems q)) + (font doc (path->string (quad-ref q font-path-key default-font-face))) + (font-size doc (quad-ref q 'font-size 12)) + (fill-color doc (quad-ref q 'color "black")) + (define str (unsafe-car (quad-elems q))) + (match-define (list x y) (quad-origin q)) + (text doc str x y + #:tracking (quad-ref q 'character-tracking 0) + #:bg (quad-ref q 'bg) + #:features (list (cons #"tnum" 1)) + #:link (quad-ref q 'link))) + +(define (q:string-draw-end q doc) + (when (draw-debug-string?) + (draw-debug q doc "#99f" "#ccf"))) + +(define (q:string-printable? q [sig #f]) + ;; printable unless single space, which is not printable at start or end + (match (quad-elems q) + [(cons elem _) + (case elem + [(" " #\space) (not (memq sig '(start end)))] + [else #true])] + [_ #true])) +(define q:string (q #:type string-quad + #:in 'baseline-in + #:out 'baseline-out + #:printable q:string-printable? + #:draw q:string-draw + #:draw-end q:string-draw-end)) (define (make-size-promise q [str-arg #f]) (delay @@ -87,7 +86,7 @@ (define (draw-debug q doc [fill-color "#f99"] [stroke-color "#fcc"]) - (when draw-debug? + (when (draw-debug?) (save doc) (line-width doc 0.5) (apply rect doc (append (quad-origin q) (size q))) @@ -99,18 +98,20 @@ (fill doc stroke-color) (restore doc))) -(define line-height 16) -(define q:line (q #:size (pt 0 line-height) +(define dumb-hardcoded-line-height 16) +(define q:line (q #:size (pt 0 dumb-hardcoded-line-height) #:inner 'sw #:out 'sw #:printable #true #:draw-start (if draw-debug-line? draw-debug void))) + (struct line-spacer quad () #:transparent) (define q:line-spacer (q #:type line-spacer - #:size (pt 0 (* line-height 0.6)) + #:size (pt 0 (* dumb-hardcoded-line-height 0.6)) #:out 'sw #:printable (λ (q sig) (not (memq sig '(start end)))) - #:draw-start (if draw-debug-line? draw-debug void))) + #:draw-start (if (draw-debug-line?) draw-debug void))) + (define q:line-spacer-unbreakable (struct-copy line-spacer q:line-spacer [attrs #:parent quad @@ -123,12 +124,9 @@ (member (unsafe-car (quad-elems q)) softies))) (define (consolidate-runs pcs ending-q) - (for/fold ([runs empty] - [pcs pcs] - #:result (reverse runs)) - ([i (in-naturals)] - #:break (empty? pcs)) + (let loop ([runs empty][pcs pcs]) (match pcs + [(? empty?) (reverse runs)] [(cons (? string-quad? strq) rest) (define-values (run-pcs rest) (splitf-at pcs (λ (p) (same-run? strq p)))) (define new-run (struct-copy quad q:string @@ -138,8 +136,8 @@ [size (delay (pt (for/sum ([pc (in-list run-pcs)]) (pt-x (size pc))) (pt-y (size strq))))])) - (values (cons new-run runs) rest)] - [(cons first rest) (values (cons first runs) rest)]))) + (loop (cons new-run runs) rest)] + [(cons first rest) (loop (cons first runs) rest)]))) (define (render-hyphen qs ending-q) ;; naive handling of soft hyphen: @@ -170,15 +168,6 @@ (check-true (line-break? (second (atomize (q "foo" pbr "bar")))))) (define (copy-block-attrs source-hash dest-hash) - (define block-attrs '(display - inset-top inset-bottom inset-left inset-right - border-inset-top border-inset-bottom border-inset-left border-inset-right - border-width-left border-width-right border-width-top border-width-bottom - border-color-left border-color-right border-color-top border-color-bottom - background-color - keep-lines keep-first keep-last keep-all keep-with-next - line-align line-align-last first-line-indent - line-wrap)) (for* ([k (in-list block-attrs)] [v (in-value (hash-ref source-hash k #f))] #:when v) @@ -188,16 +177,17 @@ (define (handle-hyphenate qs) ;; find quads that want hyphenation and split them into smaller pieces ;; do this before ->string-quad so that it can handle the sizing promises - (apply append (for/list ([q (in-list qs)]) - (match (quad-ref q 'hyphenate) - [(or #false "false") (list q)] - [_ (for*/list ([str (in-list (quad-elems q))] - [hyphen-char (in-value #\u00AD)] - [hstr (in-value (hyphenate str hyphen-char - #:min-left-length 4 - #:min-right-length 3))] - [substr (in-list (regexp-match* (regexp (string hyphen-char)) hstr #:gap-select? #t))]) - (struct-copy quad q [elems (list substr)]))])))) + (apply append + (for/list ([q (in-list qs)]) + (match (quad-ref q 'hyphenate) + [(or #false "false") (list q)] + [_ (for*/list ([str (in-list (quad-elems q))] + [hyphen-char (in-value #\u00AD)] + [hstr (in-value (hyphenate str hyphen-char + #:min-left-length 4 + #:min-right-length 3))] + [substr (in-list (regexp-match* (regexp (string hyphen-char)) hstr #:gap-select? #t))]) + (struct-copy quad q [elems (list substr)]))])))) (define-quad filler quad ()) (define (fill-wrap qs ending-q line-q) @@ -216,14 +206,15 @@ ;; words may still be in hyphenated fragments ;; (though soft hyphens would have been removed) ;; so group them (but no need to consolidate — that happens elsewhere) - (define occupied-width (match align-value - ;; for justified line, we care about size of words without spaces - ["justify" (for*/sum ([word-sublist (in-list word-sublists)] - [word (in-list word-sublist)]) - (pt-x (size word)))] - ;; for others, we care about size with spaces - [_ (for/sum ([q (in-list qs)]) - (pt-x (size q)))])) + (define occupied-width + (match align-value + ;; for justified line, we care about size of words without spaces + ["justify" (for*/sum ([word-sublist (in-list word-sublists)] + [word (in-list word-sublist)]) + (pt-x (size word)))] + ;; for others, we care about size with spaces + [_ (for/sum ([q (in-list qs)]) + (pt-x (size q)))])) (define empty-hspace (- line-width (quad-ref (car qs) 'inset-left 0) occupied-width @@ -242,28 +233,30 @@ (define-quad offsetter quad ()) +(define (hr-draw dq doc) + (match-define (list left top) (quad-origin dq)) + (match-define (list right bottom)(size dq)) + (save doc) + (translate doc left (+ top (/ bottom 2))) + (move-to doc 0 0) + (line-to doc right 0) + (line-width doc 0.5) + (stroke doc "black") + (restore doc)) + +(define (make-hr-quad line-q) + (struct-copy quad line-q [draw-start hr-draw])) + (define ((finish-line-wrap line-q) pcs-in opening-q ending-q idx) ;; we curry line-q so that the wrap size can be communicated to this operation ;; remove unused soft hyphens so they don't affect final shaping - (define pcs-printing - (for/list ([pc (in-list pcs-in)] - #:unless (equal? (quad-elems pc) '("\u00AD"))) - pc)) + (define pcs-printing (for/list ([pc (in-list pcs-in)] + #:unless (equal? (quad-elems pc) '("\u00AD"))) + pc)) (append (cond [(empty? pcs-printing) null] - [(hr-break? ending-q) - (list (struct-copy quad line-q - [draw-start (λ (dq doc) - (match-define (list left top) (quad-origin dq)) - (match-define (list right bottom)(size dq)) - (save doc) - (translate doc left (+ top (/ bottom 2))) - (move-to doc 0 0) - (line-to doc right 0) - (line-width doc 0.5) - (stroke doc "black") - (restore doc))]))] + [(hr-break? ending-q) (list (make-hr-quad line-q))] [else ;; render hyphen first so that all printable characters are available for size-dependent ops. (define pcs-with-hyphen (render-hyphen pcs-printing ending-q)) @@ -377,22 +370,66 @@ (define side-margin (/ 120 (if zoom-mode? zoom-scale 1))) (define page-offset (pt (/ side-margin (if zoom-mode? 3 1)) (/ top-margin (if zoom-mode? 3 1)))) + +(define (page-draw-start q doc) + (add-page doc) + (scale doc (if zoom-mode? zoom-scale 1) (if zoom-mode? zoom-scale 1))) + +(define (page-draw-end q doc) + (font-size doc 10) + (font doc default-font-face) + (fill-color doc "black") + (text doc (format "~a · ~a at ~a" (hash-ref (quad-attrs q) 'page-number) + (hash-ref (quad-attrs q) 'doc-title) + (date->string (current-date) #t)) + side-margin + (+ (- (pdf-height doc) bottom-margin) 20))) + (define q:page (q #:offset page-offset - #:draw-start (λ (q doc) (add-page doc) - (scale doc (if zoom-mode? zoom-scale 1) (if zoom-mode? zoom-scale 1))) - #:draw-end (λ (q doc) - (font-size doc 10) - (font doc default-font-face) - (fill-color doc "black") - (text doc (format "~a · ~a at ~a" (hash-ref (quad-attrs q) 'page-number) - (hash-ref (quad-attrs q) 'doc-title) - (date->string (current-date) #t)) - side-margin - (+ (- (pdf-height doc) bottom-margin) 20))))) + #:draw-start page-draw-start + #:draw-end page-draw-end)) (define q:doc (q #:draw-start (λ (q doc) (start-doc doc)) #:draw-end (λ (q doc) (end-doc doc)))) +(define ((block-draw-start first-line) q doc) + ;; adjust drawing coordinates for border inset + (match-define (list bil bit bir bib) + (for/list ([k (in-list '(border-inset-left border-inset-top border-inset-right border-inset-bottom))]) + (quad-ref first-line k 0))) + (match-define (list left top) (pt+ (quad-origin q) (list bil bit))) + (match-define (list width height) (pt- (size q) (list (+ bil bir) (+ bit bib)))) + ;; fill rect + (cond + [(quad-ref first-line 'background-color) + => (λ (bgcolor) + (rect doc left top width height) + (fill doc bgcolor))]) + ;; draw border + (match-define (list bw-left bw-top bw-right bw-bottom) + (map (λ (k) (max 0 (quad-ref first-line k 0))) '(border-width-left + border-width-top + border-width-right + border-width-bottom))) + ;; adjust start and end points based on adjacent border width + ;; so all borders overlap rectangularly + (define (half x) (/ x 2.0)) + (define right (+ left width)) + (define bottom (+ top height)) + (define (box-side x1 y1 x2 y2 color stroke-width) + (when (positive? stroke-width) + (move-to doc x1 y1) + (line-to doc x2 y2) + (stroke doc (or color "black") stroke-width))) + (box-side (- left (half bw-left)) top (+ right (half bw-right)) top + (quad-ref first-line 'border-color-top) bw-top) + (box-side right (- top (half bw-top)) right (+ bottom (half bw-bottom)) + (quad-ref first-line 'border-color-right) bw-right) + (box-side (+ right (half bw-right)) bottom (- left (half bw-left)) bottom + (quad-ref first-line 'border-color-bottom) bw-bottom) + (box-side left (+ bottom (half bw-bottom)) left (- top (half bw-top)) + (quad-ref first-line 'border-color-left) bw-left)) + (define (block-wrap lines) (define first-line (car lines)) (q #:in 'nw @@ -404,48 +441,11 @@ (pt-y (size line))) (quad-ref first-line 'inset-top 0) (quad-ref first-line 'inset-bottom 0)))) - #:draw-start (λ (q doc) - ;; adjust drawing coordinates for border inset - (match-define (list bil bit bir bib) - (map (λ (k) (quad-ref first-line k 0)) - '(border-inset-left border-inset-top border-inset-right border-inset-bottom))) - (match-define (list left top) (pt+ (quad-origin q) (list bil bit))) - (match-define (list width height) (pt- (size q) (list (+ bil bir) (+ bit bib)))) - ;; fill rect - (cond - [(quad-ref first-line 'background-color) - => (λ (bgcolor) - (rect doc left top width height) - (fill doc bgcolor))]) - ;; draw border - (match-define (list bw-left bw-top bw-right bw-bottom) - (map (λ (k) (max 0 (quad-ref first-line k 0))) '(border-width-left - border-width-top - border-width-right - border-width-bottom))) - ;; adjust start and end points based on adjacent border width - ;; so all borders overlap rectangularly - (define (half x) (/ x 2.0)) - (define right (+ left width)) - (define bottom (+ top height)) - (define (box-side x1 y1 x2 y2 color stroke-width) - (when (positive? stroke-width) - (move-to doc x1 y1) - (line-to doc x2 y2) - (stroke doc (or color "black") stroke-width))) - (box-side (- left (half bw-left)) top (+ right (half bw-right)) top - (quad-ref first-line 'border-color-top) bw-top) - (box-side right (- top (half bw-top)) right (+ bottom (half bw-bottom)) - (quad-ref first-line 'border-color-right) bw-right) - (box-side (+ right (half bw-right)) bottom (- left (half bw-left)) bottom - (quad-ref first-line 'border-color-bottom) bw-bottom) - (box-side left (+ bottom (half bw-bottom)) left (- top (half bw-top)) - (quad-ref first-line 'border-color-left) bw-left)) - #:draw-end (if draw-debug-block? + #:draw-start (block-draw-start first-line) + #:draw-end (if (draw-debug-block?) (λ (q doc) (draw-debug q doc "#6c6" "#9c9")) void))) - (define (contiguous-group-by pred xs) ;; like `group-by`, but only groups together contiguous xs with the same pred value. (let loop ([xs xs][groups null]) @@ -463,6 +463,17 @@ (contiguous-group-by values '(1 1 2 2 2 3 4 5 5 6 6 7 8 9)) '((1 1) (2 2 2) (3) (4) (5 5) (6 6) (7) (8) (9)))) +(define ((page-finish-wrap path) lns q0 q idx) + (list (struct-copy quad q:page + [attrs (let ([page-number idx] + [h (hash-copy (quad-attrs q:page))]) + (hash-set! h 'page-number page-number) + (define-values (dir name _) + (split-path (path-replace-extension path #""))) + (hash-set! h 'doc-title (string-titlecase (path->string name))) + h)] + [elems (insert-blocks lns)]))) + (define (page-wrap xs vertical-height path) ;; on timing of `insert-blocks`: ;; can't do it before because it depends on where pages are broken. @@ -476,23 +487,14 @@ ;; do trial block insertions (for/sum ([x (in-list (insert-blocks wrap-qs))]) (pt-y (size x)))) - #:finish-wrap (λ (lns q0 q idx) - (list (struct-copy quad q:page - [attrs (let ([page-number idx] - [h (hash-copy (quad-attrs q:page))]) - (hash-set! h 'page-number page-number) - (define-values (dir name _) - (split-path (path-replace-extension path #""))) - (hash-set! h 'doc-title (string-titlecase (path->string name))) - h)] - [elems (insert-blocks lns)]))))) + #:finish-wrap (page-finish-wrap path))) (define (insert-blocks lines) (define groups-of-lines (contiguous-group-by (λ (x) (quad-ref x 'display)) lines)) (append* (for/list ([line-group (in-list groups-of-lines)]) - (match (quad-ref (car line-group) 'display) - [#false line-group] - [_ (list (block-wrap line-group))])))) + (if (quad-ref (car line-group) 'display) + (list (block-wrap line-group)) + line-group)))) (define (handle-cascading-attrs attrs) (resolve-font-path attrs) @@ -526,8 +528,9 @@ (parameterize ([current-doc pdf] [verbose-quad-printing? #false]) (setup-font-path-table! pdf-path) - (let* ([x (time-name parse-qexpr (qexpr->quad `(q ((font-family ,default-font-family) - (font-size ,(number->string default-font-size))) ,xs)))] + (let* ([x (time-name parse-qexpr + (qexpr->quad `(q ((font-family ,default-font-family) + (font-size ,(number->string default-font-size))) ,xs)))] [x (time-name atomize (atomize x #:attrs-proc handle-cascading-attrs))] [x (time-name hyphenate (handle-hyphenate x))] [x (time-name ->string-quad (map ->string-quad x))] diff --git a/quad/quadwriter/markdown.rkt b/quad/quadwriter/markdown.rkt index 88bfeab4..3ea2ca3e 100644 --- a/quad/quadwriter/markdown.rkt +++ b/quad/quadwriter/markdown.rkt @@ -4,12 +4,12 @@ racket/match quadwriter/core "tags.rkt" + "font.rkt" "reader-helper.rkt") (provide (except-out (all-defined-out) mb) (rename-out [mb #%module-begin]) - #%app #%datum #%top-interaction) -(provide (all-from-out "tags.rkt") - rsquo rsquo lsquo ldquo hellip ndash mdash) + #%app #%datum #%top-interaction + (all-from-out "tags.rkt")) (define rsquo "’") (define rdquo "”") diff --git a/quad/quadwriter/param.rkt b/quad/quadwriter/param.rkt index e8d29062..3714f6fa 100644 --- a/quad/quadwriter/param.rkt +++ b/quad/quadwriter/param.rkt @@ -1,3 +1,8 @@ #lang debug racket/base (provide (all-defined-out)) -(define current-doc (make-parameter #f)) \ No newline at end of file +(define current-doc (make-parameter #f)) + +(define draw-debug? (make-parameter #f)) +(define draw-debug-line? (make-parameter #t)) +(define draw-debug-block? (make-parameter #t)) +(define draw-debug-string? (make-parameter #t)) \ No newline at end of file diff --git a/quad/quadwriter/tags.rkt b/quad/quadwriter/tags.rkt index 511168e9..17000671 100644 --- a/quad/quadwriter/tags.rkt +++ b/quad/quadwriter/tags.rkt @@ -5,19 +5,20 @@ racket/string racket/list racket/dict - txexpr/base) + txexpr/base + "font.rkt") (provide (all-defined-out)) (define (root attrs exprs) (qexpr (append `(#;(first-line-indent "12") #;(line-align "center") - (line-wrap "kp") + #;(line-wrap "kp") (line-height "17") #;(line-align-last "center")) attrs) exprs)) (define-tag-function (p attrs exprs) ;; no font-family so that it adopts whatever the surrounding family is - (qexpr (append `((keep-first "2")(keep-last "3") (line-align "justify") (font-size-adjust "100%") (character-tracking "0") (hyphenate "true") (display ,(symbol->string (gensym)))) attrs) exprs)) + (qexpr (append `((keep-first "2")(keep-last "3") (line-align "left") (font-size-adjust "100%") (character-tracking "0") (hyphenate "true") (display ,(symbol->string (gensym)))) attrs) exprs)) (define-tag-function (hr attrs exprs) hrbr)