suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

svn: r13986

Browse Source
This commit is contained in:
Robby Findler 2009-03-06 19:37:04 +00:00
parent 060bb38ebb
commit cab47712fb
3 changed files with 14 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/drscheme/private/drscheme-normal.ss
View File

@ -233,9 +233,10 @@
(cond (cond
[(or prince-kuhio-day? kamehameha-day?) [(or prince-kuhio-day? kamehameha-day?)
(set-splash-progress-bar? #f) (set-splash-progress-bar? #f)
(let ([size ((dynamic-require 'drscheme/private/palaka 'palaka-pattern-size) 4)])
(vector (dynamic-require 'drscheme/private/honu-logo 'draw-honu) (vector (dynamic-require 'drscheme/private/honu-logo 'draw-honu)
280 size
280)] size))]
[texas-independence-day? [texas-independence-day?
(build-path (collection-path "icons") "texas-plt-bw.gif")] (build-path (collection-path "icons") "texas-plt-bw.gif")]
[(and halloween? high-color?) [(and halloween? high-color?)

2
collects/drscheme/private/honu-logo.ss
View File

@ -417,7 +417,6 @@
(define black-honu-bitmap 'not-yet-the-bitmap) (define black-honu-bitmap 'not-yet-the-bitmap)
(define black-honu-bdc (make-object bitmap-dc%)) (define black-honu-bdc (make-object bitmap-dc%))
(send black-honu-bdc set-smoothing 'aligned)
(define (do-draw dc left-body-color right-body-color) (define (do-draw dc left-body-color right-body-color)
(send dc draw-bitmap black-honu-bitmap 0 0) (send dc draw-bitmap black-honu-bitmap 0 0)
@ -437,6 +436,7 @@
(define (recalc-bitmap) (define (recalc-bitmap)
(send black-honu-bdc set-bitmap black-honu-bitmap) (send black-honu-bdc set-bitmap black-honu-bitmap)
(send black-honu-bdc set-smoothing 'aligned)
(draw-palaka black-honu-bdc (send black-honu-bitmap get-width) (send black-honu-bitmap get-height)) (draw-palaka black-honu-bdc (send black-honu-bitmap get-width) (send black-honu-bitmap get-height))
(draw black-honu-bdc (draw black-honu-bdc
"black" "black" "black" "black" "black" "black" "black" "black" "black" "black" "black" "black"

15
collects/drscheme/private/palaka.ss
View File

@ -1,16 +1,19 @@
#lang scheme/base #lang scheme/base
(require scheme/class scheme/gui/base) (require scheme/class scheme/gui/base)
(provide draw-palaka palaka-pattern-size)
(define scale 1) (define scale 1)
(define palaka-color (send the-color-database find-color "lightsteelblue")) (define palaka-color (send the-color-database find-color "lightsteelblue"))
(define stripe-width (* scale 6)) (define stripe-width (* scale 6))
(define stripe-gap (* scale 2)) (define stripe-gap (* scale 2))
(define blank-space-between-stripe-sets (* stripe-width 5))
(define ε 0) (define ε 0)
(define vert-stripe-percent (- 1/2 ε)) (define vert-stripe-percent (- 1/2 ε))
(define horiz-stripe-percent (+ 1/4 ε)) (define horiz-stripe-percent (+ 1/4 ε))
(define quadrant-size (* 2 (+ (* stripe-width 4) (define quadrant-size (+ (* stripe-width 4)
(* stripe-gap 3)))) (* stripe-gap 3)
blank-space-between-stripe-sets))
(define-syntax-rule (define-syntax-rule
(four-times i e1 e ...) (four-times i e1 e ...)
(let loop ([i 0]) (let loop ([i 0])
@ -50,18 +53,18 @@
quadrant-size quadrant-size
stripe-width))) stripe-width)))
(define (palaka-pattern-size i) (+ (* quadrant-size i) blank-space-between-stripe-sets))
#; #;
(begin (begin
(define f (new frame% [label "Palaka"])) (define f (new frame% [label "Palaka"]))
(define c (new canvas% (define c (new canvas%
[parent f] [parent f]
[min-width 200] [min-width (palaka-pattern-size 4)]
[min-height 200] [min-height (palaka-pattern-size 4)]
[paint-callback [paint-callback
(λ (c dc) (λ (c dc)
(let-values ([(cw ch) (send c get-client-size)]) (let-values ([(cw ch) (send c get-client-size)])
(send dc set-smoothing 'aligned) (send dc set-smoothing 'aligned)
(draw-palaka dc cw ch)))])) (draw-palaka dc cw ch)))]))
(send f show #t)) (send f show #t))
(provide draw-palaka)