diff --git a/quad/qtest/emoji.rkt b/quad/qtest/emoji.rkt new file mode 100644 index 00000000..b1b4e441 --- /dev/null +++ b/quad/qtest/emoji.rkt @@ -0,0 +1,5 @@ +#lang quadwriter/markdown + + +馃槀 Hel馃槀lo 馃槀 + diff --git a/quad/quad/atomize.rkt b/quad/quad/atomize.rkt index 4ecac5eb..f1d5f26b 100644 --- a/quad/quad/atomize.rkt +++ b/quad/quad/atomize.rkt @@ -7,9 +7,12 @@ txexpr sugar/list racket/function + "unicode/emoji.rkt" + fontland "quad.rkt" "qexpr.rkt" - "param.rkt") + "param.rkt" + "util.rkt") (provide (all-defined-out)) (module+ test @@ -51,44 +54,87 @@ (define (same-run? qa qb) (eq? (quad-ref qa run-key) (quad-ref qb run-key))) -(define (atomize qx #:attrs-proc [attrs-proc values]) +(define handle-fallback + (let ([font-cache (make-hash)] + [gid-cache (make-hash)]) + (位 (missing-glyph-action str attrs fallback-font emoji-font) + (match missing-glyph-action + ;; #false = no op + [#false (list (cons attrs str))] + [action + (define font-path (hash-ref attrs 'font-path)) + (define f (hash-ref! font-cache font-path (位 () (open-font font-path)))) + (define glyph-ids+chars + (for/list ([c (in-string str)]) + (define glyph-id + (hash-ref! gid-cache (cons c font-path) + (位 () (glyph-id (vector-ref (glyphrun-glyphs (layout f (string c))) 0))))) + (define fallback-result (and (zero? glyph-id) (if (emoji? c) 'emoji 'fallback))) + (cons fallback-result c))) + (for*/list ([cprs (in-list (contiguous-group-by car glyph-ids+chars eq?))] + [fallback-val (in-value (car (car cprs)))] + #:unless (and fallback-val (eq? action 'omit))) + (define str (list->string (map cdr cprs))) + (define maybe-fallback-attrs + (cond + [(not fallback-val) attrs] + [(eq? action 'warning) + (displayln (format "warning: glyph ~a is not available in font ~a" str (path->string font-path))) + attrs] + [(eq? action 'error) + (raise-argument-error 'quad (format "glyph that exists in font ~a" (path->string font-path)) str)] + [(eq? fallback-val 'emoji) (let ([h (hash-copy attrs)]) + (hash-set! h 'font-path emoji-font) + h)] + [(eq? fallback-val 'fallback) (let ([h (hash-copy attrs)]) + (hash-set! h 'font-path fallback-font) + h)])) + (cons maybe-fallback-attrs str))])))) + + +(define (atomize qx #:attrs-proc [attrs-proc values] + #:fallback [fallback-font #f] + #:emoji [emoji-font #f]) ;; atomize a quad by reducing it to the smallest indivisible formatting units. ;; which are multi-character quads with the same formatting. - (define atomized-qs - (let loop ([x (make-quad qx)] - [attrs (hash-copy (current-default-attrs))] - [key (eq-hash-code (current-default-attrs))]) - (match-define-values (next-key next-attrs) - ;; make a new run when we encounter non-empty attrs - (match (quad-attrs x) - [(? hash-empty?) (values key attrs)] - [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) - [(? null?) ((quad-attrs x) . update-with! . next-attrs) (list x)] - [_ - ;; we don't use `struct-copy` here because it needs to have the structure id at compile time. - ;; whereas with this technique, we can extract a constructor for any structure type. - ;; notice that the technique depends on - ;; 1) we only need to update attrs and elems - ;; 2) we make them the first two fields, so we know to drop the first two fields of x-tail - (define x-constructor (derive-quad-constructor x)) - (define x-tail (drop (struct->list x) 2)) - (match (merge-adjacent-strings (quad-elems x) 'isolate-white) - [(? pair? merged-elems) - (append* - (for/list ([elem (in-list merged-elems)]) - (match elem - [(? string? str) (list (apply x-constructor next-attrs (list str) x-tail))] - [_ (loop elem next-attrs next-key)])))] - ;; if merged elements are empty (for instance, series of empty strings) - ;; then zero out the elements in the quad. - [_ (list (apply x-constructor next-attrs null x-tail))])]))) - #;(trimf atomized-qs (位 (q) (equal? (quad-elems q) '(" ")))) - atomized-qs) + (define missing-glyph-action (current-missing-glyph-action)) + + (let loop ([x (make-quad qx)] + [attrs (hash-copy (current-default-attrs))] + [key (eq-hash-code (current-default-attrs))]) + (match-define-values (next-key next-attrs) + ;; make a new run when we encounter non-empty attrs + (match (quad-attrs x) + [(? hash-empty?) (values key attrs)] + [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) + [(? null?) ((quad-attrs x) . update-with! . next-attrs) (list x)] + [_ + ;; we don't use `struct-copy` here because it needs to have the structure id at compile time. + ;; whereas with this technique, we can extract a constructor for any structure type. + ;; notice that the technique depends on + ;; 1) we only need to update attrs and elems + ;; 2) we make them the first two fields, so we know to drop the first two fields of x-tail + (define x-constructor (derive-quad-constructor x)) + (define x-tail (drop (struct->list x) 2)) + (match (merge-adjacent-strings (quad-elems x) 'isolate-white) + [(? pair? merged-elems) + (append* + (for/list ([elem (in-list merged-elems)]) + (match elem + [(? string? str) + (for/list ([attrstr (in-list + (handle-fallback missing-glyph-action str next-attrs fallback-font emoji-font))]) + (match-define (cons attrs str) attrstr) + (apply x-constructor attrs (list str) x-tail))] + [_ (loop elem next-attrs next-key)])))] + ;; if merged elements are empty (for instance, series of empty strings) + ;; then zero out the elements in the quad. + [_ (list (apply x-constructor next-attrs null x-tail))])]))) (module+ test (define (filter-private-keys qs) diff --git a/quad/quad/main.rkt b/quad/quad/main.rkt index 4e4c457c..c1f369c3 100644 --- a/quad/quad/main.rkt +++ b/quad/quad/main.rkt @@ -5,11 +5,13 @@ "qexpr.rkt" "wrap.rkt" "position.rkt" -"param.rkt") +"param.rkt" +"util.rkt") (provide (all-from-out "atomize.rkt" "quad.rkt" "qexpr.rkt" "wrap.rkt" "position.rkt" -"param.rkt")) \ No newline at end of file +"param.rkt" +"util.rkt")) \ No newline at end of file diff --git a/quad/quad/param.rkt b/quad/quad/param.rkt index b4efabfb..45a02bca 100644 --- a/quad/quad/param.rkt +++ b/quad/quad/param.rkt @@ -3,4 +3,5 @@ (define current-default-attrs (make-parameter (make-hasheq))) (define current-wrap-distance (make-parameter 1)) -(define current-default-font-size (make-parameter 12)) \ No newline at end of file +(define current-default-font-size (make-parameter 12)) +(define current-missing-glyph-action (make-parameter #f)) ; #f or 'error or 'warning or 'fallback or 'omit \ No newline at end of file diff --git a/quad/quadwriter/unicode/LICENSE b/quad/quad/unicode/LICENSE similarity index 100% rename from quad/quadwriter/unicode/LICENSE rename to quad/quad/unicode/LICENSE diff --git a/quad/quadwriter/unicode/emoji-prep.rkt b/quad/quad/unicode/emoji-prep.rkt similarity index 96% rename from quad/quadwriter/unicode/emoji-prep.rkt rename to quad/quad/unicode/emoji-prep.rkt index ace99f6c..5533aa6a 100644 --- a/quad/quadwriter/unicode/emoji-prep.rkt +++ b/quad/quad/unicode/emoji-prep.rkt @@ -19,7 +19,7 @@ (string->symbol (string-trim tag))))) (strip-context (with-syntax ([LINES lines]) - #'(module _ quadwriter/unicode/emoji-prep + #'(module _ quad/unicode/emoji-prep . LINES))))) (define-syntax (make-cond stx) diff --git a/quad/quadwriter/unicode/emoji.rkt b/quad/quad/unicode/emoji.rkt similarity index 99% rename from quad/quadwriter/unicode/emoji.rkt rename to quad/quad/unicode/emoji.rkt index 6582aaa9..4211676c 100644 --- a/quad/quadwriter/unicode/emoji.rkt +++ b/quad/quad/unicode/emoji.rkt @@ -1,4 +1,4 @@ -#lang quadwriter/unicode/emoji-prep +#lang quad/unicode/emoji-prep # emoji-sequences.txt # Date: 2019-01-15, 12:17:16 GMT diff --git a/quad/quad/util.rkt b/quad/quad/util.rkt new file mode 100644 index 00000000..74e87793 --- /dev/null +++ b/quad/quad/util.rkt @@ -0,0 +1,20 @@ +#lang racket/base +(require racket/match racket/list) +(provide (all-defined-out)) + +(define (contiguous-group-by pred xs [equality equal?]) + ;; like `group-by`, but only groups together contiguous xs with the same pred value. + (let loop ([xs xs][groups null]) + (match xs + [(== empty equality) (reverse groups)] + [(cons first-x other-xs) + (define equivalence-val (pred first-x)) + (define-values (group-members rest) (splitf-at other-xs (位 (x) (equal? (pred x) equivalence-val)))) + (define new-group (cons first-x group-members)) ; group-members might be empty + (loop rest (cons new-group groups))]))) + +(module+ test + (require rackunit) + (check-equal? + (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)))) \ No newline at end of file diff --git a/quad/quadwriter/core.rkt b/quad/quadwriter/core.rkt index 8f3bd505..891a96c5 100644 --- a/quad/quadwriter/core.rkt +++ b/quad/quadwriter/core.rkt @@ -178,6 +178,7 @@ #:id 'hrbr)) (module+ test + (require rackunit) (check-true (line-break? (second (quad-elems (q "foo" pbr "bar"))))) (check-true (line-break? (second (atomize (q "foo" pbr "bar")))))) @@ -492,23 +493,6 @@ (位 (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]) - (match xs - [(== empty) (reverse groups)] - [(cons first-x other-xs) - (define equivalence-val (pred first-x)) - (define-values (group-members rest) (splitf-at other-xs (位 (x) (equal? (pred x) equivalence-val)))) - (define new-group (cons first-x group-members)) ; group-members might be empty - (loop rest (cons new-group groups))]))) - -(module+ test - (require rackunit) - (check-equal? - (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/match (from-parent qs [where #f]) ;; doesn't change any positioning. doesn't depend on state. can happen anytime. ;; can be repeated without damage. @@ -610,7 +594,10 @@ [qx (qexpr->quad `(q ((font-family ,default-font-family) (font-size ,(number->string default-font-size))) ,qx))]) (setup-font-path-table! pdf-path) - (atomize qx #:attrs-proc handle-cascading-attrs))) + (parameterize ([current-missing-glyph-action 'fallback]) + (time-name atomize (atomize qx #:attrs-proc handle-cascading-attrs + #:fallback (hash-ref font-paths (cons "default-fallback" 'r) #f) + #:emoji (hash-ref font-paths (cons "default-emoji" 'r) #f)))))) ;; page size can be specified by name, or measurements. ;; explicit measurements from page-height and page-width supersede those from page-size. @@ -648,7 +635,7 @@ (quad-ref (car qs) 'page-margin-top (位 () (quad-ref (car qs) 'page-margin-bottom default-y-margin))))] [bottom-margin (let ([vert-optical-adjustment 10]) (or (debug-y-margin) - (quad-ref (car qs) 'page-margin-bottom (位 () (+ vert-optical-adjustment (quad-ref (car qs) 'page-margin-top default-y-margin))))))] + (quad-ref (car qs) 'page-margin-bottom (位 () (+ vert-optical-adjustment (quad-ref (car qs) 'page-margin-top default-y-margin))))))] [page-wrap-size (- (pdf-height pdf) top-margin bottom-margin)] [page-quad (struct-copy quad q:page [shift (pt left-margin top-margin)] diff --git a/quad/quadwriter/fonts/default-fallback/LICENSE_OFL.txt b/quad/quadwriter/fonts/default-fallback/LICENSE_OFL.txt new file mode 100644 index 00000000..d952d62c --- /dev/null +++ b/quad/quadwriter/fonts/default-fallback/LICENSE_OFL.txt @@ -0,0 +1,92 @@ +This Font Software is licensed under the SIL Open Font License, +Version 1.1. + +This license is copied below, and is also available with a FAQ at: +http://scripts.sil.org/OFL + +----------------------------------------------------------- +SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007 +----------------------------------------------------------- + +PREAMBLE +The goals of the Open Font License (OFL) are to stimulate worldwide +development of collaborative font projects, to support the font +creation efforts of academic and linguistic communities, and to +provide a free and open framework in which fonts may be shared and +improved in partnership with others. + +The OFL allows the licensed fonts to be used, studied, modified and +redistributed freely as long as they are not sold by themselves. The +fonts, including any derivative works, can be bundled, embedded, +redistributed and/or sold with any software provided that any reserved +names are not used by derivative works. The fonts and derivatives, +however, cannot be released under any other type of license. The +requirement for fonts to remain under this license does not apply to +any document created using the fonts or their derivatives. + +DEFINITIONS +"Font Software" refers to the set of files released by the Copyright +Holder(s) under this license and clearly marked as such. This may +include source files, build scripts and documentation. + +"Reserved Font Name" refers to any names specified as such after the +copyright statement(s). + +"Original Version" refers to the collection of Font Software +components as distributed by the Copyright Holder(s). + +"Modified Version" refers to any derivative made by adding to, +deleting, or substituting -- in part or in whole -- any of the +components of the Original Version, by changing formats or by porting +the Font Software to a new environment. + +"Author" refers to any designer, engineer, programmer, technical +writer or other person who contributed to the Font Software. + +PERMISSION & CONDITIONS +Permission is hereby granted, free of charge, to any person obtaining +a copy of the Font Software, to use, study, copy, merge, embed, +modify, redistribute, and sell modified and unmodified copies of the +Font Software, subject to the following conditions: + +1) Neither the Font Software nor any of its individual components, in +Original or Modified Versions, may be sold by itself. + +2) Original or Modified Versions of the Font Software may be bundled, +redistributed and/or sold with any software, provided that each copy +contains the above copyright notice and this license. These can be +included either as stand-alone text files, human-readable headers or +in the appropriate machine-readable metadata fields within text or +binary files as long as those fields can be easily viewed by the user. + +3) No Modified Version of the Font Software may use the Reserved Font +Name(s) unless explicit written permission is granted by the +corresponding Copyright Holder. This restriction only applies to the +primary font name as presented to the users. + +4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font +Software shall not be used to promote, endorse or advertise any +Modified Version, except to acknowledge the contribution(s) of the +Copyright Holder(s) and the Author(s) or with their explicit written +permission. + +5) The Font Software, modified or unmodified, in part or in whole, +must be distributed entirely under this license, and must not be +distributed under any other license. The requirement for fonts to +remain under this license does not apply to any document created using +the Font Software. + +TERMINATION +This license becomes null and void if any of the above conditions are +not met. + +DISCLAIMER +THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT +OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE +COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL +DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM +OTHER DEALINGS IN THE FONT SOFTWARE. diff --git a/quad/quadwriter/fonts/default-fallback/bold-italic/NotoSans-BoldItalic.ttf b/quad/quadwriter/fonts/default-fallback/bold-italic/NotoSans-BoldItalic.ttf new file mode 100644 index 00000000..385e6acb Binary files /dev/null and b/quad/quadwriter/fonts/default-fallback/bold-italic/NotoSans-BoldItalic.ttf differ diff --git a/quad/quadwriter/fonts/default-fallback/bold/NotoSans-Bold.ttf b/quad/quadwriter/fonts/default-fallback/bold/NotoSans-Bold.ttf new file mode 100644 index 00000000..1db7886e Binary files /dev/null and b/quad/quadwriter/fonts/default-fallback/bold/NotoSans-Bold.ttf differ diff --git a/quad/quadwriter/fonts/default-fallback/italic/NotoSans-Italic.ttf b/quad/quadwriter/fonts/default-fallback/italic/NotoSans-Italic.ttf new file mode 100644 index 00000000..6d2c71c8 Binary files /dev/null and b/quad/quadwriter/fonts/default-fallback/italic/NotoSans-Italic.ttf differ diff --git a/quad/quadwriter/fonts/default-fallback/regular/NotoSans-Regular.ttf b/quad/quadwriter/fonts/default-fallback/regular/NotoSans-Regular.ttf new file mode 100644 index 00000000..0a01a062 Binary files /dev/null and b/quad/quadwriter/fonts/default-fallback/regular/NotoSans-Regular.ttf differ