diff --git a/quad2/render.rkt b/quad2/render.rkt index ce2e2d8e..ecdbd8f3 100644 --- a/quad2/render.rkt +++ b/quad2/render.rkt @@ -5,16 +5,54 @@ txexpr) (provide (all-defined-out)) -(struct $renderer (doc-start-func - doc-end-func - page-start-func - page-end-func - text-func - set-font-func - move-func - return-func) #:transparent) +(module inner racket/base + (provide (all-defined-out)) + (struct $renderer (doc-start-func + doc-end-func + page-start-func + page-end-func + text-func + set-font-func + move-func + return-func) #:transparent) -(define current-renderer (make-parameter ($renderer void void void void void void void void))) + (define-syntax-rule (check-arity PROCNAME [PROC ARITY] ...) + (begin + (unless (or (eq? (procedure-arity PROC) ARITY) (equal? void PROC)) + (raise-argument-error PROCNAME (format "procedure of arity ~a for ~a" ARITY 'PROC) PROC)) ...)) + + (define (make-renderer + #:doc-start-func [doc-start-func void] + #:doc-end-func [doc-end-func void] + #:page-start-func [page-start-func void] + #:page-end-func [page-end-func void] + #:text-func [text-func void] + #:set-font-func [set-font-func void] + #:move-func [move-func void] + #:return-func [return-func void]) + (check-arity 'make-renderer + [doc-start-func 0] + [doc-end-func 0] + [page-start-func 2] + [page-end-func 0] + [text-func 1] + [set-font-func 1] + [move-func 2] + [return-func 0]) + ($renderer doc-start-func + doc-end-func + page-start-func + page-end-func + text-func + set-font-func + move-func + return-func))) + +(require 'inner) + +(define null-renderer (make-renderer)) + +(define current-renderer (make-parameter null-renderer)) (define text-renderer ;; scan over the instructions and record where the chars want to go @@ -23,12 +61,12 @@ [xmax 0] [ymax 0] [results null]) - ($renderer - void - void + (make-renderer + #:page-start-func (λ (width height) (set! xmax width) (set! ymax height)) + #:page-end-func (λ () ;; fill in a character grid (define str (string-join @@ -38,13 +76,12 @@ (for/list ([x (in-range xmax)]) (hash-ref char-pos-table (make-rectangular x y) (char->integer #\space)))))) "\n")) (set! results (cons str results))) - (λ (str) (hash-set! char-pos-table current-loc str)) - void - (λ (x y) (set! current-loc (make-rectangular x y))) - (λ () - #;(unless (pair? results) - (error 'text-renderer-failed)) - (for-each displayln results))))) + #:text-func (λ (str) (hash-set! char-pos-table current-loc str)) + #:move-func (λ (x y) (set! current-loc (make-rectangular x y))) + #:return-func (λ () + #;(unless (pair? results) + (error 'text-renderer-failed)) + (for-each displayln results))))) (require racket/gui) @@ -54,9 +91,8 @@ [dc #f] [current-loc 0+0i] [current-font #false]) - ($renderer - void - void + (make-renderer + #:page-start-func (let ([my-face (match (get-face-list 'mono) [(? null?) (error 'no-mono-font-available)] [(cons face _) face])]) @@ -66,10 +102,11 @@ (set! dc (new bitmap-dc% [bitmap target])) (send dc set-font (make-font #:size 1 #:face my-face)) (send dc set-text-foreground "black"))) - void + #:text-func (λ (charint) (when dc (send dc draw-text (string (integer->char charint)) (real-part current-loc) (imag-part current-loc)))) + #:set-font-func (λ (ps) ;; racket/draw can't load arbitrary user fonts from a path ;; https://github.com/racket/racket/issues/1348 @@ -78,7 +115,9 @@ ;; but it would allow slightly more accurate rendering for contexts ;; that don't support fonts by path (log-quad2-warning (format "can't load font ~a" ps))) + #:move-func (λ (x y) (set! current-loc (make-rectangular x y))) + #:return-func (λ () (for-each displayln (map (λ (target) (make-object image-snip% target)) targets)))))) (define (html-renderer html-file) @@ -89,24 +128,28 @@ [pages null] [fonts (make-hasheqv)] [current-font ""]) - ($renderer - void - void + (make-renderer + #:page-start-func (λ (width height) (set! page-quads null) (set! xmax width) (set! ymax height)) + #:page-end-func (λ () (set! pages (cons `(div ((class "page") (style ,(format "position: relative;width:~apx;height:~apx;border:1px solid black;background:white" xmax ymax))) ,@(reverse page-quads)) pages)) (set! page-quads null)) + #:text-func (λ (charint) (set! page-quads (cons `(div ((style ,(format "position: absolute;left:~apx;top:~apx;font-family:~a;font-size:~apx" (real-part current-loc) (imag-part current-loc) current-font 12))) ,(string (integer->char charint))) page-quads))) + #:set-font-func (λ (ps) (set! current-font (hash-ref! fonts ps (λ () (gensym 'font))))) + #:move-func (λ (x y) (set! current-loc (make-rectangular x y))) + #:return-func (λ () (with-output-to-file html-file #:exists 'replace