From 1d40971ea54b18a22eb3442c36ea44a61bc68469 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Fri, 4 Jan 2019 00:56:29 -0800 Subject: [PATCH] touches --- quad/quad/atomize.rkt | 72 +++++++++++++++++++++---------------------- quad/quad/quad.rkt | 12 ++++++-- 2 files changed, 44 insertions(+), 40 deletions(-) diff --git a/quad/quad/atomize.rkt b/quad/quad/atomize.rkt index 51b17683..f1d10d2f 100644 --- a/quad/quad/atomize.rkt +++ b/quad/quad/atomize.rkt @@ -1,5 +1,5 @@ #lang debug racket/base -(require racket/string racket/class racket/match racket/list txexpr racket/dict racket/function +(require racket/string racket/hash racket/class racket/match racket/list txexpr racket/dict racket/function "quad.rkt" "param.rkt") (provide (all-defined-out)) (module+ test (require rackunit)) @@ -7,8 +7,7 @@ (define (update-with base-hash . update-hashes) ;; starting with base-hash, add or update keys found in update-hashes (define h (make-hasheq)) - (for ([(k v) (in-dict (append-map hash->list (list* base-hash update-hashes)))]) - (hash-set! h k v)) + (apply hash-union! #:combine (λ (v1 v2) v2) h base-hash update-hashes) h) (module+ test @@ -28,23 +27,21 @@ (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 - (make-quad (quad-attrs (car ws)) '(#\space)) + (make-quad (quad-attrs (car ws)) #\space) null)) rest))))) (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)))) + (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)))) (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 #f (list qx)) qx)][attrs (current-default-attrs)]) + (let loop ([x (if (string? qx) (q #f qx) qx)][attrs (current-default-attrs)]) (match x - [(? char? c) (list (q attrs (list c)))] + [(? char? c) (list (q attrs c))] [(? string?) (append* (for/list ([c (in-string x)]) ;; strings are exploded (loop c attrs)))] [(? quad?) ;; qexprs with attributes are recursed @@ -58,30 +55,30 @@ (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-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 (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 + (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 ;; 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"))) + (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 - (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"))) + (q (hasheq 'k "v") #\H) + (q (hasheq 'k "v") #\i) + (q (hasheq 'k "v") #\space) + (q (hasheq 'k "v") #\Y) + (q (hasheq 'k "v") #\o) + (q (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 - (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)))) + (q (hasheq 'k1 "v1" 'k2 42) #\H) + (q (hasheq 'k1 "v1" 'k2 42) #\i) + (q (hasheq 'k1 "v1" 'k2 42) #\space) + (q (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\Y) + (q (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\o) + (q (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\u)))) (define whitespace-pat #px"\\s+") (define (merge-and-isolate-white str) @@ -102,7 +99,7 @@ (define run-key 'run) (define (same-run? qa qb) - (eq? (hash-ref (get-field attrs qa) run-key) (hash-ref (get-field attrs qb) run-key))) + (eq? (hash-ref (quad-attrs qa) run-key) (hash-ref (quad-attrs qb) run-key))) (define (runify qx) ;; runify a quad by reducing it to a series of "runs", @@ -123,16 +120,17 @@ (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 (make-quad next-attrs (list elem))) + (list (make-quad next-attrs elem)) (loop elem next-attrs next-key))))])) (λ (q) (string=? " " (car (quad-elems q)))))) #;(module+ test + ;; this test doesn't work because of presence of 'idx and 'run keys (check-equal? - (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")))) + (runify (q (hasheq 'foo 42) (q "Hi" " idiot" (q (hasheq 'bar 84) "There") "Eve" "ry" "one"))) + (list (q (hasheq 'foo 42) "Hi") + (q (hasheq 'foo 42) " ") + (q (hasheq 'foo 42) "idiot") + (q (hasheq 'foo 42 'bar 84) "There") + (q (hasheq 'foo 42) "Everyone")))) diff --git a/quad/quad/quad.rkt b/quad/quad/quad.rkt index fa8fd5a7..60803888 100644 --- a/quad/quad/quad.rkt +++ b/quad/quad/quad.rkt @@ -1,5 +1,5 @@ #lang debug racket/base -(require racket/struct) +(require racket/struct racket/dict racket/match) (provide (all-defined-out)) (module+ test (require rackunit)) @@ -40,7 +40,11 @@ (define (default-printable [sig #f]) #f) -(define (make-quad [attrs #f] [elems null]) +;; todo: convert immutable hashes to mutable on input? +(define make-quad + (match-lambda* + [(list (== #false) elems ...) elems (apply make-quad (make-hasheq) elems)] + [(list (? hash? attrs) elems ...) ;; 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 @@ -69,7 +73,9 @@ printable pre-draw post-draw - draw)) + draw)] + [(list (? dict? assocs) elems ...) assocs (apply make-quad (make-hasheq assocs) elems)] + [(list elems ...) (apply make-quad #f elems)])) (define q make-quad)