From 5c7e99838cd15fa85333276ddb7d9a7fdb41e236 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sat, 10 Feb 2018 13:47:08 -0600 Subject: [PATCH] more --- quad/quad/atomize.rkt | 3 +- quad/quad/break.rkt | 115 ++++++++++++++++++++++++++---------------- 2 files changed, 72 insertions(+), 46 deletions(-) diff --git a/quad/quad/atomize.rkt b/quad/quad/atomize.rkt index 45d09757..f997cb80 100644 --- a/quad/quad/atomize.rkt +++ b/quad/quad/atomize.rkt @@ -13,11 +13,10 @@ ((hasheq 'foo "bar" 'zim "zam") . update-with . (hasheq 'zim "BANG") (hasheq 'toe "jam") (hasheq 'foo "zay")) '#hasheq((zim . "BANG") (foo . "zay") (toe . "jam")))) -(define (merge-whitespace aqs) +(define (merge-whitespace aqs [white-aq? (λ (aq) (char-whitespace? (car (qe aq))))]) ;; collapse each sequence of whitespace aqs to the first one, and make it a space ;; also drop leading & trailing whitespaces ;; (same behavior as web browsers) - (define (white-aq? aq) (char-whitespace? (car (qe aq)))) (let loop ([acc null][aqs aqs]) (if (null? aqs) (flatten acc) diff --git a/quad/quad/break.rkt b/quad/quad/break.rkt index a4d4f46a..1d2c2c72 100644 --- a/quad/quad/break.rkt +++ b/quad/quad/break.rkt @@ -1,10 +1,10 @@ #lang debug racket/base -(require racket/contract racket/list txexpr sugar/debug sugar/list racket/promise +(require racket/contract racket/list txexpr sugar/debug sugar/list racket/promise racket/function "param.rkt" "qexpr.rkt" "atomize.rkt" "quad.rkt") -(define debug #f) -(define/contract (breaks xs-in +(define/contract (breaks xs [target-size (current-line-width)] + [debug #f] #:break-val [break-val 'break] ;; todo: generalize these procs so they're not particular to quads #:mandatory-break-proc [mandatory-break? (λ (q) (memv (car (qe q)) '(#\newline)))] @@ -14,46 +14,59 @@ (delay (values 0 1 0)) (delay (values 1 1 1)))))]) (if (promise? val) (force val) (val))))]) - ((any/c) (integer? #:break-val any/c - #:mandatory-break-proc procedure? - #:optional-break-proc procedure? - #:size-proc procedure?) . ->* . (listof any/c)) + ((any/c) (integer? any/c + #:break-val any/c + #:mandatory-break-proc procedure? + #:optional-break-proc procedure? + #:size-proc procedure?) . ->* . (listof any/c)) + #;(and (pair? xs) + (let ([can-be-break? (disjoin mandatory-break? optional-break?)]) + (for/first ([x (in-list xs)] + [next-x (in-list (cdr xs))] + #:when (and (can-be-break? x) (can-be-break? next-x))) + (raise-argument-error 'breaks "no adjacent break possibilities allowed in input" (list x next-x))))) (define last-breakpoint-k #f) (define (capture-k!) (let/cc k (set! last-breakpoint-k k) #f)) - (for/fold ([xss null] - [size-so-far 0] - #:result (reverse xss)) - ([x (in-list xs-in)]) + (for/fold ([vals null] + [size-so-far #f] + #:result (reverse (dropf vals optional-break?))) + ([x (in-list xs)]) (define-values (size-start size-mid size-end) (size-proc x)) (cond - [(<= (+ size-so-far size-end) target-size) ;; check overflow condition based on size-end (as if x were breakpoint) + [(and (not size-so-far) (optional-break? x)) (when debug (report x 'skipping-opt-break-at-beginning)) + (values vals size-so-far)] + [(or (not size-so-far) (<= (+ size-so-far size-end) target-size)) ;; check overflow condition based on size-end (as if x were breakpoint) + (define (insert-break) (values (cons break-val (dropf vals optional-break?)) #f)) (cond [(mandatory-break? x) (when debug (report x 'got-mandatory-break)) - (values (cons break-val xss) 0)] + (insert-break)] [(and (optional-break? x) (capture-k!)) (when debug (report x 'resuming-breakpoint)) ;; return point for k - (set! last-breakpoint-k #f) ;; prevents continuation loop - (values (cons break-val xss) 0)] ;; when break is found, q is omitted from accumulation + (set! last-breakpoint-k #f) ;; prevents continuation loop + (insert-break)] ;; when break is found, q is omitted from accumulation [else (when debug (report x 'add-to-line)) - (values (cons x xss) (if (zero? size-so-far) ;; we're still at start - size-start - (+ size-so-far size-mid)))])] ;; otherwise recur based on size-mid + (values (cons x vals) (if (not 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 x 'invoking-last-breakpoint)) (last-breakpoint-k #t)] [else (when debug (report x 'falling-back)) - (values (list* x break-val xss) size-start)]))) ;; fallback if no last-breakpoint-k exists + (values (list* x break-val vals) size-start)]))) ;; fallback if no last-breakpoint-k exists + + +(define x (q (hasheq 'size (delay (values 1 1 1))) #\x)) +(define zwx (q (hasheq 'size (delay (values 0 0 0))) #\z)) +(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 (q (hasheq 'size (delay (values 0 1 0))) #\space)) +(define br (q (hasheq 'size (delay (values 0 0 0))) #\newline)) (module+ test (require rackunit) - (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 (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 ([b (in-list (breaks (atomize str) int))]) (cond @@ -61,26 +74,40 @@ [else #\|])))) (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) (list ch 'break ch)) - (check-equal? (breaks (list ch ch sp ch) 2) (list ch ch 'break ch)) + (check-equal? (breaks (list x) 1) (list x)) + (check-equal? (breaks (list x x) 1) (list x 'break x)) + (check-equal? (breaks (list x x x) 1) (list x 'break x 'break x)) + (check-equal? (breaks (list x x x) 2) (list x x 'break x)) + (check-equal? (breaks (list x x x x) 2) (list x x 'break x x)) + (check-equal? (breaks (list x x x x x) 3) (list x x x 'break x x)) + (check-equal? (breaks (list x x x x x) 1) (list x 'break x 'break x 'break x 'break x)) + (check-equal? (breaks (list x x x x x) 10) (list x x x x x)) + + (check-equal? (breaks (list x sp x) 1) (list x 'break x)) + (check-equal? (breaks (list x x sp x) 2) (list x x 'break x)) (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 x sp x x) 3) (list x 'break x x)) + + ;; leading & trailing spaces + (check-equal? (breaks (list sp x) 2) (list x)) + (check-equal? (breaks (list x sp) 2) (list x)) + (check-equal? (breaks (list sp x sp) 2) (list x)) + (check-equal? (breaks (list sp sp x sp sp) 2) (list x)) + (check-equal? (breaks (list sp sp x sp sp x sp) 1) (list x 'break x)) + + ;; zero width nonbreakers + (check-equal? (breaks (list sp zwx) 2) (list zwx)) + (check-equal? (breaks (list zwx sp) 2) (list zwx)) + (check-equal? (breaks (list sp zwx sp) 2) (list zwx)) + (check-equal? (breaks (list sp sp zwx sp sp) 2) (list zwx)) + (check-equal? (breaks (list sp sp zwx sp sp zwx sp) 2) (list zwx sp sp zwx)) (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? (breaks (list x br x x) 3) (list x 'break x x)) + (check-equal? (breaks (list x x br x) 3) (list x x 'break x)) + (check-equal? (breaks (list x x x x) 3) (list x x x 'break x)) + (check-equal? (breaks (list x x x sp x x) 2) (list x x 'break x 'break x x)) + (check-equal? (breaks (list x x x sp x x) 3) (list x x x 'break x x)) (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")