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

the skeleton chokes

Browse Source
main
Matthew Butterick 6 years ago
parent 5a23d154d2
commit 97b48c4cc4
2 changed files with 114 additions and 133 deletions
Show Stats Download Patch File Download Diff File

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

@ -16,7 +16,7 @@
((hasheq 'foo "bar" 'zim "zam") . update-with . (hasheq 'zim "BANG") (hasheq 'toe "jam") (hasheq 'foo "zay"))
(make-hasheq '((zim . "BANG") (foo . "zay") (toe . "jam")))))
(define (merge-whitespace qs [white-q? (λ (aq) (char-whitespace? (car (get-field elems aq))))])
(define (merge-whitespace qs [white-q? (λ (aq) (char-whitespace? (car (quad-elems aq))))])
;; collapse each sequence of whitespace qs to the first one, and make it a space
;; also drop leading & trailing whitespaces
;; (same behavior as web browsers)
@ -28,57 +28,60 @@
(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? ws)) ;; we have ws
(quad (get-field attrs (car ws)) #\space)
(make-quad (quad-attrs (car ws)) '(#\space))
null)) rest)))))
#;(module+ test
(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))))
(module+ test
(define (qq . xs) (q #f xs))
(define (qqa attrs . xs) (q attrs xs))
(check-equal? (merge-whitespace (list (qq #\space) (qq #\newline) (qq #\H) (qq #\space) (qq #\newline) (qq #\space) (qq #\i) (qq #\newline)))
(list (qq #\H) (qq #\space) (qq #\i))))
(define (atomize qx)
;; normalize a quad by reducing it to one-character quads.
;; propagate attrs downward.
(define atomic-quads
(let loop ([x (if (string? qx) (q qx) qx)][attrs (current-default-attrs)])
(let loop ([x (if (string? qx) (q #f (list qx)) qx)][attrs (current-default-attrs)])
(match x
[(? char? c) (list (q attrs c))]
[(? char? c) (list (q attrs (list c)))]
[(? string?) (append* (for/list ([c (in-string x)]) ;; strings are exploded
(loop c attrs)))]
[(? quad?) ;; qexprs with attributes are recursed
(define this-attrs (get-field attrs x))
(define elems (get-field elems x))
(define this-attrs (quad-attrs x))
(define elems (quad-elems x))
(define merged-attrs (attrs . update-with . this-attrs))
(append* (for/list ([elem (in-list elems)])
(loop elem merged-attrs)))]
[else (raise-argument-error 'atomize "valid item" x)])))
(merge-whitespace atomic-quads))
#;(module+ test
(require rackunit)
(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-exn exn:fail:contract? (λ () (atomize #t)))
(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
(module+ test
(require rackunit)
(check-equal? (atomize (qq "Hi")) (list (qq #\H) (qq #\i)))
(check-equal? (atomize (qq "Hi " (qq "You"))) (list (qq #\H) (qq #\i) (qq #\space) (qq #\Y) (qq #\o) (qq #\u)))
(check-exn exn:fail:contract? (λ () (atomize #t)))
(check-equal? (atomize (qq "H i")) (list (qq #\H) (qq #\space) (qq #\i)))
(check-equal? (atomize (qq "H \n\n i")) (list (qq #\H) (qq #\space) (qq #\i))) ;; collapse whitespace to single
;; 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 " (q "You")))
(list
(quad (hasheq 'k "v") #\H)
(quad (hasheq 'k "v") #\i)
(quad (hasheq 'k "v") #\space)
(quad (hasheq 'k "v") #\Y)
(quad (hasheq 'k "v") #\o)
(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")))
(list
(quad (hasheq 'k1 "v1" 'k2 42) #\H)
(quad (hasheq 'k1 "v1" 'k2 42) #\i)
(quad (hasheq 'k1 "v1" 'k2 42) #\space)
(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") #\u))))
;; with attributes
(check-equal? (atomize (qqa (hasheq 'k "v") "Hi")) (list (qqa (hasheq 'k "v") #\H) (qqa (hasheq 'k "v") #\i)))
(check-equal? (atomize (qqa (hasheq 'k "v") "Hi " (qq "You")))
(list
(qqa (hasheq 'k "v") #\H)
(qqa (hasheq 'k "v") #\i)
(qqa (hasheq 'k "v") #\space)
(qqa (hasheq 'k "v") #\Y)
(qqa (hasheq 'k "v") #\o)
(qqa (hasheq 'k "v") #\u)))
(check-equal? (atomize (qqa (hasheq 'k1 "v1" 'k2 42) "Hi \n\n" (qqa (hasheq 'k1 "v2" 'k3 "foo") "\n \nYou")))
(list
(qqa (hasheq 'k1 "v1" 'k2 42) #\H)
(qqa (hasheq 'k1 "v1" 'k2 42) #\i)
(qqa (hasheq 'k1 "v1" 'k2 42) #\space)
(qqa (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\Y)
(qqa (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\o)
(qqa (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\u))))
(define whitespace-pat #px"\\s+")
(define (merge-and-isolate-white str)
@ -113,19 +116,19 @@
[key first-key])
(match x
[(? quad?) ;; qexprs with attributes are recursed
(define this-attrs (get-field attrs x))
(define elems (get-field elems x))
(define this-attrs (quad-attrs x))
(define elems (quad-elems x))
(define next-key (if (hash-empty? this-attrs) key (gensym)))
(define next-attrs (if (hash-empty? this-attrs) attrs (attrs . update-with . this-attrs)))
(unless (hash-empty? this-attrs) (hash-set! next-attrs run-key next-key))
(append* (for/list ([elem (in-list (merge-adjacent-strings elems 'merge-white))])
(if (string? elem)
(list (q next-attrs elem))
(list (make-quad next-attrs (list elem)))
(loop elem next-attrs next-key))))]))
(λ (q) (string=? " " (car (get-field elems q))))))
(λ (q) (string=? " " (car (quad-elems q))))))
#;(module+ test
(check-equal?
(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"))))
(runify (qqa (hasheq 'foo 42) (qq "Hi" " idiot" (qqa (hasheq 'bar 84) "There") "Eve" "ry" "one")))
(list (qqa (hasheq 'foo 42) "Hi") (qqa (hasheq 'foo 42) " ") (qqa (hasheq 'foo 42) "idiot") (qqa (hasheq 'foo 42 'bar 84) "There") (qqa (hasheq 'foo 42) "Everyone"))))

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

@ -1,106 +1,84 @@
#lang debug racket/base
(require racket/match racket/promise racket/dict racket/class)
(require racket/struct)
(provide (all-defined-out))
(module+ test (require rackunit))
(define quad%
(class* object% (equal<%>)
(super-new)
(init-field [(@attrs attrs) null] [(@elems elems) null])
;; why 'nw and 'ne as defaults for in and out points:
;; if size is '(0 0), 'nw and 'ne are the same point,
;; and everything piles up at the origin
;; if size is otherwise, the items don't pile up (but rather lay out in a row)
(field [(@in in) 'nw]
[(@out out) 'ne]
[(@inner inner) #f]
[@printable #f]
[(@size size) '(0 0)]
[(@offset offset) '(0 0)]
[(@origin origin) '(0 0)])
(define (printable? q [signal #f])
((quad-printable q) q signal))
(define/public (offset [signal #f]) @offset)
(define/public (printable? [signal #f])
(match (or @printable
(match @elems
[(list (and (? char?) (? char-whitespace?)))
#:when (memq signal '(start end)) #false]
[else #true]))
[(? procedure? proc) (proc signal)]
[(? promise? prom) (force prom)]
[val val]))
(define (draw q [surface #f])
((quad-draw q) q surface))
(define/public (size)
(match @size
[(? procedure? proc) (proc)]
[(? promise? prom) (force prom)]
[val val]))
(define/public (pre-draw surface) (void))
(define/public (post-draw surface) (void))
(define (hashes-equal? h1 h2)
(and (= (length (hash-keys h1)) (length (hash-keys h2)))
(for/and ([(k v) (in-hash h1)])
(and (hash-has-key? h2 k) (equal? (hash-ref h2 k) v)))))
(define/public (draw [surface #f])
(pre-draw surface)
(for-each (λ (e) (send e draw surface)) @elems)
(post-draw surface))
(define (quad=? q1 q2 recur?)
(and
;; exclude attrs from initial comparison
(andmap equal? (cdr (struct->list q1)) (cdr (struct->list q2)))
;; and compare them key-by-key
(hashes-equal? (quad-attrs q1) (quad-attrs q2))))
;; equal<%> interface
(define/public-final (equal-to? other recur)
(define other-attrs (get-field attrs other))
(define other-elems (get-field elems other))
(and (list? @attrs)
(list? other-attrs)
(= (length @attrs) (length other-attrs))
(andmap equal? (sort (hash->list @attrs) #:key car symbol<?)
(sort (hash->list other-attrs) #:key car symbol<?))
(= (length @elems) (length other-elems))
(andmap equal? @elems other-elems)))
;; The hash codes need to be insensitive to casing as well.
;; We'll just downcase the word and get its hash code.
(define/public-final (equal-hash-code-of hash-code)
(hash-code this))
(define/public-final (equal-secondary-hash-code-of hash-code)
(hash-code this))))
(struct quad (attrs
elems
in
out
inner
offset
origin
size
printable
pre-draw
post-draw
draw) #:transparent #:mutable
#:methods gen:equal+hash
[(define equal-proc quad=?)
(define (hash-proc h recur) (equal-hash-code h))
(define (hash2-proc h recur) (equal-secondary-hash-code h))])
(define (quad? x) (is-a? x quad%))
(define (quad-attrs? x) (and (hash? x) (hash-eq? x)))
(define (quad-elem? x) (or (char? x) (string? x) (quad? x)))
(define (quad-elems? xs) (and (pair? xs) (andmap quad-elem? xs)))
(define (quad #:type [type quad%] . xs)
(match xs
[(list #f xs ...) (apply quad #:type type (hasheq) xs)]
[(list (list (? symbol? sym) rest ...) (? quad-elem? elems) ...)
(make-object type (apply hasheq (cons sym rest)) elems)]
[(list (? dict? attrs) (? quad-elem? elems) ...)
(make-object type (for/hasheq ([(k v) (in-dict attrs)])
(values k v)) elems)]
[(list (? quad-attrs? attrs) (? quad-elem? elems) ...) (make-object type attrs elems)]
[(list (? quad-elem? elems) ...) (apply quad #:type type #f elems)]
[else (error 'bad-quad-input)]))
(define q quad)
(define (quads? xs) (andmap quad? xs))
(define (atomic-quad? x) (and (quad? x) (match (get-field elems x)
[(list (? char?)) #t]
[else #f])))
(define (atomic-quads? xs) (andmap atomic-quad? xs))
(define (default-printable [sig #f]) #f)
(module+ test
(check-true (atomic-quad? (make-object quad% '#hasheq() '(#\H))))
(check-true (atomic-quads? (list (make-object quad% '#hasheq() '(#\H))))))
(define (make-quad [attrs #f] [elems null])
;; why 'nw and 'ne as defaults for in and out points:
;; if size is '(0 0), 'nw and 'ne are the same point,
;; and everything piles up at the origin
;; if size is otherwise, the items don't pile up (but rather lay out in a row)
(define in 'nw)
(define out 'ne)
(define inner #f)
(define offset '(0 0))
(define origin '(0 0))
(define size '(0 0))
(define printable default-printable)
(define pre-draw void)
(define post-draw void)
(define (draw q surface)
((quad-pre-draw q) q surface)
(for-each (λ (qi) ((quad-draw qi) qi surface)) (quad-elems q))
((quad-post-draw q) q surface))
(quad (or attrs (make-hasheq))
elems
in
out
inner
offset
origin
size
printable
pre-draw
post-draw
draw))
#|
(define break% (class quad% (super-new)))
(define (break . xs) (apply quad #:type break% xs))
(define b break)
|#
(define q make-quad)
(module+ test
(define x (make-object
(class quad%
(super-new)
(define/override (draw [surface #f])
(println "foo"))) '(#\H #\e #\l #\o)))
(send x draw))
(define q1 (make-quad #f '(#\H #\e #\l #\o)))
(define q2 (make-quad #f '(#\H #\e #\l #\o)))
(define q3 (make-quad #f '(#\H #\e #\l)))
(check-true (equal? q1 q1))
(check-true (equal? q1 q2))
(check-false (equal? q1 q3))
(set-quad-draw! q1 (λ (q surface) "foo"))
(check-equal? (draw q1) "foo"))

Write Preview
Loading…
Cancel
Save