From 9b4515a104953f918d484e312f1a96fb80a5fb96 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sat, 25 Apr 2020 21:16:09 -0700 Subject: [PATCH] more --- pollen/app/refont.rkt | 145 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 145 insertions(+) create mode 100644 pollen/app/refont.rkt diff --git a/pollen/app/refont.rkt b/pollen/app/refont.rkt new file mode 100644 index 0000000..bc9c211 --- /dev/null +++ b/pollen/app/refont.rkt @@ -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)))) \ No newline at end of file