From 2b6e5cb185b623485f59f423a1e48fb4d84a0cb7 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Fri, 9 Feb 2018 12:47:19 -0800 Subject: [PATCH] abstracter --- quad/quad/atomize.rkt | 14 +++--- quad/quad/break.rkt | 105 ++++++++++++++++++++++-------------------- quad/quad/quad.rkt | 2 +- 3 files changed, 64 insertions(+), 57 deletions(-) diff --git a/quad/quad/atomize.rkt b/quad/quad/atomize.rkt index d8954fdc..45d09757 100644 --- a/quad/quad/atomize.rkt +++ b/quad/quad/atomize.rkt @@ -26,12 +26,12 @@ (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 - (break (qa (car ws)) #\space) + (quad (qa (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) (b #\space) (q #\i)))) + (list (q #\H) (q #\space) (q #\i)))) (define/contract (atomize qx) ;; normalize a quad by reducing it to one-character quads. @@ -53,10 +53,10 @@ (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) (b #\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-equal? (atomize (q "H i")) (list (q #\H) (b #\space) (q #\i))) - (check-equal? (atomize (q "H \n\n i")) (list (q #\H) (b #\space) (q #\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 (q (hasheq 'k "v") "Hi")) (list (q (hasheq 'k "v") #\H) (q (hasheq 'k "v") #\i))) @@ -64,7 +64,7 @@ (list ($quad '#hasheq((k . "v")) '(#\H)) ($quad '#hasheq((k . "v")) '(#\i)) - ($break '#hasheq((k . "v")) '(#\space)) + ($quad '#hasheq((k . "v")) '(#\space)) ($quad '#hasheq((k . "v")) '(#\Y)) ($quad '#hasheq((k . "v")) '(#\o)) ($quad '#hasheq((k . "v")) '(#\u)))) @@ -72,7 +72,7 @@ (list ($quad '#hasheq((k1 . "v1") (k2 . 42)) '(#\H)) ($quad '#hasheq((k1 . "v1") (k2 . 42)) '(#\i)) - ($break '#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")) '(#\o)) ($quad '#hasheq((k1 . "v2") (k2 . 42) (k3 . "foo")) '(#\u))))) \ No newline at end of file diff --git a/quad/quad/break.rkt b/quad/quad/break.rkt index ed7c7f28..851ed72c 100644 --- a/quad/quad/break.rkt +++ b/quad/quad/break.rkt @@ -12,41 +12,50 @@ (or (null? sublists) (= 1 (apply max (map length sublists)))))))) (define debug #f) -(define/contract (breaks qs-in [target-size (current-line-width)]) - ((alternating-atomic-quads?) (integer?) . ->* . (listof any/c)) +(define/contract (breaks qs-in + [target-size (current-line-width)] + #:break-val [break-val 'break] + #:mandatory-break-proc [mandatory-break? (λ (q) (memv (car (qe q)) '(#\newline)))] + #:optional-break-proc [optional-break? (λ (q) (memv (car (qe q)) '(#\space)))] + #:size-proc [size-proc (λ (q) (let ([val (hash-ref (qa q) 'size (λ () + (if (memv (car (qe q)) '(#\space)) + (delay (values 0 1 0)) + (delay (values 1 1 1)))))]) + (if (promise? val) (force val) (val))))]) + ((quads?) (integer? #:break-val any/c + #:mandatory-break-proc procedure? + #:optional-break-proc procedure? + #:size-proc procedure?) . ->* . (listof any/c)) (define last-breakpoint-k #f) (define (capture-k!) (let/cc k (set! last-breakpoint-k k) #f)) (define break-here #t) - (define mandatory-breaks '(#\newline)) - (for/fold ([bs null] + (for/fold ([qss null] [break-open? #t] [size-so-far 0] - #:result (reverse bs)) + #:result (reverse qss)) ([(q qidx) (in-indexed qs-in)]) - (define-values (size-start size-mid size-end) (let ([val (hash-ref (qa q) 'size (λ () - (if ($break? q) - (delay (values 0 1 0)) - (delay (values 1 1 1)))))]) - (if (promise? val) (force val) (val)))) + (define-values (size-start size-mid size-end) (size-proc q)) (cond [(not break-open?) (when debug (report q 'open-break)) - (values (cons (not break-here) bs) (not break-open?) (+ size-so-far size-start))] + (values (append (list q) qss) (not break-open?) (+ size-so-far size-start))] [(<= (+ size-so-far size-end) target-size) ;; check condition based on size-end (as if x were breakpoint) ... (cond - [(or (memv (car (qe q)) mandatory-breaks) - (and ($break? q) (capture-k!))) ;; return point for `last-breakpoint-k` + [(or (mandatory-break? q) + (and (optional-break? q) (capture-k!))) ;; return point for `last-breakpoint-k` (when debug (report q 'resuming-breakpoint)) (set! last-breakpoint-k #f) ;; prevents continuation loop - (values (cons break-here bs) (not break-open?) 0)] ;; closes the break at this quad + ;; when break is found, q is omitted from accumulation + (values (append (list break-val) qss) (not break-open?) 0)] ;; closes the break at this quad [else (when debug (report q 'add-to-line)) - (values (cons (not break-here) bs) break-open? (if (zero? size-so-far) ;; we're still at start - size-start - (+ size-so-far size-mid)))])] ;; otherwise recur based on size-mid + (values (append (list q) qss) break-open? (if (zero? size-so-far) ;; we're still at start + size-start + (+ size-so-far size-mid)))])] ;; otherwise recur based on size-mid ;; overflow handlers [last-breakpoint-k (when debug (report q 'invoking-last-breakpoint)) (last-breakpoint-k #t)] [else (when debug (report q 'falling-back)) - (values (cons break-here bs) break-open? size-start)]))) ;; fallback if no last-breakpoint-k exists + (values (append (list q break-val) qss) break-open? size-start)]))) +;; fallback if no last-breakpoint-k exists ;; todo bug: constrain breaking to certain junctures (define ch (q (hasheq 'size (delay (values 1 1 1))) #\x)) @@ -54,44 +63,42 @@ (define b (q (hasheq 'size (delay (values 1 1 1))) #\b)) (define c (q (hasheq 'size (delay (values 1 1 1))) #\c)) (define d (q (hasheq 'size (delay (values 1 1 1))) #\d)) -(define sp (break (hasheq 'size (delay (values 0 1 0))) #\space)) -(define br (break (hasheq 'size (delay (values 0 0 0))) #\newline)) +(define sp (q (hasheq 'size (delay (values 0 1 0))) #\space)) +(define br (q (hasheq 'size (delay (values 0 0 0))) #\newline)) (define (visual-breaks str int) - (apply string (for/list ([c (in-string str)] - [b (in-list (breaks (atomize str) int))]) - (cond - [(not b) c] - [(eqv? c #\space) #\|] - [else #\*])))) + (apply string (for/list ([b (in-list (breaks (atomize str) int))]) + (cond + [(quad? b) (car (qe b))] + [else #\|])))) (module+ test - (check-equal? (breaks (list) 1) null) - (check-equal? (breaks (list ch) 1) '(#f)) - (check-equal? (breaks (list ch ch) 1) '(#f #t)) - (check-equal? (breaks (list ch ch ch) 1) '(#f #t #t)) - (check-equal? (breaks (list ch ch ch) 2) '(#f #f #t)) - (check-equal? (breaks (list ch ch ch ch) 2) '(#f #f #t #f)) - (check-equal? (breaks (list ch ch ch ch ch) 3) '(#f #f #f #t #f)) - (check-equal? (breaks (list ch ch ch ch ch) 1) '(#f #t #t #t #t)) - (check-equal? (breaks (list ch ch ch ch ch) 10) '(#f #f #f #f #f)) + (check-equal? (breaks (list) 1) null) + (check-equal? (breaks (list ch) 1) (list ch)) + (check-equal? (breaks (list ch ch) 1) (list ch 'break ch)) + (check-equal? (breaks (list ch ch ch) 1) (list ch 'break ch 'break ch)) + (check-equal? (breaks (list ch ch ch) 2) (list ch ch 'break ch)) + (check-equal? (breaks (list ch ch ch ch) 2) (list ch ch 'break ch ch)) + (check-equal? (breaks (list ch ch ch ch ch) 3) (list ch ch ch 'break ch ch)) + (check-equal? (breaks (list ch ch ch ch ch) 1) (list ch 'break ch 'break ch 'break ch 'break ch)) + (check-equal? (breaks (list ch ch ch ch ch) 10) (list ch ch ch ch ch)) - (check-equal? (breaks (list ch sp ch) 1) '(#f #t #f)) - (check-equal? (breaks (list ch ch sp ch) 2) '(#f #f #t #f)) - (check-equal? (breaks (list a sp b) 3) '(#f #f #f)) - (check-equal? (breaks (list ch sp ch ch) 3) '(#f #t #f #f)) + (check-equal? (breaks (list ch sp ch) 1) (list ch 'break ch)) + (check-equal? (breaks (list ch ch sp ch) 2) (list ch ch 'break ch)) + (check-equal? (breaks (list a sp b) 3) (list a sp b)) + (check-equal? (breaks (list ch sp ch ch) 3) (list ch 'break ch ch)) - (check-equal? (breaks (list a br b) 2) '(#f #t #f)) - (check-equal? (breaks (list ch br ch ch) 3) '(#f #t #f #f)) - (check-equal? (breaks (list ch ch br ch) 3) '(#f #f #t #f)) - (check-equal? (breaks (list ch ch ch ch) 3) '(#f #f #f #t)) - (check-equal? (breaks (list ch ch ch sp ch ch) 2) '(#f #f #t #t #f #f)) - (check-equal? (breaks (list ch ch ch sp ch ch) 3) '(#f #f #f #t #f #f)) + (check-equal? (breaks (list a br b) 2) (list a 'break b)) + (check-equal? (breaks (list ch br ch ch) 3) (list ch 'break ch ch)) + (check-equal? (breaks (list ch ch br ch) 3) (list ch ch 'break ch)) + (check-equal? (breaks (list ch ch ch ch) 3) (list ch ch ch 'break ch)) + (check-equal? (breaks (list ch ch ch sp ch ch) 2) (list ch ch 'break ch 'break ch ch)) + (check-equal? (breaks (list ch ch ch sp ch ch) 3) (list ch ch ch 'break ch ch)) - (check-equal? (visual-breaks "My dog has fleas" 1) "M*|d**|h**|f****") - (check-equal? (visual-breaks "My dog has fleas" 2) "My|do*|ha*|fl*a*") - (check-equal? (visual-breaks "My dog has fleas" 3) "My|dog|has|fle*s") - (check-equal? (visual-breaks "My dog has fleas" 4) "My|dog|has|flea*") + (check-equal? (visual-breaks "My dog has fleas" 1) "M|y|d|o|g|h|a|s|f|l|e|a|s") + (check-equal? (visual-breaks "My dog has fleas" 2) "My|do|g|ha|s|fl|ea|s") + (check-equal? (visual-breaks "My dog has fleas" 3) "My|dog|has|fle|as") + (check-equal? (visual-breaks "My dog has fleas" 4) "My|dog|has|flea|s") (check-equal? (visual-breaks "My dog has fleas" 5) "My|dog|has|fleas") (check-equal? (visual-breaks "My dog has fleas" 6) "My dog|has|fleas") (check-equal? (visual-breaks "My dog has fleas" 7) "My dog|has|fleas") diff --git a/quad/quad/quad.rkt b/quad/quad/quad.rkt index 9c1145ef..37249b26 100644 --- a/quad/quad/quad.rkt +++ b/quad/quad/quad.rkt @@ -14,7 +14,7 @@ [(list (? quad-attrs? attrs) (? quad-elem? elems) ...) (type attrs elems)] [(list (? quad-elem? elems) ...) (apply quad #:type type #f elems)] [else (error 'bad-quad-input)])) -(define (quads? xs) (and (pair? xs) (andmap quad? xs))) +(define (quads? xs) (andmap quad? xs)) (define (atomic-quad? x) (and (quad? x) (match (qe x) [(list (? char?)) #t] [else #f])))