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

need for speed

Browse Source
main
Matthew Butterick 6 years ago
parent b6c2c97fcf
commit 24f0ca5ff1
7 changed files with 81 additions and 55 deletions
Show Stats Download Patch File Download Diff File

5
quad/quad/atomize.rkt
Unescape Escape View File

@ -6,7 +6,8 @@
(define (update-with base-hash . update-hashes)
;; starting with base-hash, add or update keys found in update-hashes
(apply hasheq (flatten (map hash->list (list* base-hash update-hashes)))))
(for/hasheq ([(k v) (in-dict (append-map hash->list (list* base-hash update-hashes)))])
(values k v)))
(module+ test
(check-equal?
@ -39,7 +40,7 @@
(define atomic-quads
(let loop ([x (if (string? qx) (q qx) qx)][attrs (current-default-attrs)])
(match x
[(? char? c) (list (q attrs c))]
[(? char? c) (list (q (hash-set attrs 'id (gensym)) c))]
[(? string?) (append* (for/list ([c (in-string x)]) ;; strings are exploded
(loop c attrs)))]
[($quad this-attrs elems) ;; qexprs with attributes are recursed

40
quad/quad/break.rkt
Unescape Escape View File

@ -2,17 +2,19 @@
(require racket/contract racket/list racket/match txexpr sugar/debug sugar/define sugar/list racket/promise racket/function (only-in racket/control call/prompt) racket/future
"param.rkt" "qexpr.rkt" "atomize.rkt" "quad.rkt" "generic.rkt" "position.rkt")
(define distance-cache (make-hasheq))
(define/contract (distance q)
(any/c . -> . real?)
;; linear distance from in point to out point
(cond
[(quad? q)
(match-define (list ∆x ∆y) (map - (out-point q) (in-point q)))
(cond
[(zero? ∆x) ∆y]
[(zero? ∆y) ∆x]
[else (sqrt (+ (* ∆x ∆x) (* ∆y ∆y)))])]
[else 0]))
(hash-ref! distance-cache (hash-ref (attrs q) 'id q)
(λ ()
(cond
[(quad? q)
(match-define (list ∆x ∆y) (map - (out-point q) (in-point q)))
(cond
[(zero? ∆x) ∆y]
[(zero? ∆y) ∆x]
[else (sqrt (+ (* ∆x ∆x) (* ∆y ∆y)))])]
[else 0]))))
(define+provide/contract (break xs
@ -67,22 +69,22 @@
[else
(define-values (head tail) (splitf-at xs (λ (x) (not (hard-break? x)))))
(values (cons (future (λ () (cleanup-wraplist (break-softs head
target-size
debug
break-val
soft-break?
finish-wrap-proc)))) wraps) tail)])))
target-size
debug
break-val
soft-break?
finish-wrap-proc)))) wraps) tail)])))
(append (if break-before? (list break-val) empty) (cleanup-wraplist wraps) (if break-after? (list break-val) empty)))
(define (nonprinting-at-start? x) (if (quad? x) (not (printable? x 'start)) #t))
(define (nonprinting-at-end? x) (if (quad? x) (not (printable? x 'end)) #t))
(define (break-softs xs
target-size
debug
break-val
soft-break?
finish-wrap-proc)
target-size
debug
break-val
soft-break?
finish-wrap-proc)
(define start-signal (gensym))
(define last-soft-break-k #f)
(define (capture-soft-break-k!)

BIN
quad/quad/charter.ttf
View File

Binary file not shown.

6
quad/quad/position.rkt
Unescape Escape View File

@ -25,19 +25,21 @@
(define fonts (make-hash))
(hash-ref! fonts p (λ () (openSync p))))
(define ascender-cache (make-hash))
(define/contract (ascender q)
(quad? . -> . real?)
(define p (hash-ref (attrs q) 'font "Courier"))
(unless p
(error 'ascender-no-font-key))
(ascent (get-font p)))
(hash-ref! ascender-cache p (λ () (ascent (get-font p)))))
(define units-cache (make-hash))
(define/contract (units-per-em q)
(quad? . -> . real?)
(define p (hash-ref (attrs q) 'font "Courier"))
(unless p
(error 'units-per-em-no-font-key))
(unitsPerEm (get-font p)))
(hash-ref! units-cache p (λ () (unitsPerEm (get-font p)))))
(define (fontsize q)
;; this needs to not default to 0

15
quad/quad/typewriter-raw.rkt
Unescape Escape View File

@ -0,0 +1,15 @@
#lang debug br
(require racket/runtime-path pitfall/document)
(define-runtime-path fira "fira.ttf")
(define PS "typewriter-raw.pdf")
(define doc (make-object PDFDocument
(hasheq 'compress #t
'autoFirstPage #t
'size '(300 200))))
(time (send* doc
[pipe (open-output-file PS #:exists 'replace)]
[registerFont "Fira" (path->string fira)]
[font "Fira"]
[fontSize 12]
[text "Hello world" 36 36]))
(send doc end)

5
quad/quad/typewriter-test.rkt
Unescape Escape View File

@ -1,7 +1,8 @@
#lang quad/typewriter
◊quad[#:fontsize "11"]{Hello world}
◊;quad[#:fontsize "11"]{Hello world}
◊;quad[#:fontsize "11"]{◊quad[#:link "http://beautifulracket.com"]{An expression that} is not a value can ◊quad[#:fontsize "22"]{always} ◊quad[#:fontsize "7"]{be partitioned} into}
◊;quad[#:fontsize "11"]{◊quad[#:link "http://beautifulracket.com"]{An expression that} is not a value can ◊quad[#:fontsize "22"]{always} ◊quad[#:fontsize "7"]{be partitioned} into two parts: a redex, which is the part that changed in a single-step simplification (highlighted), and the continuation, which is the evaluation context surrounding an expression. In (- 4 (+ 1 1)), the redex is (+ 1 1), and the continuation is (- 4 []), where [] takes the place of the redex. That is, the continuation says how to "continue" after the redex is reduced to a value."}
◊quad[#:fontsize "11"]{◊quad[#:link "http://beautifulracket.com"]{An expression that} is not a value can ◊quad[#:fontsize "22"]{always} ◊quad[#:fontsize "7"]{be partitioned} into two parts: a redex, which is the part that changed in a single-step simplification (highlighted), and the continuation, which is the evaluation context surrounding an expression. In (- 4 (+ 1 1)), the redex is (+ 1 1), and the continuation is (- 4 []), where [] takes the place of the redex. That is, the continuation says how to "continue" after the redex is reduced to a value.}

65
quad/quad/typewriter.rkt
Unescape Escape View File

@ -5,12 +5,12 @@
(provide (rename-out [mb #%module-begin]) (except-out (all-from-out br/quicklang) #%module-begin))
(define-runtime-path fira "fira.ttf")
(define-runtime-path charter "charter.ttf")
(define soft-break? (λ (q) (and (quad? q) (memv (car (elems q)) '(#\space #\- #\u00AD)))))
(struct $shim $quad () #:transparent)
(struct $char $quad () #:transparent)
(define util-doc (make-object PDFDocument))
(define current-doc (make-parameter #f))
(define (draw-debug q doc)
(send doc save)
(send doc lineWidth 0.25)
@ -28,16 +28,17 @@
($char (hash-set* (attrs q)
'in 'bi
'out 'bo
'font fira
'font charter
'size
(delay
(let ([fontsize (string->number (hash-ref (attrs q) 'fontsize "12"))]
[str (apply string (elems q))])
(send util-doc fontSize (string->number (hash-ref (attrs q) 'fontsize "12")))
(send util-doc font fira)
(send* (current-doc)
[fontSize (string->number (hash-ref (attrs q) 'fontsize "12"))]
[font (path->string charter)])
(list
(send util-doc widthOfString str)
(send util-doc currentLineHeight))))
(send (current-doc) widthOfString str)
(send (current-doc) currentLineHeight))))
'printable? (case (car (elems q))
[(#\u00AD) (λ (sig) (memq sig '(end)))]
[(#\space) (λ (sig) (not (memq sig '(start end))))]
@ -51,8 +52,8 @@
=>
(λ (url-str) (apply as-link doc str url-str (origin q)))]
[else
(println str)
(time-name send-text (send/apply doc text str (origin q)))])))) (elems q)))
#;(println str)
(send/apply doc text str (origin q))])))) (elems q)))
(struct $line $quad () #:transparent)
(struct $page $quad () #:transparent)
(struct $doc $quad () #:transparent)
@ -63,7 +64,7 @@
(define (run-attrs-match left right)
(define missing (gensym))
(for/and ([k (in-list '(link weight fontsize))])
(equal? (hash-ref (attrs left) k missing) (hash-ref (attrs right) k missing))))
(equal? (hash-ref (attrs left) k missing) (hash-ref (attrs right) k missing))))
(define (consolidate-runs pcs)
(for/fold ([runs empty]
@ -73,12 +74,13 @@
#:break (empty? pcs))
(define-values (run-pcs rest) (splitf-at pcs (λ (p) (run-attrs-match (car pcs) p))))
(define new-run ($char (hash-set (attrs (car pcs))
'size (delay (apply map + (map size run-pcs))))
'size (delay (list (pt-x (apply map + (map size run-pcs)))
(pt-y (size (car pcs))))))
(append-map elems run-pcs)))
(values (cons new-run runs) rest)))
(define line-height 16)
(define consolidate-into-runs? #f)
(define consolidate-into-runs? #t)
(define (line-wrap xs size [debug #f])
(break xs size debug
#:break-val (make-break #\newline)
@ -109,14 +111,14 @@
(send doc fontSize 10)
(define str (string-append "page " (number->string page-count)))
;; page number
#;(as-link doc str "https://practicaltypography.com" 10 10)
(as-link doc str "https://practicaltypography.com" 10 10)
(set! page-count (add1 page-count)))) '(#\page)))
(define (page-wrap xs size [debug #f])
(break xs size debug
#:break-before? #t
#:break-val pb
#:soft-break-proc $break?
#:finish-wrap-proc (λ (pcs) (list ($page (hasheq) (filter-not $break? pcs))))))
#:finish-wrap-proc (λ (pcs) (list ($page (hasheq 'offset '(36 36)) (filter-not $break? pcs))))))
(define (typeset qarg)
(define chars 25)
@ -124,30 +126,33 @@
(define lines-per-page (* 4 line-height))
(let* ([x (time-name line-wrap (line-wrap (map charify (atomize qarg)) line-width))]
[x (time-name page-wrap (page-wrap x lines-per-page))]
[x (time-name position (position ($doc (hasheq 'origin '(36 36)) x)))])
[x (time-name position (position ($doc (hasheq) x)))])
x))
(provide quad)
(define quad (default-tag-function 'quad))
(define (run qin [path "test.pdf"])
(define doc (time-name make-doc
(make-object PDFDocument
(hasheq 'compress #t
'autoFirstPage #f
'size '(300 200)))))
(parameterize ([current-doc doc])
(time-name config-doc
(send* doc
[pipe (open-output-file path #:exists 'replace)]
[font (path->string charter)]
[fontSize 12]))
(define q (typeset qin))
(time-name draw (draw q doc))
(time-name end-doc (send doc end))))
(define-macro (mb . ARGS)
(with-pattern ([PS (syntax-property #'ARGS 'ps)])
#'(#%module-begin
(let ([doc (time-name make-doc
(make-object PDFDocument
(hasheq 'compress #t
'autoFirstPage #f
'size '(300 200))))])
(time-name config-doc
(send* doc
[pipe (open-output-file PS #:exists 'replace)]
[registerFont "Fira" (path->string fira)]
[font "Fira"]
[fontSize 12]))
(define q (typeset (qexpr->quad (quad . ARGS))))
(time-name draw (draw q doc))
(time-name end-doc (send doc end)))
(run (qexpr->quad (quad . ARGS)) PS)
(void))))
(module reader syntax/module-reader
@ -164,4 +169,4 @@
#:syntax? #t
#:inside? #t
#:command-char #\◊))
(syntax-property (quad-at-reader path-string p) 'ps (path-replace-extension path-string #".pdf"))))
(syntax-property (quad-at-reader path-string p) 'ps (path-replace-extension path-string #".pdf"))))

Write Preview
Loading…
Cancel
Save