From 6efcc8cdd7d493cd21ad509a12341417caf3a86c Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Mon, 5 Mar 2018 15:06:45 -0800
Subject: [PATCH] introduce `printable?`

---
 quad/quad/generic.rkt    |  5 +--
 quad/quad/position.rkt   | 20 +++++------
 quad/quad/quad.rkt       | 26 +++++++++------
 quad/quad/typewriter.rkt | 21 ++++++------
 quad/quad/wrap.rkt       | 72 +++++++++++++++++++---------------------
 5 files changed, 74 insertions(+), 70 deletions(-)

diff --git a/quad/quad/generic.rkt b/quad/quad/generic.rkt
index bb608839..61532d7f 100644
--- a/quad/quad/generic.rkt
+++ b/quad/quad/generic.rkt
@@ -7,8 +7,9 @@
   (out quad)
   (inner quad)
 
-  (size quad [signal])
-  (offset quad [signal])
+  (printable? quad [signal])
+  (size quad)
+  (offset quad)
 
   (origin quad)
   (set-origin! quad where)
diff --git a/quad/quad/position.rkt b/quad/quad/position.rkt
index 698a1726..6a970aa6 100644
--- a/quad/quad/position.rkt
+++ b/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 [signal #f])
-  ((quad? symbol?) (any/c) . ->* . point?)
+(define/contract (anchor->point q anchor)
+  (quad? symbol? . -> . point?)
   (unless (valid-anchor? anchor)
     (raise-argument-error 'relative-anchor-pt "valid anchor" anchor))
   (match-define (list x-fac y-fac)
@@ -27,22 +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  )]))
-  (match-define (list x y) (size q signal))
+  (match-define (list x y) (size q))
   (pt (coerce-int (* x x-fac)) (coerce-int (* y y-fac))))
 
-(define point/c ((quad?) (any/c) . ->* . point?))
+(define point/c (quad? . -> . point?))
 
-(define/contract (inner-point q [signal #f])
+(define/contract (inner-point q)
   point/c
-  (pt+ (origin q) (anchor->point q (inner q) signal) (offset q)))
+  (pt+ (origin q) (anchor->point q (inner q)) (offset q)))
 
-(define/contract (in-point q [signal #f])
+(define/contract (in-point q)
   point/c
-  (anchor->point q (in q) signal))
+  (anchor->point q (in q)))
 
-(define/contract (out-point q [signal #f])
+(define/contract (out-point q)
   point/c
-  (pt+ (origin q) (anchor->point q (out q) signal))) ; no offset because end-point is calculated without padding
+  (pt+ (origin q) (anchor->point q (out q)))) ; no offset because end-point is calculated without padding
 
 
 (define/contract (position q [previous-end-pt (origin q)])
diff --git a/quad/quad/quad.rkt b/quad/quad/quad.rkt
index e6263a7b..78a66d35 100644
--- a/quad/quad/quad.rkt
+++ b/quad/quad/quad.rkt
@@ -3,12 +3,12 @@
 (provide (all-defined-out))
 (module+ test (require rackunit))
 
-(define (default-size-proc q sig)
+(define (default-visibility-proc q sig)
   (match (elems q)
     [(list (? (λ (x) (and (char? x) (char-whitespace? x))) c)) (case sig
-                                                                 [(start end) '(0 0)]
-                                                                 [else '(1 1)])]
-    [else '(1 1)]))
+                                                                 [(start end) #f]
+                                                                 [else #t])]
+    [else #t]))
 
 (struct $quad (attrs elems) #:transparent #:mutable
   #:methods gen:quad
@@ -17,11 +17,17 @@
    (define (in q) (hash-ref (attrs q) 'in 'nw))
    (define (out q) (hash-ref (attrs q) 'out 'ne))
    (define (inner q) (hash-ref (attrs q) 'inner (λ () (in q))))
-   (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 (printable? q [signal #f]) 
+     (let ([v (hash-ref (attrs q) 'printable? (λ () (default-visibility-proc q signal)))])
+       (cond
+         [(procedure? v) (v signal)]
+         [(promise? v) (force v)]
+         [else v])))
+   (define (size q) (let ([v (hash-ref (attrs q) 'size '(1 1))])
+                      (cond
+                        [(procedure? v) (v)]
+                        [(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)))
@@ -38,7 +44,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)]))
diff --git a/quad/quad/typewriter.rkt b/quad/quad/typewriter.rkt
index 7c666a90..dc675237 100644
--- a/quad/quad/typewriter.rkt
+++ b/quad/quad/typewriter.rkt
@@ -8,21 +8,22 @@
 (struct $char $quad () #:transparent)
 (define (charify q)
   ($char (hash-set* (attrs q)
-                    'size (case (car (elems q))
-                            [(#\u00AD)
-                             (λ (sig) (case sig
-                                        [(end) '(7.2 12)]
-                                        [else #f]))]
-                            [(#\space) (λ (sig) (case sig
-                                                  [(start end) #f]
-                                                  [else '(7.2 12)]))]
-                            [else (const '(7.2 12))])
+                    'size (const '(7.2 12))
+                    'printable? (case (car (elems q))
+                                  [(#\u00AD)
+                                   (λ (sig) (case sig
+                                              [(end) #t]
+                                              [else #f]))]
+                                  [(#\space) (λ (sig) (case sig
+                                                        [(start end) #f]
+                                                        [else #t]))]
+                                  [else #t])
                     'draw (λ (q doc) (send/apply doc text (apply string (elems q)) (origin q)))) (elems q)))
 (struct $line $quad () #:transparent)
 (struct $page $quad () #:transparent)
 (struct $doc $quad () #:transparent)
 (struct $break $quad () #:transparent)
-(define (break . xs) ($break (hasheq 'size #f) xs))
+(define (break . xs) ($break (hasheq 'printable? #f) xs))
 
 (define line-height 16)
 (define (line-wrap xs size [debug #f])
diff --git a/quad/quad/wrap.rkt b/quad/quad/wrap.rkt
index 8c9c0146..28d99f8f 100644
--- a/quad/quad/wrap.rkt
+++ b/quad/quad/wrap.rkt
@@ -2,18 +2,16 @@
 (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])
-  ((any/c) (any/c) . ->* . (or/c #f real?))
+(define/contract (distance q)
+  (any/c . -> . real?)
   ;; linear distance from in point to out point
-  ;; or #f if quad is nonprinting
   (cond
     [(quad? q)
-     (and (size q signal)
-          (match-let ([(list ∆x ∆y) (map - (out-point q signal) (in-point q signal))])
-            (cond
-              [(zero? ∆x) ∆y]
-              [(zero? ∆y) ∆x]
-              [else (sqrt (+ (* ∆x ∆x) (* ∆y ∆y)))])))]
+     (match-define (list ∆x ∆y) (map - (out-point q) (in-point q)))
+     (cond
+       [(zero? ∆x) ∆y]
+       [(zero? ∆y) ∆x]
+       [else (sqrt (+ (* ∆x ∆x) (* ∆y ∆y)))])]
     [else 0]))
 
 
@@ -30,12 +28,12 @@
                   #:optional-break-proc procedure?
                   #:finish-wrap-proc procedure?) . ->* . (listof any/c))
   (define start-signal (gensym))
-  (define (nonprinting-at-start? x) (not (distance x 'start)))
-  (define (nonprinting-at-end? x) (not (distance x 'end)))
+  (define (nonprinting-at-start? x) (if (quad? x) (not (printable? x 'start)) #t))
+  (define (nonprinting-at-end? x) (if (quad? x) (not (printable? x 'end)) #t))
   (define (finish-wrap pieces) (finish-wrap-proc (reverse (dropf pieces (λ (x) (and (optional-break? x)
                                                                                     (nonprinting-at-end? x)))))))
   (define last-optional-break-k #f)
-  (define (capture-optional-break-k!) (let/cc k (set! last-optional-break-k k) #f))
+  (define (capture-optional-break-k!) (when debug (report 'capturing-break)) (let/cc k (set! last-optional-break-k k) #f))
   (call/prompt ;; continuation boundary for last-optional-break-k
    (thunk
     (let loop ([wraps null][wrap-pieces null][dist-so-far start-signal][xs xs])
@@ -47,11 +45,13 @@
         [else
          (define x (car xs))
          (define at-start? (eq? dist-so-far start-signal))
-         (define underflow? (and (not at-start?) (<= (+ dist-so-far (or (distance x 'end) 0)) target-size)))
+         (define underflow? (and (not at-start?) (<= (+ dist-so-far (if (and (quad? x) (printable? x 'end)) (distance x) 0)) target-size)))
          (define (add-to-current-wrap)
-           (define dist (distance x (and at-start? 'start)))
+           
+           (define printable (and (quad? x) (printable? x (and at-start? 'start)))) 
+           (define dist (and printable (distance x)))
            (loop wraps
-                 (if dist (cons x wrap-pieces) wrap-pieces) ; omit nonprinting quad
+                 (if (and (quad? x) (not printable)) wrap-pieces (cons x wrap-pieces)) ; omit nonprinting quad
                  (if at-start? (or dist start-signal) (+ dist-so-far (or dist 0)))
                  (cdr xs)))
          (define (insert-break [before? #f])
@@ -115,19 +115,19 @@
 (define x (q #f #\x))
 (define zwx (q (list 'size (pt 0 0)) #\z))
 (define hyph (q #f #\-))
-(define shy (q (list 'size (λ (sig)
-                             (case sig
-                               [(end) (pt 1 1)]
-                               [else #f]))) #\-))
+(define shy (q (list 'size (pt 1 1) 'printable? (λ (sig)
+                                                  (case sig
+                                                    [(end) #t]
+                                                    [else #f]))) #\-))
 (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) #f]
-                              [else (pt 1 1)]))) #\space))
-(define br (q (list 'size #f) #\newline))
+(define sp (q (list 'size (pt 1 1) 'printable? (λ (sig)
+                                                 (case sig
+                                                   [(start end) #f]
+                                                   [else #t]))) #\space))
+(define br (q (list 'size (pt 0 0) 'printable? #f) #\newline))
 (define optional-break? (λ (q) (and (quad? q) (memv (car (elems q)) '(#\space #\-)))))
 
 (define (linewrap xs size [debug #f])
@@ -136,6 +136,7 @@
         #:mandatory-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline))))
         #:optional-break-proc optional-break?))
 
+
 (module+ test
   (require rackunit)
 
@@ -151,6 +152,7 @@
    (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)))
 
+
   (test-case
    "chars and spaces"
    (check-equal? (linewrap (list x sp x) 1) (list x 'lb x))
@@ -158,6 +160,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))
@@ -166,7 +169,6 @@
    (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
    "hard hyphens"
    (check-equal? (linewrap (list hyph) 1) (list hyph))
@@ -222,20 +224,17 @@
    (check-equal? (linewrap (list a sp b sp sp br sp c) 3) (list a sp b 'lb c))
    (check-equal? (linewrap (list x x x x) 3) (list x x x 'lb x))
    (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)))
+   (check-equal? (linewrap (list x x x sp x x) 3) (list x x x 'lb x x))))
 
   (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 #\|]))))
-
-  (check-equal? (visual-wrap "M d" 1 1) "M|d")
-
-      #|
-(test-case
+(module+ test
+  (test-case
    "visual breaks"
-   (check-equal? (visual-wrap "My dog has fleas" 1 1) "M|y|d|o|g|h|a|s|f|l|e|a|s")
+   (check-equal? (visual-wrap "My dog has fleas" 1) "M|y|d|o|g|h|a|s|f|l|e|a|s")
    (check-equal? (visual-wrap "My dog has fleas" 2) "My|do|g|ha|s|fl|ea|s")
    (check-equal? (visual-wrap "My dog has fleas" 3) "My|dog|has|fle|as")
    (check-equal? (visual-wrap "My dog has fleas" 4) "My|dog|has|flea|s")
@@ -250,7 +249,7 @@
    (check-equal? (visual-wrap "My dog has fleas" 13) "My dog has|fleas")
    (check-equal? (visual-wrap "My dog has fleas" 14) "My dog has|fleas")
    (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"))
+   (check-equal? (visual-wrap "My dog has fleas" 16) "My dog has fleas")))
 
 
   (define (pagewrap xs size [debug #f])
@@ -260,6 +259,7 @@
           #:optional-break-proc (λ (x) (eq? x 'lb))))
   (define pbr (q '(size #f) #\page))
 
+(module+ test
   (test-case
    "soft page breaks"
    (check-equal? (pagewrap null 2) null)
@@ -278,7 +278,6 @@
    (check-equal? (pagewrap (list x pbr pbr x x) 1) (list x 'pb 'pb x 'pb x))
    (check-equal? (pagewrap (list x pbr pbr x x) 2) (list x 'pb 'pb x x))
    (check-equal? (pagewrap (list 'lb x 'lb 'lb pbr 'lb x x 'lb) 2) (list x 'pb x x)))
-
   (test-case
    "composed line breaks and page breaks"
    (check-equal? (pagewrap (linewrap null 1) 2) null)
@@ -305,7 +304,4 @@
    (check-equal? (linewrap2 (list a sp b sp sp br sp c) 3) (list (slug a sp b) 'lb (slug c)))
    (check-equal? (linewrap2 (list x x x x) 3) (list (slug x x x) 'lb (slug x)))
    (check-equal? (linewrap2 (list x x x sp x x) 2) (list (slug x x) 'lb (slug x) 'lb (slug x x)))
-   (check-equal? (linewrap2 (list x x x sp x x) 3) (list (slug x x x) 'lb (slug x x))))
-|#
-
-  )
\ No newline at end of file
+   (check-equal? (linewrap2 (list x x x sp x x) 3) (list (slug x x x) 'lb (slug x x)))))
\ No newline at end of file