mbutterick
/
typesetting
2
1
Fork 0
Code Issues 13 Pull Requests Projects Releases Wiki Activity

set a word width correct size

Browse Source
main
Matthew Butterick 2 years ago
parent 4297717f25
commit ab900dc3b7
8 changed files with 108 additions and 67 deletions
Show Stats Download Patch File Download Diff File

57
quad2/draw.rkt
Unescape Escape View File

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

29
quad2/layout.rkt
Unescape Escape View File

@ -8,14 +8,6 @@
($point? $size? . -> . $point?) ($point? $size? . -> . $point?)
($point (+ ($point-x p0) ($size-width p1)) (+ ($point-y p0) ($size-height p1)))) ($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 (min-x rect) ($point-x ($rect-origin rect)))
(define (width rect) ($size-width ($rect-size rect))) (define (width rect) ($size-width ($rect-size rect)))
(define (max-x rect) (+ (min-x rect) (width 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)) (set-quad-size! q ($size (length (or (quad-elems q) null)) 0))
q) q)
(define (has-size? x)
(and (quad? x) (quad-size x)))
(define-pass (layout qs) (define-pass (layout qs)
#:pre (list-of has-no-position?) ;; TODO: stronger pre & postcondition.
#:post (list-of has-position?) ;; 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 frame ($rect ($point 0 0) ($size (current-wrap-width) 30)))
(define (quad-fits? q posn) (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)] (for/fold ([posn0 ($point 0 0)]
#:result (filter has-position? qs)) #:result qs)
([q (in-list (map make-debug-size qs))] ([q (in-list qs)]
#:when (quad-size q)) #:when (quad-size q))
(define first-posn-on-next-line ($point 0 (add1 ($point-y posn0)))) (define first-posn-on-next-line ($point 0 (add1 ($point-y posn0))))
(define other-possible-posns (list first-posn-on-next-line)) (define other-possible-posns (list first-posn-on-next-line))
(define posn1 (for/first ([posn (in-list (cons posn0 other-possible-posns))] (define posn1 (for/first ([posn (in-list (cons posn0 other-possible-posns))]
#:when (quad-fits? q posn)) #:when (quad-fits? q posn))
posn)) posn))
(unless posn1 (unless posn1
(error 'no-posn-that-fits)) (error 'no-posn-that-fits))
(set-quad-origin! q posn1) (set-quad-origin! q posn1)
(posn-add posn1 (advance q)))) (posn-add posn1 ($size ($size-width (quad-size q)) 0))))

22
quad2/linearize.rkt
Unescape Escape View File

@ -38,7 +38,13 @@
[else (list (mq (list e)))])))]))))) [else (list (mq (list e)))])))])))))
(module+ test (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))) (define lqs (linearize (list q)))
lqs) lqs)
@ -115,18 +121,12 @@
(unless (eop-quad? (last qs)) (unless (eop-quad? (last qs))
(error 'not-an-eop-quad)) (error 'not-an-eop-quad))
((list-of simple-quad?) (drop-right (cdr qs) 1))) ((list-of simple-quad?) (drop-right (cdr qs) 1)))
(define bop (bop-quad)) (insert-at-end (insert-at-beginning qs (bop-quad)) (eop-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)))
(define-pass (append-boq-and-eoq qs) (define-pass (append-bod-and-eod qs)
;; attach the boq and eoq signals ;; attach the boq and eoq signals
#:pre (list-of simple-quad?) #:pre (list-of simple-quad?)
#:post (λ (qs) (match qs #:post (λ (qs) (match qs
[(list (== boq) (? simple-quad?) ... (== eoq)) #true] [(list (== bod) (? simple-quad?) ... (== eod)) #true]
[_ #false])) [_ #false]))
(set-quad-attrs! boq (quad-attrs (first qs))) (insert-at-end (insert-at-beginning qs bod) eod))
(set-quad-attrs! eoq (quad-attrs (last qs)))
(append (list boq) qs (list eoq)))

18
quad2/main.rkt
Unescape Escape View File

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

4
quad2/pipeline.rkt
Unescape Escape View File

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

26
quad2/quad.rkt
Unescape Escape View File

@ -136,9 +136,31 @@
(module+ test (module+ test
(define q (make-quad #:tag 'div #:attrs (make-hasheq '((hello . "world"))) #:elems (list "fine")))) (define q (make-quad #:tag 'div #:attrs (make-hasheq '((hello . "world"))) #:elems (list "fine"))))
(define boq (make-quad #:tag 'boq-quad)) (define bod (make-quad #:tag 'bod-quad))
(define eoq (make-quad #:tag 'eoq-quad)) (define eod (make-quad #:tag 'eod-quad))
(define (bop-quad) (make-quad #:tag 'bop-quad)) (define (bop-quad) (make-quad #:tag 'bop-quad))
(define (bop-quad? x) (and (quad? x) (eq? (quad-tag x) '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) (make-quad #:tag 'eop-quad))
(define (eop-quad? x) (and (quad? x) (eq? (quad-tag x) '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)]))

2
quad2/render.rkt
Unescape Escape View File

@ -102,7 +102,7 @@
(set! page-quads null)) (set! page-quads null))
(λ (charint) (λ (charint)
(set! page-quads (cons (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))) ,(string (integer->char charint))) page-quads)))
(λ (ps) (λ (ps)
(set! current-font (hash-ref! fonts ps (λ () (gensym 'font))))) (set! current-font (hash-ref! fonts ps (λ () (gensym 'font)))))

17
quad2/text.rkt
Unescape Escape View File

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