set a word width correct size

main
Matthew Butterick 2 years ago
parent 4297717f25
commit ab900dc3b7

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

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

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

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

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

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

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

@ -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))))
Loading…
Cancel
Save