From 7e75bfd63ef6f35def1e1e60c6736bde54c8084f Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Wed, 23 Feb 2022 17:29:28 -0800 Subject: [PATCH] stackerization --- quad/quad2/compile.rkt | 37 ++++++++++++++++++++++++++++++------- quad/quad2/drawing.rkt | 2 +- quad/quad2/main.rkt | 6 ++++-- quad/quad2/render.rkt | 27 +++++++++++++++++++++------ 4 files changed, 56 insertions(+), 16 deletions(-) diff --git a/quad/quad2/compile.rkt b/quad/quad2/compile.rkt index 098baa52..17c66581 100644 --- a/quad/quad2/compile.rkt +++ b/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 diff --git a/quad/quad2/drawing.rkt b/quad/quad2/drawing.rkt index 272f9a10..dca95efa 100644 --- a/quad/quad2/drawing.rkt +++ b/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) \ No newline at end of file diff --git a/quad/quad2/main.rkt b/quad/quad2/main.rkt index 1c506ded..cd4f61b5 100644 --- a/quad/quad2/main.rkt +++ b/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) diff --git a/quad/quad2/render.rkt b/quad/quad2/render.rkt index 6f0db6d4..edf84599 100644 --- a/quad/quad2/render.rkt +++ b/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)])))