set a word width correct size

quad2/draw.rkt

@@ -9,27 +9,28 @@
 (provide (all-defined-out))
 
 (define-pass (make-drawing-insts qs)
-  #:pre (list-of has-position?)
+  ;; TODO: stronger precondition. but `has-position?` is too strong
+  #:pre (list-of quad?)
   #:post (list-of $drawing-inst?)
   (apply append
          (let ([current-font #false])
            (for/list ([q (in-list qs)])
-                     (cond
-                       [(eq? boq q) (list ($doc-start))]
-                       [(eq? eoq q) (list ($doc-end))]
-                       [(bop-quad? q) (list ($page-start (quad-ref q :page-width) (quad-ref q :page-height)))]
-                       [(eop-quad? q) (list ($page-end))]
-                       [(quad? q)
-                        (append
-                         (match (quad-ref q :font-path)
-                           [(== current-font) null]
-                           [font-path
-                            (set! current-font font-path)
-                            (list ($font font-path))])
-                         (if (pair? (quad-elems q))
-                             (list ($move (quad-origin q)) ($text (char->integer (car (string->list (car (quad-elems q)))))))
-                             null))]
-                       [else (raise-argument-error 'make-drawing-insts "known thing" q)])))))
+             (cond
+               [(eq? bod q) (list ($doc-start))]
+               [(eq? eod q) (list ($doc-end))]
+               [(bop-quad? q) (list ($page-start (quad-ref q :page-width) (quad-ref q :page-height)))]
+               [(eop-quad? q) (list ($page-end))]
+               [(quad? q)
+                (append
+                 (match (quad-ref q :font-path)
+                   [(== current-font) null]
+                   [font-path
+                    (set! current-font font-path)
+                    (list ($font font-path))])
+                 (if (pair? (quad-elems q))
+                     (list ($move (quad-origin q)) ($text (char->integer (car (string->list (car (quad-elems q)))))))
+                     null))]
+               [else (raise-argument-error 'make-drawing-insts "known thing" q)])))))
 
 (define valid-tokens '(doc-start doc-end page-start page-end text move set-font))
 
@@ -41,14 +42,14 @@
   (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
-                                    ;; TODO: embed these code-generating functions
-                                    ;; as properties of the structs
-                                    [($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 width height) (list height width 'page-start)]
-                                    [($page-end) '(page-end)]
-                                    [_ (error 'unknown-drawing-inst)])) " ")) "\n"))
+     (string-join (map ~a (match x
+                            ;; TODO: embed these code-generating functions
+                            ;; as properties of the structs
+                            [($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 width height) (list height width 'page-start)]
+                            [($page-end) '(page-end)]
+                            [_ (error 'unknown-drawing-inst)])) " ")) "\n"))

quad2/layout.rkt

@@ -8,14 +8,6 @@
   ($point? $size? . -> . $point?)
   ($point (+ ($point-x p0) ($size-width p1)) (+ ($point-y p0) ($size-height p1))))
 
-(define/contract (size q)
-  (quad? . -> . $size?)
-  (quad-size q))
-
-(define/contract (advance q)
-  (quad? . -> . $size?)
-  (quad-size q))
-
 (define (min-x rect) ($point-x ($rect-origin rect)))
 (define (width rect) ($size-width ($rect-size rect)))
 (define (max-x rect) (+ (min-x rect) (width rect)))
@@ -49,22 +41,29 @@
   (set-quad-size! q ($size (length (or (quad-elems q) null)) 0))
   q)
 
+(define (has-size? x)
+  (and (quad? x) (quad-size x)))
+
 (define-pass (layout qs)
-  #:pre (list-of has-no-position?)
-  #:post (list-of has-position?)
+  ;; TODO: stronger pre & postcondition.
+  ;; but `has-size?` is too strong for precondition,
+  ;; and `has-position?` is too strong for postcondition.
+  ;; because we need to preserve signals like bop and eop
+  #:pre (list-of quad?)
+  #:post (list-of quad?)
   (define frame ($rect ($point 0 0) ($size (current-wrap-width) 30)))
   (define (quad-fits? q posn)
-    (rect-contains-rect? frame ($rect posn (size q))))
+    (rect-contains-rect? frame ($rect posn (quad-size q))))
   (for/fold ([posn0 ($point 0 0)]
-             #:result (filter has-position? qs))
-            ([q (in-list (map make-debug-size qs))]
+             #:result qs)
+            ([q (in-list qs)]
              #:when (quad-size q))
     (define first-posn-on-next-line ($point 0 (add1 ($point-y posn0))))
     (define other-possible-posns (list first-posn-on-next-line))
     (define posn1 (for/first ([posn (in-list (cons posn0 other-possible-posns))]
                               #:when (quad-fits? q posn))
-                             posn))
+                    posn))
     (unless posn1
       (error 'no-posn-that-fits))
     (set-quad-origin! q posn1)
-    (posn-add posn1 (advance q))))
+    (posn-add posn1 ($size ($size-width (quad-size q)) 0))))

quad2/linearize.rkt

@@ -38,7 +38,13 @@
                                             [else (list (mq (list e)))])))])))))
 
 (module+ test
-  (define q (make-quad #:attrs (hasheq 'foo 42) #:elems (list (make-quad #:elems (list "Hi" "    idiot" (make-quad #:attrs (hasheq 'bar 84) #:elems '("There")) " Eve" "ry" "one" (make-quad #:attrs (hasheq 'zam 108) #:elems null))))))
+  (define q (make-quad #:attrs (hasheq 'foo 42)
+                       #:elems (list (make-quad
+                                      #:attrs (make-hasheq)
+                                      #:elems (list "Hi" "    idiot"
+                                                    (make-quad #:attrs (hasheq 'bar 84)
+                                                               #:elems '("There")) " Eve" "ry" "one" (make-quad #:attrs (hasheq 'zam 108)
+                                                                                                                #:elems null))))))
   (define lqs (linearize (list q)))
   lqs)
 
@@ -115,18 +121,12 @@
            (unless (eop-quad? (last qs))
              (error 'not-an-eop-quad))
            ((list-of simple-quad?) (drop-right (cdr qs) 1)))
-  (define bop (bop-quad))
-  (define eop (eop-quad))
-  (set-quad-attrs! bop (quad-attrs (first qs)))
-  (set-quad-attrs! eop (quad-attrs (last qs)))
-  (append (list bop) qs (list eop)))
+ (insert-at-end (insert-at-beginning qs (bop-quad)) (eop-quad)))
 
-(define-pass (append-boq-and-eoq qs)
+(define-pass (append-bod-and-eod qs)
   ;; attach the boq and eoq signals
   #:pre (list-of simple-quad?)
   #:post (λ (qs) (match qs
-                   [(list (== boq) (? simple-quad?) ... (== eoq)) #true]
+                   [(list (== bod) (? simple-quad?) ... (== eod)) #true]
                    [_ #false]))
-  (set-quad-attrs! boq (quad-attrs (first qs)))
-  (set-quad-attrs! eoq (quad-attrs (last qs)))
-  (append (list boq) qs (list eoq)))
+  (insert-at-end (insert-at-beginning qs bod) eod))

quad2/main.rkt

@@ -12,6 +12,7 @@
          "constants.rkt"
          "param.rkt"
          "page.rkt"
+         "text.rkt"
          racket/match)
 
 (define quad-compile
@@ -41,9 +42,6 @@
    parse-dimension-strings
    resolve-font-sizes
    resolve-font-features
-   parse-page-sizes
-   resolve-font-paths
-   complete-attr-paths
 
    ;; linearization =============
    ;; we postpone this step until we're certain any
@@ -54,17 +52,21 @@
    linearize
    
    ;; post-linearization resolutions & parsings ============= 
+   parse-page-sizes
+   print-pass
+   resolve-font-paths
+   print-pass
+   complete-attr-paths
    mark-text-runs
    merge-adjacent-strings
    split-whitespace
    split-into-single-char-quads
-   
-   print-pass
    fill-missing-font-path
    remove-font-without-char
    insert-fallback-font
    append-bop-and-eop
-   append-boq-and-eoq
+   append-bod-and-eod
+   measure-text-runs
    layout
    make-drawing-insts
    stackify))
@@ -82,9 +84,9 @@
                    [current-use-postconditions? #t])
       (quad-compile (bootstrap-input x))))
 
-  (match (test-compile "WHO")
+  (match (test-compile "Whomever")
     [(? string? insts)
-     (displayln insts)
+     #;(displayln insts)
      #;(render insts #:using text-renderer)
      #;(render insts #:using drr-renderer)
      (render insts #:using (html-renderer (build-path (find-system-path 'desk-dir) "test.html")))

quad2/pipeline.rkt

@@ -58,7 +58,7 @@
                    (define failure-msg (format "~a pass (as precondition)" 'PASS-NAME))
                    (with-handlers ([exn:fail:contract? (make-failure-handler failure-msg)])
                      (unless (PRECOND-PROC ARG)
-                       (raise-argument-error 'PASS-NAME (symbol->string 'PRECOND-PROC) ARG))))
+                       (raise-argument-error 'PASS-NAME (format "~a" 'PRECOND-PROC) ARG))))
                  ;; a pass can be functional or mutational.
                  ;; if it returns void, assume mutational
                  ;; and return the input item.
@@ -71,7 +71,7 @@
                      (define failure-msg (format "~a pass (as postcondition)" 'PASS-NAME))
                      (with-handlers ([exn:fail:contract? (make-failure-handler failure-msg)])
                        (unless (POSTCOND-PROC res)
-                         (raise-argument-error 'PASS-NAME (symbol->string 'POSTCOND-PROC) ARG)))))))
+                         (raise-argument-error 'PASS-NAME (format "~a" 'POSTCOND-PROC) ARG)))))))
            'PASS-NAME)))]))
 
 (define-pass (print-pass qs)

quad2/quad.rkt

@@ -136,9 +136,31 @@
 (module+ test
   (define q (make-quad #:tag 'div #:attrs (make-hasheq '((hello . "world"))) #:elems (list "fine"))))
 
-(define boq (make-quad #:tag 'boq-quad))
-(define eoq (make-quad #:tag 'eoq-quad))
+(define bod (make-quad #:tag 'bod-quad))
+(define eod (make-quad #:tag 'eod-quad))
 (define (bop-quad) (make-quad #:tag 'bop-quad))
 (define (bop-quad? x) (and (quad? x) (eq? (quad-tag x) 'bop-quad)))
 (define (eop-quad) (make-quad #:tag 'eop-quad))
 (define (eop-quad? x) (and (quad? x) (eq? (quad-tag x) 'eop-quad)))
+
+(define (insert-at-beginning qs x)
+  (unless (andmap quad? qs)
+    (raise-argument-error 'insert-at-beginning "list of quads" qs))
+  (unless (quad? x)
+    (raise-argument-error 'insert-at-beginning "quad" x))
+  (cond
+    [(pair? qs)
+     (set-quad-attrs! x (quad-attrs (first qs)))
+     (cons x qs)]
+    [else (list x)]))
+
+(define (insert-at-end qs x)
+  (unless (andmap quad? qs)
+    (raise-argument-error 'insert-at-end "list of quads" qs))
+  (unless (quad? x)
+    (raise-argument-error 'insert-at-end "quad" x))
+  (cond
+    [(pair? qs)
+     (set-quad-attrs! x (quad-attrs (last qs)))
+     (append qs (list x))]
+    [else (list x)]))

quad2/render.rkt

@@ -102,7 +102,7 @@
        (set! page-quads null))
      (λ (charint)
        (set! page-quads (cons
-                         `(div ((style ,(format "position: absolute;left:~apx;top:~apx;font-family:~a" (real-part current-loc) (imag-part current-loc) current-font)))
+                         `(div ((style ,(format "position: absolute;left:~apx;top:~apx;font-family:~a;font-size:~apx" (real-part current-loc) (imag-part current-loc) current-font 12)))
                                ,(string (integer->char charint))) page-quads)))
      (λ (ps)
        (set! current-font (hash-ref! fonts ps (λ () (gensym 'font)))))

quad2/text.rkt

@@ -0,0 +1,17 @@
+#lang debug racket/base
+(require "pipeline.rkt"
+         "quad.rkt"
+         "attr.rkt"
+         "glyphrun.rkt"
+         fontland)
+(provide (all-defined-out))
+
+(define-pass (measure-text-runs qs)
+  #:pre (list-of quad?)
+  #:post (list-of quad?)
+  (for ([q (in-list qs)]
+        #:when (eq? (quad-tag q) 'text-run))
+    (define font (get-font (quad-ref q :font-path)))
+    (define x-advance (glyph-position-x-advance (vector-ref (glyphrun-positions (layout font (car (quad-elems q)))) 0)))
+    (define font-size (quad-ref q :font-size))
+    (set-quad-size! q ($size (* (/ x-advance (font-units-per-em font) 1.0) font-size) font-size))))