From 7a84b4224192c66ec5e02a325ff71e9316013f78 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Wed, 23 Feb 2022 16:30:43 -0800
Subject: [PATCH] multi rendering experiment

---
 quad/quad2/compile.rkt | 87 ++++++++++++++++++++++++++++++++++++++
 quad/quad2/drawing.rkt |  8 ++++
 quad/quad2/main.rkt    | 95 ++++--------------------------------------
 quad/quad2/pass.rkt    | 18 ++++++++
 quad/quad2/quad.rkt    | 10 +++++
 quad/quad2/render.rkt  | 64 ++++++++++++++++++++++++++++
 6 files changed, 194 insertions(+), 88 deletions(-)
 create mode 100644 quad/quad2/compile.rkt
 create mode 100644 quad/quad2/drawing.rkt
 create mode 100644 quad/quad2/pass.rkt
 create mode 100644 quad/quad2/quad.rkt
 create mode 100644 quad/quad2/render.rkt

diff --git a/quad/quad2/compile.rkt b/quad/quad2/compile.rkt
new file mode 100644
index 00000000..098baa52
--- /dev/null
+++ b/quad/quad2/compile.rkt
@@ -0,0 +1,87 @@
+#lang debug racket/base
+(require racket/contract racket/function rackunit racket/list "pass.rkt" "drawing.rkt" "quad.rkt")
+(provide quad-compile)
+
+(define/contract (posn-add p0 p1)
+  ($point? $size? . -> . $point?)
+  ($point (+ ($point-x p0) ($size-width p1)) (+ ($point-y p0) ($size-height p1))))
+
+(define/contract (size char)
+  ($quad? . -> . $size?)
+  ($size 1 1))
+
+(define/contract (advance char)
+  ($quad? . -> . $size?)
+  ($size 1 0))
+
+(define/contract (quadify str)
+  (string? . -> . (listof $quad?))
+  (for/list ([c (in-string str)])
+            ($quad #f c)))
+
+(define/contract (make-compiler . passes)
+  (() #:rest (listof pass/c)
+      . ->* . (any/c . -> . (listof any/c)))
+  (apply compose1 (reverse (cons quadify passes))))
+
+(define (min-x rect) ($point-x ($rect-origin rect)))
+(define (width rect) ($size-width ($rect-size rect)))
+(define (max-x rect) (+ (min-x rect) (width rect)))
+(define (min-y rect) ($point-y ($rect-origin rect)))
+(define (height rect) ($size-height ($rect-size rect)))
+(define (max-y rect) (+ (min-y rect) (height rect)))
+
+(define/contract (rect-contains-point? rect pt)
+  ($rect? $point? . -> . boolean?)
+  (and (<= (min-x rect) ($point-x pt) (max-x rect))
+       (<= (min-y rect) ($point-y pt) (max-y rect))))
+
+(define/contract (rect-contains-rect? outer inner)
+  ($rect? $rect? . -> . boolean?)
+  (and (rect-contains-point? outer ($rect-origin inner))
+       (rect-contains-point? outer ($point (max-x inner) (max-y inner)))))
+  
+(define (has-position? q) (not (eq? ($quad-posn q) #false)))
+(define-pass (layout qs)
+  #:precondition (λ (qs) (and (list? qs) (andmap (λ (q) (not (has-position? q))) qs)))
+  #:postcondition (λ (qs) (and (list? qs) (andmap has-position? qs)))
+  (define frame ($rect ($point 0 0) ($size (current-wrap-width) 30)))
+  (define (quad-fits? q posn)
+    (define q-size (size q))
+    (define quad-rect ($rect posn q-size))
+    (and (rect-contains-rect? frame quad-rect) posn))
+  (for/fold ([posn ($point 0 0)]
+             #:result qs)
+            ([q (in-list qs)])
+    (define first-posn-on-next-line ($point 0 (add1 ($point-y posn))))
+    (define winning-posn (or (ormap (λ (posn) (quad-fits? q posn)) (list posn first-posn-on-next-line)) (error 'no-posn-that-fits)))
+    (set-$quad-posn! q winning-posn)
+    (posn-add winning-posn (advance q))))
+
+(define-pass (make-drawing-insts qs)
+  #:precondition (λ (qs) (andmap has-position? qs))
+  #:postcondition (λ (qs) (andmap $drawing-inst? qs))
+  (flatten
+   (list ($doc 'start) ($page 'start)
+         (for/list ([q (in-list qs)])
+                   (cond
+                     [($quad? q)
+                      (list ($move ($quad-posn q)) ($text ($quad-char q)))]
+                     [else (error 'render-unknown-thing)]))
+         ($page 'end) ($doc 'end))))
+  
+(define quad-compile (make-compiler layout make-drawing-insts))
+#;(check-equal? 
+   (list
+    ($quad ($point 0 0) #\H)
+    ($quad ($point 1 0) #\e)
+    ($quad ($point 2 0) #\l)
+    ($quad ($point 3 0) #\l)
+    ($quad ($point 4 0) #\o)
+    ($quad ($point 0 1) #\space)
+    ($quad ($point 1 1) #\w)
+    ($quad ($point 2 1) #\o)
+    ($quad ($point 3 1) #\r)
+    ($quad ($point 4 1) #\l)
+    ($quad ($point 0 2) #\d)))
+
diff --git a/quad/quad2/drawing.rkt b/quad/quad2/drawing.rkt
new file mode 100644
index 00000000..272f9a10
--- /dev/null
+++ b/quad/quad2/drawing.rkt
@@ -0,0 +1,8 @@
+#lang racket/base
+(provide (all-defined-out))
+
+(struct $drawing-inst () #:transparent)
+(struct $move $drawing-inst (posn) #:transparent) ; an absolute location in coordinate system (not relative to last loc)
+(struct $text $drawing-inst (char) #:transparent)
+(struct $doc $drawing-inst (inst) #:transparent)
+(struct $page $drawing-inst (inst) #:transparent)
\ No newline at end of file
diff --git a/quad/quad2/main.rkt b/quad/quad2/main.rkt
index 9f051ff6..1c506ded 100644
--- a/quad/quad2/main.rkt
+++ b/quad/quad2/main.rkt
@@ -1,94 +1,13 @@
 #lang debug racket/base
-(require racket/contract racket/function rackunit)
+(require "compile.rkt" "render.rkt" "quad.rkt")
 
-(struct $point (x y) #:transparent #:mutable)
-(struct $size (width height) #:transparent #:mutable)
-(struct $rect (origin size) #:transparent #:mutable)
+(define drawing-insts (parameterize ([current-wrap-width 6])
+                       #R (quad-compile "Hello this is the radio")))
 
-(struct $quad (posn char) #:transparent #:mutable)
+(render-to-text drawing-insts)
 
-(define/contract (posn-add p0 p1)
-  ($point? $size? . -> . $point?)
-  ($point (+ ($point-x p0) ($size-width p1)) (+ ($point-y p0) ($size-height p1))))
+(render-to-bitmap drawing-insts)
 
-(define/contract (size char)
-  ($quad? . -> . $size?)
-  ($size 1 1))
+#;(render-to-html drawing-insts)
 
-(define/contract (advance char)
-  ($quad? . -> . $size?)
-  ($size 1 0))
-
-(define pass/c ((listof $quad?) . -> . (listof $quad?)))
-
-(define/contract (quadify str)
-  (string? . -> . (listof $quad?))
-  (for/list ([c (in-string str)])
-            ($quad #f c)))
-
-(define/contract (make-compiler . passes)
-  (() #:rest (listof pass/c)
-      . ->* . (string? . -> . (listof $quad?)))
-  (apply compose1 (reverse (cons quadify passes))))
-
-(define-syntax-rule (define-pass (PASS-NAME ARG)
-                      #:precondition PRECOND-PROC
-                      #:postcondition POSTCOND-PROC
-                      EXPRS ...)
-  (define/contract (PASS-NAME ARG)
-    pass/c
-    (unless (PRECOND-PROC ARG)
-      (error 'precondition-failed))
-    (define res (let () EXPRS ...))
-    (unless (POSTCOND-PROC res)
-      (error 'postcondition-failed))
-    res))
-
-(define (min-x rect) ($point-x ($rect-origin rect)))
-(define (width rect) ($size-width ($rect-size rect)))
-(define (max-x rect) (+ (min-x rect) (width rect)))
-(define (min-y rect) ($point-y ($rect-origin rect)))
-(define (height rect) ($size-height ($rect-size rect)))
-(define (max-y rect) (+ (min-y rect) (height rect)))
-
-(define/contract (rect-contains-point? rect pt)
-  ($rect? $point? . -> . boolean?)
-  (and (<= (min-x rect) ($point-x pt) (max-x rect))
-       (<= (min-y rect) ($point-y pt) (max-y rect))))
-
-(define/contract (rect-contains-rect? outer inner)
-  ($rect? $rect? . -> . boolean?)
-  (and (rect-contains-point? outer ($rect-origin inner))
-       (rect-contains-point? outer ($point (max-x inner) (max-y inner)))))
-  
-(define (has-position? q) (not (eq? ($quad-posn q) #false)))
-(define-pass (layout qs)
-  #:precondition (λ (qs) (andmap (λ (q) (not (has-position? q))) qs))
-  #:postcondition (λ (qs) (andmap has-position? qs))
-  (define frame ($rect ($point 0 0) ($size 5 30)))
-  (define (quad-fits? q posn)
-    (define q-size (size q))
-    (define quad-rect ($rect posn q-size))
-    (and (rect-contains-rect? frame quad-rect) posn))
-  (for/fold ([posn ($point 0 0)]
-             #:result qs)
-            ([q (in-list qs)])
-    (define first-posn-on-next-line ($point 0 (add1 ($point-y posn))))
-    (define winning-posn (or (ormap (λ (posn) (quad-fits? q posn)) (list posn first-posn-on-next-line)) (error 'no-posn-that-fits)))
-    (set-$quad-posn! q winning-posn)
-    (posn-add winning-posn (advance q))))
-
-(define compile (make-compiler layout))
-(check-equal? (compile "Hello world")
-              (list
-               ($quad ($point 0 0) #\H)
-               ($quad ($point 1 0) #\e)
-               ($quad ($point 2 0) #\l)
-               ($quad ($point 3 0) #\l)
-               ($quad ($point 4 0) #\o)
-               ($quad ($point 0 1) #\space)
-               ($quad ($point 1 1) #\w)
-               ($quad ($point 2 1) #\o)
-               ($quad ($point 3 1) #\r)
-               ($quad ($point 4 1) #\l)
-               ($quad ($point 0 2) #\d)))
\ No newline at end of file
+#;(render-to-pdf drawing-insts)
\ No newline at end of file
diff --git a/quad/quad2/pass.rkt b/quad/quad2/pass.rkt
new file mode 100644
index 00000000..31b5ab49
--- /dev/null
+++ b/quad/quad2/pass.rkt
@@ -0,0 +1,18 @@
+#lang racket/base
+(require racket/contract)
+(provide (all-defined-out))
+
+(define pass/c (any/c . -> . any/c))
+
+(define-syntax-rule (define-pass (PASS-NAME ARG)
+                      #:precondition PRECOND-PROC
+                      #:postcondition POSTCOND-PROC
+                      EXPRS ...)
+  (define/contract (PASS-NAME ARG)
+    pass/c
+    (unless (PRECOND-PROC ARG)
+      (error 'PASS-NAME (format "precondition failed: ~a" 'PRECOND-PROC)))
+    (define res (let () EXPRS ...))
+    (unless (POSTCOND-PROC res)
+      (error 'PASS-NAME (format "postcondition failed: ~a" 'POSTCOND-PROC)))
+    res))
\ No newline at end of file
diff --git a/quad/quad2/quad.rkt b/quad/quad2/quad.rkt
new file mode 100644
index 00000000..52972585
--- /dev/null
+++ b/quad/quad2/quad.rkt
@@ -0,0 +1,10 @@
+#lang racket/base
+(provide (all-defined-out))
+
+(struct $point (x y) #:transparent #:mutable)
+(struct $size (width height) #:transparent #:mutable)
+(struct $rect (origin size) #:transparent #:mutable)
+
+(struct $quad (posn char) #:transparent #:mutable)
+
+(define current-wrap-width (make-parameter 5))
\ No newline at end of file
diff --git a/quad/quad2/render.rkt b/quad/quad2/render.rkt
new file mode 100644
index 00000000..6f0db6d4
--- /dev/null
+++ b/quad/quad2/render.rkt
@@ -0,0 +1,64 @@
+#lang debug racket/base
+(require "pass.rkt" "drawing.rkt" "quad.rkt" racket/match racket/string)
+(provide (all-defined-out))
+
+(define-syntax-rule (define-render-pass (PASS-NAME ARG)
+                      EXPRS ...)
+  (define-pass (PASS-NAME ARG)
+    #:precondition (λ (xs) (and (list? xs) (andmap $drawing-inst? xs)))
+    #:postcondition values
+    EXPRS ...))
+
+(define-render-pass (render-to-text xs)
+  (define move-posns (map $move-posn (filter $move? xs)))
+  (define xmax (add1 (apply max (map $point-x move-posns))))
+  (define ymax (add1 (apply max (map $point-y move-posns))))
+  (define char-pos-table (make-hasheqv))
+  ;; scan over the instructions and record where the chars want to go
+  (let loop ([current-loc 0+0i][xs xs])
+    (unless (null? xs)
+      (match xs
+        [(cons ($move ($point x y)) rest)
+         (loop (make-rectangular x y) rest)]
+        [(cons ($text c) rest)
+         (hash-set! char-pos-table current-loc c)
+         (loop current-loc rest)]
+        [(cons _ rest) (loop current-loc rest)])))
+  ;; fill in a character grid
+  (displayln
+   (string-join
+    (for/list ([y (in-range ymax)])
+              (list->string
+               (for/list ([x (in-range xmax)])
+                         (hash-ref char-pos-table (make-rectangular x y) #\space)))) "\n")))
+
+(require racket/gui)
+(define-render-pass (render-to-bitmap xs)
+  (define move-posns (map $move-posn (filter $move? xs)))
+  (define xmax (add1 (apply max (map $point-x move-posns))))
+  (define ymax (add1 (apply max (map $point-y move-posns))))
+  
+  (define em-scale 30)
+  (define target (make-bitmap (* em-scale xmax) (* em-scale ymax)))
+  (define dc (new bitmap-dc% [bitmap target]))
+  (send dc scale em-scale em-scale) 
+
+  (define face-list (get-face-list 'mono))
+  (when (null? face-list)
+    (error 'no-mono-font-available))
+  (define my-face (car face-list))
+  (send dc set-font (make-font #:size 1 #:face my-face))
+  (send dc set-text-foreground "black")
+
+  (let loop ([current-loc 0+0i][xs xs])
+    (unless (null? xs)
+      (match xs
+        [(cons ($move ($point x y)) rest)
+         (loop (make-rectangular x y) rest)]
+        [(cons ($text c) rest)
+           (send dc draw-text (string c) (real-part current-loc) (imag-part current-loc))
+         (loop current-loc rest)]
+        [(cons _ rest) (loop current-loc rest)])))
+  
+  (make-object image-snip% target))
+