add `set-font` drawing instruction

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)])
+         (let ([current-font #false])
-           (cond
+           (for/list ([q (in-list qs)])
-             [(quad? q)
+                     (append
-              (if (pair? (quad-elems q))
+                      (match (quad-ref q :font-path)
-                  (list ($move (quad-posn q)) ($text (char->integer (car (string->list (car (quad-elems q)))))))
+                        [(== current-font) (list)]
-                  (list))]
+                        [font-path
-             [else (error 'render-unknown-thing)]))
+                         (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
+             (string-join (map ~a (match x
-                            [($move ($point x y)) (list y x 'move)]
+                                    [($move ($point x y)) (list y x 'move)]
-                            [($text charint) (list charint 'text)]
+                                    [($text charint) (list charint 'text)]
-                            [($doc 'start) '(doc-start)]
+                                    [($font path-string) (list path-string 'set-font)]
-                            [($doc 'end) '(doc-end)]
+                                    [($doc 'start) '(doc-start)]
-                            [($page 'start) (list ymax xmax 'page-start)]
+                                    [($doc 'end) '(doc-end)]
-                            [($page 'end) '(page-end)]
+                                    [($page 'start) (list ymax xmax 'page-start)]
-                            [_ (error 'unknown-drawing-inst)])) " ")) "\n"))
+                                    [($page 'end) '(page-end)]
+                                    [_ (error 'unknown-drawing-inst)])) " ")) "\n"))

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)]

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) " ")))

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]

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])))

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)