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

a bunch of improvements to the splash screen (loads less code before the splash appears, got rid of a bunch of dynamic-requires that were not necessary, fixed the lack of special screen on prince kuhio and king kamehameha days, got rid of the flicker in the tools icons)

Browse Source 
svn: r13980
This commit is contained in:
Robby Findler 2009-03-06 16:35:04 +00:00
parent f1e646c8f9
commit 283c1819a9
11 changed files with 1106 additions and 448 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/algol60/bd-tool.ss
View File

@ -1,5 +1,5 @@
(module bd-tool mzscheme (module bd-tool mzscheme
(require framework/private/encode-decode) (require framework/private/decode)
(decode 05c1dd6edc460c06d057f9226301b2e86c5c23690103a9835c (decode 05c1dd6edc460c06d057f9226301b2e86c5c23690103a9835c
e53a0f50602852d2ecce8f324379adb7ef3924b6a60aeaf6fb e53a0f50602852d2ecce8f324379adb7ef3924b6a60aeaf6fb
48dd403909a6d24daf634c984a379d189493609a731ce33ac6 48dd403909a6d24daf634c984a379d189493609a731ce33ac6

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

@ -2,41 +2,35 @@
(require mred (require mred
scheme/class scheme/class
mzlib/cmdline scheme/cmdline
scheme/list scheme/list
framework/private/bday) framework/private/bday
framework/splash)
; (current-load text-editor-load-handler) (define files-to-open (command-line #:args filenames filenames))
(define files-to-open
(command-line
(case (system-type)
[(windows) "DrScheme.exe"]
[(macosx) "drscheme" #;"DrScheme"]
[else "drscheme"])
(current-command-line-arguments)
(args filenames filenames)))
(define icons-bitmap
(let ([icons (collection-path "icons")])
(lambda (name)
(make-object bitmap% (build-path icons name)))))
;; updates the command-line-arguments with only the files ;; updates the command-line-arguments with only the files
;; to open. See also main.ss. ;; to open. See also main.ss.
(current-command-line-arguments (apply vector files-to-open)) (current-command-line-arguments (apply vector files-to-open))
(define-values (texas-independence-day? halloween?) (define-values (texas-independence-day? prince-kuhio-day? kamehameha-day? halloween?)
(let* ([date (seconds->date (current-seconds))] (let* ([date (seconds->date (current-seconds))]
[month (date-month date)] [month (date-month date)]
[day (date-day date)]) [day (date-day date)])
(values (and (= 3 month) (= 2 day)) (values (and (= 3 month) (= 2 day))
(and (= 3 month) (= 26 day))
(and (= 6 month) (= 11 day))
(and (= 10 month) (= 31 day))))) (and (= 10 month) (= 31 day)))))
(define high-color? ((get-display-depth) . > . 8)) (define high-color? ((get-display-depth) . > . 8))
(define special-state #f) (define special-state #f)
(define normal-bitmap #f) ; set by load-magic-images (define normal-bitmap #f) ; set by load-magic-images
(define icons-bitmap
(let ([icons (collection-path "icons")])
(lambda (name)
(make-object bitmap% (build-path icons name)))))
(define-struct magic-image (chars filename [bitmap #:mutable])) (define-struct magic-image (chars filename [bitmap #:mutable]))
(define (magic-img str img) (define (magic-img str img)
@ -77,9 +71,7 @@
(when ((length key-codes) . > . longest-magic-string) (when ((length key-codes) . > . longest-magic-string)
(set! key-codes (take key-codes longest-magic-string)))) (set! key-codes (take key-codes longest-magic-string))))
(let ([set-splash-bitmap (set-splash-char-observer
(dynamic-require 'framework/splash 'set-splash-bitmap)])
((dynamic-require 'framework/splash 'set-splash-char-observer)
(λ (evt) (λ (evt)
(let ([ch (send evt get-key-code)]) (let ([ch (send evt get-key-code)])
(when (char? ch) (when (char? ch)
@ -93,7 +85,7 @@
(if (eq? special-state match) (if (eq? special-state match)
(begin (set! special-state #f) normal-bitmap) (begin (set! special-state #f) normal-bitmap)
(begin (set! special-state match) (begin (set! special-state match)
(magic-image-bitmap match))))))))))) (magic-image-bitmap match))))))))))
(when (eb-bday?) (when (eb-bday?)
(let () (let ()
@ -137,7 +129,7 @@
[(< angle 0) (normalize-angle (+ angle (* 2 pi)))] [(< angle 0) (normalize-angle (+ angle (* 2 pi)))]
[else (normalize-angle (- angle (* 2 pi)))])) [else (normalize-angle (- angle (* 2 pi)))]))
(define splash-canvas ((dynamic-require 'framework/splash 'get-splash-canvas))) (define splash-canvas (get-splash-canvas))
(define (draw-single-step dc offset) (define (draw-single-step dc offset)
(send bdc draw-bitmap eli 0 0) (send bdc draw-bitmap eli 0 0)
(draw-single-loop omega-str bdc offset (/ main-size 2) (/ main-size 2) 120 32 outer-color) (draw-single-loop omega-str bdc offset (/ main-size 2) (/ main-size 2) 120 32 outer-color)
@ -184,7 +176,7 @@
(define (eli-event evt) (define (eli-event evt)
(cond (cond
[(send evt leaving?) [(send evt leaving?)
((dynamic-require 'framework/splash 'set-splash-paint-callback) orig-paint) (set-splash-paint-callback orig-paint)
(when gc-b (when gc-b
(unregister-collecting-blit splash-canvas)) (unregister-collecting-blit splash-canvas))
(send splash-canvas refresh) (send splash-canvas refresh)
@ -192,7 +184,7 @@
(kill-thread draw-thread) (kill-thread draw-thread)
(set! draw-thread #f))] (set! draw-thread #f))]
[(send evt entering?) [(send evt entering?)
((dynamic-require 'framework/splash 'set-splash-paint-callback) eli-paint) (set-splash-paint-callback eli-paint)
(when gc-b (when gc-b
(register-collecting-blit splash-canvas (register-collecting-blit splash-canvas
(floor (- (/ main-size 2) (floor (- (/ main-size 2)
@ -206,7 +198,7 @@
(unless draw-thread (unless draw-thread
(start-thread))])) (start-thread))]))
(define splash-eventspace ((dynamic-require 'framework/splash 'get-splash-eventspace))) (define splash-eventspace (get-splash-eventspace))
(define draw-next-state (define draw-next-state
(let ([o 0]) (let ([o 0])
(lambda () (lambda ()
@ -231,24 +223,29 @@
(draw-next-state) (draw-next-state)
(sleep .01) (sleep .01)
(loop)))))) (loop))))))
(define orig-paint ((dynamic-require 'framework/splash 'get-splash-paint-callback))) (define orig-paint (get-splash-paint-callback))
(draw-next-state) (draw-next-state)
((dynamic-require 'framework/splash 'set-splash-event-callback) eli-event) (set-splash-event-callback eli-event)
(send splash-canvas refresh))) (send splash-canvas refresh)))
((dynamic-require 'framework/splash 'start-splash) (start-splash
(build-path (collection-path "icons")
(cond (cond
[(or prince-kuhio-day? kamehameha-day?)
(set-splash-progress-bar? #f)
(vector (dynamic-require 'drscheme/private/honu-logo 'draw-honu)
280
280)]
[texas-independence-day? [texas-independence-day?
"texas-plt-bw.gif"] (build-path (collection-path "icons") "texas-plt-bw.gif")]
[(and halloween? high-color?) [(and halloween? high-color?)
"PLT-pumpkin.png"] (build-path (collection-path "icons") "PLT-pumpkin.png")]
[high-color? "PLT-206.png"] [high-color?
(build-path (collection-path "icons") "PLT-206.png")]
[(= (get-display-depth) 1) [(= (get-display-depth) 1)
"pltbw.gif"] (build-path (collection-path "icons") "pltbw.gif")]
[else [else
"plt-flat.gif"])) (build-path (collection-path "icons") "plt-flat.gif")])
"DrScheme" "DrScheme"
99) 99)

529
collects/drscheme/private/honu-logo.ss Normal file
View File

@ -0,0 +1,529 @@
#lang scheme/base
(provide draw-honu)
(require scheme/class
scheme/gui/base
"palaka.ss")
(define pi (atan 0 -1))
(define body-path (make-object dc-path%))
(define (find-arc-spot x y w h end)
(let ([ce (cos end)]
[se (- (sin end))])
(values (+ x (* w 1/2) (* w 1/2 ce))
(+ y (* h 1/2) (* h 1/2 se)))))
(define weighted-arc
(lambda (path x y w h start end ccw? [dx1 0.0] [dy1 0.2] [dx2 dx1] [dy2 (- dy1)])
(let ([sweep (let loop ([s (if ccw? (- end start) (- start end))])
(if (< s 0)
(loop (+ s (* 2 pi)))
s))])
(if (> sweep pi)
(let ([halfway ((if ccw? + -) start (/ sweep 2))])
(weighted-arc path x y w h start halfway ccw? dx1 dy1 dx2 dy2)
(weighted-arc path x y w h halfway end ccw? dx2 (- dy2) dx1 (- dy1)))
(let ([p (new dc-path%)])
;; Set p to be the arc for a unit circle,
;; centered on the X-axis:
(let* ([x0 (cos (/ sweep 2))]
[y0 (sin (/ sweep 2))]
[x1 (/ (- 4 x0) 3)]
[y1 (/ (* (- 1 x0) (- 3 x0)) (* 3 y0))]
[x2 x1]
[y2 (- y1)]
[x3 x0]
[y3 (- y0)]
[sw (/ w 2)]
[sh (/ h 2)])
(send p move-to x0 y0)
(send p curve-to
(+ x1 dx1) (+ y1 dy1)
(+ x2 dx2) (+ y2 dy2)
x3 y3)
;; Rotate to match start:
(send p rotate (+ (if ccw? start end) (/ sweep 2)))
;; Scale to match width and height:
(send p scale (/ w 2) (/ h 2))
;; Translate to match x and y
(send p translate (+ x (/ w 2)) (+ y (/ h 2)))
(unless ccw?
(send p reverse)))
(send path append p))))))
(define overall-rotation (- (* pi 1/2 3/8)))
(define body-width 100)
(define body-height 110)
(define body-thickness 12)
(define angle-offset (* pi 1/10))
(define big-fin-curve-top-offset 0)
(define big-fin-curve-bottom-offset 4)
(define big-fin-top-angle (* pi 3/12))
(define big-fin-bottom-angle (* pi 2/12))
(define big-fin-size 60)
(define big-fin-right-edge (+ body-width big-fin-size))
(define little-fin-top-angle (- (* pi (/ 3.5 12))))
(define little-fin-bottom-angle (- (* pi (/ 4.5 12))))
(define little-fin-size 20)
(define little-fin-far-y (+ body-height little-fin-size))
(define pointy-tip-offset 8)
(define head-angle-span (* pi 1/6))
(define head-cx (/ body-width 2))
(define head-cy -8)
(define head-width 30)
(define head-height 40)
(define acos-arg
(* (/ 2 head-width) (- (* (cos (- (/ pi 2) (/ head-angle-span 2)))
(/ body-width 2)))))
(define head-theta-start (- (acos acos-arg)))
(define head-theta-end (- pi head-theta-start))
(define-values (head-attach-left-x head-attach-left-y)
(find-arc-spot 0 0 body-width body-height (+ (/ pi 2) (/ head-angle-span 2))))
(define-values (head-attach-right-x head-attach-right-y)
(find-arc-spot 0 0 body-width body-height (- (/ pi 2) (/ head-angle-span 2))))
(define right-edge-of-center-line (+ (/ body-width 2) (/ body-thickness 2)))
(define left-edge-of-center-line (- (/ body-width 2) (/ body-thickness 2)))
(define-values (big-fin-top-x big-fin-top-y)
(find-arc-spot 0 0 body-width body-height big-fin-top-angle))
(define-values (big-fin-bottom-x big-fin-bottom-y)
(find-arc-spot 0 0 body-width body-height big-fin-bottom-angle))
(define-values (left-little-fin-top-x left-little-fin-top-y)
(find-arc-spot 0 0 body-width body-height (- pi little-fin-top-angle)))
(define-values (left-little-fin-bottom-x left-little-fin-bottom-y)
(find-arc-spot 0 0 body-width body-height (- pi little-fin-bottom-angle)))
(define-values (little-fin-top-x little-fin-top-y)
(find-arc-spot 0 0 body-width body-height little-fin-top-angle))
(define-values (little-fin-bottom-x little-fin-bottom-y)
(find-arc-spot 0 0 body-width body-height little-fin-bottom-angle))
(define-values (inner-right-arc-top-x inner-right-arc-top-y)
(find-arc-spot
body-thickness
body-thickness
(- body-width body-thickness body-thickness)
(- body-height body-thickness body-thickness)
(- (* pi 1/2) angle-offset)))
(define-values (inner-right-arc-bottom-x inner-right-arc-bottom-y)
(find-arc-spot
body-thickness
body-thickness
(- body-width body-thickness body-thickness)
(- body-height body-thickness body-thickness)
(+ (* pi 3/2) angle-offset)))
(define (add-big-fin-top add)
(let ([fin-width (- big-fin-right-edge big-fin-top-x)])
(add big-fin-top-x
big-fin-top-y
(+ big-fin-top-x (* 1/3 fin-width))
big-fin-curve-top-offset
(+ big-fin-top-x (* 2/3 fin-width))
big-fin-curve-top-offset
big-fin-right-edge
(+ big-fin-bottom-y 10))))
(define (add-big-fin-bottom add)
(let ([fin-width (- big-fin-right-edge big-fin-bottom-x)])
(add
(+ big-fin-bottom-x fin-width)
(+ big-fin-bottom-y 10)
(+ big-fin-bottom-x (* 1/3 fin-width))
(- (/ (+ big-fin-bottom-y big-fin-top-y) 2)
big-fin-curve-bottom-offset)
(+ big-fin-bottom-x (* 1/5 fin-width))
(/ (+ big-fin-bottom-y big-fin-top-y) 2)
big-fin-bottom-x
big-fin-bottom-y)))
(define (add-little-fin-top add)
(add
little-fin-top-x
little-fin-top-y
(+ little-fin-top-x (* (- little-fin-top-x little-fin-bottom-x) 2/3))
(+ little-fin-top-y (* (- little-fin-far-y little-fin-top-y) 1/3))
(+ little-fin-top-x (* (- little-fin-top-x little-fin-bottom-x) 1/3))
(+ little-fin-top-y (* (- little-fin-far-y little-fin-top-y) 2/3))
little-fin-top-x
little-fin-far-y))
(define (add-little-fin-bottom add)
(add
little-fin-top-x
little-fin-far-y
(+ little-fin-top-x (* (- little-fin-bottom-x little-fin-top-x) 2/3))
(+ little-fin-top-y (* (- little-fin-far-y little-fin-top-y) 1/3))
(+ little-fin-top-x (* (- little-fin-bottom-x little-fin-top-x) 2/3))
(+ little-fin-top-y (* (- little-fin-far-y little-fin-top-y) 1/3))
little-fin-bottom-x
little-fin-bottom-y))
(define (add-dot path x y)
(let ([p (new dc-path%)])
(send p ellipse (- x 2) (- y 2) 4 4)
(send path append p)))
(define (same-side-add x1 y1 x2 y2 x3 y3 x4 y4)
(send body-path curve-to x2 y2 x3 y3 x4 y4))
(define (same-side-add/dot x1 y1 x2 y2 x3 y3 x4 y4)
(send body-path line-to x1 y1)
(add-dot body-path x1 y1)
(send body-path line-to x2 y2)
(add-dot body-path x2 y2)
(send body-path line-to x3 y3)
(add-dot body-path x3 y3))
(define (opposite-side-add x1 y1 x2 y2 x3 y3 x4 y4)
(let ([conv (lambda (x y) (values (+ (- x) body-width) y))])
(let-values ([(cx1 cy1) (conv x1 y1)]
[(cx2 cy2) (conv x2 y2)]
[(cx3 cy3) (conv x3 y3)])
(send body-path curve-to cx3 cy3 cx2 cy2 cx1 cy1))))
(define (opposite-side-add/dot x1 y1 x2 y2 x3 y3 x4 y4)
(let ([conv (lambda (x y) (values (+ (- x) body-width) y))])
(let-values ([(cx1 cy1) (conv x1 y1)]
[(cx2 cy2) (conv x2 y2)]
[(cx3 cy3) (conv x3 y3)])
(send body-path line-to cx3 cy3)
(add-dot body-path cx3 cy3)
(send body-path line-to cx2 cy2)
(add-dot body-path cx2 cy2)
(send body-path line-to cx1 cy1)
(add-dot body-path cx1 cy1))))
(define side-perturb-y 0.0)
(define side-perturb-x -0.1)
(weighted-arc body-path 0 0 body-width body-height big-fin-bottom-angle little-fin-top-angle #f
side-perturb-x side-perturb-y)
(add-little-fin-top same-side-add)
(add-little-fin-bottom same-side-add)
(send body-path line-to
little-fin-bottom-x
little-fin-bottom-y)
(send body-path line-to
(/ body-width 2)
(+ body-height pointy-tip-offset))
(send body-path line-to
left-little-fin-bottom-x
left-little-fin-bottom-y)
(add-little-fin-bottom opposite-side-add)
(add-little-fin-top opposite-side-add)
(weighted-arc body-path 0 0 body-width body-height
(- pi little-fin-top-angle)
(- pi big-fin-bottom-angle)
#f
side-perturb-x side-perturb-y)
(add-big-fin-bottom opposite-side-add)
(add-big-fin-top opposite-side-add)
(weighted-arc body-path 0 0 body-width body-height (- pi big-fin-top-angle) (+ (/ pi 2) (/ head-angle-span 2)) #f 0 0)
(weighted-arc body-path
(- head-cx (/ head-width 2))
(- head-cy (/ head-height 2))
head-width
head-height
head-theta-start
head-theta-end
#f 0 0 0 -0.2)
(weighted-arc body-path 0 0 body-width body-height (- (/ pi 2) (/ head-angle-span 2)) big-fin-top-angle #f 0 0)
(add-big-fin-top same-side-add)
(add-big-fin-bottom same-side-add)
(send body-path close)
(define (make-right-hole-path)
(let ([right-hole-path (make-object dc-path%)])
(define arc/end
(lambda (x y w h start end [cc? #t] [dx1 0] [dy1 0.2] [dx2 0] [dy2 -0.2])
(weighted-arc right-hole-path x y w h start end cc? dx1 dy1 dx2 dy2)
(find-arc-spot x y w h end)))
(define-values (arc1x arc1y)
(arc/end body-thickness
body-thickness
(- body-width body-thickness body-thickness)
(- body-height body-thickness body-thickness)
(- (* pi 1/2) angle-offset)
(+ (* pi 3/2) angle-offset)
#f -0.2 0.2 0 -0.2))
(define little-arc-size (* 2 (- inner-right-arc-bottom-x right-edge-of-center-line)))
(define-values (arc2x arc2y)
(arc/end
right-edge-of-center-line
(- inner-right-arc-bottom-y little-arc-size)
little-arc-size
little-arc-size
(* 3/2 pi)
pi
#f
0 0 0 0))
(let ([arc2y (- body-height arc2y)])
(send right-hole-path curve-to
(+ (/ (+ (* 2 arc1x) (* 1 arc2x)) 3) -4)
(/ (+ (* 2 arc1y) (* 1 arc2y)) 3)
(+ (/ (+ (* 1 arc1x) (* 2 arc2x)) 3) -4)
(/ (+ (* 1 arc1y) (* 2 arc2y)) 3)
arc2x arc2y))
(weighted-arc right-hole-path
right-edge-of-center-line
inner-right-arc-top-y
little-arc-size
little-arc-size
pi
(* 1/2 pi)
#f
0 0 0 0)
(send right-hole-path close)
right-hole-path))
(define (make-left-hole-path)
(let ([left-hole-path (make-right-hole-path)])
(send left-hole-path scale -1 1)
(send left-hole-path translate
(+ right-edge-of-center-line left-edge-of-center-line) 0)
left-hole-path))
(define right-hole-path (make-right-hole-path))
(define left-hole-path (make-left-hole-path))
(define (adjust-path path)
(send path translate (+ (- big-fin-right-edge body-width) 1) (+ (- head-cy) (/ head-height 2) 2))
(send path rotate overall-rotation))
(adjust-path body-path)
(adjust-path left-hole-path)
(adjust-path right-hole-path)
(define pale-red-color (make-object color% 242 183 183))
(define pale-blue-color (make-object color% 183 202 242))
(define pale-background-color (make-object color% 209 220 248))
(define current-body-path body-path)
(define current-left-hole-path left-hole-path)
(define current-right-hole-path right-hole-path)
(define (draw dc main-pen-color main-color left-pen-color left-color right-pen-color right-color dx dy)
(send dc set-brush main-color 'solid)
(send dc set-pen main-pen-color 1 'solid)
(send dc draw-path current-body-path dx dy)
(draw-holes dc left-pen-color left-color right-pen-color right-color dx dy))
(define (draw-holes dc left-pen-color left-color right-pen-color right-color dx dy)
(send dc set-brush left-color 'solid)
(send dc set-pen left-pen-color 1 'solid)
(send dc draw-path current-left-hole-path dx dy)
(send dc set-brush right-color 'solid)
(send dc set-pen right-pen-color 1 'solid)
(send dc draw-path current-right-hole-path dx dy))
(define base-width 260)
(define base-height 240)
(define dark-x 80)
(define dark-y -20)
(define current-dark-x dark-x)
(define current-dark-y dark-y)
(define light-x 350)
(define light-y dark-y)
(define current-light-x light-x)
(define current-light-y light-y)
(define (rescale w h)
(let ([scale (min (/ w base-width) (/ h base-height))])
(set! current-body-path (new dc-path%))
(send current-body-path append body-path)
(send current-body-path scale scale scale)
(set! current-left-hole-path (new dc-path%))
(send current-left-hole-path append left-hole-path)
(send current-left-hole-path scale scale scale)
(set! current-right-hole-path (new dc-path%))
(send current-right-hole-path append right-hole-path)
(send current-right-hole-path scale scale scale)
(set! current-light-x (* light-x scale))
(set! current-light-y (* light-y scale))
(set! current-dark-x (* dark-x scale))
(set! current-dark-y (* dark-y scale))))
(define my-canvas%
(class canvas%
(define/override (on-size w h)
(rescale w h))
(super-new)))
(define (vector-map f v)
(build-vector (vector-length v)
(λ (i) (f (vector-ref v i)))))
(define color-series
(vector-map (λ (l) (vector-map (λ (x) (send the-color-database find-color x)) l))
'#(#("red" "blue")
#("red" "blue")
#("Magenta" "MediumOrchid")
#("MediumOrchid" "Magenta")
#("blue" "red"))))
(define black-honu-bitmap 'not-yet-the-bitmap)
(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)
(send dc draw-bitmap black-honu-bitmap 0 0)
(send dc set-smoothing 'aligned)
(draw-holes dc left-body-color left-body-color right-body-color right-body-color
current-dark-x
current-dark-y))
(define (set-size w h)
;; update the bitmap if the size has changed
(unless (and (is-a? black-honu-bitmap bitmap%)
(equal? w (send black-honu-bitmap get-width))
(equal? h (send black-honu-bitmap get-height)))
(rescale w h)
(set! black-honu-bitmap (make-object bitmap% w h))
(recalc-bitmap)))
(define (recalc-bitmap)
(send black-honu-bdc set-bitmap black-honu-bitmap)
(draw-palaka black-honu-bdc (send black-honu-bitmap get-width) (send black-honu-bitmap get-height))
(draw black-honu-bdc
"black" "black" "black" "black" "black" "black"
current-dark-x
current-dark-y)
(send black-honu-bdc set-bitmap #f))
(define (set-val val left-body-color right-body-color)
(cond
[(and (<= 0 val)
(< val 1))
(let* ([scaled-val (* val (- (vector-length color-series) 1))]
[set (floor scaled-val)]
[in-set-val (- scaled-val set)]
[before-colors (vector-ref color-series set)]
[after-colors (vector-ref color-series (+ set 1))])
(linear-color-combination (vector-ref before-colors 0)
(vector-ref after-colors 0)
in-set-val
left-body-color)
(linear-color-combination (vector-ref before-colors 1)
(vector-ref after-colors 1)
in-set-val
right-body-color))]
[else
(let ([set (vector-ref color-series (- (vector-length color-series) 1))])
(send left-body-color copy-from (vector-ref set 0))
(send right-body-color copy-from (vector-ref set 1)))]))
(define (linear-color-combination xc yc val uc)
(send uc set
(linear-combination (send xc red) (send yc red) val)
(linear-combination (send xc green) (send yc green) val)
(linear-combination (send xc blue) (send yc blue) val)))
(define (linear-combination x y val)
(floor (+ x (* val (- y x)))))
(define draw-honu
(let ()
;; colors
(define left-body-color (make-object color% 0 0 0))
(define right-body-color (make-object color% 0 0 0))
(λ (dc val range w h)
(set-size w h)
(set-val (/ val range) left-body-color right-body-color)
(do-draw dc left-body-color right-body-color))))
#;
(let ()
(define f (new frame% (label "")))
(define c2 (new canvas% [parent f]
[min-width 200]
[min-height 200]
[style '(no-autoclear)]
[paint-callback
(λ (c dc)
(let-values ([(w h) (send c get-client-size)])
(draw-honu dc
(send slider get-value)
100
w
h)))]))
(define slider (new slider%
[label #f]
[min-value 0]
[max-value 100]
[parent f]
[callback
(λ (a b)
(send c2 refresh))]))
(define b (new button%
[label "animate"]
[parent f]
[callback
(λ (x y)
(thread
(λ ()
(let loop ([i 0])
(queue-callback
(λ ()
(send slider set-value i)
(send c2 refresh)))
(unless (= i 100)
(sleep 1/20)
(loop (+ i 1)))))))]))
(send f show #t))

67
collects/drscheme/private/palaka.ss Executable file
View File

@ -0,0 +1,67 @@
#lang scheme/base
(require scheme/class scheme/gui/base)
(define scale 1)
(define palaka-color (send the-color-database find-color "lightsteelblue"))
(define stripe-width (* scale 6))
(define stripe-gap (* scale 2))
(define ε 0)
(define vert-stripe-percent (- 1/2 ε))
(define horiz-stripe-percent (+ 1/4 ε))
(define quadrant-size (* 2 (+ (* stripe-width 4)
(* stripe-gap 3))))
(define-syntax-rule
(four-times i e1 e ...)
(let loop ([i 0])
(when (< i 4)
e1 e ...
(loop (+ i 1)))))
(define (draw-palaka dc w h)
(let ([alpha (send dc get-alpha)])
(send dc set-pen palaka-color 1 'transparent)
(let loop ([dx (- (/ quadrant-size 2))])
(when (< dx w)
(let loop ([dy (- (/ quadrant-size 2))])
(when (< dy h)
(send dc set-alpha 1)
(send dc set-brush palaka-color 'solid)
(send dc draw-rectangle dx dy quadrant-size quadrant-size)
(send dc set-brush "white" 'solid)
(draw-one-palaka dc dx dy)
(loop (+ dy quadrant-size))))
(loop (+ dx quadrant-size))))
(send dc set-alpha alpha)))
(define (draw-one-palaka dc dx dy)
(four-times
i
(send dc set-alpha vert-stripe-percent)
(send dc draw-rectangle
(+ dx (* i (+ stripe-width stripe-gap)))
dy
stripe-width
quadrant-size)
(send dc set-alpha horiz-stripe-percent)
(send dc draw-rectangle
dx
(+ dy (* i (+ stripe-width stripe-gap)))
quadrant-size
stripe-width)))
#;
(begin
(define f (new frame% [label "Palaka"]))
(define c (new canvas%
[parent f]
[min-width 200]
[min-height 200]
[paint-callback
(λ (c dc)
(let-values ([(cw ch) (send c get-client-size)])
(send dc set-smoothing 'aligned)
(draw-palaka dc cw ch)))]))
(send f show #t))
(provide draw-palaka)

64
collects/drscheme/private/tools.ss
View File

@ -1,15 +1,16 @@
#lang scheme/unit #lang scheme/unit
(require setup/getinfo (require scheme/class
mred
scheme/class
scheme/list scheme/list
scheme/runtime-path
scheme/contract
setup/getinfo
mred
framework
framework/splash
"drsig.ss" "drsig.ss"
"language-object-contract.ss" "language-object-contract.ss"
scheme/contract string-constants)
framework
string-constants
scheme/runtime-path)
(require (for-syntax scheme/base scheme/match)) (require (for-syntax scheme/base scheme/match))
@ -349,13 +350,12 @@
(unless (and (is-a? bitmap bitmap%) (unless (and (is-a? bitmap bitmap%)
(send bitmap ok?)) (send bitmap ok?))
(k #f)) (k #f))
(let ([splash-eventspace ((dynamic-require 'framework/splash 'get-splash-eventspace))] (let ([splash-eventspace (get-splash-eventspace)]
[splash-bitmap ((dynamic-require 'framework/splash 'get-splash-bitmap))] [splash-canvas (get-splash-canvas)]
[splash-canvas ((dynamic-require 'framework/splash 'get-splash-canvas))]) [splash-width (get-splash-width)]
[splash-height (get-splash-height)])
(unless (and (eventspace? splash-eventspace) (unless (and (eventspace? splash-eventspace)
(is-a? splash-bitmap bitmap%)
(send splash-bitmap ok?)
(is-a? splash-canvas canvas%)) (is-a? splash-canvas canvas%))
(k (void))) (k (void)))
@ -363,36 +363,26 @@
(queue-callback (queue-callback
(lambda () (lambda ()
(let ([bdc (make-object bitmap-dc%)] (let ([bdc (make-object bitmap-dc%)]
[translated-tool-bitmap-y (max 0 (- (send splash-bitmap get-height) tool-bitmap-y tool-bitmap-size))]) [translated-tool-bitmap-y
(max 0 (- splash-height tool-bitmap-y tool-bitmap-size))])
;; truncate/expand the bitmap, if necessary
(unless (and (= tool-bitmap-size (send bitmap get-width))
(= tool-bitmap-size (send bitmap get-height)))
(let ([new-b (make-object bitmap% tool-bitmap-size tool-bitmap-size #f)])
(send bdc set-bitmap new-b)
(send bdc clear)
(send bdc draw-bitmap-section splash-bitmap
0 0
tool-bitmap-x translated-tool-bitmap-y
tool-bitmap-size tool-bitmap-size)
(send bdc draw-bitmap bitmap
(max 0 (- (/ tool-bitmap-size 2)
(/ (send bitmap get-width) 2)))
(max 0 (- (/ tool-bitmap-size 2)
(/ (send bitmap get-height) 2)))
'solid
(make-object color% "black")
(send bitmap get-loaded-mask))
(send bdc set-bitmap #f)
(set! bitmap new-b)))
;; add the bitmap, but centered at its position
;; (used to truncate the bitmap
;; if it was too large, but no longer)
((dynamic-require 'framework/splash 'add-splash-icon) ((dynamic-require 'framework/splash 'add-splash-icon)
bitmap tool-bitmap-x translated-tool-bitmap-y) bitmap
(floor (+ tool-bitmap-x
(- (/ tool-bitmap-size 2)
(/ (send bitmap get-width) 2))))
(floor (+ translated-tool-bitmap-y
(- (/ tool-bitmap-size 2)
(/ (send bitmap get-height) 2)))))
(set! tool-bitmap-x (+ tool-bitmap-x tool-bitmap-size tool-bitmap-gap)) (set! tool-bitmap-x (+ tool-bitmap-x tool-bitmap-size tool-bitmap-gap))
(when ((+ tool-bitmap-x tool-bitmap-gap tool-bitmap-size) . > . (send splash-bitmap get-width)) (when ((+ tool-bitmap-x tool-bitmap-gap tool-bitmap-size) . > . splash-width)
(set! tool-bitmap-y (+ tool-bitmap-y tool-bitmap-size tool-bitmap-gap)) (set! tool-bitmap-y (+ tool-bitmap-y tool-bitmap-size tool-bitmap-gap))
(set! tool-bitmap-x tool-bitmap-gap)) (set! tool-bitmap-x tool-bitmap-gap))
(when ((+ tool-bitmap-y tool-bitmap-gap tool-bitmap-size) . > . (send splash-bitmap get-width)) (when ((+ tool-bitmap-y tool-bitmap-gap tool-bitmap-size) . > . splash-width)
(set! tool-bitmap-y tool-bitmap-gap))))))) (set! tool-bitmap-y tool-bitmap-gap)))))))
bitmap))) bitmap)))

5
collects/framework/private/bday.ss
View File

@ -1,6 +1,5 @@
#lang mzscheme #lang scheme/base
(require "decode.ss")
(require framework/private/encode-decode)
(decode (decode
\5d8f4 \5d8f4
\10ec22010 \10ec22010

43
collects/framework/private/decode.ss Normal file
View File

@ -0,0 +1,43 @@
#lang scheme/base
(require (for-syntax mzlib/inflate
scheme/base))
(provide decode)
(define-syntax (decode stx)
(syntax-case stx ()
[(_ arg ...)
(andmap identifier? (syntax->list (syntax (arg ...))))
(let ()
(define (decode-sexp str)
(let* ([loc
(let loop ([chars (string->list str)])
(cond
[(null? chars) '()]
[(null? (cdr chars)) (error 'to-sexp "missing digit somewhere")]
[else (let ([fst (to-digit (car chars))]
[snd (to-digit (cadr chars))])
(cons
(+ (* fst 16) snd)
(loop (cddr chars))))]))])
(let-values ([(p-in p-out) (make-pipe)])
(inflate (open-input-bytes (apply bytes loc)) p-out)
(read p-in))))
(define (to-digit char)
(cond
[(char<=? #\0 char #\9)
(- (char->integer char)
(char->integer #\0))]
[(char<=? #\a char #\f)
(+ 10 (- (char->integer char)
(char->integer #\a)))]))
(define decoded
(decode-sexp
(apply
string-append
(map (λ (x) (symbol->string (syntax-e x)))
(syntax->list (syntax (arg ...)))))))
(datum->syntax stx decoded stx))]))

106
collects/framework/private/encode-decode.ss
View File

@ -1,106 +0,0 @@
#lang mzscheme
(require mzlib/deflate
mzlib/match
mzlib/pretty)
(require-for-syntax mzlib/inflate
mzlib/string)
(provide encode-sexp
decode
encode-module)
(define (encode-module in-filename out-filename)
(call-with-input-file in-filename
(λ (port)
(let ([mod (read port)])
(unless (eof-object? (read port))
(error 'encode-module "found an extra expression"))
(match mod
[`(module ,m mzscheme ,@(bodies ...))
(call-with-output-file out-filename
(λ (oport)
(let ([chopped (chop-up (encode-sexp `(begin ,@bodies)))])
(fprintf oport "(module ~a mzscheme\n" m)
(fprintf oport " (require framework/private/encode-decode)\n")
(fprintf oport " (decode ~a" (car chopped))
(for-each (lambda (chopped)
(fprintf oport "\n ~a" chopped))
(cdr chopped))
(fprintf oport "))\n")))
'truncate 'text)]
[else (error 'encode-module "cannot parse module")])))))
(define (chop-up sym)
(let ([chopping-point 50])
(let loop ([str (symbol->string sym)])
(cond
[(<= (string-length str) chopping-point)
(list (string->symbol str))]
[else
(cons (string->symbol (substring str 0 chopping-point))
(loop (substring str chopping-point (string-length str))))]))))
(define (encode-sexp sexp)
(define (str->sym string)
(string->symbol
(apply
string-append
(map
(λ (x)
(to-hex x))
(bytes->list string)))))
(define (to-hex n)
(let ([digit->hex
(λ (d)
(cond
[(<= d 9) d]
[else (integer->char (+ d -10 (char->integer #\a)))]))])
(cond
[(< n 16) (format "0~a" (digit->hex n))]
[else (format "~a~a"
(digit->hex (quotient n 16))
(digit->hex (modulo n 16)))])))
(let ([in (open-input-string (format "~s" sexp))]
[out (open-output-bytes)])
(deflate in out)
(str->sym (get-output-bytes out))))
(define-syntax (decode stx)
(syntax-case stx ()
[(_ arg ...)
(andmap identifier? (syntax->list (syntax (arg ...))))
(let ()
(define (decode-sexp str)
(let* ([loc
(let loop ([chars (string->list str)])
(cond
[(null? chars) '()]
[(null? (cdr chars)) (error 'to-sexp "missing digit somewhere")]
[else (let ([fst (to-digit (car chars))]
[snd (to-digit (cadr chars))])
(cons
(+ (* fst 16) snd)
(loop (cddr chars))))]))])
(let-values ([(p-in p-out) (make-pipe)])
(inflate (open-input-bytes (apply bytes loc)) p-out)
(read p-in))))
(define (to-digit char)
(cond
[(char<=? #\0 char #\9)
(- (char->integer char)
(char->integer #\0))]
[(char<=? #\a char #\f)
(+ 10 (- (char->integer char)
(char->integer #\a)))]))
(define decoded
(decode-sexp
(apply
string-append
(map (λ (x) (symbol->string (syntax-e x)))
(syntax->list (syntax (arg ...)))))))
(datum->syntax-object stx decoded stx))]))

67
collects/framework/private/encode.ss Normal file
View File

@ -0,0 +1,67 @@
#lang scheme/base
(require mzlib/deflate
mzlib/match
mzlib/pretty)
(require (for-syntax mzlib/inflate
mzlib/string))
(provide encode-sexp
encode-module)
(define (encode-module in-filename out-filename)
(call-with-input-file in-filename
(λ (port)
(let ([mod (read port)])
(unless (eof-object? (read port))
(error 'encode-module "found an extra expression"))
(match mod
[`(module ,m mzscheme ,@(bodies ...))
(call-with-output-file out-filename
(λ (oport)
(let ([chopped (chop-up (encode-sexp `(begin ,@bodies)))])
(fprintf oport "(module ~a mzscheme\n" m)
(fprintf oport " (require framework/private/decode)\n")
(fprintf oport " (decode ~a" (car chopped))
(for-each (lambda (chopped)
(fprintf oport "\n ~a" chopped))
(cdr chopped))
(fprintf oport "))\n")))
'truncate 'text)]
[else (error 'encode-module "cannot parse module")])))))
(define (chop-up sym)
(let ([chopping-point 50])
(let loop ([str (symbol->string sym)])
(cond
[(<= (string-length str) chopping-point)
(list (string->symbol str))]
[else
(cons (string->symbol (substring str 0 chopping-point))
(loop (substring str chopping-point (string-length str))))]))))
(define (encode-sexp sexp)
(define (str->sym string)
(string->symbol
(apply
string-append
(map
(λ (x)
(to-hex x))
(bytes->list string)))))
(define (to-hex n)
(let ([digit->hex
(λ (d)
(cond
[(<= d 9) d]
[else (integer->char (+ d -10 (char->integer #\a)))]))])
(cond
[(< n 16) (format "0~a" (digit->hex n))]
[else (format "~a~a"
(digit->hex (quotient n 16))
(digit->hex (modulo n 16)))])))
(let ([in (open-input-string (format "~s" sexp))]
[out (open-output-bytes)])
(deflate in out)
(str->sym (get-output-bytes out))))

138
collects/framework/splash.ss
View File

@ -1,24 +1,29 @@
#lang scheme/base
(module splash mzscheme (require scheme/class
(require mzlib/class scheme/file
mzlib/file scheme/gui/base)
mred)
(provide get-splash-bitmap (provide get-splash-bitmap
set-splash-bitmap set-splash-bitmap
get-splash-canvas get-splash-canvas
get-splash-eventspace get-splash-eventspace
get-splash-paint-callback
set-splash-paint-callback
start-splash start-splash
shutdown-splash shutdown-splash
close-splash close-splash
add-splash-icon add-splash-icon
set-splash-progress-bar?
set-splash-char-observer set-splash-char-observer
set-splash-paint-callback set-splash-event-callback
get-splash-paint-callback get-splash-event-callback
set-splash-event-callback) get-splash-width
get-splash-height)
(define splash-filename #f)
(define splash-bitmap #f) (define splash-bitmap #f)
(define splash-cache-bitmap #f)
(define splash-cache-dc (make-object bitmap-dc%))
(define splash-eventspace (make-eventspace)) (define splash-eventspace (make-eventspace))
(define (get-splash-bitmap) splash-bitmap) (define (get-splash-bitmap) splash-bitmap)
@ -28,14 +33,44 @@
(define (get-splash-canvas) splash-canvas) (define (get-splash-canvas) splash-canvas)
(define (get-splash-eventspace) splash-eventspace) (define (get-splash-eventspace) splash-eventspace)
(define (set-splash-paint-callback pc) (set! splash-paint-callback pc))
(define (get-splash-paint-callback) splash-paint-callback) (define (get-splash-paint-callback) splash-paint-callback)
(define (set-splash-event-callback ec) (set! splash-event-callback ec)) (define (set-splash-paint-callback sp)
(set! splash-paint-callback sp)
(refresh-splash))
(define (splash-paint-callback dc) (define (get-splash-width) (send splash-canvas get-width))
(if splash-bitmap (define (get-splash-height) (send splash-canvas get-height))
(send dc draw-bitmap splash-bitmap 0 0)
(send dc clear)) (define (set-splash-event-callback cb) (set! splash-event-callback cb))
(define (get-splash-event-callback cb) splash-event-callback)
(define (refresh-splash)
(define (recompute-bitmap/refresh)
(send splash-cache-dc set-bitmap splash-cache-bitmap)
(call-splash-paint-callback splash-cache-dc)
(send splash-cache-dc set-bitmap #f)
(send splash-canvas on-paint))
(cond
[(not (is-a? splash-cache-bitmap bitmap%)) (void)]
[(eq? (current-thread) (eventspace-handler-thread splash-eventspace))
(recompute-bitmap/refresh)]
[else
(parameterize ([current-eventspace splash-eventspace])
(queue-callback
recompute-bitmap/refresh))]))
(define (call-splash-paint-callback dc)
(cond
[(equal? 1 (procedure-arity splash-paint-callback))
(splash-paint-callback dc)]
[else
(splash-paint-callback dc
(send gauge get-value)
(send gauge get-range)
(get-splash-width)
(get-splash-height))])
(for-each (λ (icon) (for-each (λ (icon)
(send dc draw-bitmap (send dc draw-bitmap
(icon-bm icon) (icon-bm icon)
@ -45,6 +80,16 @@
(make-object color% "black") (make-object color% "black")
(send (icon-bm icon) get-loaded-mask))) (send (icon-bm icon) get-loaded-mask)))
icons)) icons))
(define (set-splash-progress-bar? b?)
(send gauge-panel change-children
(λ (l) (if b? (list gauge) '()))))
(define (splash-paint-callback dc)
(if splash-bitmap
(send dc draw-bitmap splash-bitmap 0 0)
(send dc clear)))
(define (splash-event-callback evt) (void)) (define (splash-event-callback evt) (void))
(define char-observer void) (define char-observer void)
@ -55,11 +100,10 @@
(define icons null) (define icons null)
(define (add-splash-icon bm x y) (define (add-splash-icon bm x y)
(set! icons (cons (make-icon bm x y) icons)) (set! icons (cons (make-icon bm x y) icons))
(send splash-canvas on-paint)) (refresh-splash))
(define (start-splash _splash-filename _splash-title width-default) (define (start-splash splash-draw-spec _splash-title width-default)
(set! splash-title _splash-title) (set! splash-title _splash-title)
(set! splash-filename _splash-filename)
(set! splash-max-width (max 1 (splash-get-preference (get-splash-width-preference-name) width-default))) (set! splash-max-width (max 1 (splash-get-preference (get-splash-width-preference-name) width-default)))
(send gauge set-range splash-max-width) (send gauge set-range splash-max-width)
(send splash-frame set-label splash-title) (send splash-frame set-label splash-title)
@ -70,19 +114,41 @@
(set! splash-eventspace #f) (set! splash-eventspace #f)
(k (void))) (k (void)))
(unless splash-filename (cond
(no-splash)) [(or (path? splash-draw-spec)
(unless (file-exists? splash-filename) (string? splash-draw-spec))
(fprintf (current-error-port) "WARNING: bitmap path ~s not found~n" splash-filename) (unless (file-exists? splash-draw-spec)
(fprintf (current-error-port) "WARNING: bitmap path ~s not found~n" splash-draw-spec)
(no-splash)) (no-splash))
(set! splash-bitmap (make-object bitmap% splash-filename)) (set! splash-bitmap (make-object bitmap% splash-draw-spec))
(unless (send splash-bitmap ok?) (unless (send splash-bitmap ok?)
(fprintf (current-error-port) "WARNING: bad bitmap ~s~n" splash-filename) (fprintf (current-error-port) "WARNING: bad bitmap ~s~n" splash-draw-spec)
(no-splash)) (no-splash))
(send splash-canvas min-width (send splash-bitmap get-width)) (send splash-canvas min-width (send splash-bitmap get-width))
(send splash-canvas min-height (send splash-bitmap get-height)) (send splash-canvas min-height (send splash-bitmap get-height))
(set! splash-cache-bitmap (make-object bitmap%
(send splash-bitmap get-width)
(send splash-bitmap get-height)))]
[(and (vector? splash-draw-spec)
(procedure? (vector-ref splash-draw-spec 0))
(number? (vector-ref splash-draw-spec 1))
(number? (vector-ref splash-draw-spec 2)))
(set! splash-paint-callback (vector-ref splash-draw-spec 0))
(send splash-canvas min-width (vector-ref splash-draw-spec 1))
(send splash-canvas min-height (vector-ref splash-draw-spec 2))
(set! splash-cache-bitmap (make-object bitmap%
(vector-ref splash-draw-spec 1)
(vector-ref splash-draw-spec 2)))]
[(not splash-draw-spec)
(no-splash)]
[else
(fprintf (current-error-port)
"WARNING: unknown splash spec: ~s" splash-draw-spec)
(no-splash)])
(refresh-splash)
(send splash-frame center 'both) (send splash-frame center 'both)
(send splash-frame show #t) (send splash-frame show #t)
(flush-display) (yield) (sleep) (flush-display) (yield) (sleep)
@ -118,14 +184,17 @@
(let ([finalf (splitup-path f)]) (let ([finalf (splitup-path f)])
(set! splash-current-width (+ splash-current-width 1)) (set! splash-current-width (+ splash-current-width 1))
(when (<= splash-current-width splash-max-width) (when (<= splash-current-width splash-max-width)
(send gauge set-value splash-current-width)) (send gauge set-value splash-current-width)
(unless (member gauge (send gauge-panel get-children))
;; when the gauge is not visible, we'll redraw the canvas
(refresh-splash)))
(old-load f expected))) (old-load f expected)))
(let-values ([(make-compilation-manager-load/use-compiled-handler (let-values ([(make-compilation-manager-load/use-compiled-handler
manager-trace-handler) manager-trace-handler)
(if (or (getenv "PLTDRCM") (if (or (getenv "PLTDRCM")
(getenv "PLTDRDEBUG")) (getenv "PLTDRDEBUG"))
(parameterize ([current-namespace (make-namespace)]) (parameterize ([current-namespace (make-base-namespace)])
(values (values
(dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler) (dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler)
(dynamic-require 'compiler/cm 'manager-trace-handler))) (dynamic-require 'compiler/cm 'manager-trace-handler)))
@ -155,6 +224,9 @@
(make-object bitmap% (build-path (collection-path "icons") "touch.bmp"))] (make-object bitmap% (build-path (collection-path "icons") "touch.bmp"))]
[max-value 1]) [max-value 1])
(define/public (get-range) max-value)
(define/public (get-value) funny-value)
[define/public set-range (λ (r) (set! max-value r))] [define/public set-range (λ (r) (set! max-value r))]
[define/public set-value [define/public set-value
(λ (new-value) (λ (new-value)
@ -225,9 +297,9 @@
(define splash-canvas% (define splash-canvas%
(class canvas% (class canvas%
(inherit get-dc) (inherit get-client-size get-dc)
(define/override (on-char evt) (char-observer evt)) (define/override (on-char evt) (char-observer evt))
(define/override (on-paint) (splash-paint-callback (get-dc))) (define/override (on-paint) (send (get-dc) draw-bitmap splash-cache-bitmap 0 0))
(define/override (on-event evt) (splash-event-callback evt)) (define/override (on-event evt) (splash-event-callback evt))
(super-new))) (super-new)))
@ -239,15 +311,15 @@
(send splash-frame set-alignment 'center 'center) (send splash-frame set-alignment 'center 'center)
(define panel (make-object vertical-pane% splash-frame)) (define panel (make-object vertical-pane% splash-frame))
(define splash-canvas (make-object splash-canvas% panel)) (define splash-canvas (new splash-canvas% [parent panel] [style '(no-autoclear)]))
(define h-panel (make-object horizontal-pane% panel)) (define gauge-panel (make-object horizontal-pane% panel))
(define gauge (define gauge
(if funny? (if funny?
(make-object funny-gauge% h-panel) (make-object funny-gauge% gauge-panel)
(make-object gauge% #f splash-max-width h-panel '(horizontal)))) (make-object gauge% #f splash-max-width gauge-panel '(horizontal))))
(send panel stretchable-width #f) (send panel stretchable-width #f)
(send panel stretchable-height #f) (send panel stretchable-height #f)
(send h-panel set-alignment 'center 'top) (send gauge-panel set-alignment 'center 'top)
(send splash-canvas focus) (send splash-canvas focus)
(send splash-canvas stretchable-width #f) (send splash-canvas stretchable-width #f)
(send splash-canvas stretchable-height #f)) (send splash-canvas stretchable-height #f)

10
collects/mzlib/inflate.ss
View File

@ -1,5 +1,5 @@
#lang scheme/base
(module inflate mzscheme (require (for-syntax scheme/base))
(provide inflate (provide inflate
gunzip-through-ports gunzip-through-ports
@ -120,7 +120,7 @@
error in the data. */ error in the data. */
|# |#
(define-struct huft (e b v)) (define-struct huft (e b v) #:mutable)
(define (huft-copy dest src) (define (huft-copy dest src)
(set-huft-e! dest (huft-e src)) (set-huft-e! dest (huft-e src))
@ -591,7 +591,7 @@
(set! t (vector-ref tl (bitwise-and bb ml))) (set! t (vector-ref tl (bitwise-and bb ml)))
; (printf "t->e: ~s t->b: ~s\n" (huft-e t) (huft-b t)) ; (printf "t->e: ~s t->b: ~s\n" (huft-e t) (huft-b t))
(set! e (huft-e t)) (set! e (huft-e t))
(if (> e 16) (when (> e 16)
(jump-to-next)) (jump-to-next))
(DUMPBITS (huft-b t)) (DUMPBITS (huft-b t))
; (printf "e: ~s\n" e) ; (printf "e: ~s\n" e)
@ -928,4 +928,4 @@
void void
(lambda () (do-gunzip in #f name-filter)) (lambda () (do-gunzip in #f name-filter))
(lambda () (close-input-port in))))])) (lambda () (close-input-port in))))]))
)