make way for atomize

quad/quad2/atomize.rkt

@@ -1,4 +1,8 @@
 #lang debug racket/base
+(require racket/match
+         "compile.rkt"
+         "quad.rkt")
+(provide atomize)
 
 #|
 
@@ -11,3 +15,11 @@ For instance, the top-level attrs represent a list object
 that will eventually be the tail of the attrs in every atomized quad.
 |#
 
+(define-pass (atomize q)
+  #:precondition quad?
+  #:postcondition (list-of quad?)
+  (match (quad-elems q)
+    [(cons str _)
+     (for/list ([c (in-string str)])
+               (make-quad #:attrs (make-quad-attrs (list (cons 'char c)))))]
+    [_ (error 'atomize-branch-unimplemented)]))

quad/quad2/compile.rkt

@@ -1,114 +1,29 @@
 #lang debug racket/base
-(require racket/contract
-         racket/function
-         rackunit
-         racket/list
-         racket/match
-         racket/string
-         racket/format
-         "pass.rkt"
-         "drawing.rkt"
+(require racket/match
          "quad.rkt")
-(provide quad-compile quad-compile-to-stack stackify valid-tokens)
-
-(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)])
-            (make-quad #f (make-quad-attrs (list (cons 'char c))))))
-
-(define (make-compiler . passes)
-  (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) (and (list? qs) (andmap has-position? qs)))
-  #:postcondition (λ (qs) (and (list? 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 (char->integer (quad-char q))))]
-                     [else (error 'render-unknown-thing)]))
-         ($page 'end) ($doc 'end))))
-
-(define valid-tokens '(doc-start doc-end page-start page-end text move))
-
-(define-pass (stackify xs)
-  #:precondition (λ (xs) (and (list? xs) (andmap $drawing-inst? xs)))
-  #:postcondition string?
-  (define move-points (map $move-posn (filter $move? xs)))
-  (define xmax (add1 (apply max (map $point-x move-points))))
-  (define ymax (add1 (apply max (map $point-y move-points))))
-  (string-join
-   (for/list ([x (in-list xs)])
-             (string-join (map ~a (match x
-                                    [($move ($point x y)) (list y x 'move)]
-                                    [($text charint) (list charint 'text)]
-                                    [($doc 'start) '(doc-start)]
-                                    [($doc 'end) '(doc-end)]
-                                    [($page 'start) (list ymax xmax 'page-start)]
-                                    [($page 'end) '(page-end)]
-                                    [_ (error 'unknown-drawing-inst)])) " ")) "\n"))
-
-(define quad-compile-to-stack (make-compiler layout make-drawing-insts stackify))
-(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)))
-
+(provide (all-defined-out))
+
+(struct compiler (passes)
+  #:constructor-name make-compiler
+  #:guard (λ (procs name)
+            (unless ((list-of procedure?) procs)
+              (raise-argument-error 'bad-input-to-compiler-constructor "list of procedures" procs))
+            procs)
+  #:property prop:procedure
+  (λ (self input) ((apply compose1 (reverse (compiler-passes self))) input)))
+
+(define (compiler-append c passes)
+  (make-compiler (append (compiler-passes c) passes)))
+
+(define-syntax-rule (define-pass (PASS-NAME ARG OTHER-ARG ...)
+                      #:precondition PRECOND-PROC
+                      #:postcondition POSTCOND-PROC
+                      EXPRS ...)
+  (define PASS-NAME
+    (make-compiler (list (λ (ARG OTHER-ARG ...)
+                           (unless (PRECOND-PROC ARG)
+                             (error 'PASS-NAME (format "precondition failed: ~a for value ~v" 'PRECOND-PROC ARG)))
+                           (define res (let () EXPRS ...))
+                           (unless (POSTCOND-PROC res)
+                             (error 'PASS-NAME (format "postcondition failed: ~a for value ~v" 'POSTCOND-PROC res)))
+                           res)))))

quad/quad2/draw.rkt

@@ -0,0 +1,41 @@
+#lang debug racket/base
+(require racket/list
+         racket/string
+         racket/format
+         racket/match
+         "quad.rkt"
+         "compile.rkt"
+         "struct.rkt"
+         "layout.rkt")
+(provide (all-defined-out))
+
+(define-pass (make-drawing-insts qs)
+  #:precondition (list-of has-position?)
+  #:postcondition (list-of $drawing-inst?)
+  (flatten
+   (list ($doc 'start) ($page 'start)
+         (for/list ([q (in-list qs)])
+                   (cond
+                     [(quad? q)
+                      (list ($move (quad-posn q)) ($text (char->integer (quad-char q))))]
+                     [else (error 'render-unknown-thing)]))
+         ($page 'end) ($doc 'end))))
+
+(define valid-tokens '(doc-start doc-end page-start page-end text move))
+
+(define-pass (stackify xs)
+  #:precondition (λ (xs) (and (list? xs) (andmap $drawing-inst? xs)))
+  #:postcondition string?
+  (define move-points (map $move-posn (filter $move? xs)))
+  (define xmax (add1 (apply max (map $point-x move-points))))
+  (define ymax (add1 (apply max (map $point-y move-points))))
+  (string-join
+   (for/list ([x (in-list xs)])
+             (string-join (map ~a (match x
+                                    [($move ($point x y)) (list y x 'move)]
+                                    [($text charint) (list charint 'text)]
+                                    [($doc 'start) '(doc-start)]
+                                    [($doc 'end) '(doc-end)]
+                                    [($page 'start) (list ymax xmax 'page-start)]
+                                    [($page 'end) '(page-end)]
+                                    [_ (error 'unknown-drawing-inst)])) " ")) "\n"))

quad/quad2/layout.rkt

@@ -0,0 +1,52 @@
+#lang debug racket/base
+(require racket/contract
+         "compile.rkt"
+         "quad.rkt")
+(provide layout)
+
+(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 (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-pass (layout qs)
+  #:precondition (list-of has-no-position?)
+  #:postcondition (list-of has-position?)
+  (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))))

quad/quad2/main.rkt

@@ -1,5 +1,31 @@
 #lang debug racket/base
-(require "compile.rkt" "render.rkt" "quad.rkt" racket/string)
+(require "layout.rkt"
+         "render.rkt"
+         "quad.rkt"
+         "compile.rkt"
+         "atomize.rkt"
+         "layout.rkt"
+         "draw.rkt"
+         racket/string
+         racket/match)
+
+(define-pass (bootstrap x)
+  #:precondition values
+  #:postcondition quad?
+  (match x
+    [(? quad?) x]
+    [(list (? quad?) ...) (make-quad #:elems (list x))]
+    [_ (make-quad #:elems (list x))]))
+
+
+(define quad-compile (make-compiler (list
+                                     bootstrap
+                                     atomize
+                                     layout
+                                     make-drawing-insts)))
+
+(define quad-compile-to-stack (compiler-append quad-compile
+                                               (list stackify)))
 
 (define drawing-insts (parameterize ([current-wrap-width 13])
                         (quad-compile-to-stack "Hello this is the earth")))

quad/quad2/pass.rkt

@@ -1,15 +0,0 @@
-#lang racket/base
-(require racket/contract)
-(provide (all-defined-out))
-
-(define-syntax-rule (define-pass (PASS-NAME ARG OTHER-ARG ...)
-                      #:precondition PRECOND-PROC
-                      #:postcondition POSTCOND-PROC
-                      EXPRS ...)
-  (define (PASS-NAME ARG OTHER-ARG ...)
-    (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))

quad/quad2/quad.rkt

@@ -9,31 +9,31 @@
 (define current-wrap-width (make-parameter 5))
 (define current-page-size (make-parameter ($size 10 10)))
 
-(define (quad? x)
-  (match x
-    [($quad (? quad-tag?)
-            (? quad-attrs?)
-            (? quad-elems?)) #true]
-    [_ #false]))
-
-(struct $quad (tag attrs elems) #:transparent #:mutable)
-
-(define quad-tag $quad-tag)
+(define (list-of proc) (λ (x) (and (list? x) (andmap proc x))))
+
+(struct quad (tag attrs elems) #:transparent #:mutable
+  #:constructor-name quad-constructor
+  #:guard (λ (tag attrs elems name)
+            (unless (match (list tag attrs elems)
+                      [(list (? quad-tag?)
+                             (? quad-attrs?)
+                             (? quad-elems?)) #true]
+                      [_ #false])
+              (error 'no-dice))
+            (values tag attrs elems)))
+             
 (define (quad-tag? x) (match x
                         [(or (? symbol?) #false) #true]
                         [_ #false]))
-(define set-quad-tag! set-$quad-tag!)
-(define quad-attrs $quad-attrs)
 (define (make-quad-attrs alist) (make-hasheq alist))
 (define (quad-attrs? x) (hash-eq? x))
-(define set-quad-attrs! set-$quad-attrs!)
-(define quad-elems $quad-elems)
 (define (quad-elems? x) (list? x))
-(define set-quad-elems! set-$quad-elems!)
 
-(define/contract (make-quad tag attrs . elems)
-  ((quad-tag? quad-attrs?) #:rest quad-elems? . ->* . quad?)
-  ($quad tag attrs elems))
+(define/contract (make-quad #:tag [tag #false]
+                            #:attrs [attrs (make-quad-attrs null)]
+                            #:elems [elems null])
+  (() (#:tag quad-tag? #:attrs quad-attrs? #:elems quad-elems?) . ->* . quad?)
+  (quad-constructor tag attrs elems))
 
 (define (quad-ref q key [default-val #false])
   (hash-ref (quad-attrs q) key default-val))
@@ -52,4 +52,8 @@
 (define-quad-field posn)
 (define-quad-field char)
 
-#;(define q (make-quad 'div (make-hasheq '((hello . "world"))) "fine"))
+(define (has-no-position? q) (not (has-position? q)))
+(define (has-position? q) (quad-posn q))
+
+(module+ test
+  (define q (make-quad #:tag 'div #:attrs (make-hasheq '((hello . "world"))) #:elems (list "fine"))))

quad/quad2/render.rkt

@@ -1,5 +1,5 @@
 #lang debug racket/base
-(require "pass.rkt" "quad.rkt" "compile.rkt")
+(require "compile.rkt" "draw.rkt" "layout.rkt")
 (provide (all-defined-out))
 
 (struct $renderer (doc-start-func
@@ -68,9 +68,7 @@
      (λ (x y) (set! current-loc (make-rectangular x y)))
      (λ () (for-each displayln (map (λ (target) (make-object image-snip% target)) targets))))))
 
-(define-pass (render inst-str #:using [renderer (current-renderer)])
-  #:precondition string?
-  #:postcondition any/c
+(define (render inst-str #:using [renderer (current-renderer)])
   (let/ec exit
     (for/fold ([stack null]
                #:result (void))