stackerization

quad/quad2/compile.rkt

@@ -1,6 +1,15 @@
 #lang debug racket/base
-(require racket/contract racket/function rackunit racket/list "pass.rkt" "drawing.rkt" "quad.rkt")
-(provide quad-compile)
+(require racket/contract
+         racket/function
+         rackunit
+         racket/list
+         racket/match
+         racket/string
+         racket/format
+         "pass.rkt"
+         "drawing.rkt"
+         "quad.rkt")
+(provide quad-compile quad-compile-to-stack stackify)
 
 (define/contract (posn-add p0 p1)
   ($point? $size? . -> . $point?)
@@ -21,7 +30,7 @@
 
 (define/contract (make-compiler . passes)
   (() #:rest (listof pass/c)
-      . ->* . (any/c . -> . (listof any/c)))
+      . ->* . (any/c . -> . any/c))
   (apply compose1 (reverse (cons quadify passes))))
 
 (define (min-x rect) ($point-x ($rect-origin rect)))
@@ -59,17 +68,31 @@
     (posn-add winning-posn (advance q))))
 
 (define-pass (make-drawing-insts qs)
-  #:precondition (λ (qs) (andmap has-position? qs))
-  #:postcondition (λ (qs) (andmap $drawing-inst? 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 ($quad-char q)))]
+                      (list ($move ($quad-posn q)) ($text (char->integer ($quad-char q))))]
                      [else (error 'render-unknown-thing)]))
          ($page 'end) ($doc 'end))))
-  
+
+
+(define-pass (stackify xs)
+  #:precondition (λ (xs) (and (list? xs) (andmap $drawing-inst? xs)))
+  #:postcondition string?
+  (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 sym) (list sym 'doc)]
+                                    [($page sym) (list sym 'page)]
+                                    [_ (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/quad2/drawing.rkt

@@ -3,6 +3,6 @@
 
 (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 $text $drawing-inst (charint) #:transparent)
 (struct $doc $drawing-inst (inst) #:transparent)
 (struct $page $drawing-inst (inst) #:transparent)

quad/quad2/main.rkt

@@ -1,8 +1,10 @@
 #lang debug racket/base
-(require "compile.rkt" "render.rkt" "quad.rkt")
+(require "compile.rkt" "render.rkt" "quad.rkt" racket/string)
 
 (define drawing-insts (parameterize ([current-wrap-width 6])
-                       #R (quad-compile "Hello this is the radio")))
+                        (quad-compile-to-stack "Hello this is the earth")))
+
+(displayln (string-replace drawing-insts "\n" " "))
 
 (render-to-text drawing-insts)
 

quad/quad2/render.rkt

@@ -2,12 +2,26 @@
 (require "pass.rkt" "drawing.rkt" "quad.rkt" racket/match racket/string)
 (provide (all-defined-out))
 
+(define (unstackify inst-str)
+  (define tok-port (open-input-string inst-str))
+  (let loop ([acc null][stack null])
+    (match (read tok-port)
+      [(? eof-object?) (reverse acc)]
+      [tok
+       (match (cons tok stack)
+         [(list* 'doc sym rest) (loop (cons ($doc sym) acc) rest)]
+         [(list* 'page sym rest) (loop (cons ($page sym) acc) rest)]
+         [(list* 'text charint rest) (loop (cons ($text charint) acc) rest)]
+         [(list* 'move x y rest) (loop (cons ($move ($point x y)) acc) rest)]
+         [new-stack (loop acc new-stack)])])))
+
 (define-syntax-rule (define-render-pass (PASS-NAME ARG)
                       EXPRS ...)
   (define-pass (PASS-NAME ARG)
-    #:precondition (λ (xs) (and (list? xs) (andmap $drawing-inst? xs)))
+    #:precondition string?
     #:postcondition values
-    EXPRS ...))
+    (let ([ARG (unstackify ARG)])
+      EXPRS ...)))
 
 (define-render-pass (render-to-text xs)
   (define move-posns (map $move-posn (filter $move? xs)))
@@ -29,8 +43,9 @@
    (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")))
+               (map integer->char
+                    (for/list ([x (in-range xmax)])
+                              (hash-ref char-pos-table (make-rectangular x y) (char->integer #\space)))))) "\n")))
 
 (require racket/gui)
 (define-render-pass (render-to-bitmap xs)
@@ -55,8 +70,8 @@
       (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))
+        [(cons ($text charint) rest)
+         (send dc draw-text (string (integer->char charint)) (real-part current-loc) (imag-part current-loc))
          (loop current-loc rest)]
         [(cons _ rest) (loop current-loc rest)])))