diff --git a/pollen/app/make-pollen-icons.rkt b/pollen/app/make-pollen-icons.rkt new file mode 100644 index 0000000..e9b780e --- /dev/null +++ b/pollen/app/make-pollen-icons.rkt @@ -0,0 +1,13 @@ +#lang br +(require pict icns file/ico rsvg) + +(define p (svg-file->pict "pollen-raw.svg")) +(send (pict->bitmap p) save-file "pollen.png" 'png) + +(with-output-to-file "pollen.icns" + (λ () (void (write-bytes (pict->icns-bytes p)))) + #:exists 'replace) + +(write-icos (for/list ([size '(16 32 48 256)]) + (argb->ico size size (pict->argb-pixels (scale p (/ size 720))))) "pollen.ico" + #:exists 'replace) \ No newline at end of file diff --git a/pollen/app/pollen-font.rkt b/pollen/app/pollen-font.rkt new file mode 100644 index 0000000..0a68e48 --- /dev/null +++ b/pollen/app/pollen-font.rkt @@ -0,0 +1,142 @@ +#lang debug racket +(require racket/gui sugar/coerce sugar/debug) +(define current-cell-size (make-parameter 120)) +(define current-dc (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 (map (λ (x) (list (* (current-cell-size) (sub1 (modulo x 10))) (* (current-cell-size) (- 4 (sub1 (floor (/ x 10))))) )) vs)) + (send p move-to (first (car pts)) (second (car pts))) + (for-each (λ (pt) (send p line-to (first pt) (second pt))) (cdr pts)) + (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 (type str [xoffset 0] [yoffset 0] #:color color-proc #:width width) + (define glyphs (map (λ (i) ($glyph (->string (car i)) (map pathify (cdr i)))) font-definition)) + (cond + [(equal? str "") (void)] + [else + (define gname (substring str 0 1)) + (define g (findf (λ (g) (equal? ($glyph-name g) gname)) glyphs)) + (when g + (define pen (make-pen #:color (->string (color-proc)) #:width width #:style 'solid #:cap 'projecting #:join 'miter)) + (send (current-dc) set-pen pen) + (send (current-dc) set-brush "white" 'transparent) + (for-each (λ (p) (send (current-dc) draw-path p (+ xoffset (current-cell-size)) (+ yoffset (current-cell-size)))) ($glyph-paths g))) + (type (substring str 1) (+ xoffset (* (current-cell-size) char-edge-size)) yoffset #:color color-proc #:width width)])) + +(define (layer-type str #:xoffset [xoffset 0] #:yoffset [yoffset 0] . attrs) + (define layers (for/list ([i (in-range 0 (length attrs) 2)]) (list (list-ref attrs i) (list-ref attrs (add1 i))))) + (for-each (λ (layer) (type str xoffset yoffset #:color (first layer) #:width (* (current-cell-size) (current-stroke-scale) (second layer)))) layers)) + +(define (render text layers [stroke-scale 1] [name (gensym)]) + (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))) + (define target (make-bitmap horiz vert)) + (parameterize ([current-dc (if (equal? 'svg (current-target)) + (new svg-dc% [width horiz] [height vert] [output (format "/Users/MB/Desktop/~a.svg" name)] [exists 'replace]) + (new bitmap-dc% [bitmap target]))] + [current-stroke-scale stroke-scale]) + (when (eq? 'svg (current-target)) + (send (current-dc) start-doc "start") + (send (current-dc) start-page)) + (send (current-dc) set-smoothing 'smoothed) + (for* ([(line lineno) (in-indexed lines)] + [layer (in-list layers)]) + (define layer-color (first layer)) + (define layer-thickness (second layer)) + (layer-type line #:xoffset 0 #:yoffset (* (current-cell-size) char-edge-size lineno) layer-color layer-thickness)) + (make-object image-snip% target) + (when (eq? 'svg (current-target)) + (send (current-dc) end-page) + (send (current-dc) end-doc)) + (when (eq? 'png (current-target)) + (send target save-file (format "/Users/MB/Desktop/~a.png" name) 'png)))) + +(define-syntax-rule (render-svg arg ...) + (parameterize ([current-target 'svg]) + (render arg ...))) + +(define-syntax-rule (render-png arg ...) + (parameterize ([current-target 'png]) + (render arg ...))) + +(define (random-select xs) + (list-ref xs (random (length xs)))) + +(module+ main + (current-target 'svg) + + (define (do-it text name) + (render-svg text + (list (list (λ () 'Black) 11) + (list (λ () 'White) 9) + (list (λ () 'Black) 7) + (list (λ () 'White) 5) + (list (λ () 'Black) 3) + (list (λ () 'White) 1)) + (/ 1 char-edge-size) name)) + + (do-it "P" 'pollen-raw)) \ No newline at end of file diff --git a/pollen/info.rkt b/pollen/info.rkt index 32ce3fd..36d0c2d 100644 --- a/pollen/info.rkt +++ b/pollen/info.rkt @@ -5,7 +5,7 @@ (define compile-omit-paths '("test" "tools" "server-extras" "scribblings/third-tutorial-files")) ;; it's redundant to test "pollen.scrbl" because it incorporates the other scribble sources by reference ;; don't test app.rkt because it launches the gui -(define test-omit-paths '("test/data" "tools" "server-extras" "scribblings/third-tutorial-files" "scribblings/pollen.scrbl" "app/app.rkt")) +(define test-omit-paths '("test/data" "tools" "server-extras" "scribblings/third-tutorial-files" "scribblings/pollen.scrbl" "app")) ;; don't put #"p" in this list because it's not a #lang (define module-suffixes '(#"pp" #"pm" #"pmd" #"ptree"))