From f60e46f39f86897abc696ab762681f79e56df66b Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Thu, 24 Feb 2022 10:58:18 -0800 Subject: [PATCH] callback-driven renderer --- quad/quad2/compile.rkt | 16 +++-- quad/quad2/main.rkt | 10 ++- quad/quad2/pass.rkt | 7 +- quad/quad2/quad.rkt | 3 +- quad/quad2/render.rkt | 148 ++++++++++++++++++++++------------------- 5 files changed, 98 insertions(+), 86 deletions(-) diff --git a/quad/quad2/compile.rkt b/quad/quad2/compile.rkt index 17c66581..5063b284 100644 --- a/quad/quad2/compile.rkt +++ b/quad/quad2/compile.rkt @@ -9,7 +9,7 @@ "pass.rkt" "drawing.rkt" "quad.rkt") -(provide quad-compile quad-compile-to-stack stackify) +(provide quad-compile quad-compile-to-stack stackify valid-tokens) (define/contract (posn-add p0 p1) ($point? $size? . -> . $point?) @@ -28,9 +28,7 @@ (for/list ([c (in-string str)]) ($quad #f c))) -(define/contract (make-compiler . passes) - (() #:rest (listof pass/c) - . ->* . (any/c . -> . any/c)) +(define (make-compiler . passes) (apply compose1 (reverse (cons quadify passes)))) (define (min-x rect) ($point-x ($rect-origin rect))) @@ -79,17 +77,23 @@ [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 sym) (list sym 'doc)] - [($page sym) (list sym 'page)] + [($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)) diff --git a/quad/quad2/main.rkt b/quad/quad2/main.rkt index cd4f61b5..386b4846 100644 --- a/quad/quad2/main.rkt +++ b/quad/quad2/main.rkt @@ -1,15 +1,13 @@ #lang debug racket/base (require "compile.rkt" "render.rkt" "quad.rkt" racket/string) -(define drawing-insts (parameterize ([current-wrap-width 6]) +(define drawing-insts (parameterize ([current-wrap-width 13]) (quad-compile-to-stack "Hello this is the earth"))) -(displayln (string-replace drawing-insts "\n" " ")) +(displayln drawing-insts) -(render-to-text drawing-insts) - -(render-to-bitmap drawing-insts) +(render drawing-insts #:using text-renderer) +(render drawing-insts #:using drr-renderer) #;(render-to-html drawing-insts) - #;(render-to-pdf drawing-insts) \ No newline at end of file diff --git a/quad/quad2/pass.rkt b/quad/quad2/pass.rkt index 31b5ab49..b25f4eaf 100644 --- a/quad/quad2/pass.rkt +++ b/quad/quad2/pass.rkt @@ -2,14 +2,11 @@ (require racket/contract) (provide (all-defined-out)) -(define pass/c (any/c . -> . any/c)) - -(define-syntax-rule (define-pass (PASS-NAME ARG) +(define-syntax-rule (define-pass (PASS-NAME ARG OTHER-ARG ...) #:precondition PRECOND-PROC #:postcondition POSTCOND-PROC EXPRS ...) - (define/contract (PASS-NAME ARG) - pass/c + (define (PASS-NAME ARG OTHER-ARG ...) (unless (PRECOND-PROC ARG) (error 'PASS-NAME (format "precondition failed: ~a" 'PRECOND-PROC))) (define res (let () EXPRS ...)) diff --git a/quad/quad2/quad.rkt b/quad/quad2/quad.rkt index 52972585..ed0cc8cb 100644 --- a/quad/quad2/quad.rkt +++ b/quad/quad2/quad.rkt @@ -7,4 +7,5 @@ (struct $quad (posn char) #:transparent #:mutable) -(define current-wrap-width (make-parameter 5)) \ No newline at end of file +(define current-wrap-width (make-parameter 5)) +(define current-page-size (make-parameter ($size 10 10))) \ No newline at end of file diff --git a/quad/quad2/render.rkt b/quad/quad2/render.rkt index aaddb4fd..41de9582 100644 --- a/quad/quad2/render.rkt +++ b/quad/quad2/render.rkt @@ -1,79 +1,91 @@ #lang debug racket/base -(require "pass.rkt" "drawing.rkt" "quad.rkt" racket/match racket/string) +(require "pass.rkt" "quad.rkt" "compile.rkt") (provide (all-defined-out)) -(define (unstackify inst-str) - (for/fold ([acc null] - [stack null] - #:result (reverse acc)) - ([tok (in-port read (open-input-string inst-str))]) - (match (cons tok stack) - [(list* 'doc sym rest) (values (cons ($doc sym) acc) rest)] - [(list* 'page sym rest) (values (cons ($page sym) acc) rest)] - [(list* 'text charint rest) (values (cons ($text charint) acc) rest)] - [(list* 'move x y rest) (values (cons ($move ($point x y)) acc) rest)] - [new-stack (values acc new-stack)]))) +(struct $renderer (doc-start-func + doc-end-func + page-start-func + page-end-func + text-func + move-func + return-func) #:transparent) -(define-syntax-rule (define-render-pass (PASS-NAME ARG) - EXPRS ...) - (define-pass (PASS-NAME ARG) - #:precondition string? - #:postcondition values - (let ([ARG (unstackify ARG)]) - EXPRS ...))) +(define current-renderer (make-parameter ($renderer void void void void void void void))) -(define-render-pass (render-to-text xs) - (define move-posns (map $move-posn (filter $move? xs))) - (define (max-of field) (apply max (map field move-posns))) - (define xmax (add1 (max-of $point-x))) - (define ymax (add1 (max-of $point-y))) - (define char-pos-table (make-hasheqv)) +(define text-renderer ;; 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 - (map integer->char - (for/list ([x (in-range xmax)]) - (hash-ref char-pos-table (make-rectangular x y) (char->integer #\space)))))) "\n"))) + (let ([char-pos-table (make-hasheqv)] + [current-loc 0+0i] + [xmax 0] + [ymax 0] + [results null]) + ($renderer + void + void + (λ (width height) + (set! xmax width) + (set! ymax height)) + (λ () + ;; fill in a character grid + (define str (string-join + (for/list ([y (in-range ymax)]) + (list->string + (map integer->char + (for/list ([x (in-range xmax)]) + (hash-ref char-pos-table (make-rectangular x y) (char->integer #\space)))))) "\n")) + (set! results (cons str results))) + (λ (charint) (hash-set! char-pos-table current-loc charint)) + (λ (x y) (set! current-loc (make-rectangular x y))) + (λ () + (unless (pair? results) + (error 'text-renderer-failed)) + (for-each displayln results))))) (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") +(define drr-renderer + ;; scan over the instructions and record where the chars want to go + (let ([targets null] + [dc #f] + [current-loc 0+0i]) + ($renderer + void + void + (let ([em-scale 30] + [my-face (match (get-face-list 'mono) + [(? null?) (error 'no-mono-font-available)] + [(cons face _) face])]) + (λ (width height) + (define target (make-bitmap (* em-scale width) (* em-scale height))) + (set! targets (cons target targets)) + (set! dc (new bitmap-dc% [bitmap target])) + (send dc scale em-scale em-scale) + (send dc set-font (make-font #:size 1 #:face my-face)) + (send dc set-text-foreground "black"))) + void + (λ (charint) + (send dc draw-text (string (integer->char charint)) (real-part current-loc) (imag-part current-loc))) + (λ (x y) (set! current-loc (make-rectangular x y))) + (λ () (for-each displayln (map (λ (target) (make-object image-snip% target)) targets)))))) - (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 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)]))) - - (make-object image-snip% target)) +(define-pass (render inst-str #:using [renderer (current-renderer)]) + #:precondition string? + #:postcondition any/c + (let/ec exit + (for/fold ([stack null] + #:result (void)) + ([tok (in-port read (open-input-string inst-str))]) + (define next-stack (cons tok stack)) + (cond + [(memq tok valid-tokens) + (match next-stack + [(list* 'doc-start rest) (($renderer-doc-start-func renderer)) rest] + [(list* 'doc-end _) (exit (($renderer-doc-end-func renderer)))] + [(list* 'page-start x y rest) (($renderer-page-start-func renderer) x y) rest] + [(list* 'page-end rest) (($renderer-page-end-func renderer)) rest] + [(list* 'text charint rest) (($renderer-text-func renderer) charint) rest] + [(list* 'move x y rest) (($renderer-move-func renderer) x y) rest] + [_ next-stack])] + [else next-stack]))) + (($renderer-return-func renderer)))