b5618b7d13
Note that this requires a running Finder. Note also that the process involves attaching the created DMG which means that it might be problematic with a machine that might have a volume by the same name already attached (since the applescript uses the volume name, which is not required to be unique).
195 lines
7.9 KiB
Racket
195 lines
7.9 KiB
Racket
#lang racket/base
|
|
|
|
(require slideshow racket/gui/base racket/runtime-path)
|
|
|
|
(provide plt-title-background
|
|
make-plt-title-background
|
|
plt-red-color
|
|
plt-blue-color
|
|
plt-background-color
|
|
plt-lambda-color
|
|
plt-pen-color
|
|
plt-pen-style)
|
|
|
|
(define plt-red-color (make-object color% 242 183 183))
|
|
(define plt-blue-color (make-object color% 183 202 242))
|
|
(define plt-background-color (make-object color% 209 220 248))
|
|
(define plt-lambda-color (send the-color-database find-color "white"))
|
|
(define plt-pen-color "black")
|
|
(define plt-pen-style 'transparent)
|
|
|
|
(define (with-dc-settings dc thunk)
|
|
(define alpha (send dc get-alpha))
|
|
(define smoothing (send dc get-smoothing))
|
|
(define pen (send dc get-pen))
|
|
(define brush (send dc get-brush))
|
|
(thunk)
|
|
(send* dc (set-alpha alpha)
|
|
(set-smoothing smoothing)
|
|
(set-pen pen)
|
|
(set-brush brush)))
|
|
|
|
(define (make-plt-title-background
|
|
red-color blue-color background-color lambda-color pen-color pen-style
|
|
#:clip? [clip? #t] #:edge-cleanup-pen [edge-cleanup-pen #f])
|
|
(define-syntax-rule (make-path cmd ...)
|
|
(let ([p (new dc-path%)]) (send* p cmd ...) p))
|
|
(define left-lambda-path
|
|
(make-path (move-to 153 44)
|
|
(line-to 161.5 60)
|
|
(curve-to 202.5 49 230 42 245 61)
|
|
(curve-to 280.06 105.41 287.5 141 296.5 186)
|
|
(curve-to 301.12 209.08 299.11 223.38 293.96 244)
|
|
(curve-to 281.34 294.54 259.18 331.61 233.5 375)
|
|
(curve-to 198.21 434.63 164.68 505.6 125.5 564)
|
|
(line-to 135 572)))
|
|
(define left-logo-path
|
|
(make-path (append left-lambda-path)
|
|
(arc 0 0 630 630 (* 235/360 2 pi) (* 121/360 2 pi) #f)))
|
|
(define bottom-lambda-path
|
|
(make-path (move-to 135 572)
|
|
(line-to 188.5 564)
|
|
(curve-to 208.5 517 230.91 465.21 251 420)
|
|
(curve-to 267 384 278.5 348 296.5 312)
|
|
(curve-to 301.01 302.98 318 258 329 274)
|
|
(curve-to 338.89 288.39 351 314 358 332)
|
|
(curve-to 377.28 381.58 395.57 429.61 414 477)
|
|
(curve-to 428 513 436.5 540 449.5 573)
|
|
(line-to 465 580)
|
|
(line-to 529 545)))
|
|
(define bottom-logo-path
|
|
(make-path (append bottom-lambda-path)
|
|
(arc 0 0 630 630 (* 314/360 2 pi) (* 235/360 2 pi) #f)))
|
|
(define right-lambda-path
|
|
(make-path (move-to 153 44)
|
|
(curve-to 192.21 30.69 233.21 14.23 275 20)
|
|
(curve-to 328.6 27.4 350.23 103.08 364 151)
|
|
(curve-to 378.75 202.32 400.5 244 418 294)
|
|
(curve-to 446.56 375.6 494.5 456 530.5 537)
|
|
(line-to 529 545)))
|
|
(define right-logo-path
|
|
(make-path (append right-lambda-path)
|
|
(arc 0 0 630 630 (* 314/360 2 pi) (* 121/360 2 pi) #t)))
|
|
(define lambda-path ;; the lambda by itself (no circle)
|
|
(let ([p (new dc-path%)])
|
|
(send p append left-lambda-path)
|
|
(send p append bottom-lambda-path)
|
|
(let ([t (make-object dc-path%)])
|
|
(send t append right-lambda-path)
|
|
(send t reverse)
|
|
(send p append t))
|
|
(send p close)
|
|
p))
|
|
|
|
;; (define lambda-path
|
|
;; (make-path (append left-lambda-path)
|
|
;; (append bottom-lambda-path)
|
|
;; (append right-lambda-path)))
|
|
|
|
;; This function draws the paths with suitable colors:
|
|
(define (paint-plt dc dx dy)
|
|
(send dc set-smoothing 'aligned)
|
|
(define old-pen (send dc get-pen))
|
|
(define old-brush (send dc get-brush))
|
|
(define old-clip (send dc get-clipping-region))
|
|
(send dc set-pen pen-color 0 pen-style)
|
|
(cond [(procedure? lambda-color)
|
|
(with-dc-settings dc
|
|
(λ () (lambda-color dc)
|
|
(send dc draw-path lambda-path dx dy)))]
|
|
[lambda-color
|
|
(send* dc (set-brush lambda-color 'solid)
|
|
(draw-path lambda-path dx dy))]
|
|
[else (void)])
|
|
;; Draw red regions
|
|
(cond [(is-a? red-color bitmap%)
|
|
(define rgn1 (new region% [dc dc]))
|
|
(define rgn2 (new region% [dc dc]))
|
|
(send rgn1 set-path left-logo-path dx dy #;(- dx 150) #;(- dy 20))
|
|
(send rgn2 set-path bottom-logo-path dx dy #;(- dx 150) #;(- dy 20))
|
|
(send rgn2 union rgn1)
|
|
(send dc set-clipping-region rgn2)
|
|
;; the left and top values of the bounding box seem to change over
|
|
;; time, so I've just put reasonable numbers below.
|
|
(let-values ([(sw sh) (send dc get-scale)])
|
|
(send* dc (set-scale 1 1)
|
|
(draw-bitmap red-color 220 100)
|
|
(set-scale sw sh)))
|
|
(send dc set-clipping-region old-clip)
|
|
(cleanup-edges left-logo-path dc dx dy)
|
|
(cleanup-edges bottom-logo-path dc dx dy)]
|
|
[(procedure? red-color)
|
|
(with-dc-settings dc
|
|
(λ () (red-color dc)
|
|
(send* dc (draw-path left-logo-path dx dy)
|
|
(draw-path bottom-logo-path dx dy))))]
|
|
[else (send* dc (set-brush red-color 'solid)
|
|
(draw-path left-logo-path dx dy)
|
|
(draw-path bottom-logo-path dx dy))])
|
|
;; Draw blue region
|
|
(cond [(is-a? blue-color bitmap%)
|
|
(define rgn (new region% [dc dc]))
|
|
(send rgn set-path right-logo-path dx dy #;(- dx 150) #;(- dy 20))
|
|
(send dc set-clipping-region rgn)
|
|
;; the left and top values of the bounding box seem to change over
|
|
;; time, so I've just put reasonable numbers below.
|
|
(let-values ([(sw sh) (send dc get-scale)])
|
|
(send* dc (set-scale 1 1)
|
|
(draw-bitmap blue-color 430 50)
|
|
(set-scale sw sh)))
|
|
(send dc set-clipping-region old-clip)
|
|
(cleanup-edges right-logo-path dc dx dy)]
|
|
[(procedure? blue-color)
|
|
(with-dc-settings dc
|
|
(λ () (blue-color dc)
|
|
(send dc draw-path right-logo-path dx dy)))]
|
|
[else (send* dc (set-brush blue-color 'solid)
|
|
(draw-path right-logo-path dx dy))])
|
|
(send* dc (set-pen old-pen)
|
|
(set-brush old-brush)
|
|
(set-clipping-region old-clip)))
|
|
(define (cleanup-edges path dc dx dy)
|
|
(when edge-cleanup-pen
|
|
(define pen (send dc get-pen))
|
|
(define brush (send dc get-brush))
|
|
(define alpha (send dc get-alpha))
|
|
(send* dc (set-pen edge-cleanup-pen)
|
|
(set-brush "black" 'transparent)
|
|
(set-alpha .8)
|
|
(draw-path path dx dy)
|
|
(set-pen pen)
|
|
(set-brush brush)
|
|
(set-alpha alpha))))
|
|
(define image (pin-over
|
|
(if background-color
|
|
(colorize (filled-rectangle client-w client-h)
|
|
background-color)
|
|
(blank client-w client-h))
|
|
320 50
|
|
(scale (dc paint-plt 630 630 0 0) 12/10)))
|
|
(if clip? (clip image) image))
|
|
|
|
(define plt-title-background
|
|
(make-plt-title-background plt-red-color
|
|
plt-blue-color
|
|
plt-background-color
|
|
plt-lambda-color
|
|
plt-pen-color
|
|
plt-pen-style))
|
|
|
|
(define-runtime-path arrow.png "128x128-arrow.png")
|
|
(define blue-arrow (read-bitmap arrow.png))
|
|
|
|
(define result.png "racket-rising.png")
|
|
|
|
(define size 1)
|
|
(define bmp (make-bitmap (round (* 1024 size 2/3)) (* 768 size 1/2)))
|
|
(define bdc (make-object bitmap-dc% bmp))
|
|
(draw-pict (scale plt-title-background size) bdc -100 0)
|
|
(void (send bdc draw-bitmap
|
|
blue-arrow
|
|
(/ (- (send bmp get-width) (send blue-arrow get-width)) 2)
|
|
(/ (- (send bmp get-height) (send blue-arrow get-height)) 2)))
|
|
(when (send bmp save-file result.png 'png)
|
|
(printf "wrote ~a\n" result.png))
|