let's get stricter

main
Matthew Butterick 2 years ago
parent 4aac042157
commit 54b2ff0bf9

@ -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

Loading…
Cancel
Save