diff --git a/quad2/draw.rkt b/quad2/draw.rkt index 8d1327d9..a3c94518 100644 --- a/quad2/draw.rkt +++ b/quad2/draw.rkt @@ -6,7 +6,8 @@ "quad.rkt" "pipeline.rkt" "struct.rkt" - "layout.rkt") + "layout.rkt" + "constants.rkt") (provide (all-defined-out)) (define-pass (make-drawing-insts qs) @@ -14,16 +15,23 @@ #:post (list-of $drawing-inst?) (flatten (list ($doc 'start) ($page 'start) - (for/list ([q (in-list qs)]) - (cond - [(quad? q) - (if (pair? (quad-elems q)) - (list ($move (quad-posn q)) ($text (char->integer (car (string->list (car (quad-elems q))))))) - (list))] - [else (error 'render-unknown-thing)])) + (let ([current-font #false]) + (for/list ([q (in-list qs)]) + (append + (match (quad-ref q :font-path) + [(== current-font) (list)] + [font-path + (set! current-font font-path) + (list ($font font-path))]) + (cond + [(quad? q) + (if (pair? (quad-elems q)) + (list ($move (quad-posn q)) ($text (char->integer (car (string->list (car (quad-elems q))))))) + (list))] + [else (error 'render-unknown-thing)])))) ($page 'end) ($doc 'end)))) -(define valid-tokens '(doc-start doc-end page-start page-end text move)) +(define valid-tokens '(doc-start doc-end page-start page-end text move set-font)) (define-pass (stackify xs) #:pre (list-of $drawing-inst?) @@ -33,11 +41,12 @@ (define ymax (if (pair? move-points) (add1 (apply max (map $point-y move-points))) 0)) (string-join (for/list ([x (in-list xs)]) - (string-join (map ~a (match x - [($move ($point x y)) (list y x 'move)] - [($text charint) (list charint 'text)] - [($doc 'start) '(doc-start)] - [($doc 'end) '(doc-end)] - [($page 'start) (list ymax xmax 'page-start)] - [($page 'end) '(page-end)] - [_ (error 'unknown-drawing-inst)])) " ")) "\n")) \ No newline at end of file + (string-join (map ~a (match x + [($move ($point x y)) (list y x 'move)] + [($text charint) (list charint 'text)] + [($font path-string) (list path-string 'set-font)] + [($doc 'start) '(doc-start)] + [($doc 'end) '(doc-end)] + [($page 'start) (list ymax xmax 'page-start)] + [($page 'end) '(page-end)] + [_ (error 'unknown-drawing-inst)])) " ")) "\n")) \ No newline at end of file diff --git a/quad2/font.rkt b/quad2/font.rkt index 4d00fded..a8034d84 100644 --- a/quad2/font.rkt +++ b/quad2/font.rkt @@ -272,7 +272,8 @@ ;; at this point we have a font-path value for each character ;; (which might be #false) ;; but we don't know if the character is in that font. - ;; for chars whose font is missing, we mark the font-path as #false. + ;; for quads with a font-path that doesn't contain the char, + ;; we change the font-path to be #false. #:pre (list-of simple-quad-with-font-path-key?) #:post (list-of simple-quad-with-font-path-key?) (for* ([q (in-list qs)] diff --git a/quad2/log.rkt b/quad2/log.rkt new file mode 100644 index 00000000..0abbb596 --- /dev/null +++ b/quad2/log.rkt @@ -0,0 +1,17 @@ +#lang racket/base +(require racket/format + racket/string + racket/logging) + +(provide (all-defined-out)) + +;; creates `quad2-logger` and associated functions: +;; log-quad2-fatal, log-quad2-error, log-quad2-warning, +;; log-quad2-info, and log-quad2-debug +(define-logger quad2) + +(define (message . items) + (log-quad2-info (string-join (map ~a items) " "))) + +(define (message-debug . items) + (log-quad2-debug (string-join (map ~a items) " "))) diff --git a/quad2/main.rkt b/quad2/main.rkt index 623cf2f7..9cdf46a6 100644 --- a/quad2/main.rkt +++ b/quad2/main.rkt @@ -59,7 +59,7 @@ make-drawing-insts stackify))) -(module+ test +(module+ main (require "render.rkt") (define (test-compile x) (parameterize ([current-wrap-width 13] diff --git a/quad2/render.rkt b/quad2/render.rkt index cc65600e..9b0fbcc8 100644 --- a/quad2/render.rkt +++ b/quad2/render.rkt @@ -1,7 +1,9 @@ #lang debug racket/base (require "pipeline.rkt" "draw.rkt" - "layout.rkt") + "layout.rkt" + "log.rkt" + "glyphrun.rkt") (provide (all-defined-out)) (struct $renderer (doc-start-func @@ -10,9 +12,10 @@ page-end-func text-func move-func - return-func) #:transparent) + return-func + set-font-func) #:transparent) -(define current-renderer (make-parameter ($renderer void void void void void void void))) +(define current-renderer (make-parameter ($renderer void void void void void void void void))) (define text-renderer ;; scan over the instructions and record where the chars want to go @@ -41,7 +44,8 @@ (λ () (unless (pair? results) (error 'text-renderer-failed)) - (for-each displayln results))))) + (for-each displayln results)) + void))) (require racket/gui) @@ -49,7 +53,8 @@ ;; scan over the instructions and record where the chars want to go (let ([targets null] [dc #f] - [current-loc 0+0i]) + [current-loc 0+0i] + [current-font #false]) ($renderer void void @@ -68,7 +73,15 @@ (λ (charint) (send dc draw-text (string (integer->char charint)) (real-part current-loc) (imag-part current-loc))) (λ (x y) (set! current-loc (make-rectangular x y))) - (λ () (for-each displayln (map (λ (target) (make-object image-snip% target)) targets)))))) + (λ () (for-each displayln (map (λ (target) (make-object image-snip% target)) targets))) + (λ (ps) + ;; racket/draw can't load arbitrary user fonts from a path + ;; https://github.com/racket/racket/issues/1348 + ;; TODO: font substitution? but this would require + ;; holding & propagating Panose-like metadata about the font + ;; but it would allow slightly more accurate rendering for contexts + ;; that don't support fonts by path + (log-quad2-warning (format "can't load font ~a" ps)))))) (define (render inst-str #:using [renderer (current-renderer)]) (let/ec exit @@ -84,6 +97,7 @@ [(list* 'page-start x y rest) (($renderer-page-start-func renderer) x y) rest] [(list* 'page-end rest) (($renderer-page-end-func renderer)) rest] [(list* 'text charint rest) (($renderer-text-func renderer) charint) rest] + [(list* 'set-font path-string rest) (($renderer-set-font-func renderer) (symbol->string path-string)) rest] [(list* 'move x y rest) (($renderer-move-func renderer) x y) rest] [_ next-stack])] [else next-stack]))) diff --git a/quad2/struct.rkt b/quad2/struct.rkt index 14c7bf5a..e211bc7c 100644 --- a/quad2/struct.rkt +++ b/quad2/struct.rkt @@ -5,6 +5,7 @@ (struct $drawing-inst () #:transparent) (struct $move $drawing-inst (posn) #:transparent) ; an absolute location in coordinate system (not relative to last loc) (struct $text $drawing-inst (charint) #:transparent) +(struct $font $drawing-inst (path-string) #:transparent) (struct $doc $drawing-inst (inst) #:transparent) (struct $page $drawing-inst (inst) #:transparent)