From 907b6c11df90e14ad8fabc70a29806f03fcc9f52 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Sun, 4 Feb 2018 21:43:27 -0800
Subject: [PATCH] a loop

---
 quad/quad/atomize.rkt |  4 +-
 quad/quad/break.rkt   | 94 +++++++++++++++++++++++++++++++++++++++++++
 quad/quad/param.rkt   |  5 +++
 quad/quad/qexpr.rkt   |  4 +-
 4 files changed, 103 insertions(+), 4 deletions(-)
 create mode 100644 quad/quad/break.rkt
 create mode 100644 quad/quad/param.rkt

diff --git a/quad/quad/atomize.rkt b/quad/quad/atomize.rkt
index 28e8f8ce..72c51250 100644
--- a/quad/quad/atomize.rkt
+++ b/quad/quad/atomize.rkt
@@ -1,6 +1,6 @@
 #lang racket/base
 (require racket/contract racket/match racket/list txexpr sugar/debug
-         "qexpr.rkt")
+         "qexpr.rkt" "param.rkt")
 (provide (all-defined-out))
 
 (define/contract (atomize qx)
@@ -8,7 +8,7 @@
   ;; propagate attrs downward by appending to front of attrs list.
   ;; ok to have duplicate attrs (leftmost attr takes precedence)
   (qexpr? . -> . (listof qexpr?))
-  (let loop ([x qx][attrs null])
+  (let loop ([x qx][attrs (current-default-attrs)])
     (match x
       [(? string?) (for/list ([c (in-string x)]) ;; strings are exploded
                      (qexpr attrs (string c)))]
diff --git a/quad/quad/break.rkt b/quad/quad/break.rkt
new file mode 100644
index 00000000..8b7e79df
--- /dev/null
+++ b/quad/quad/break.rkt
@@ -0,0 +1,94 @@
+#lang racket/base
+(require racket/contract racket/list txexpr sugar/debug
+         "param.rkt" "qexpr.rkt" "atomize.rkt")
+(module+ test (require rackunit))
+
+(define/contract (break qs-in [target-size (current-line-width)]
+                        #:size-proc [size-proc (λ () 1)]
+                        #:break-start-key [break-start-key 'break-start]
+                        #:break-end-key [break-end-key 'break-end]
+                        #:breakable-proc [breakable? (λ (q) #t)])
+  (((listof qexpr?)) (integer? #:size-proc procedure?
+                               #:break-start-key symbol?
+                               #:break-end-key symbol?
+                               #:breakable-proc procedure?) . ->* . (listof qexpr?))
+  (define last-breakpoint-k (λ (x) (error 'no-breakpoint-found)))
+  (define (capture-k!) (let/cc k (set! last-breakpoint-k k) #f))
+  (for/fold ([qs null]
+             [acc-size 0]
+             #:result (reverse qs))
+            ([q (in-list qs-in)]
+             [next-q (in-list (append (cdr qs-in) (list #f)))])
+    (define next-acc-size (and next-q (+ acc-size (size-proc next-q))))
+    (cond
+      [(or (not next-acc-size) (and (breakable? next-q) (capture-k!)))
+       (values (cons (attr-set q break-end-key "true") qs) 0)]
+      [(zero? acc-size) (if (breakable? q)
+                            (values (cons q qs) 0)
+                            (values (cons (attr-set q break-start-key "true") qs) next-acc-size))]
+      [(< next-acc-size target-size) (values (cons q qs) next-acc-size)]
+      [else (last-breakpoint-k #t)])))
+
+(module+ test
+  (check-equal? (break (atomize "aaa bb cc ddddd") 5
+                       #:size-proc (λ (q) 1)
+                       #:break-start-key 'line-start
+                       #:break-end-key 'line-end
+                       #:breakable-proc (λ (q) (equal? (second q) " ")))
+                '((q ((line-start "true")) "a")
+                  (q "a")
+                  (q ((line-end "true")) "a")
+                  (q " ")
+                  (q ((line-start "true")) "b")
+                  (q "b")
+                  (q " ")
+                  (q "c")
+                  (q ((line-end "true")) "c")
+                  (q " ")
+                  (q ((line-start "true")) "d")
+                  (q "d")
+                  (q "d")
+                  (q "d")
+                  (q ((line-end "true")) "d")))
+  (check-equal?
+   (break (atomize "aaa bb cc ddddd") 6
+          #:size-proc (λ (q) 1)
+          #:break-start-key 'line-start
+          #:break-end-key 'line-end
+          #:breakable-proc (λ (q) (equal? (second q) " ")))
+   '((q ((line-start "true")) "a")
+     (q "a")
+     (q "a")
+     (q " ")
+     (q "b")
+     (q ((line-end "true")) "b")
+     (q " ")
+     (q ((line-start "true")) "c")
+     (q ((line-end "true")) "c")
+     (q " ")
+     (q ((line-start "true")) "d")
+     (q "d")
+     (q "d")
+     (q "d")
+     (q ((line-end "true")) "d")))
+
+  (check-equal? (break (atomize "aaa bb cc ddddd") 8
+                       #:size-proc (λ (q) 1)
+                       #:break-start-key 'line-start
+                       #:break-end-key 'line-end
+                       #:breakable-proc (λ (q) (equal? (second q) " ")))
+                '((q ((line-start "true")) "a")
+                  (q "a")
+                  (q "a")
+                  (q " ")
+                  (q "b")
+                  (q ((line-end "true")) "b")
+                  (q " ")
+                  (q ((line-start "true")) "c")
+                  (q "c")
+                  (q " ")
+                  (q "d")
+                  (q "d")
+                  (q "d")
+                  (q "d")
+                  (q ((line-end "true")) "d"))))
\ No newline at end of file
diff --git a/quad/quad/param.rkt b/quad/quad/param.rkt
new file mode 100644
index 00000000..b2b275af
--- /dev/null
+++ b/quad/quad/param.rkt
@@ -0,0 +1,5 @@
+#lang racket/base
+(provide (all-defined-out))
+
+(define current-default-attrs (make-parameter null))
+(define current-line-width (make-parameter 1))
\ No newline at end of file
diff --git a/quad/quad/qexpr.rkt b/quad/quad/qexpr.rkt
index 06c6bccc..f0e4ebd0 100644
--- a/quad/quad/qexpr.rkt
+++ b/quad/quad/qexpr.rkt
@@ -1,5 +1,5 @@
-#lang br
-(require xml racket/contract txexpr)
+#lang racket/base
+(require xml racket/contract racket/match racket/list txexpr)
 (provide (all-defined-out))
 
 (module+ test (require rackunit))