From d80154595b22aaf02db886752f8a6bc18cfbcb24 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Thu, 8 Feb 2018 15:34:58 -0800 Subject: [PATCH] level up --- quad/quad/atomize.rkt | 4 +- quad/quad/break.rkt | 138 ++++++++++++++++++++++++------------------ quad/quad/pred.rkt | 5 ++ 3 files changed, 85 insertions(+), 62 deletions(-) create mode 100644 quad/quad/pred.rkt diff --git a/quad/quad/atomize.rkt b/quad/quad/atomize.rkt index 3e62b07c..d8954fdc 100644 --- a/quad/quad/atomize.rkt +++ b/quad/quad/atomize.rkt @@ -36,9 +36,9 @@ (define/contract (atomize qx) ;; normalize a quad by reducing it to one-character quads. ;; propagate attrs downward. - (quad? . -> . (listof atomic-quad?)) + ((or/c quad? string?) . -> . (listof atomic-quad?)) (define atomic-quads - (let loop ([x qx][attrs (current-default-attrs)]) + (let loop ([x (if (string? qx) (q qx) qx)][attrs (current-default-attrs)]) (match x [(? char? c) (list (q attrs c))] [(? string?) (append* (for/list ([c (in-string x)]) ;; strings are exploded diff --git a/quad/quad/break.rkt b/quad/quad/break.rkt index b460a357..ed7c7f28 100644 --- a/quad/quad/break.rkt +++ b/quad/quad/break.rkt @@ -1,40 +1,69 @@ #lang debug racket/base -(require racket/contract racket/list txexpr sugar/debug racket/promise +(require racket/contract racket/list txexpr sugar/debug sugar/list racket/promise "param.rkt" "qexpr.rkt" "atomize.rkt" "quad.rkt") (module+ test (require rackunit)) -(define/contract (breaks xs-in [target-size (current-line-width)]) - (((listof atomic-quad?)) (integer?) . ->* . (listof any/c)) +(define (alternating-atomic-quads? xs) + (or (null? xs) + (and (atomic-quads? xs) + (not ($break? (first xs))) + (not ($break? (last xs))) + (let ([sublists (filter-split xs (compose1 not $break?))]) + (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 last-breakpoint-k #f) (define (capture-k!) (let/cc k (set! last-breakpoint-k k) #f)) - (for/fold ([xs null] + (define break-here #t) + (define mandatory-breaks '(#\newline)) + (for/fold ([bs null] [break-open? #t] [size-so-far 0] - #:result (reverse xs)) - ([(x idx) (in-indexed xs-in)]) - (define-values (size-start size-mid size-end breakability) (let ([x (hash-ref (qa x) 'size)]) - (if (promise? x) (force x) (x)))) + #:result (reverse bs)) + ([(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)))) (cond - [(not break-open?) (values (cons #f xs) #t (+ size-so-far size-start))] + [(not break-open?) (when debug (report q 'open-break)) + (values (cons (not break-here) bs) (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 (eq? breakability 'must) (and (eq? breakability 'can) (capture-k!))) ;; return point for `last-breakpoint-k` - (set! last-breakpoint-k #f) - (values (cons #f xs) #f 0)] ;; closes the break at this quad - [else - (values (cons #f xs) #t (if (zero? size-so-far) ;; we're still at start - size-start - (+ size-so-far size-mid)))])] ;; otherwise recur based on size-mid - ;; todo bug: but this doesn't work right with a trailing sequence of word spaces - + [(or (memv (car (qe q)) mandatory-breaks) + (and ($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 + [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 ;; overflow handlers - [last-breakpoint-k (last-breakpoint-k #t)] - [else (values (cons #t xs) #t size-start)]))) ;; fallback if no last-breakpoint-k exists + [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 ;; todo bug: constrain breaking to certain junctures -(define ch (q (hasheq 'size (delay (values 1 1 1 #f))) #\c)) -(define sp (break (hasheq 'size (delay (values 0 1 0 'can))) #\space)) -(define br (break (hasheq 'size (delay (values 0 0 0 'must))) #\newline)) +(define ch (q (hasheq 'size (delay (values 1 1 1))) #\x)) +(define a (q (hasheq 'size (delay (values 1 1 1))) #\a)) +(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 (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 #\*])))) (module+ test (check-equal? (breaks (list) 1) null) @@ -46,43 +75,32 @@ (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 sp) 1) '(#f)) - (check-equal? (breaks (list sp sp) 1) '(#f #f)) - (check-equal? (breaks (list sp sp) 2) '(#f #f)) - (check-equal? (breaks (list sp sp) 3) '(#f #f)) - (check-equal? (breaks (list sp sp sp) 1) '(#f #f #f)) - (check-equal? (breaks (list sp sp sp) 2) '(#f #f #f)) - (check-equal? (breaks (list sp sp sp) 3) '(#f #f #f)) - - ;; now it gets weird - (check-equal? (breaks (list ch sp) 1) '(#f #f)) - (check-equal? (breaks (list sp ch) 1) '(#f #f)) - (check-equal? (breaks (list sp ch ch) 1) '(#f #f #t)) - (check-equal? (breaks (list ch sp ch) 1) '(#f #f #t)) - #| - (check-equal? (break (list ch sp sp ch) 1) '(#f #f #t #f)) - (check-equal? (break (list ch sp ch sp) 1) '(#f #f #t #f)) - (check-equal? (break (list ch ch sp ch) 2) '(#f #f #f #t)) - (check-equal? (break (list ch sp ch) 3) '(#f #f #f)) - (check-equal? (break (list ch sp ch ch) 3) '(#f #f #t #f)) - - ;; trailing spaces - (check-equal? (break (list ch sp) 3) '(#t #f)) - (check-equal? (break (list ch sp sp) 3) '(#t #f #f)) - (check-equal? (break (list ch sp sp) 2) '(#t #f #f)) - (check-equal? (break (list ch sp sp) 1) '(#t #f #f)) ; fails + (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? (break (list ch br ch) 2) '(#t #f #t)) - (check-equal? (break (list ch br ch ch) 3) '(#t #f #t #f)) - (check-equal? (break (list ch ch br ch) 3) '(#t #f #f #t)) - (check-equal? (break (list ch ch ch ch) 3) '(#t #f #f #t)) - - (check-equal? (break (list ch ch ch sp sp ch ch) 2) '(#t #f #t #f #f #t #f)) - (check-equal? (break (list ch ch ch sp ch ch) 3) '(#t #f #f #f #t #f)) - |# - - ) - + (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? (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" 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") + (check-equal? (visual-breaks "My dog has fleas" 8) "My dog|has|fleas") + (check-equal? (visual-breaks "My dog has fleas" 9) "My dog|has fleas") + (check-equal? (visual-breaks "My dog has fleas" 10) "My dog has|fleas") + (check-equal? (visual-breaks "My dog has fleas" 11) "My dog has|fleas") + (check-equal? (visual-breaks "My dog has fleas" 12) "My dog has|fleas") + (check-equal? (visual-breaks "My dog has fleas" 13) "My dog has|fleas") + (check-equal? (visual-breaks "My dog has fleas" 14) "My dog has|fleas") + (check-equal? (visual-breaks "My dog has fleas" 15) "My dog has|fleas") + (check-equal? (visual-breaks "My dog has fleas" 16) "My dog has fleas")) \ No newline at end of file diff --git a/quad/quad/pred.rkt b/quad/quad/pred.rkt new file mode 100644 index 00000000..84e5aad1 --- /dev/null +++ b/quad/quad/pred.rkt @@ -0,0 +1,5 @@ +#lang racket/base +(provide (all-defined-out)) + +(define current-default-attrs (make-parameter (make-hasheq))) +(define current-line-width (make-parameter 1)) \ No newline at end of file