72 lines
2.3 KiB
Racket
72 lines
2.3 KiB
Racket
#lang scheme/gui
|
|
|
|
(define width 16)
|
|
(define height 16)
|
|
|
|
(define (draw1 dc color?) (draw dc "pdf" 0 7 color?))
|
|
(define (draw2 dc color?) (draw dc "htm" -1 5 color?))
|
|
|
|
(define (draw dc str dx dy color?)
|
|
(send dc clear)
|
|
(send dc set-font (send the-font-list find-or-create-font 15 " Futura" 'swiss 'normal 'bold))
|
|
(let-values ([(tw th _1 _2) (send dc get-text-extent "@")])
|
|
(when color? (send dc set-text-foreground (send the-color-database find-color "gray")))
|
|
(send dc draw-text "@"
|
|
(- (/ width 2) (/ tw 2))
|
|
(- (/ height 2) (/ th 2)))
|
|
(send dc set-font (send the-font-list find-or-create-font 6 " Gill Sans" 'swiss 'normal 'bold))
|
|
(when color? (send dc set-text-foreground (send the-color-database find-color "purple")))
|
|
(send dc draw-text str (+ 0 dx) (- height dy) #f 0 (* pi 1/4))))
|
|
|
|
(define f (new frame% [label ""] [width 100] [height 100] [alignment '(center center)]))
|
|
(define c (new canvas%
|
|
[parent f]
|
|
[stretchable-width #f]
|
|
[stretchable-height #f]
|
|
[paint-callback (λ (c dc) (draw-bm dc pdf-bitmap))]
|
|
[min-width 16]
|
|
[min-height 16]))
|
|
(define c2 (new canvas%
|
|
[parent f]
|
|
[stretchable-width #f]
|
|
[stretchable-height #f]
|
|
[paint-callback (λ (c dc) (draw-bm dc html-bitmap))]
|
|
[min-width 16]
|
|
[min-height 16]))
|
|
|
|
|
|
(define (mk-bitmap draw)
|
|
(define mask-bm (make-object bitmap% width height))
|
|
(define bm (make-object bitmap% width height))
|
|
(define bdc (make-object bitmap-dc%))
|
|
(send bm set-loaded-mask mask-bm)
|
|
(send bdc set-bitmap mask-bm)
|
|
(draw bdc #f)
|
|
(send bdc set-bitmap bm)
|
|
(draw bdc #t)
|
|
(send bdc set-bitmap #f)
|
|
bm)
|
|
|
|
(define (draw-bm dc bm)
|
|
#;(send dc draw-bitmap (send bm get-loaded-mask) 0 0)
|
|
|
|
(send dc set-pen "lightgray" 1 'transparent)
|
|
(send dc set-brush "lightgray" 'solid)
|
|
(send dc draw-rectangle 0 0 width height)
|
|
(send dc draw-bitmap bm 0 0
|
|
'solid
|
|
(send the-color-database find-color "black")
|
|
(send bm get-loaded-mask)))
|
|
|
|
|
|
(define pdf-bitmap (mk-bitmap draw1))
|
|
(define html-bitmap (mk-bitmap draw2))
|
|
|
|
(begin
|
|
(send pdf-bitmap save-file "../pdf.png" 'png)
|
|
(send html-bitmap save-file "../html.png" 'png))
|
|
|
|
(match (current-command-line-arguments)
|
|
[(vector "skip") (void)]
|
|
[_ (send f show #t)])
|