diff --git a/quad/qtest/fark.rkt b/quad/qtest/fark.rkt index 49129eef..2730890d 100644 --- a/quad/qtest/fark.rkt +++ b/quad/qtest/fark.rkt @@ -2,7 +2,7 @@ # Hyphenate -A simple _hyphenation engine_ that uses the Knuth–Liang hyphenation algorithm originally developed for TeX. +A simple _hyphenation engine_ that uses the _**Knuth–Liang**_ hyphenation algorithm originally developed for TeX. I **have added little** to their work. Accordingly, I take no credit, except a spoonful of *snako-bits.* @@ -25,7 +25,7 @@ it's a codeblock! ``` -> A simple _hyphenation engine_ that uses the Knuth–Liang hyphenation algorithm originally developed for TeX. A simple _hyphenation engine_ that uses the Knuth–Liang hyphenation algorithm originally developed for TeX. +> A simple _hyphenation engine_ that **uses** the _**Knuth–Liang**_ hyphenation algorithm originally developed for TeX. A simple _hyphenation engine_ that uses the Knuth–Liang hyphenation algorithm originally developed for TeX. ``` diff --git a/quad/qtest/fonts/charter-bold-italic.ttf b/quad/qtest/fonts/charter/charter-bold-italic.ttf similarity index 100% rename from quad/qtest/fonts/charter-bold-italic.ttf rename to quad/qtest/fonts/charter/charter-bold-italic.ttf diff --git a/quad/qtest/fonts/charter-bold.ttf b/quad/qtest/fonts/charter/charter-bold.ttf similarity index 100% rename from quad/qtest/fonts/charter-bold.ttf rename to quad/qtest/fonts/charter/charter-bold.ttf diff --git a/quad/qtest/fonts/charter-italic.ttf b/quad/qtest/fonts/charter/charter-italic.ttf similarity index 100% rename from quad/qtest/fonts/charter-italic.ttf rename to quad/qtest/fonts/charter/charter-italic.ttf diff --git a/quad/qtest/fonts/charter.ttf b/quad/qtest/fonts/charter/charter.ttf similarity index 100% rename from quad/qtest/fonts/charter.ttf rename to quad/qtest/fonts/charter/charter.ttf diff --git a/quad/qtest/fonts/default.ttf b/quad/qtest/fonts/default.ttf new file mode 100644 index 00000000..33c6d7cb Binary files /dev/null and b/quad/qtest/fonts/default.ttf differ diff --git a/quad/qtest/fonts/fira-light-bold-italic.ttf b/quad/qtest/fonts/fira-light/fira-light-bold-italic.ttf similarity index 100% rename from quad/qtest/fonts/fira-light-bold-italic.ttf rename to quad/qtest/fonts/fira-light/fira-light-bold-italic.ttf diff --git a/quad/qtest/fonts/fira-light-bold.ttf b/quad/qtest/fonts/fira-light/fira-light-bold.ttf similarity index 100% rename from quad/qtest/fonts/fira-light-bold.ttf rename to quad/qtest/fonts/fira-light/fira-light-bold.ttf diff --git a/quad/qtest/fonts/fira-light-italic.ttf b/quad/qtest/fonts/fira-light/fira-light-italic.ttf similarity index 100% rename from quad/qtest/fonts/fira-light-italic.ttf rename to quad/qtest/fonts/fira-light/fira-light-italic.ttf diff --git a/quad/qtest/fonts/fira-light.ttf b/quad/qtest/fonts/fira-light/fira-light.ttf similarity index 100% rename from quad/qtest/fonts/fira-light.ttf rename to quad/qtest/fonts/fira-light/fira-light.ttf diff --git a/quad/qtest/fonts/fira-mono.ttf b/quad/qtest/fonts/fira-mono/fira-mono.ttf similarity index 100% rename from quad/qtest/fonts/fira-mono.ttf rename to quad/qtest/fonts/fira-mono/fira-mono.ttf diff --git a/quad/qtest/fonts/fira-bold-italic.ttf b/quad/qtest/fonts/fira/fira-bold-italic.ttf similarity index 100% rename from quad/qtest/fonts/fira-bold-italic.ttf rename to quad/qtest/fonts/fira/fira-bold-italic.ttf diff --git a/quad/qtest/fonts/fira-bold.ttf b/quad/qtest/fonts/fira/fira-bold.ttf similarity index 100% rename from quad/qtest/fonts/fira-bold.ttf rename to quad/qtest/fonts/fira/fira-bold.ttf diff --git a/quad/qtest/fonts/fira-italic.ttf b/quad/qtest/fonts/fira/fira-italic.ttf similarity index 100% rename from quad/qtest/fonts/fira-italic.ttf rename to quad/qtest/fonts/fira/fira-italic.ttf diff --git a/quad/qtest/fonts/fira.ttf b/quad/qtest/fonts/fira/fira.ttf similarity index 100% rename from quad/qtest/fonts/fira.ttf rename to quad/qtest/fonts/fira/fira.ttf diff --git a/quad/qtest/markdown.rkt b/quad/qtest/markdown.rkt index a7f61ad0..d7471980 100644 --- a/quad/qtest/markdown.rkt +++ b/quad/qtest/markdown.rkt @@ -1,5 +1,5 @@ #lang debug racket/base -(require (for-syntax racket/base) txexpr racket/runtime-path racket/string racket/promise racket/match racket/list +(require (for-syntax racket/base) txexpr racket/runtime-path racket/path racket/string racket/promise racket/match racket/list pitfall quad sugar/debug pollen/tag racket/unsafe/ops) (provide (except-out (all-from-out racket/base) #%module-begin) (rename-out [mb #%module-begin]) @@ -17,7 +17,8 @@ (define mdash "—") (define-tag-function (p attrs exprs) - (qexpr (append `((keep-first "2")(keep-last "3")(font-family "charter") (display ,(symbol->string (gensym)))) attrs) exprs)) + ;; no font-family so that it adopts whatever the surrounding family is + (qexpr (append `((keep-first "2")(keep-last "3") (display ,(symbol->string (gensym)))) attrs) exprs)) (define-tag-function (hr attrs exprs) hrbr) @@ -69,7 +70,7 @@ (define new-exprs (add-between (for*/list ([expr (in-list exprs)] [str (in-list (string-split (string-join (get-elements expr) "") "\n"))]) - `(,(get-tag expr) ,(get-attrs expr) ,(string-replace str " " " "))) + `(,(get-tag expr) ,(get-attrs expr) ,(string-replace str " " " "))) lbr)) (qexpr (list* '(display "block") '(background-color "aliceblue") '(font-family "fira-mono") '(fontsize "11") '(line-height "14") @@ -90,7 +91,7 @@ (qexpr (list* '(inset-left "20") attrs) (add-between (for/list ([(expr idx) (in-indexed exprs)]) - (list* (get-tag expr) (cons (list 'list-index (or bullet-val (format "~a" (add1 idx)))) (get-attrs expr)) (get-elements expr))) + (list* (get-tag expr) (cons (list 'list-index (or bullet-val (format "~a" (add1 idx)))) (get-attrs expr)) (get-elements expr))) pbr))) (define-tag-function (ol attrs exprs) (list-base attrs exprs)) @@ -123,18 +124,7 @@ (λ (q doc) (draw-debug q doc "#99f" "#ccf")) void))) -(define-runtime-path charter "fonts/charter.ttf") -(define-runtime-path charter-bold "fonts/charter-bold.ttf") -(define-runtime-path charter-italic "fonts/charter-italic.ttf") -(define-runtime-path fira "fonts/fira.ttf") -(define-runtime-path fira-bold "fonts/fira-bold.ttf") -(define-runtime-path fira-italic "fonts/fira.ttf") -(define-runtime-path fira-light "fonts/fira-light.ttf") -(define-runtime-path fira-light-bold "fonts/fira-light-bold.ttf") -(define-runtime-path fira-light-italic "fonts/fira-light-italic.ttf") -(define-runtime-path fira-mono "fonts/fira-mono.ttf") - -(define default-font-face charter) +(define default-font-face "fonts/default.ttf") (define default-font-family "charter") (define default-font-size 12) @@ -145,37 +135,6 @@ (struct-copy quad q:string [attrs (let ([attrs (quad-attrs q)]) - ;; attrs hashes are shared between many quads. - ;; so the first update will change every reference to the shared hash - ;; hence why we ignore if val is already a path - ;; but this op should ideally happen earlier - (unless (quad-ref q font-path-key) - (hash-set! attrs font-path-key - (match (string-downcase - (string-replace (or (quad-ref q 'font-family) default-font-family) " " "-")) - ["charter" (if (quad-ref q 'font-bold) - (if (quad-ref q 'font-italic) - (error 'no-charter-bold-italic) - charter-bold) - (if (quad-ref q 'font-italic) - charter-italic - charter))] - ["fira" (if (quad-ref q 'font-bold) - (if (quad-ref q 'font-italic) - (error 'no-fira-bold-italic) - fira-bold) - (if (quad-ref q 'font-italic) - fira-italic - fira))] - ["fira-light" (if (quad-ref q 'font-bold) - (if (quad-ref q 'font-italic) - (error 'no-fira-light-italic) - fira-light-bold) - (if (quad-ref q 'font-italic) - fira-light-italic - fira-light))] - ["fira-mono" fira-mono] - [_ default-font-face]))) (hash-ref! attrs 'fontsize default-font-size) attrs)] [elems (quad-elems q)] @@ -237,9 +196,9 @@ (define new-run (struct-copy quad q:string [attrs (quad-attrs (car pcs))] [elems (merge-adjacent-strings (apply append (for/list ([pc (in-list run-pcs)]) - (quad-elems pc))))] + (quad-elems pc))))] [size (delay (pt (for/sum ([pc (in-list run-pcs)]) - (pt-x (size pc))) + (pt-x (size pc))) (pt-y (size (car pcs)))))])) (values (cons new-run runs) rest))) @@ -266,7 +225,7 @@ (for* ([k (in-list block-attrs)] [v (in-value (hash-ref source-hash k #f))] #:when v) - (hash-set! dest-hash k v)) + (hash-set! dest-hash k v)) dest-hash) (define (line-wrap xs wrap-size) @@ -335,8 +294,8 @@ [prev-ln (in-list (cdr reversed-lines))] #:when (and (line-spacer? this-ln) (quad-ref prev-ln 'keep-with-next))) - (make-nobreak! prev-ln) - (make-nobreak! this-ln))) + (make-nobreak! prev-ln) + (make-nobreak! this-ln))) (define (apply-keeps lines) (define groups-of-lines (contiguous-group-by (λ (x) (quad-ref x 'display)) lines)) @@ -376,7 +335,7 @@ (scale doc (if zoom-mode? 3 1) (if zoom-mode? 3 1))) #:draw-end (λ (q doc) (font-size doc 10) - (font doc charter) + (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) @@ -395,7 +354,7 @@ #:elems lines #:size (delay (pt (pt-x (size first-line)) ; (+ (for/sum ([line (in-list lines)]) - (pt-y (size line))) + (pt-y (size line))) (quad-ref first-line 'inset-top 0) (quad-ref first-line 'inset-bottom 0)))) #:draw-start (λ (q doc) @@ -458,13 +417,18 @@ '((1 1) (2 2 2) (3) (4) (5 5) (6 6) (7) (8) (9)))) (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. + ;; could do it after, but it would require going back inside each page quad + ;; which seems overly interdependent, because `insert-blocks` is used to determine break locations. + ;; `page-wrap` should emit quads that are complete. (wrap xs vertical-height #:soft-break (λ (q) #true) #:no-break (λ (q) (quad-ref q 'no-pbr)) #:distance (λ (q dist-so-far wrap-qs) ;; do trial block insertions (for/sum ([x (in-list (insert-blocks wrap-qs))]) - (pt-y (size x)))) + (pt-y (size x)))) #:finish-wrap (λ (lns q0 q idx) (list (struct-copy quad q:page [attrs (let ([page-number idx] @@ -479,23 +443,81 @@ (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))])))) - -(define (run xs path) + (match (quad-ref (car line-group) 'display) + [#false line-group] + [_ (list (block-wrap line-group))])))) + +(define font-paths (make-hash)) + +(define (setup-font-path-table! base-path) + ;; populate `font-paths` table with font paths + ;; search "fonts" subdirectory in project for other subdirectories + ;; which are presumed to contain fonts. + ;; and link them to their family names & styles. + ;; this allows a flexible mapping from internal to external names, like @font-face + ;; note that all the semantics are derived from the file system + ;; not any metadata fields within the font. + ;; this is faster and easier, because you can just muck with the directory and filenames + ;; to change the font mapping. + ;; though it also creates the potential for mischief, + ;; if a font is named something that doesn't reflect its visual reality. + ;; but we are not the font police. + (define-values (dir path _) (split-path base-path)) + (define fonts-dir (build-path dir "fonts")) + (for* ([font-family-subdir (in-directory fonts-dir)] + #:when (directory-exists? font-family-subdir) + [font-path (in-directory font-family-subdir)] + #:when (path-has-extension? font-path #"ttf")) + (match-define (list font-path-string family-name) + (map (λ (x) (path->string (find-relative-path fonts-dir x))) (list font-path font-family-subdir))) + (define key + (cons family-name + (match (string-downcase font-path-string) + [(and (regexp "bold") (regexp "italic")) 'bi] + [(regexp "bold") 'b] + [(regexp "italic") 'i] + [_ 'r]))) + ;; only set value if there's not one there already. + ;; this means that we only use the first eligible font we find. + (hash-ref! font-paths key font-path))) + +(define (font-attrs->path font-family bold italic) + ;; find the font-path corresponding to a certain family name and style. + (define key (cons font-family + (cond + [(and bold italic) 'bi] + [bold 'b] + [italic 'i] + [else 'r]))) + (define regular-key (cons font-family 'r)) + (cond + [(hash-ref font-paths key #false)] + ;; if there isn't one, try the regular style. + [(hash-ref font-paths regular-key #false)] + ;; If there isn't one, use the default. + [else default-font-face])) + +(define (resolve-font-path attrs) + (define this-font-family (hash-ref! attrs 'font-family default-font-family)) + (define this-bold (hash-ref! attrs 'font-bold #false)) + (define this-italic (hash-ref! attrs 'font-italic #false)) + (hash-set! attrs 'font-path (font-attrs->path this-font-family this-bold this-italic))) + +(define (run xs pdf-path) (define pdf (time-name make-pdf (make-pdf #:compress #t #:auto-first-page #f - #:output-path path + #:output-path pdf-path #:width (if zoom-mode? 350 612) #:height (if zoom-mode? 400 792)))) (define line-width (- (pdf-width pdf) (* 2 side-margin))) (define vertical-height (- (pdf-height pdf) top-margin bottom-margin)) - (let* ([x (time-name atomize (atomize (qexpr->quad xs)))] + (setup-font-path-table! pdf-path) + (let* ([x (time-name parse-qexpr (qexpr->quad xs))] + [x (time-name atomize (atomize x #:attrs-proc resolve-font-path))] [x (time-name ->string-quad (map (λ (x) (->string-quad pdf x)) x))] [x (time-name line-wrap (line-wrap x line-width))] [x (time-name apply-keeps (apply-keeps x))] - [x (time-name page-wrap (page-wrap x vertical-height path))] + [x (time-name page-wrap (page-wrap x vertical-height pdf-path))] [x (time-name position (position (struct-copy quad q:doc [elems x])))]) (time-name draw (draw x pdf)))) diff --git a/quad/quad/atomize.rkt b/quad/quad/atomize.rkt index c274e7bc..919cb929 100644 --- a/quad/quad/atomize.rkt +++ b/quad/quad/atomize.rkt @@ -50,7 +50,7 @@ (define (same-run? qa qb) (eq? (quad-ref qa run-key) (quad-ref qb run-key))) -(define (atomize qx) +(define (atomize qx #:attrs-proc [attrs-proc values]) ;; atomize a quad by reducing it to the smallest indivisible formatting units. ;; which are multi-character quads with the same formatting. (define atomized-qs @@ -64,6 +64,7 @@ [this-attrs (define next-key (eq-hash-code this-attrs)) (define next-attrs (attrs . update-with . this-attrs)) (hash-set! next-attrs run-key next-key) + (attrs-proc next-attrs) (values next-key next-attrs)])) (match (quad-elems x) [(? pair? elems)