You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
65 lines
2.3 KiB
Racket
65 lines
2.3 KiB
Racket
3 years ago
|
#lang debug racket/base
|
||
|
|
(require "pass.rkt" "drawing.rkt" "quad.rkt" racket/match racket/string)
|
||
|
|
(provide (all-defined-out))
|
||
|
|
|
||
|
|
(define-syntax-rule (define-render-pass (PASS-NAME ARG)
|
||
|
|
EXPRS ...)
|
||
|
|
(define-pass (PASS-NAME ARG)
|
||
|
|
#:precondition (λ (xs) (and (list? xs) (andmap $drawing-inst? xs)))
|
||
|
|
#:postcondition values
|
||
|
|
EXPRS ...))
|
||
|
|
|
||
|
|
(define-render-pass (render-to-text 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 char-pos-table (make-hasheqv))
|
||
|
|
;; 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
|
||
|
|
(for/list ([x (in-range xmax)])
|
||
|
|
(hash-ref char-pos-table (make-rectangular x y) #\space)))) "\n")))
|
||
|
|
|
||
|
|
(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")
|
||
|
|
|
||
|
|
(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)
|
||
|
|
(send dc draw-text (string c) (real-part current-loc) (imag-part current-loc))
|
||
|
|
(loop current-loc rest)]
|
||
|
|
[(cons _ rest) (loop current-loc rest)])))
|
||
|
|
|
||
|
|
(make-object image-snip% target))
|
||
|
|
|