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

touchy

Browse Source
main
Matthew Butterick 6 years ago
parent 926ec47828
commit 0e3049640f
5 changed files with 36 additions and 35 deletions
Show Stats Download Patch File Download Diff File

4
quad/quad/generic.rkt
Unescape Escape View File

@ -3,8 +3,8 @@
(provide (all-defined-out)) (provide (all-defined-out))
(define-generics quad (define-generics quad
(start quad) (in quad)
(end quad) (out quad)
(inner quad) (inner quad)
(size quad [signal]) (size quad [signal])

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

@ -36,22 +36,22 @@
point/c point/c
(pt+ (origin q) (anchor->point q (inner q) signal) (offset q))) (pt+ (origin q) (anchor->point q (inner q) signal) (offset q)))
(define/contract (start-point q [signal #f]) (define/contract (in-point q [signal #f])
point/c point/c
(anchor->point q (start q) signal)) (anchor->point q (in q) signal))
(define/contract (end-point q [signal #f]) (define/contract (out-point q [signal #f])
point/c point/c
(pt+ (origin q) (anchor->point q (end q) signal))) ; no offset because end-point is calculated without padding (pt+ (origin q) (anchor->point q (out q) signal))) ; no offset because end-point is calculated without padding
(define/contract (position q [previous-end-pt (pt 0 0)]) (define/contract (position q [previous-end-pt (pt 0 0)])
((quad?) (point?) . ->* . quad?) ((quad?) (point?) . ->* . quad?)
(set-origin! q (pt- previous-end-pt (start-point q))) (set-origin! q (pt- previous-end-pt (in-point q)))
(for/fold ([pt (inner-point q)]) (for/fold ([pt (inner-point q)])
([q (in-list (elems q))] ([q (in-list (elems q))]
#:when (quad? q)) #:when (quad? q))
(end-point (position q pt))) (out-point (position q pt)))
q) q)
@ -61,14 +61,14 @@
"origins" "origins"
(define size (pt 10 10)) (define size (pt 10 10))
(define orig (pt 5 5)) (define orig (pt 5 5))
(check-equal? (origin (position (quad (hasheq 'start 'nw 'size size)) orig)) (pt 5 5)) (check-equal? (origin (position (quad (hasheq 'in 'nw 'size size)) orig)) (pt 5 5))
(check-equal? (origin (position (quad (hasheq 'start 'n 'size size)) orig)) (pt 0 5)) (check-equal? (origin (position (quad (hasheq 'in 'n 'size size)) orig)) (pt 0 5))
(check-equal? (origin (position (quad (hasheq 'start 'ne 'size size)) orig)) (pt -5 5)) (check-equal? (origin (position (quad (hasheq 'in 'ne 'size size)) orig)) (pt -5 5))
(check-equal? (origin (position (quad (hasheq 'start 'e 'size size)) orig)) (pt -5 0)) (check-equal? (origin (position (quad (hasheq 'in 'e 'size size)) orig)) (pt -5 0))
(check-equal? (origin (position (quad (hasheq 'start 'se 'size size)) orig)) (pt -5 -5)) (check-equal? (origin (position (quad (hasheq 'in 'se 'size size)) orig)) (pt -5 -5))
(check-equal? (origin (position (quad (hasheq 'start 's 'size size)) orig)) (pt 0 -5)) (check-equal? (origin (position (quad (hasheq 'in 's 'size size)) orig)) (pt 0 -5))
(check-equal? (origin (position (quad (hasheq 'start 'sw 'size size)) orig)) (pt 5 -5)) (check-equal? (origin (position (quad (hasheq 'in 'sw 'size size)) orig)) (pt 5 -5))
(check-equal? (origin (position (quad (hasheq 'start 'w 'size size)) orig)) (pt 5 0))) (check-equal? (origin (position (quad (hasheq 'in 'w 'size size)) orig)) (pt 5 0)))
(test-case (test-case
"inner points" "inner points"
@ -99,10 +99,10 @@
(test-case (test-case
"folding positions" "folding positions"
(check-equal? (position (quad (quad '(end se) (quad) (quad) (quad)) (check-equal? (position (quad (quad '(out se) (quad) (quad) (quad))
(quad '(end se) (quad) (quad) (quad)) (quad '(out se) (quad) (quad) (quad))
(quad '(end se) (quad) (quad) (quad)))) (quad '(out se) (quad) (quad) (quad))))
(quad '(origin (0 0)) (quad '(origin (0 0))
(quad '(origin (0 0) end se) (quad '(origin (0 0))) (quad '(origin (1 0))) (quad '(origin (2 0)))) (quad '(origin (0 0) out se) (quad '(origin (0 0))) (quad '(origin (1 0))) (quad '(origin (2 0))))
(quad '(origin (1 1) end se) (quad '(origin (1 1))) (quad '(origin (2 1))) (quad '(origin (3 1)))) (quad '(origin (1 1) out se) (quad '(origin (1 1))) (quad '(origin (2 1))) (quad '(origin (3 1))))
(quad '(origin (2 2) end se) (quad '(origin (2 2))) (quad '(origin (3 2))) (quad '(origin (4 2)))))))) (quad '(origin (2 2) out se) (quad '(origin (2 2))) (quad '(origin (3 2))) (quad '(origin (4 2))))))))

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

@ -14,9 +14,9 @@
#:methods gen:quad #:methods gen:quad
[(define (elems q) ($quad-elems q)) [(define (elems q) ($quad-elems q))
(define (attrs q) ($quad-attrs q)) (define (attrs q) ($quad-attrs q))
(define (start q) (hash-ref (attrs q) 'start 'nw)) (define (in q) (hash-ref (attrs q) 'in 'nw))
(define (end q) (hash-ref (attrs q) 'end 'ne)) (define (out q) (hash-ref (attrs q) 'out 'ne))
(define (inner q) (hash-ref (attrs q) 'inner (λ () (start q)))) (define (inner q) (hash-ref (attrs q) 'inner (λ () (in q))))
(define (size q [signal #f]) (let ([v (hash-ref (attrs q) 'size (λ () (default-size-proc q signal)))]) (define (size q [signal #f]) (let ([v (hash-ref (attrs q) 'size (λ () (default-size-proc q signal)))])
(cond (cond
[(procedure? v) (v signal)] [(procedure? v) (v signal)]

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

@ -15,12 +15,12 @@
(struct $page $quad () #:transparent) (struct $page $quad () #:transparent)
(struct $doc $quad () #:transparent) (struct $doc $quad () #:transparent)
(struct $break $quad () #:transparent) (struct $break $quad () #:transparent)
(define (break . xs) ($break (hasheq 'size (delay (values 0 0 0))) xs)) (define (break . xs) ($break (hasheq 'size '(0 0)) xs))
(define (lbs xs size [debug #f]) (define (lbs xs size [debug #f])
(wrap xs size debug (wrap xs size debug
#:break-val (break #\newline) #:break-val (break #\newline)
#:optional-break-proc optional-break? #:optional-break-proc optional-break?
#:finish-segment-proc (λ (pcs) (list ($line (hasheq) (map charify pcs)))))) #:finish-segment-proc (λ (pcs) (list ($line (hasheq 'size '(0 12) 'out 'sw) (map charify pcs))))))
(define (pbs xs size [debug #f]) (define (pbs xs size [debug #f])
(wrap xs size debug (wrap xs size debug
@ -29,7 +29,7 @@
#:finish-segment-proc (λ (pcs) (list ($page (hasheq) (filter-not $break? pcs)))))) #:finish-segment-proc (λ (pcs) (list ($page (hasheq) (filter-not $break? pcs))))))
(define (typeset args) (define (typeset args)
(quad->qexpr ($doc (hasheq) (map position (filter-not $break? (pbs (lbs (atomize (apply quad #f args)) (* 3 7.2)) (* 2 12))))))) ($doc (hasheq) (map position (filter-not $break? (pbs (lbs (atomize (apply quad #f args)) 3) (* 5 12))))))
(define-syntax-rule (mb lang-line-config-arg . args) (define-syntax-rule (mb lang-line-config-arg . args)
(#%module-begin (#%module-begin

15
quad/quad/wrap.rkt
Unescape Escape View File

@ -6,7 +6,7 @@
((any/c) (any/c) . ->* . real?) ((any/c) (any/c) . ->* . real?)
(cond (cond
[(quad? q) [(quad? q)
(match-define (list ∆x ∆y) (map - (end-point q signal) (start-point q signal))) (match-define (list ∆x ∆y) (map - (out-point q signal) (in-point q signal)))
(cond (cond
[(zero? ∆x) ∆y] [(zero? ∆x) ∆y]
[(zero? ∆y) ∆x] [(zero? ∆y) ∆x]
@ -59,12 +59,13 @@
(add-to-segment)])] (add-to-segment)])]
[(or at-start? underflow?) (when debug (report x 'add-ordinary-char)) [(or at-start? underflow?) (when debug (report x 'add-ordinary-char))
(add-to-segment)] (add-to-segment)]
;; overflow handlers
[last-optional-break-k (when debug (report x 'invoking-last-breakpoint)) [last-optional-break-k (when debug (report x 'invoking-last-breakpoint))
(last-optional-break-k #t)] (last-optional-break-k #t)]
;; fallback if no last-breakpoint-k exists
[else (when debug (report x 'falling-back)) [else (when debug (report x 'falling-back))
(match-define-values (vals _ _) (insert-break)) (match-define-values (vals _ _) (insert-break))
(values vals (list x) (distance x 'start))]))))) ;; fallback if no last-breakpoint-k exists (values vals (list x) (distance x 'start))])))))
(define x (q #f #\x)) (define x (q #f #\x))
@ -210,10 +211,10 @@
(define (slug . xs) ($slug #f xs)) (define (slug . xs) ($slug #f xs))
(define (linewrap2 xs size [debug #f]) (define (linewrap2 xs size [debug #f])
(wrap xs size debug (wrap xs size debug
#:break-val 'lb #:break-val 'lb
#:mandatory-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline)))) #:mandatory-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline))))
#:optional-break-proc optional-break? #:optional-break-proc optional-break?
#:finish-segment-proc (λ (pcs) (list ($slug #f pcs))))) #:finish-segment-proc (λ (pcs) (list ($slug #f pcs)))))
(module+ test (module+ test
(test-case (test-case

Write Preview
Loading…
Cancel
Save