more more

quad/quad/break.rkt

@@ -7,8 +7,8 @@
                          [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)))]
-                         #:optional-break-proc [optional-break? (λ (q) (memv (car (qe q)) '(#\space)))]
+                         #:mandatory-break-proc [mandatory-break? (λ (q) (and (quad? q) (memv (car (qe q)) '(#\newline))))]
+                         #:optional-break-proc [optional-break? (λ (q) (and (quad? 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))
@@ -25,29 +25,37 @@
                        [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 start-signal (gensym))
   (define last-breakpoint-k #f)
   (define (capture-k!) (let/cc k (set! last-breakpoint-k k) #f))
   (for/fold ([vals null]
-             [size-so-far #f]
+             [size-so-far start-signal]
              #:result (reverse (dropf vals optional-break?)))
             ([x (in-list xs)])
+    (define (at-start?) (eq? size-so-far start-signal))
+    (define (underflow?) (<= (+ size-so-far size-end) target-size))
+    (define (add-to-segment)
+      (values (cons x vals) (if (at-start?)
+                                size-start
+                                (+ size-so-far size-mid))))
     (define-values (size-start size-mid size-end) (size-proc x))
+    (define (insert-break)
+      ;; when break is found, q is omitted from accumulation
+      ;; and any preceding optional breaks are dropped (that would be trailing before the break)
+      (values (cons break-val (dropf vals optional-break?)) start-signal))
     (cond
-      [(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))
+      [(mandatory-break? x) (when debug (report x 'got-mandatory-break))
+                            (insert-break)]
+      [(optional-break? x)
        (cond
-         [(mandatory-break? x) (when debug (report x 'got-mandatory-break))
-                               (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
-                                                 (insert-break)] ;; when break is found, q is omitted from accumulation
-         [else (when debug (report x 'add-to-line))
-               (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
+         [(at-start?) (when debug (report x 'skipping-opt-break-at-beginning)) (values vals size-so-far)]
+         [(and (underflow?) (capture-k!)) (when debug (report x 'resuming-breakpoint))
+                                          (set! last-breakpoint-k #f) ;; prevents continuation loop
+                                          (insert-break)]
+         [else (when debug (report x 'add-optional-break))
+               (add-to-segment)])]
+      [(or (at-start?) (underflow?)) (when debug (report x 'add-ordinary-char))
+                                          (add-to-segment)]
       [last-breakpoint-k (when debug (report x 'invoking-last-breakpoint))
                          (last-breakpoint-k #t)]
       [else (when debug (report x 'falling-back))
@@ -66,62 +74,83 @@
 
 (module+ test
   (require rackunit)
+
+  (test-case
+   "chars"
+   (check-equal? (breaks (list) 1) null)  
+   (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)))
+
+  (test-case
+   "chars and spaces"
+   (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 x sp x x) 3) (list x 'break x x)))
+
+  (test-case
+   "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)))
   
+  (test-case
+   "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)))
+
+  (test-case
+   "mandatory breaks"
+   (check-equal? (breaks (list br) 2) (list 'break))
+   (check-equal? (breaks (list a br b) 2) (list a 'break b))
+   (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)))
+
+  (test-case
+   "mandatory breaks and spurious spaces"
+   (check-equal? (breaks (list a sp sp sp br b) 2) (list a 'break b))
+   (check-equal? (breaks (list x sp br sp sp x x sp) 3) (list x 'break x x))
+   (check-equal? (breaks (list sp sp x x sp sp br sp sp sp x) 3) (list x x 'break x))
+   (check-equal? (breaks (list a sp b sp sp br sp c) 3) (list a sp b 'break c))
+   (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)))
+
   (define (visual-breaks str int)
     (apply string (for/list ([b (in-list (breaks (atomize str) int))])
                     (cond
                       [(quad? b) (car (qe b))]
                       [else #\|]))))
-  
-  (check-equal? (breaks (list) 1) null)  
-  (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 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 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")
-  (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")
-  (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"))
+  (test-case
+   "visual breaks"
+   (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")
+   (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")))