From ab900dc3b7ec4aa533ef0b9fbbe4d0de8d90477b Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 16 May 2022 13:49:17 -0700 Subject: [PATCH] set a word width correct size --- quad2/draw.rkt | 57 +++++++++++++++++++++++---------------------- quad2/layout.rkt | 29 +++++++++++------------ quad2/linearize.rkt | 22 ++++++++--------- quad2/main.rkt | 18 +++++++------- quad2/pipeline.rkt | 4 ++-- quad2/quad.rkt | 26 +++++++++++++++++++-- quad2/render.rkt | 2 +- quad2/text.rkt | 17 ++++++++++++++ 8 files changed, 108 insertions(+), 67 deletions(-) create mode 100644 quad2/text.rkt diff --git a/quad2/draw.rkt b/quad2/draw.rkt index 926f67f9..a5a4009c 100644 --- a/quad2/draw.rkt +++ b/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")) \ No newline at end of file + (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")) \ No newline at end of file diff --git a/quad2/layout.rkt b/quad2/layout.rkt index 64c9d5c9..b723e6dc 100644 --- a/quad2/layout.rkt +++ b/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)))) \ No newline at end of file + (posn-add posn1 ($size ($size-width (quad-size q)) 0)))) \ No newline at end of file diff --git a/quad2/linearize.rkt b/quad2/linearize.rkt index bbb1b39b..d56e1180 100644 --- a/quad2/linearize.rkt +++ b/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))) \ No newline at end of file + (insert-at-end (insert-at-beginning qs bod) eod)) \ No newline at end of file diff --git a/quad2/main.rkt b/quad2/main.rkt index b5ebf77c..8490f4aa 100644 --- a/quad2/main.rkt +++ b/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"))) diff --git a/quad2/pipeline.rkt b/quad2/pipeline.rkt index 1697fbdc..265c55ab 100644 --- a/quad2/pipeline.rkt +++ b/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) diff --git a/quad2/quad.rkt b/quad2/quad.rkt index 73f3234b..bcb1b7eb 100644 --- a/quad2/quad.rkt +++ b/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)])) \ No newline at end of file diff --git a/quad2/render.rkt b/quad2/render.rkt index c5edba05..41370029 100644 --- a/quad2/render.rkt +++ b/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))))) diff --git a/quad2/text.rkt b/quad2/text.rkt new file mode 100644 index 00000000..40f5261c --- /dev/null +++ b/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)))) \ No newline at end of file