dev-app
Matthew Butterick 4 years ago
parent d0baaf3b66
commit 9b4515a104

@ -0,0 +1,145 @@
#lang debug racket
(require racket/gui sugar/coerce sugar/debug)
(define current-cell-size (make-parameter 30))
(define current-dc (make-parameter #f))
(define current-bitmap (make-parameter #f))
(define current-target (make-parameter 'gui))
(define current-stroke-scale (make-parameter 1))
(define char-edge-size 6)
(define (pathify vs)
(define p (new dc-path%))
(define pts
(for/list ([v (in-list vs)])
(list (* (current-cell-size) (sub1 (modulo v 10)))
(* (current-cell-size) (- 4 (sub1 (floor (/ v 10))))))))
(send/apply p move-to (car pts))
(for/last ([pt (in-list (cdr pts))])
(send/apply p line-to pt))
(when (= (first vs) (last vs)) (send p close))
p)
(struct $glyph (name paths))
(define font-definition
'((a (51 54 45 15 12 21 31 33))
(b (11 51 55 25 14 13) (35 33))
(c (25 15 11 41 52 55 45))
(d (31 11 14 25 45 54 51))
(e (15 11 41 52 55 35 33))
(E (55 52 41 11 15) (31 35))
(f (11 41 52 55) (31 35))
(g (33 35 15 11 41 52 55))
(h (11 51) (15 55) (31 35))
(i (11 15) (51 55) (13 53))
(j (53 55 15 12 21 31))
(k (11 51) (11 21 54 55) (43 34 25 15))
(L (51 11 15) (53 33 35))
(l (25 15 11 41 52))
(m (11 51 54 45 15) (53 13))
(n (11 51 54 45 15))
(N (11 51 52 43 23 14 15 55))
(O (11 41 52 55 25 14 11))
(o (51 54 45 15 12 21 51))
(P (11 51 54 45 35 24 23))
(p (51 54 45 35 33 13 11 31))
(p0 (11 51 55 35 24 23))
(q (33 24 13 11 41 52 55 35 24))
(r (11 51 53 54 45 35 33 23 14 15))
(s (11 14 25 35 31 41 52 55))
(t (31 51 55 35) (53 13) (11 15))
(T (51 55) (53 13))
(u (51 21 12 15 55))
(v (55 35 13 11 51))
(w (51 21 12 15 55) (53 13))
(x (51 52 43 23 14 15) (11 12 23 43 54 55))
(X (51 41 32 34 25 15) (11 21 32 34 45 55))
(y (51 31 35)(55 25 14 11))
(z (51 55 45 34 32 21 11 15))
( (12 21 41 52 43 54 45 25 14 12))
(0 (51 54 45 15 12 21 31 51))
(1 (51 53 13) (11 15))
(2 (51 54 45 35 31 11 15))
(3 (51 54 45 15 11) (31 35))
(4 (41 21 25) (54 14))
(5 (55 51 31 35 25 14 11))
(6 (31 35 25 14 11 41 52 55))
(7 (51 55 45 22 12))
(8 (12 21 51 54 45 15 12) (31 35))
(9 (11 14 25 55 52 41 31 35))
(λ (51 52 25 15) (11 21 43))
(> (51 52 25 15))
(% (11 51) (12 52) (13 53) (14 54) (15 55))
(^ (11 51) (12 42) (13 33) (14 24))
(< (11 21 43))
(|(| (55 54 43 23 14 15))
(|)| (51 52 43 23 12 11))))
(define glyphs (map (λ (i) ($glyph (->string (car i)) (map pathify (cdr i)))) font-definition))
(define (type str [xoffset 0] [yoffset 0] #:color color-proc #:width width)
(send* (current-dc)
[set-brush "white" 'transparent]
[set-pen (make-pen #:color (->string (if (procedure? color-proc) (color-proc) color-proc)) #:width width #:style 'solid #:cap 'projecting #:join 'miter)])
(for/fold ([xoffset xoffset]
[yoffset yoffset])
([c (in-list (string->list str))])
(define g (findf (λ (g) (equal? ($glyph-name g) (string c))) glyphs))
(when g
(for ([p (in-list ($glyph-paths g))])
(send (current-dc) draw-path p
(+ xoffset (current-cell-size))
(+ yoffset (current-cell-size)))))
(values (+ xoffset (* (current-cell-size) char-edge-size)) yoffset)))
(define (layer-type str #:xoffset [xoffset 0] #:yoffset [yoffset 0] . attrs)
(for ([layer (in-list (for/list ([i (in-range 0 (length attrs) 2)])
(list (list-ref attrs i) (list-ref attrs (add1 i)))))])
(type str xoffset yoffset #:color (first layer) #:width (* (current-cell-size) (current-stroke-scale) (second layer)))))
(define (render text layers [stroke-scale (/ 1 char-edge-size)] [name 'test])
(define lines (string-split text))
(define horiz (* (current-cell-size) (apply max (map string-length lines)) char-edge-size))
(define vert (* (current-cell-size) char-edge-size (length lines)))
(parameterize* ([current-bitmap (case (current-target)
[(svg) #false]
[else (make-bitmap horiz vert)])]
[current-dc
(case (current-target)
[(svg) (new svg-dc%
[width horiz]
[height vert]
[output (build-path
(find-system-path 'desk-dir)
(format "~a.svg" name))]
[exists 'replace])]
[else (new bitmap-dc% [bitmap (current-bitmap)])])]
[current-stroke-scale stroke-scale])
(case (current-target)
[(svg) (send* (current-dc) [start-doc ""][start-page])])
(send (current-dc) set-smoothing 'smoothed)
(for* ([(line lineidx) (in-indexed lines)]
[layer (in-list layers)])
(apply layer-type line
#:yoffset (* (current-cell-size) char-edge-size lineidx)
layer))
(case (current-target)
[(svg) (send* (current-dc) [end-page][end-doc])]
[(png) (send (current-bitmap) save-file (build-path
(find-system-path 'desk-dir)
(format "~a.png" name)) 'png)]
[(gui) (make-object image-snip% (current-bitmap))])))
(define (render-svg . args)
(parameterize ([current-target 'svg])
(apply render args)))
(define (render-png . args)
(parameterize ([current-target 'png])
(apply render args)))
(module+ main
(render "PoLEn" (for/list ([color (in-cycle '(Black White))]
[size (in-range 11 0 -2)])
(list color size))))
Loading…
Cancel
Save