abstracter

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)))))

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")

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])))