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

some call it progress

Browse Source
main
Matthew Butterick 6 years ago
parent ab24a49ac6
commit 5a23d154d2
3 changed files with 57 additions and 65 deletions
Show Stats Download Patch File Download Diff File

26
quad/qtest/typewriter.rkt
Unescape Escape View File

@ -75,7 +75,7 @@
(set-field! out this 'sw))) (set-field! out this 'sw)))
(define page% (class quad% (super-new) (define page% (class quad% (super-new)
(set-field! offset this'(36 36)) (set-field! offset this'(36 36))
(define/override (start doc) (define/override (pre-draw doc)
(add-page doc) (add-page doc)
(font-size doc 10) (font-size doc 10)
(define str (string-append "page " (number->string page-count))) (define str (string-append "page " (number->string page-count)))
@ -86,8 +86,8 @@
(restore doc) (restore doc)
(set! page-count (add1 page-count))))) (set! page-count (add1 page-count)))))
(define doc% (class quad% (super-new) (define doc% (class quad% (super-new)
(define/override (start doc) (start-doc doc)) (define/override (pre-draw doc) (start-doc doc))
(define/override (end doc) (end-doc doc)))) (define/override (post-draw doc) (end-doc doc))))
(define break% (class quad% (super-new))) (define break% (class quad% (super-new)))
(define page-count 1) (define page-count 1)
(define (make-break . xs) (make-object break% (hasheq 'printable? #f 'size '(0 0)) xs)) (define (make-break . xs) (make-object break% (hasheq 'printable? #f 'size '(0 0)) xs))
@ -122,20 +122,12 @@
(consolidate-runs pcs) (consolidate-runs pcs)
pcs)))))) pcs))))))
;; 181231 it's weird that setup work for page is in the page break,
;; which is between pages, not associated with either
(define pb (make-object (let ([pb (class break%
(super-new)
(define/override (printable?) #f)
(inherit-field (@size size))
(set! @size '(0 0)))])
pb) '(#\page)))
(define ($break? x) (is-a? x break%)) (define ($break? x) (is-a? x break%))
(define (page-wrap xs size [debug #f]) (define (page-wrap xs size [debug #f])
(break xs size debug (break xs size debug
#:break-before? #t #:break-before? #t
#:break-val pb #:break-val (make-object break%)
#:soft-break-proc $break? #:soft-break-proc $break?
#:finish-wrap-proc (λ (pcs) (list (make-object page% (hasheq) (filter-not $break? pcs)))))) #:finish-wrap-proc (λ (pcs) (list (make-object page% (hasheq) (filter-not $break? pcs))))))
@ -144,8 +136,8 @@
(define line-width (* 7.2 chars)) (define line-width (* 7.2 chars))
(define lines-per-page (* 40 line-height)) (define lines-per-page (* 40 line-height))
(time-name config-pdf (time-name config-pdf
[font pdf (path->string charter)] (font pdf (path->string charter))
[font-size pdf 12]) (font-size pdf 12))
(let* ([x (time-name runify (runify qarg))] (let* ([x (time-name runify (runify qarg))]
[x (time-name quadify (map (λ (x) (quadify pdf x)) x))] [x (time-name quadify (map (λ (x) (quadify pdf x)) x))]
[x (time-name line-wrap (line-wrap x line-width))] [x (time-name line-wrap (line-wrap x line-width))]
@ -154,10 +146,12 @@
x)) x))
(define (run qin [path "test.pdf"]) (define (run qin [path "test.pdf"])
(define pdf (time-name make-pdf (make-pdf #:compress #t))) (define pdf (time-name make-pdf (make-pdf #:compress #t
#:auto-first-page #f
#:output-path path)))
(define q (typeset pdf qin)) (define q (typeset pdf qin))
(report draw-counter) (report draw-counter)
(time-name draw (with-output-to-file path (λ () (send q draw pdf)) #:exists 'replace)) (time-name draw (send q draw pdf))
(report draw-counter)) (report draw-counter))
(define-syntax (mb stx) (define-syntax (mb stx)

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

@ -1,5 +1,5 @@
#lang debug racket/base #lang debug racket/base
(require racket/class racket/match racket/list txexpr racket/dict racket/function (require racket/string racket/class racket/match racket/list txexpr racket/dict racket/function
"quad.rkt" "param.rkt") "quad.rkt" "param.rkt")
(provide (all-defined-out)) (provide (all-defined-out))
(module+ test (require rackunit)) (module+ test (require rackunit))
@ -16,15 +16,15 @@
((hasheq 'foo "bar" 'zim "zam") . update-with . (hasheq 'zim "BANG") (hasheq 'toe "jam") (hasheq 'foo "zay")) ((hasheq 'foo "bar" 'zim "zam") . update-with . (hasheq 'zim "BANG") (hasheq 'toe "jam") (hasheq 'foo "zay"))
(make-hasheq '((zim . "BANG") (foo . "zay") (toe . "jam"))))) (make-hasheq '((zim . "BANG") (foo . "zay") (toe . "jam")))))
(define (merge-whitespace aqs [white-aq? (λ (aq) (char-whitespace? (car (get-field elems aq))))]) (define (merge-whitespace qs [white-q? (λ (aq) (char-whitespace? (car (get-field elems aq))))])
;; collapse each sequence of whitespace aqs to the first one, and make it a space ;; collapse each sequence of whitespace qs to the first one, and make it a space
;; also drop leading & trailing whitespaces ;; also drop leading & trailing whitespaces
;; (same behavior as web browsers) ;; (same behavior as web browsers)
(let loop ([acc null][aqs aqs]) (let loop ([acc null][qs qs])
(if (null? aqs) (if (null? qs)
(flatten acc) (flatten acc)
(let*-values ([(bs rest) (splitf-at aqs (negate white-aq?))] (let*-values ([(bs rest) (splitf-at qs (negate white-q?))]
[(ws rest) (splitf-at rest white-aq?)]) [(ws rest) (splitf-at rest white-q?)])
(loop (list acc bs (if (and (pair? rest) ;; we precede bs (only #t if rest starts with bs, because we took the ws) (loop (list acc bs (if (and (pair? rest) ;; we precede bs (only #t if rest starts with bs, because we took the ws)
(pair? bs) ;; we follow bs (pair? bs) ;; we follow bs
(pair? ws)) ;; we have ws (pair? ws)) ;; we have ws
@ -32,8 +32,8 @@
null)) rest))))) null)) rest)))))
#;(module+ test #;(module+ test
(check-equal? (merge-whitespace (list (q #\space) (q #\newline) (q #\H) (q #\space) (q #\newline) (q #\space) (q #\i) (q #\newline))) (check-equal? (merge-whitespace (list (q #\space) (q #\newline) (q #\H) (q #\space) (q #\newline) (q #\space) (q #\i) (q #\newline)))
(list (q #\H) (q #\space) (q #\i)))) (list (q #\H) (q #\space) (q #\i))))
(define (atomize qx) (define (atomize qx)
;; normalize a quad by reducing it to one-character quads. ;; normalize a quad by reducing it to one-character quads.
@ -43,58 +43,56 @@
(match x (match x
[(? char? c) (list (q attrs c))] [(? char? c) (list (q attrs c))]
[(? string?) (append* (for/list ([c (in-string x)]) ;; strings are exploded [(? string?) (append* (for/list ([c (in-string x)]) ;; strings are exploded
(loop c attrs)))] (loop c attrs)))]
[(? quad?) ;; qexprs with attributes are recursed [(? quad?) ;; qexprs with attributes are recursed
(define this-attrs (get-field attrs x)) (define this-attrs (get-field attrs x))
(define elems (get-field elems x)) (define elems (get-field elems x))
(define merged-attrs (attrs . update-with . this-attrs)) (define merged-attrs (attrs . update-with . this-attrs))
(append* (for/list ([elem (in-list elems)]) (append* (for/list ([elem (in-list elems)])
(loop elem merged-attrs)))] (loop elem merged-attrs)))]
[else (raise-argument-error 'atomize "valid item" x)]))) [else (raise-argument-error 'atomize "valid item" x)])))
(merge-whitespace atomic-quads)) (merge-whitespace atomic-quads))
(module+ test #;(module+ test
(require rackunit) (require rackunit)
(check-equal? (atomize (q "Hi")) (list (q #\H) (q #\i))) (check-equal? (atomize (q "Hi")) (list (q #\H) (q #\i)))
(check-equal? (atomize (q "Hi " (q "You"))) (list (q #\H) (q #\i) (q #\space) (q #\Y) (q #\o) (q #\u))) (check-equal? (atomize (q "Hi " (q "You"))) (list (q #\H) (q #\i) (q #\space) (q #\Y) (q #\o) (q #\u)))
(check-exn exn:fail:contract? (λ () (atomize #t))) (check-exn exn:fail:contract? (λ () (atomize #t)))
(check-equal? (atomize (q "H i")) (list (q #\H) (q #\space) (q #\i))) (check-equal? (atomize (q "H i")) (list (q #\H) (q #\space) (q #\i)))
(check-equal? (atomize (q "H \n\n i")) (list (q #\H) (q #\space) (q #\i))) ;; collapse whitespace to single (check-equal? (atomize (q "H \n\n i")) (list (q #\H) (q #\space) (q #\i))) ;; collapse whitespace to single
;; with attributes ;; with attributes
(check-equal? (atomize (q (hasheq 'k "v") "Hi")) (list (q (hasheq 'k "v") #\H) (q (hasheq 'k "v") #\i))) (check-equal? (atomize (q (hasheq 'k "v") "Hi")) (list (q (hasheq 'k "v") #\H) (q (hasheq 'k "v") #\i)))
(check-equal? (atomize (q (hasheq 'k "v") "Hi " (q "You"))) (check-equal? (atomize (q (hasheq 'k "v") "Hi " (q "You")))
(list (list
(quad (hasheq 'k "v") #\H) (quad (hasheq 'k "v") #\H)
(quad (hasheq 'k "v") #\i) (quad (hasheq 'k "v") #\i)
(quad (hasheq 'k "v") #\space) (quad (hasheq 'k "v") #\space)
(quad (hasheq 'k "v") #\Y) (quad (hasheq 'k "v") #\Y)
(quad (hasheq 'k "v") #\o) (quad (hasheq 'k "v") #\o)
(quad (hasheq 'k "v") #\u))) (quad (hasheq 'k "v") #\u)))
(check-equal? (atomize (q (hasheq 'k1 "v1" 'k2 42) "Hi \n\n" (q (hasheq 'k1 "v2" 'k3 "foo") "\n \nYou"))) (check-equal? (atomize (q (hasheq 'k1 "v1" 'k2 42) "Hi \n\n" (q (hasheq 'k1 "v2" 'k3 "foo") "\n \nYou")))
(list (list
(quad (hasheq 'k1 "v1" 'k2 42) #\H) (quad (hasheq 'k1 "v1" 'k2 42) #\H)
(quad (hasheq 'k1 "v1" 'k2 42) #\i) (quad (hasheq 'k1 "v1" 'k2 42) #\i)
(quad (hasheq 'k1 "v1" 'k2 42) #\space) (quad (hasheq 'k1 "v1" 'k2 42) #\space)
(quad (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\Y) (quad (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\Y)
(quad (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\o) (quad (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\o)
(quad (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\u)))) (quad (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\u))))
(define whitespace-pat #px"\\s+") (define whitespace-pat #px"\\s+")
(define (merge-white str) (regexp-replace* whitespace-pat str " ")) (define (merge-and-isolate-white str)
(for/list ([(m idx) (in-indexed (regexp-match* whitespace-pat str #:gap-select? #t))]
(define (isolate-white str) #:when (non-empty-string? m))
(for/list ([m (in-list (regexp-match* " " str #:gap-select? #t))] (if (even? idx) m " ")))
#:when (positive? (string-length m)))
m))
(define (merge-adjacent-strings xs [isolate-white? #false]) (define (merge-adjacent-strings xs [isolate-white? #false])
(let loop ([xs xs][acc null]) (let loop ([xs xs][acc null])
(match xs (match xs
[(== empty) (reverse acc)] [(list) (reverse acc)]
[(list (? string? strs) ..1 others ...) [(list (? string? strs) ..1 others ...)
(loop others (append (reverse ((if isolate-white? (loop others (append (reverse ((if isolate-white?
(compose1 isolate-white merge-white) merge-and-isolate-white
list) (apply string-append strs))) acc))] list) (apply string-append strs))) acc))]
[(cons x others) (loop others (cons x acc))]))) [(cons x others) (loop others (cons x acc))])))
@ -127,7 +125,7 @@
(λ (q) (string=? " " (car (get-field elems q)))))) (λ (q) (string=? " " (car (get-field elems q))))))
#;(module+ test #;(module+ test
(check-equal? (check-equal?
(runify (quad (hasheq 'foo 42) (quad "Hi" " idiot" (quad (hasheq 'bar 84) "There") "Eve" "ry" "one"))) (runify (quad (hasheq 'foo 42) (quad "Hi" " idiot" (quad (hasheq 'bar 84) "There") "Eve" "ry" "one")))
(list (quad (hasheq 'foo 42) "Hi") (quad (hasheq 'foo 42) " ") (quad (hasheq 'foo 42) "idiot") (quad (hasheq 'foo 42 'bar 84) "There") (quad (hasheq 'foo 42) "Everyone")))) (list (quad (hasheq 'foo 42) "Hi") (quad (hasheq 'foo 42) " ") (quad (hasheq 'foo 42) "idiot") (quad (hasheq 'foo 42 'bar 84) "There") (quad (hasheq 'foo 42) "Everyone"))))

8
quad/quad/quad.rkt
Unescape Escape View File

@ -37,13 +37,13 @@
[(? promise? prom) (force prom)] [(? promise? prom) (force prom)]
[val val])) [val val]))
(define/public (start surface) (void)) (define/public (pre-draw surface) (void))
(define/public (end surface) (void)) (define/public (post-draw surface) (void))
(define/public (draw [surface #f]) (define/public (draw [surface #f])
(start surface) (pre-draw surface)
(for-each (λ (e) (send e draw surface)) @elems) (for-each (λ (e) (send e draw surface)) @elems)
(end surface)) (post-draw surface))
;; equal<%> interface ;; equal<%> interface
(define/public-final (equal-to? other recur) (define/public-final (equal-to? other recur)

Write Preview
Loading…
Cancel
Save