wrap with distance

quad/quad/generic.rkt

@@ -7,8 +7,8 @@
   (end quad)
   (inner quad)
 
-  (size quad [condition])
-  (offset quad [condition])
+  (size quad [signal])
+  (offset quad [signal])
 
   (origin quad)
   (set-origin! quad where)

quad/quad/position.rkt

@@ -18,8 +18,8 @@
 (define (coerce-int x) (if (integer? x) (inexact->exact x) x))
 
 
-(define/contract (anchor->point q anchor)
-  (quad? symbol? . -> . point?)
+(define/contract (anchor->point q anchor [signal #f])
+  ((quad? symbol?) (any/c) . ->* . point?)
   (unless (valid-anchor? anchor)
     (raise-argument-error 'relative-anchor-pt "valid anchor" anchor))
   (match-define (list x-fac y-fac)
@@ -27,20 +27,22 @@
       [(nw) '(0 0  )] [(n) '(0.5 0  )] [(ne) '(1 0  )]
       [( w) '(0 0.5)] [(c) '(0.5 0.5)] [( e) '(1 0.5)]
       [(sw) '(0 1  )] [(s) '(0.5 1  )] [(se) '(1 1  )]))
-  (pt (coerce-int (* (pt-x (size q)) x-fac)) (coerce-int (* (pt-y (size q)) y-fac))))
+  (match-define (list x y) (size q signal))
+  (pt (coerce-int (* x x-fac)) (coerce-int (* y y-fac))))
 
+(define point/c ((quad?) (any/c) . ->* . point?))
 
-(define/contract (inner-point q)
-  (quad? . -> . point?)
-  (pt+ (origin q) (anchor->point q (inner q)) (offset q)))
+(define/contract (inner-point q [signal #f])
+  point/c
+  (pt+ (origin q) (anchor->point q (inner q) signal) (offset q)))
 
-(define/contract (start-point q)
-  (quad? . -> . point?)
-  (anchor->point q (start q)))
+(define/contract (start-point q [signal #f])
+  point/c
+  (anchor->point q (start q) signal))
 
-(define/contract (end-point q)
-  (quad? . -> . point?)
-  (pt+ (origin q) (anchor->point q (end q)))) ; no offset because end-point is calculated without padding
+(define/contract (end-point q [signal #f])
+  point/c
+  (pt+ (origin q) (anchor->point q (end q) signal))) ; no offset because end-point is calculated without padding
 
 
 (define/contract (position q [previous-end-pt (pt 0 0)])

quad/quad/quad.rkt

@@ -1,8 +1,15 @@
 #lang debug racket/base
-(require racket/match racket/function racket/dict "generic.rkt")
+(require racket/match racket/function racket/promise racket/dict "generic.rkt")
 (provide (all-defined-out))
 (module+ test (require rackunit))
 
+(define (default-size-proc q sig)
+  (match (elems q)
+    [(list (? char-whitespace? c)) (case sig
+                              [(start end) '(0 0)]
+                              [else '(1 1)])]
+    [else '(1 1)]))
+
 (struct $quad (attrs elems) #:transparent #:mutable
   #:methods gen:quad
   [(define (elems q) ($quad-elems q))
@@ -10,8 +17,12 @@
    (define (start q) (hash-ref (attrs q) 'start 'nw))
    (define (end q) (hash-ref (attrs q) 'end 'ne))
    (define (inner q) (hash-ref (attrs q) 'inner (λ () (start q))))
-   (define (size q [condition #f]) (hash-ref (attrs q) 'size '(1 1)))
-   (define (offset q [condition #f]) (hash-ref (attrs q) 'offset '(0 0)))
+   (define (size q [signal #f]) (let ([v (hash-ref (attrs q) 'size (λ () (default-size-proc q signal)))])
+                                  (cond
+                                    [(procedure? v) (v signal)]
+                                    [(promise? v) (force v)]
+                                    [else v])))
+   (define (offset q [signal #f]) (hash-ref (attrs q) 'offset '(0 0)))
    (define (origin q) (hash-ref (attrs q) 'origin '(0 0)))
    (define (set-origin! q val) (set-$quad-attrs! q (hash-set (attrs q) 'origin val)))
    (define (draw q [surface #f] [origin #f]) ((hash-ref (attrs q) 'draw (λ () (λ () (println "<no draw routine>"))))))])
@@ -24,7 +35,7 @@
     [(list #f xs ...) (apply quad #:type type (hasheq) xs)]
     [(list (list (? symbol? sym) rest ...) (? quad-elem? elems) ...) (type (apply hasheq (cons sym rest)) elems)]
     [(list (? dict? attrs) (? quad-elem? elems) ...) (type (for/hasheq ([(k v) (in-dict attrs)])
-                                                                       (values k v)) elems)]
+                                                             (values k v)) elems)]
     [(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)]))

quad/quad/wrap.rkt

@@ -1,38 +1,47 @@
 #lang debug racket/base
 (require racket/contract racket/list racket/match txexpr sugar/debug sugar/define sugar/list racket/promise racket/function (only-in racket/control call/prompt)
-         "param.rkt" "qexpr.rkt" "atomize.rkt" "quad.rkt" "generic.rkt")
+         "param.rkt" "qexpr.rkt" "atomize.rkt" "quad.rkt" "generic.rkt" "position.rkt")
+
+(define/contract (distance q [signal #f])
+  ((any/c) (any/c) . ->* . real?)
+  (cond
+    [(quad? q)
+     (match-define (list ∆x ∆y) (map - (end-point q signal) (start-point q signal)))
+     (cond
+       [(zero? ∆x) ∆y]
+       [(zero? ∆y) ∆x]
+       [else (sqrt (+ (* ∆x ∆x) (* ∆y ∆y)))])]
+    [else 0]))
+
 
 (define+provide/contract (wrap xs
-                                [target-size (current-line-width)]
-                                [debug #f]
-                                #:break-val [break-val 'break]
-                                #:mandatory-break-proc [mandatory-break? (const #f)]
-                                #:optional-break-proc [optional-break? (const #f)]
-                                #:finish-segment-proc [finish-segment-proc values]
-                                #:size-proc [size-proc (const 1)])
-  ((any/c) (integer? any/c
-                     #:break-val any/c
-                     #:mandatory-break-proc procedure?
-                     #:optional-break-proc procedure?
-                     #:size-proc procedure?
-                     #:finish-segment-proc procedure?) . ->* . (listof any/c))
+                               [target-size (current-line-width)]
+                               [debug #f]
+                               #:break-val [break-val 'break]
+                               #:mandatory-break-proc [mandatory-break? (const #f)]
+                               #:optional-break-proc [optional-break? (const #f)]
+                               #:finish-segment-proc [finish-segment-proc values])
+  ((any/c) (real? any/c
+                  #:break-val any/c
+                  #:mandatory-break-proc procedure?
+                  #:optional-break-proc procedure?
+                  #:finish-segment-proc procedure?) . ->* . (listof any/c))
   (define start-signal (gensym))
   (define (finish-segment pieces) (finish-segment-proc (reverse (dropf pieces optional-break?))))
   (define last-optional-break-k #f)
   (call/prompt ;; continuation boundary for last-optional-break-k
    (thunk
-    (define (capture-optional-break-k!) (let/cc k (set! last-optional-break-k k) #f))
+    (define (capture-optional-break-k!) (when debug (report 'capture)) (let/cc k (set! last-optional-break-k k) #f))
     (for/fold ([segments null]
                [pieces null]
-               [size-so-far start-signal]
+               [dist-so-far start-signal]
                #:result (append* (reverse (cons (finish-segment pieces) segments))))
               ([x (in-list xs)])
-      (define-values (size-start size-mid size-end) (size-proc x))
-      (define at-start? (eq? size-so-far start-signal))
-      (define underflow? (and (not at-start?) (<= (+ size-so-far size-end) target-size)))
+      (define at-start? (eq? dist-so-far start-signal))
+      (define underflow? (and (not at-start?) (<= (+ dist-so-far (distance x 'end)) target-size)))
       (define (add-to-segment) (values segments (cons x pieces) (if at-start?
-                                                                    size-start
-                                                                    (+ size-so-far size-mid))))
+                                                                    (distance x 'start)
+                                                                    (+ dist-so-far (distance 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)
@@ -42,7 +51,7 @@
                               (insert-break)]
         [(optional-break? x)
          (cond
-           [at-start? (when debug (report x 'skipping-opt-break-at-beginning)) (values segments null size-so-far)]
+           [at-start? (when debug (report x 'skipping-opt-break-at-beginning)) (values segments null dist-so-far)]
            [(and underflow? (capture-optional-break-k!)) (when debug (report x 'resuming-breakpoint))
                                                          (set! last-optional-break-k #f) ;; prevents continuation loop
                                                          (insert-break)]
@@ -54,29 +63,28 @@
                                (last-optional-break-k #t)]
         [else (when debug (report x 'falling-back))
               (match-define-values (vals _ _) (insert-break))
-              (values vals (list x) size-start)]))))) ;; fallback if no last-breakpoint-k exists
+              (values vals (list x) (distance x '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))
+
+(define x (q #f #\x))
+(define zwx (q (list 'size (pt 0 0)) #\z))
+(define a (q #f #\a))
+(define b (q #f #\b))
+(define c (q #f #\c))
+(define d (q #f #\d))
+(define sp (q (list 'size (λ (sig)
+                            (case sig
+                              [(start end) (pt 0 0)]
+                              [else (pt 1 1)]))) #\space))
+(define br (q (list 'size (pt 0 0)) #\newline))
 (define optional-break? (λ (q) (and (quad? q) (memv (car (elems q)) '(#\space)))))
 
 (define (linewrap xs size [debug #f])
   (wrap xs size debug
-                 #:break-val 'lb
-                 #:mandatory-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline))))
-                 #:optional-break-proc optional-break?
-                 #:size-proc (λ (q) (let ([val (hash-ref (attrs q) 'size (λ ()
-                                                                        (if (memv (car (elems q)) '(#\space))
-                                                                            (delay (values 0 1 0))
-                                                                            (delay (values 1 1 1)))))])
-                                      (if (promise? val) (force val) (val))))))
+        #:break-val 'lb
+        #:mandatory-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline))))
+        #:optional-break-proc optional-break?))
 
 (module+ test
   (require rackunit)
@@ -100,6 +108,7 @@
    (check-equal? (linewrap (list a sp b) 3) (list a sp b))
    (check-equal? (linewrap (list x sp x x) 3) (list x 'lb x x)))
 
+
   (test-case
    "leading & trailing spaces"
    (check-equal? (linewrap (list sp x) 2) (list x))
@@ -107,7 +116,7 @@
    (check-equal? (linewrap (list sp x sp) 2) (list x))
    (check-equal? (linewrap (list sp sp x sp sp) 2) (list x))
    (check-equal? (linewrap (list sp sp x sp sp x sp) 1) (list x 'lb x)))
-  
+
   (test-case
    "zero width nonbreakers"
    (check-equal? (linewrap (list sp zwx) 2) (list zwx))
@@ -138,8 +147,8 @@
    (check-equal? (linewrap (list x x x sp x x) 2) (list x x 'lb x 'lb x x))
    (check-equal? (linewrap (list x x x sp x x) 3) (list x x x 'lb x x)))
 
-  (define (visual-wrap str int)
-    (apply string (for/list ([b (in-list (linewrap (atomize str) int))])
+  (define (visual-wrap str int [debug #f])
+    (apply string (for/list ([b (in-list (linewrap (atomize str) int debug))])
                     (cond
                       [(quad? b) (car (elems b))]
                       [else #\|]))))
@@ -163,16 +172,12 @@
    (check-equal? (visual-wrap "My dog has fleas" 15) "My dog has|fleas")
    (check-equal? (visual-wrap "My dog has fleas" 16) "My dog has fleas"))
 
-  
   (define (pagewrap xs size [debug #f])
     (wrap xs size debug
-                   #:break-val 'pb
-                   #:mandatory-break-proc (λ (x) (and (quad? x) (memv (car (elems x)) '(#\page))))
-                   #:optional-break-proc (λ (x) (eq? x 'lb))
-                   #:size-proc (λ (q) (case q
-                                        [(lb) (values 0 0 0)]
-                                        [else (values 1 1 1)]))))
-  (define pbr (q (hasheq 'size (delay (values 0 0 0))) #\page))
+          #:break-val 'pb
+          #:mandatory-break-proc (λ (x) (and (quad? x) (memv (car (elems x)) '(#\page))))
+          #:optional-break-proc (λ (x) (eq? x 'lb))))
+  (define pbr (q '(size (0 0)) #\page))
 
   (test-case
    "soft page breaks"
@@ -208,11 +213,6 @@
                  #:break-val 'lb
                  #:mandatory-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline))))
                  #:optional-break-proc optional-break?
-                 #:size-proc (λ (q) (let ([val (hash-ref (attrs q) 'size (λ ()
-                                                                        (if (memv (car (elems q)) '(#\space))
-                                                                            (delay (values 0 1 0))
-                                                                            (delay (values 1 1 1)))))])
-                                      (if (promise? val) (force val) (val))))
                  #:finish-segment-proc (λ (pcs) (list ($slug #f pcs)))))
 
 (module+ test

quad/quad/wrap2.rkt

@@ -1,108 +0,0 @@
-#lang debug racket/base
-(require racket/contract racket/list racket/match txexpr sugar/debug sugar/define sugar/list racket/promise racket/function (only-in racket/control call/prompt)
-         "param.rkt" "qexpr.rkt" "atomize.rkt" "quad.rkt" "generic.rkt" "position.rkt")
-
-(define/contract (distance q [signal #f])
-  ((quad?) (any/c) . ->* . real?)
-  (match-define (list x0 y0) (start-point q))
-  (match-define (list x1 y1) (end-point q))
-  ;; pythagorically
-  (sqrt (+ (expt (- x1 x0) 2) (expt (- y1 y0) 2))))
-
-
-(define+provide/contract (wrap xs
-                               [target-size (current-line-width)]
-                               [debug #f]
-                               #:break-val [break-val 'break]
-                               #:mandatory-break-proc [mandatory-break? (const #f)]
-                               #:optional-break-proc [optional-break? (const #f)]
-                               #:finish-segment-proc [finish-segment-proc values])
-  ((any/c) (real? any/c
-                  #:break-val any/c
-                  #:mandatory-break-proc procedure?
-                  #:optional-break-proc procedure?
-                  #:finish-segment-proc procedure?) . ->* . (listof any/c))
-  (define start-signal (gensym))
-  (define (finish-segment pieces) (finish-segment-proc (reverse (dropf pieces optional-break?))))
-  (define last-optional-break-k #f)
-  (call/prompt ;; continuation boundary for last-optional-break-k
-   (thunk
-    (define (capture-optional-break-k!) (let/cc k (set! last-optional-break-k k) #f))
-    (for/fold ([segments null]
-               [pieces null]
-               [size-so-far start-signal]
-               #:result (append* (reverse (cons (finish-segment pieces) segments))))
-              ([x (in-list xs)])
-      (define at-start? (eq? size-so-far start-signal))
-      (define underflow? (and (not at-start?) (<= (+ size-so-far (size x 'end)) target-size)))
-      (define (add-to-segment) (values segments (cons x pieces) (if at-start?
-                                                                    (size x 'start)
-                                                                    (+ size-so-far (size 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 (list* (list break-val) (finish-segment pieces) segments) null start-signal))
-      (cond
-        [(mandatory-break? x) (when debug (report x 'got-mandatory-break))
-                              (insert-break)]
-        [(optional-break? x)
-         (cond
-           [at-start? (when debug (report x 'skipping-opt-break-at-beginning)) (values segments null size-so-far)]
-           [(and underflow? (capture-optional-break-k!)) (when debug (report x 'resuming-breakpoint))
-                                                         (set! last-optional-break-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-optional-break-k (when debug (report x 'invoking-last-breakpoint))
-                               (last-optional-break-k #t)]
-        [else (when debug (report x 'falling-back))
-              (match-define-values (vals _ _) (insert-break))
-              (values vals (list x) (size x 'start))]))))) ;; fallback if no last-breakpoint-k exists
-
-
-
-(define x (q (hasheq) #\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))
-(define optional-break? (λ (q) (and (quad? q) (memv (car (elems q)) '(#\space)))))
-
-(define (linewrap xs size [debug #f])
-  (wrap xs size debug
-        #:break-val 'lb
-        #:mandatory-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline))))
-        #:optional-break-proc optional-break?
-        #|
-        #:size-proc (λ (q) (let ([val (hash-ref (attrs q) 'size (λ ()
-                                                                  (if (memv (car (elems q)) '(#\space))
-                                                                      (delay (values 0 1 0))
-                                                                      (delay (values 1 1 1)))))])
-                             (if (promise? val) (force val) (val))))
-
-        |#
-        ))
-
-(module+ test
-  (require rackunit)
-
-  (test-case
-   "chars"
-   (check-equal? (linewrap (list) 1) null)
-   (check-equal? (linewrap (list x) 1) (list x))
-   #|
-   (check-equal? (linewrap (list x x) 1) (list x 'lb x))
-   (check-equal? (linewrap (list x x x) 1) (list x 'lb x 'lb x))
-   (check-equal? (linewrap (list x x x) 2) (list x x 'lb x))
-   (check-equal? (linewrap (list x x x x) 2) (list x x 'lb x x))
-   (check-equal? (linewrap (list x x x x x) 3) (list x x x 'lb x x))
-   (check-equal? (linewrap (list x x x x x) 1) (list x 'lb x 'lb x 'lb x 'lb x))
-   (check-equal? (linewrap (list x x x x x) 10) (list x x x x x))
-|#
-
-   ))