handle imperative breaks; add debug rendering

quad/quad/atomize.rkt

@@ -3,21 +3,26 @@
 (provide (all-defined-out))
 
 (define (atomize x)
-  (apply vector-immutable
+  (define empty-attrs (make-attrs))
+  (apply
+   vector-immutable
    (flatten
-   (let loop ([x x][loop-attrs default-attrs])
-     (cond
-       [(symbol? x) ($shim (make-attrs) #f x)]
-       [(string? x)
-        (for/list ([c (in-string x)])
-                  (cons ($shim (make-attrs) #f 0)
-                        (case c
-                          [(#\space #\newline #\return) ($white loop-attrs #f c)]
-                          [else ($black loop-attrs #f c)])))]
-       [else
-        (map (λ(xi) (loop xi ((quad-attrs x) . override-with . loop-attrs))) (quad-val x))])))))
+    (let loop ([x x][loop-attrs default-attrs])
+      (cond
+        [(symbol? x) ($hard empty-attrs x #f)]
+        [(string? x)
+         ;; consolidate consecutive whitespaces into single word space
+         (for/list ([c (in-string (regexp-replace* #px"\\s+" x " "))]) 
+                   (cons ($hard empty-attrs #f #f)
+                         ;; todo: is it feasible to box or otherwise object-ize a char
+                         ;; so that all the quads with that char share that object
+                         ;; and thus the measurement can be shared too?
+                         ;; (object would have to be packaged with other typographic specs)
+                         ((if (or (char=? c #\space) (char=? c #\-)) $soft $black) loop-attrs #f c)))]
+        [else
+         (map (λ(xi) (loop xi ((quad-attrs x) . override-with . loop-attrs))) (quad-val x))])))))
 
 (module+ test
   (require rackunit)
   (atomize (quad (make-attrs #:size 10 #:font "Eq") "ba" (line-break) "r" (quad (make-attrs #:size 8) "zam") "q\tux"))
-  (atomize (quad #f "Meg is " (line-break) "\nan ally.")))
+  (atomize (quad #f "Meg is-an ally.")))

quad/quad/kafka.rkt

@@ -0,0 +1,28 @@
+#lang quad/text #:text
+Produces a list of three-element lists, where each three-element list represents a set of consecutive code points for-which the Unicode standard specifies character properties. Each three-element list contains two integers and a boolean; the first integer is a starting code-point value (inclusive), the second integer is an ending code-point value (inclusive), and the boolean is #t when all characters in the code-point range have identical results for all of the character predicates above. The three-element lists are ordered in the overall result list such that later lists represent larger code-point values, and all three-element lists are separated from every other by at least one code-point value that is not specified by Unicode.
+
+One morning, when Gregor Samsa woke from troubled dreams, he found
+himself transformed in his bed into a horrible vermin.  He lay on
+his armour-like back, and if he lifted his head a little he could
+see his brown belly, slightly domed and divided by arches into stiff
+sections.  The bedding was hardly able to cover it and seemed ready
+to slide off any moment.  His many legs, pitifully thin compared
+with the size of the rest of him, waved about helplessly as he
+looked.
+
+"What's happened to me?" he thought.  It wasn't a dream. His room,
+a proper human room although a little too small, lay peacefully
+between its four familiar walls.  A collection of textile samples
+lay spread out on the table - Samsa was a travelling salesman - and
+above it there hung a picture that he had recently cut out of an
+illustrated magazine and housed in a nice, gilded frame.  It showed
+a lady fitted out with a fur hat and fur boa who sat upright,
+raising a heavy fur muff that covered the whole of her lower arm
+towards the viewer.
+
+Gregor then turned to look out the window at the dull weather.
+Drops of rain could be heard hitting the pane, which made him feel
+quite sad.  "How about if I sleep a little bit longer and forget all
+this nonsense", he thought, but that was something he was unable to
+do because he was used to sleeping on his right, and in his present
+state couldn't get into that position.  However hard he threw

quad/quad/main.rkt

@@ -1,15 +1,16 @@
 #lang racket/base
-(require "quads.rkt" "typeset.rkt" "atomize.rkt" racket/list racket/string)
+(require "quads.rkt" "typeset.rkt" "atomize.rkt" "render.rkt" racket/list racket/string)
 (provide (except-out (all-from-out racket/base "quads.rkt") #%module-begin)
          (rename-out [~module-begin #%module-begin]))
 
 (define-syntax-rule (~module-begin lang-line-config-arg . args)
   (#%module-begin
-   (define main-quad (quad #f . args))
+   (define main-quad (apply quad #f (add-between (list . args) "\n"))) ; at-reader splits lines, but we want one contiguous run
    ;; branch on config-arg to allow debug / inspection options on #lang line
    (case (string-trim lang-line-config-arg)
      [("#:atoms") (atomize main-quad)]
-     [else (typeset (atomize main-quad))])))
+     [("#:text") (time (debug-render (typeset-fit (atomize main-quad))))]
+     [else (typeset-fit (atomize main-quad))])))
 
 (module reader syntax/module-reader
   "main.rkt")

quad/quad/measure-chars.rkt

@@ -1,30 +0,0 @@
-#lang quad/dev
-(require "freetype-ffi.rkt")
-(provide (all-defined-out))
-
-(define measure-char
-  (let ([measure-cache (make-hash)]
-        [glyph-idx-cache (make-hash)]
-        [glyph-width-cache (make-hash)]
-        [em-size-cache (make-hash)]
-        [ft-library (FT_Init_FreeType)]
-        [ft-face-cache (make-hash)])
-    (λ (font-pathstring char)
-      (define (do-measure)
-        (define ft-face (hash-ref! ft-face-cache font-pathstring (λ () (FT_New_Face ft-library font-pathstring 0))))
-        (define width
-          (let ([glyph-idx (hash-ref! glyph-idx-cache (cons char font-pathstring)
-                                      (λ () (FT_Get_Char_Index ft-face (char->integer char))))])
-            (hash-ref! glyph-width-cache (cons glyph-idx font-pathstring)
-                       (λ ()
-                         (FT_Load_Glyph ft-face glyph-idx FT_LOAD_NO_RECURSE) ; loads into FTFace's 'glyph' slot
-                         (define width (FT_Vector-x (FT_GlyphSlotRec-advance (FT_FaceRec-glyph ft-face))))
-                         (* width 1.0))))) ; store as inexact
-        (define em-size
-          (hash-ref! em-size-cache font-pathstring (λ () (FT_FaceRec-units_per_EM ft-face))))
-        (/ width em-size))
-      (hash-ref! measure-cache (cons font-pathstring char) do-measure))))
-
-(module+ test
-  (require rackunit)
-  (check-equal? (measure-char "charter.ttf" #\f) .321))

quad/quad/measure.rkt

@@ -1,15 +1,42 @@
 #lang quad/dev
-(require "measure-chars.rkt")
+(require "freetype-ffi.rkt")
 (provide (all-defined-out))
 
 (define (measure! q)
   (quad-dim-set! q
                   (cond
-                    [(or ($black? q) ($white? q))
+                    [(or ($black? q) ($soft? q))
                      (* (measure-char (quad-font q) (quad-val q)) (quad-font-size q))]
                     [else 0])))
 
 (module+ test
   (require rackunit)
   (define q ($black '#hasheq((size . 12) (font . "sc.otf")) 0 #\n))
-  (check-equal? (measure-char (quad-font q) (quad-val q)) .6))
+  (check-equal? (measure-char (quad-font q) (quad-val q)) .6))
+
+(define measure-char
+  (let ([measure-cache (make-hash)]
+        [glyph-idx-cache (make-hash)]
+        [glyph-width-cache (make-hash)]
+        [em-size-cache (make-hash)]
+        [ft-library (FT_Init_FreeType)]
+        [ft-face-cache (make-hash)])
+    (λ (font-pathstring char)
+      (define (do-measure)
+        (define ft-face (hash-ref! ft-face-cache font-pathstring (λ () (FT_New_Face ft-library font-pathstring 0))))
+        (define width
+          (let ([glyph-idx (hash-ref! glyph-idx-cache (cons char font-pathstring)
+                                      (λ () (FT_Get_Char_Index ft-face (char->integer char))))])
+            (hash-ref! glyph-width-cache (cons glyph-idx font-pathstring)
+                       (λ ()
+                         (FT_Load_Glyph ft-face glyph-idx FT_LOAD_NO_RECURSE) ; loads into FTFace's 'glyph' slot
+                         (define width (FT_Vector-x (FT_GlyphSlotRec-advance (FT_FaceRec-glyph ft-face))))
+                         (* width 1.0))))) ; store as inexact
+        (define em-size
+          (hash-ref! em-size-cache font-pathstring (λ () (FT_FaceRec-units_per_EM ft-face))))
+        (/ width em-size))
+      (hash-ref! measure-cache (cons font-pathstring char) do-measure))))
+
+(module+ test
+  (require rackunit)
+  (check-equal? (measure-char "charter.ttf" #\f) .321))

quad/quad/quads.rkt

@@ -4,9 +4,8 @@
 
 (struct $quad (attrs dim val) #:transparent #:mutable)
 (struct $black $quad () #:transparent)
-(struct $white $quad () #:transparent)
-(struct $skip $quad () #:transparent)
-(struct $shim $quad () #:transparent)
+(struct $soft $quad () #:transparent)
+(struct $hard $quad () #:transparent)
 
 (define quad? $quad?)
 
@@ -54,17 +53,25 @@ measure (line width)
               (values k (or (hash-ref dest k) (hash-ref source k)))))
 
 (require (for-syntax sugar/debug))
-(define-syntax (define-break stx)
-  (syntax-case stx ()
-    [(_ name)
-     (with-syntax ([BREAK-NAME (string->symbol (string-upcase (symbol->string (syntax->datum #'name))))])
-       #'(define (name) (quad #f 'BREAK-NAME)))]))
+(define-syntax-rule (define-break name)
+  (define (name) (quad #f 'name)))
 
 (define-break page-break)
 (define-break column-break)
 (define-break block-break)
 (define-break line-break)
 
+(define-syntax (caseq stx)
+  ;; like case but strictly uses `eq?` comparison (as opposed to `equal?`)
+  (syntax-case stx ()
+    [(_ test-val [(match-val ...) . result] ... [else . else-result])
+     #'(cond
+         [(memq test-val '(match-val ...)) . result] ...
+         [else . else-result])]
+    [(_ test-val [(match-val ...) . result] ...)
+     #'(caseq test-val
+              [(match-val ...) . result] ...
+              [else (error 'caseq "no match")])]))
 
 (module+ test
   (require rackunit)

quad/quad/render.rkt

@@ -0,0 +1,30 @@
+#lang quad/dev
+(require racket/format)
+(provide (all-defined-out))
+
+(define (debug-render qs)
+  (define line-counter #f)
+  (define (line-counter-increment!)  (set! line-counter (add1 line-counter)))
+  (define (line-counter-reset!) (set! line-counter 1))
+  (line-counter-reset!)
+  (printf "   ")
+  (for ([i (in-range 1 71)])
+       (printf (cond
+                 [(zero? (modulo i 10)) "|"]
+                 [(zero? (modulo i 5)) "'"]
+                 [else "·"])))
+  (define (print-line-counter)
+    (printf "\n~a "(~r line-counter #:min-width 2 #:pad-string " " #:base 10)))
+  (print-line-counter)
+  (for ([q (in-vector qs)])
+       (define qd (quad-dim q))
+       (cond
+         [(symbol? qd)
+          (case qd
+            [(line-break) (line-counter-increment!)]
+            [(column-break)  (line-counter-reset!) (printf "\n--col--")]
+            [(page-break) (printf "\n\n==page==\n")])
+          (print-line-counter)]
+         [(or ($black? q) ($soft? q)) (printf "~a" (quad-val q))]
+         [else (void)]))
+  (printf "\n\n"))

quad/quad/typeset.rkt

@@ -2,40 +2,59 @@
 (provide (all-defined-out))
 (require "measure.rkt")
 
-(define last-bp-k #f)
-(define line-measure 80)
-(define col-measure 150)
-(define page-measure 300)
+(define last-breakpoint-k #f)
+(define (set-breakpoint-k-here!)
+  (let/cc k (set! last-breakpoint-k k) #f))
 
-(struct tp (page col line) #:transparent)
+(define char-width 6)
+(define line-width (* 60 char-width)) ; 50 chars, each 6 pts wide
+(define line-height 12)
+(define col-height (* 6 line-height)) ; 3 rows, each 12 pts high
+(define page-width (* 3 line-width)) ; meaning, two columns
 
-(define (increment-tpos tpos page col line)
-  (tp (+ (tp-page tpos) page) (+ (tp-col tpos) col) (+ (tp-line tpos) line)))
+(struct tp (page-horiz vert horiz))
 
-(define (typeset qs)
-  (for/fold ([tpos (tp 0 0 0)])
+(define page-start-position (tp 0 0 0))
+
+(define (handle-break val [tpos #f])
+  (caseq val ; test in order of frequency
+    [(line-break) (tp (tp-page-horiz tpos) (+ (tp-vert tpos) line-height) 0)]
+    [(column-break) (tp (+ (tp-page-horiz tpos) line-width) 0 0)]
+    [(page-break) page-start-position]
+    [else tpos]))
+
+(define (typeset-fit qs)
+  (for/fold ([tpos (handle-break 'page-break)])
             ([q (in-vector qs)])
+    (unless (quad-dim q) (measure! q))
     (cond
-      [(not (quad-dim q)) ; fit pass
-       (measure! q)
-       (cond
-         [(> (tp-page tpos) page-measure) (last-bp-k 'break-page)]
-         [(> (tp-col tpos) col-measure) (last-bp-k 'break-col)]
-         [(> (tp-line tpos) line-measure) (last-bp-k 'break-line)]
-         [(and ($white? q) (let/cc bp-k (set! last-bp-k bp-k) #f))
-          =>
-          (λ(k-result)
-            (quad-dim-set! q k-result)
-            (case k-result
-              [(break-line) (tp (tp-page tpos) (tp-col tpos) 0)]
-              [(break-col)  (tp (tp-page tpos) 0 0)]
-              [(break-page) (tp 0 0 0)]))]
-         [else (define qpos (quad-dim q))
-               (increment-tpos tpos qpos qpos qpos)])]
-      [else ; fill pass
-       tpos]))
+      ;; hard may contain an imperative break. Test for this first because it makes the rest irrelevant.
+      ;; todo: how to suppress spaces adjacent to imperative breaks?
+      [($hard? q) (handle-break (quad-dim q) tpos)]
+      
+      ;; test for overset (before a new bp-k gets set).
+      ;; order is precedence: test bigger breaks first
+      ;; test page-horiz with >= because one column impliedly exists at the start
+      ;; (we could also make this explicit with page-start-position but it seems clearer to use zeroes there)
+      [(>= (tp-page-horiz tpos) page-width) (last-breakpoint-k 'page-break)]
+      
+      ;; test tp-vert with >= because one column impliedly exists at the start
+      [(>= (tp-vert tpos) col-height) (last-breakpoint-k 'column-break)]
+      
+      ;; but test tp-horiz with > because no characters exist in the line at the start
+      [(> (tp-horiz tpos) line-width) (last-breakpoint-k 'line-break)]
+      
+      ;; set a new bp-k, or resume after invoking a bp-k
+      [(and ($soft? q) (set-breakpoint-k-here!))
+       => ; grabs the end value of the conditional, which is the arg passed when breakpoint-k was invoked
+       (λ (breakpoint-k-result)
+         ;; convert the white, thereby consuming it. todo: don't consume hyphens
+         (quad-dim-set! q breakpoint-k-result) 
+         (handle-break breakpoint-k-result tpos))]
+      [else (tp (tp-page-horiz tpos) (tp-vert tpos) (+ (tp-horiz tpos) (quad-dim q)))]))
   qs)
 
 (module+ test
-  (require "atomize.rkt")
-  (time (typeset (atomize (quad #f "Meg is an ally. Meg is an ally. Meg is an ally. Meg is an ally. Meg is an ally. Meg is an ally.")))))
+  (require "atomize.rkt" "render.rkt")
+  (define q (quad #f "One morning, when Gregor" (line-break) " and his old hizn himself"))
+  (time (debug-render (typeset-fit (atomize q)))))