From 283c1819a92df7e6949ece8eebf659aac777583c Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 6 Mar 2009 16:35:04 +0000 Subject: [PATCH] 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) svn: r13980 --- collects/algol60/bd-tool.ss | 2 +- collects/drscheme/private/drscheme-normal.ss | 103 ++-- collects/drscheme/private/honu-logo.ss | 529 ++++++++++++++++++ collects/drscheme/private/palaka.ss | 67 +++ collects/drscheme/private/tools.ss | 64 +-- collects/framework/private/bday.ss | 7 +- collects/framework/private/decode.ss | 43 ++ collects/framework/private/encode-decode.ss | 106 ---- collects/framework/private/encode.ss | 67 +++ collects/framework/splash.ss | 554 +++++++++++-------- collects/mzlib/inflate.ss | 12 +- 11 files changed, 1106 insertions(+), 448 deletions(-) create mode 100644 collects/drscheme/private/honu-logo.ss create mode 100755 collects/drscheme/private/palaka.ss create mode 100644 collects/framework/private/decode.ss delete mode 100644 collects/framework/private/encode-decode.ss create mode 100644 collects/framework/private/encode.ss diff --git a/collects/algol60/bd-tool.ss b/collects/algol60/bd-tool.ss index 731de43fc3..2e95304066 100644 --- a/collects/algol60/bd-tool.ss +++ b/collects/algol60/bd-tool.ss @@ -1,5 +1,5 @@ (module bd-tool mzscheme - (require framework/private/encode-decode) + (require framework/private/decode) (decode 05c1dd6edc460c06d057f9226301b2e86c5c23690103a9835c e53a0f50602852d2ecce8f324379adb7ef3924b6a60aeaf6fb 48dd403909a6d24daf634c984a379d189493609a731ce33ac6 diff --git a/collects/drscheme/private/drscheme-normal.ss b/collects/drscheme/private/drscheme-normal.ss index eeea39a3de..cd978d5395 100644 --- a/collects/drscheme/private/drscheme-normal.ss +++ b/collects/drscheme/private/drscheme-normal.ss @@ -2,41 +2,35 @@ (require mred scheme/class - mzlib/cmdline + scheme/cmdline scheme/list - framework/private/bday) + framework/private/bday + framework/splash) -; (current-load text-editor-load-handler) - -(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))))) +(define files-to-open (command-line #:args filenames filenames)) ;; updates the command-line-arguments with only the files ;; to open. See also main.ss. (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))] [month (date-month date)] [day (date-day date)]) (values (and (= 3 month) (= 2 day)) + (and (= 3 month) (= 26 day)) + (and (= 6 month) (= 11 day)) (and (= 10 month) (= 31 day))))) (define high-color? ((get-display-depth) . > . 8)) (define special-state #f) (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 (magic-img str img) @@ -77,23 +71,21 @@ (when ((length key-codes) . > . longest-magic-string) (set! key-codes (take key-codes longest-magic-string)))) -(let ([set-splash-bitmap - (dynamic-require 'framework/splash 'set-splash-bitmap)]) - ((dynamic-require 'framework/splash 'set-splash-char-observer) - (λ (evt) - (let ([ch (send evt get-key-code)]) - (when (char? ch) - ;; as soon as something is typed, load the bitmaps - (load-magic-images) - (add-key-code ch) - (let ([match (find-magic-image)]) - (when match - (set! key-codes null) - (set-splash-bitmap - (if (eq? special-state match) - (begin (set! special-state #f) normal-bitmap) - (begin (set! special-state match) - (magic-image-bitmap match))))))))))) +(set-splash-char-observer + (λ (evt) + (let ([ch (send evt get-key-code)]) + (when (char? ch) + ;; as soon as something is typed, load the bitmaps + (load-magic-images) + (add-key-code ch) + (let ([match (find-magic-image)]) + (when match + (set! key-codes null) + (set-splash-bitmap + (if (eq? special-state match) + (begin (set! special-state #f) normal-bitmap) + (begin (set! special-state match) + (magic-image-bitmap match)))))))))) (when (eb-bday?) (let () @@ -137,7 +129,7 @@ [(< angle 0) (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) (send bdc draw-bitmap eli 0 0) (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) (cond [(send evt leaving?) - ((dynamic-require 'framework/splash 'set-splash-paint-callback) orig-paint) + (set-splash-paint-callback orig-paint) (when gc-b (unregister-collecting-blit splash-canvas)) (send splash-canvas refresh) @@ -192,7 +184,7 @@ (kill-thread draw-thread) (set! draw-thread #f))] [(send evt entering?) - ((dynamic-require 'framework/splash 'set-splash-paint-callback) eli-paint) + (set-splash-paint-callback eli-paint) (when gc-b (register-collecting-blit splash-canvas (floor (- (/ main-size 2) @@ -206,7 +198,7 @@ (unless draw-thread (start-thread))])) - (define splash-eventspace ((dynamic-require 'framework/splash 'get-splash-eventspace))) + (define splash-eventspace (get-splash-eventspace)) (define draw-next-state (let ([o 0]) (lambda () @@ -231,24 +223,29 @@ (draw-next-state) (sleep .01) (loop)))))) - (define orig-paint ((dynamic-require 'framework/splash 'get-splash-paint-callback))) + (define orig-paint (get-splash-paint-callback)) (draw-next-state) - ((dynamic-require 'framework/splash 'set-splash-event-callback) eli-event) + (set-splash-event-callback eli-event) (send splash-canvas refresh))) -((dynamic-require 'framework/splash 'start-splash) - (build-path (collection-path "icons") - (cond - [texas-independence-day? - "texas-plt-bw.gif"] - [(and halloween? high-color?) - "PLT-pumpkin.png"] - [high-color? "PLT-206.png"] - [(= (get-display-depth) 1) - "pltbw.gif"] - [else - "plt-flat.gif"])) +(start-splash + (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? + (build-path (collection-path "icons") "texas-plt-bw.gif")] + [(and halloween? high-color?) + (build-path (collection-path "icons") "PLT-pumpkin.png")] + [high-color? + (build-path (collection-path "icons") "PLT-206.png")] + [(= (get-display-depth) 1) + (build-path (collection-path "icons") "pltbw.gif")] + [else + (build-path (collection-path "icons") "plt-flat.gif")]) "DrScheme" 99) diff --git a/collects/drscheme/private/honu-logo.ss b/collects/drscheme/private/honu-logo.ss new file mode 100644 index 0000000000..93646fa60c --- /dev/null +++ b/collects/drscheme/private/honu-logo.ss @@ -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)) + diff --git a/collects/drscheme/private/palaka.ss b/collects/drscheme/private/palaka.ss new file mode 100755 index 0000000000..020b17479e --- /dev/null +++ b/collects/drscheme/private/palaka.ss @@ -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) \ No newline at end of file diff --git a/collects/drscheme/private/tools.ss b/collects/drscheme/private/tools.ss index 3dee1a85cf..598aef8345 100644 --- a/collects/drscheme/private/tools.ss +++ b/collects/drscheme/private/tools.ss @@ -1,15 +1,16 @@ #lang scheme/unit -(require setup/getinfo - mred - scheme/class +(require scheme/class scheme/list + scheme/runtime-path + scheme/contract + setup/getinfo + mred + framework + framework/splash "drsig.ss" "language-object-contract.ss" - scheme/contract - framework - string-constants - scheme/runtime-path) + string-constants) (require (for-syntax scheme/base scheme/match)) @@ -349,13 +350,12 @@ (unless (and (is-a? bitmap bitmap%) (send bitmap ok?)) (k #f)) - (let ([splash-eventspace ((dynamic-require 'framework/splash 'get-splash-eventspace))] - [splash-bitmap ((dynamic-require 'framework/splash 'get-splash-bitmap))] - [splash-canvas ((dynamic-require 'framework/splash 'get-splash-canvas))]) + (let ([splash-eventspace (get-splash-eventspace)] + [splash-canvas (get-splash-canvas)] + [splash-width (get-splash-width)] + [splash-height (get-splash-height)]) (unless (and (eventspace? splash-eventspace) - (is-a? splash-bitmap bitmap%) - (send splash-bitmap ok?) (is-a? splash-canvas canvas%)) (k (void))) @@ -363,36 +363,26 @@ (queue-callback (lambda () (let ([bdc (make-object bitmap-dc%)] - [translated-tool-bitmap-y (max 0 (- (send splash-bitmap get-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))) + [translated-tool-bitmap-y + (max 0 (- splash-height tool-bitmap-y tool-bitmap-size))]) + ;; 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) - 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)) - (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-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))))))) bitmap))) diff --git a/collects/framework/private/bday.ss b/collects/framework/private/bday.ss index 82dbf74732..72b3d33c00 100644 --- a/collects/framework/private/bday.ss +++ b/collects/framework/private/bday.ss @@ -1,7 +1,6 @@ -#lang mzscheme - - (require framework/private/encode-decode) - (decode +#lang scheme/base +(require "decode.ss") +(decode \5d8f4 \10ec22010 \45aff297b02 diff --git a/collects/framework/private/decode.ss b/collects/framework/private/decode.ss new file mode 100644 index 0000000000..da5f086199 --- /dev/null +++ b/collects/framework/private/decode.ss @@ -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))])) diff --git a/collects/framework/private/encode-decode.ss b/collects/framework/private/encode-decode.ss deleted file mode 100644 index a24cfb2885..0000000000 --- a/collects/framework/private/encode-decode.ss +++ /dev/null @@ -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))])) diff --git a/collects/framework/private/encode.ss b/collects/framework/private/encode.ss new file mode 100644 index 0000000000..45084ac28c --- /dev/null +++ b/collects/framework/private/encode.ss @@ -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)))) diff --git a/collects/framework/splash.ss b/collects/framework/splash.ss index 656ba27165..240059e007 100644 --- a/collects/framework/splash.ss +++ b/collects/framework/splash.ss @@ -1,253 +1,325 @@ +#lang scheme/base -(module splash mzscheme - (require mzlib/class - mzlib/file - mred) - - (provide get-splash-bitmap - set-splash-bitmap - get-splash-canvas - get-splash-eventspace - start-splash - shutdown-splash - close-splash - add-splash-icon - set-splash-char-observer - set-splash-paint-callback - get-splash-paint-callback - set-splash-event-callback) - - (define splash-filename #f) - (define splash-bitmap #f) - (define splash-eventspace (make-eventspace)) - - (define (get-splash-bitmap) splash-bitmap) - (define (set-splash-bitmap bm) - (set! splash-bitmap bm) - (send splash-canvas on-paint)) - (define (get-splash-canvas) splash-canvas) - (define (get-splash-eventspace) splash-eventspace) +(require scheme/class + scheme/file + scheme/gui/base) - (define (set-splash-paint-callback pc) (set! splash-paint-callback pc)) - (define (get-splash-paint-callback) splash-paint-callback) - (define (set-splash-event-callback ec) (set! splash-event-callback ec)) +(provide get-splash-bitmap + set-splash-bitmap + get-splash-canvas + get-splash-eventspace + get-splash-paint-callback + set-splash-paint-callback + start-splash + shutdown-splash + close-splash + add-splash-icon + set-splash-progress-bar? + set-splash-char-observer + set-splash-event-callback + get-splash-event-callback + get-splash-width + get-splash-height) + +(define splash-bitmap #f) +(define splash-cache-bitmap #f) +(define splash-cache-dc (make-object bitmap-dc%)) +(define splash-eventspace (make-eventspace)) + +(define (get-splash-bitmap) splash-bitmap) +(define (set-splash-bitmap bm) + (set! splash-bitmap bm) + (send splash-canvas on-paint)) +(define (get-splash-canvas) splash-canvas) +(define (get-splash-eventspace) splash-eventspace) + +(define (get-splash-paint-callback) splash-paint-callback) +(define (set-splash-paint-callback sp) + (set! splash-paint-callback sp) + (refresh-splash)) + +(define (get-splash-width) (send splash-canvas get-width)) +(define (get-splash-height) (send splash-canvas get-height)) + +(define (set-splash-event-callback cb) (set! splash-event-callback cb)) +(define (get-splash-event-callback cb) splash-event-callback) + +(define (refresh-splash) - (define (splash-paint-callback dc) - (if splash-bitmap - (send dc draw-bitmap splash-bitmap 0 0) - (send dc clear)) - (for-each (λ (icon) - (send dc draw-bitmap - (icon-bm icon) - (icon-x icon) - (icon-y icon) - 'solid - (make-object color% "black") - (send (icon-bm icon) get-loaded-mask))) - icons)) - (define (splash-event-callback evt) (void)) - - (define char-observer void) - (define (set-splash-char-observer proc) - (set! char-observer proc)) - - (define-struct icon (bm x y)) - (define icons null) - (define (add-splash-icon bm x y) - (set! icons (cons (make-icon bm x y) icons)) + (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)) - (define (start-splash _splash-filename _splash-title width-default) - (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))) - (send gauge set-range splash-max-width) - (send splash-frame set-label splash-title) - (let/ec k - (define (no-splash) - (set! splash-bitmap #f) - (set! splash-canvas #f) - (set! splash-eventspace #f) - (k (void))) - - (unless splash-filename - (no-splash)) - (unless (file-exists? splash-filename) - (fprintf (current-error-port) "WARNING: bitmap path ~s not found~n" splash-filename) - (no-splash)) - - (set! splash-bitmap (make-object bitmap% splash-filename)) - (unless (send splash-bitmap ok?) - (fprintf (current-error-port) "WARNING: bad bitmap ~s~n" splash-filename) - (no-splash)) - - (send splash-canvas min-width (send splash-bitmap get-width)) - (send splash-canvas min-height (send splash-bitmap get-height)) - (send splash-frame center 'both) - (send splash-frame show #t) - (flush-display) (yield) (sleep) - (flush-display) (yield) (sleep))) + (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) + (send dc draw-bitmap + (icon-bm icon) + (icon-x icon) + (icon-y icon) + 'solid + (make-object color% "black") + (send (icon-bm icon) get-loaded-mask))) + 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 char-observer void) +(define (set-splash-char-observer proc) + (set! char-observer proc)) + +(define-struct icon (bm x y)) +(define icons null) +(define (add-splash-icon bm x y) + (set! icons (cons (make-icon bm x y) icons)) + (refresh-splash)) + +(define (start-splash splash-draw-spec _splash-title width-default) + (set! splash-title _splash-title) + (set! splash-max-width (max 1 (splash-get-preference (get-splash-width-preference-name) width-default))) + (send gauge set-range splash-max-width) + (send splash-frame set-label splash-title) + (let/ec k + (define (no-splash) + (set! splash-bitmap #f) + (set! splash-canvas #f) + (set! splash-eventspace #f) + (k (void))) - (define splash-title "no title") - - (define splash-current-width 0) - - (define (get-splash-width-preference-name) - (string->symbol (format "plt:~a-splash-max-width" splash-title))) - (define splash-max-width 1) - - (define (close-splash) - (unless (= splash-max-width splash-current-width) - (splash-set-preference (get-splash-width-preference-name) (max 1 splash-current-width))) - (set! quit-on-close? #f) - (when splash-frame - (send splash-frame show #f))) - - (define (shutdown-splash) - (set! splash-load-handler (λ (old-load f expected) (old-load f expected)))) - - (define funny? - (let ([date (seconds->date (current-seconds))]) - (and (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) - (collection-path "icons") - #t) - (= (date-day date) 25) - (= (date-month date) 12)))) - - (define (splash-load-handler old-load f expected) - (let ([finalf (splitup-path f)]) - (set! splash-current-width (+ splash-current-width 1)) - (when (<= splash-current-width splash-max-width) - (send gauge set-value splash-current-width)) - (old-load f expected))) - - (let-values ([(make-compilation-manager-load/use-compiled-handler - manager-trace-handler) - (if (or (getenv "PLTDRCM") - (getenv "PLTDRDEBUG")) - (parameterize ([current-namespace (make-namespace)]) - (values - (dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler) - (dynamic-require 'compiler/cm 'manager-trace-handler))) - (values #f #f))]) + (cond + [(or (path? splash-draw-spec) + (string? splash-draw-spec)) + (unless (file-exists? splash-draw-spec) + (fprintf (current-error-port) "WARNING: bitmap path ~s not found~n" splash-draw-spec) + (no-splash)) + + (set! splash-bitmap (make-object bitmap% splash-draw-spec)) + (unless (send splash-bitmap ok?) + (fprintf (current-error-port) "WARNING: bad bitmap ~s~n" splash-draw-spec) + (no-splash)) + + (send splash-canvas min-width (send splash-bitmap get-width)) + (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)]) - (current-load - (let ([old-load (current-load)]) - (λ (f expected) - (splash-load-handler old-load f expected)))) - - (when (and make-compilation-manager-load/use-compiled-handler + (refresh-splash) + (send splash-frame center 'both) + (send splash-frame show #t) + (flush-display) (yield) (sleep) + (flush-display) (yield) (sleep))) + +(define splash-title "no title") + +(define splash-current-width 0) + +(define (get-splash-width-preference-name) + (string->symbol (format "plt:~a-splash-max-width" splash-title))) +(define splash-max-width 1) + +(define (close-splash) + (unless (= splash-max-width splash-current-width) + (splash-set-preference (get-splash-width-preference-name) (max 1 splash-current-width))) + (set! quit-on-close? #f) + (when splash-frame + (send splash-frame show #f))) + +(define (shutdown-splash) + (set! splash-load-handler (λ (old-load f expected) (old-load f expected)))) + +(define funny? + (let ([date (seconds->date (current-seconds))]) + (and (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) + (collection-path "icons") + #t) + (= (date-day date) 25) + (= (date-month date) 12)))) + +(define (splash-load-handler old-load f expected) + (let ([finalf (splitup-path f)]) + (set! splash-current-width (+ splash-current-width 1)) + (when (<= splash-current-width splash-max-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))) + +(let-values ([(make-compilation-manager-load/use-compiled-handler manager-trace-handler) - (printf "PLTDRCM/PLTDRDEBUG: reinstalling CM load handler after setting splash load handler\n") - (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler)) - (when (or (equal? (getenv "PLTDRCM") "trace") - (equal? (getenv "PLTDRDEBUG") "trace")) - (printf "PLTDRCM/PLTDRDEBUG: reinstalling CM trace handler after setting splash load handler\n") - (manager-trace-handler - (λ (x) (display "2: ") (display x) (newline)))))) + (if (or (getenv "PLTDRCM") + (getenv "PLTDRDEBUG")) + (parameterize ([current-namespace (make-base-namespace)]) + (values + (dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler) + (dynamic-require 'compiler/cm 'manager-trace-handler))) + (values #f #f))]) - (define funny-gauge% - (class canvas% - (inherit get-dc min-width min-height stretchable-width stretchable-height) - (field - [funny-value 0] - [funny-bitmap - (make-object bitmap% (build-path (collection-path "icons") "touch.bmp"))] - [max-value 1]) + (current-load + (let ([old-load (current-load)]) + (λ (f expected) + (splash-load-handler old-load f expected)))) + + (when (and make-compilation-manager-load/use-compiled-handler + manager-trace-handler) + (printf "PLTDRCM/PLTDRDEBUG: reinstalling CM load handler after setting splash load handler\n") + (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler)) + (when (or (equal? (getenv "PLTDRCM") "trace") + (equal? (getenv "PLTDRDEBUG") "trace")) + (printf "PLTDRCM/PLTDRDEBUG: reinstalling CM trace handler after setting splash load handler\n") + (manager-trace-handler + (λ (x) (display "2: ") (display x) (newline)))))) - [define/public set-range (λ (r) (set! max-value r))] - [define/public set-value - (λ (new-value) - (let* ([before-x - (floor (* (send funny-bitmap get-width) (/ funny-value max-value)))] - [after-x - (ceiling (* (send funny-bitmap get-width) (/ new-value max-value)))] - [width (- after-x before-x)]) - (send (get-dc) draw-line - (+ before-x 2) 0 - (+ width 2) 0) - (send (get-dc) draw-line - (+ before-x 2) (+ (send funny-bitmap get-height) 4) - (+ width 2) (+ (send funny-bitmap get-height) 4)) - (send (get-dc) draw-bitmap-section funny-bitmap - (+ 2 before-x) 2 - before-x 0 - width (send funny-bitmap get-height))) - (set! funny-value new-value))] +(define funny-gauge% + (class canvas% + (inherit get-dc min-width min-height stretchable-width stretchable-height) + (field + [funny-value 0] + [funny-bitmap + (make-object bitmap% (build-path (collection-path "icons") "touch.bmp"))] + [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-value + (λ (new-value) + (let* ([before-x + (floor (* (send funny-bitmap get-width) (/ funny-value max-value)))] + [after-x + (ceiling (* (send funny-bitmap get-width) (/ new-value max-value)))] + [width (- after-x before-x)]) + (send (get-dc) draw-line + (+ before-x 2) 0 + (+ width 2) 0) + (send (get-dc) draw-line + (+ before-x 2) (+ (send funny-bitmap get-height) 4) + (+ width 2) (+ (send funny-bitmap get-height) 4)) + (send (get-dc) draw-bitmap-section funny-bitmap + (+ 2 before-x) 2 + before-x 0 + width (send funny-bitmap get-height))) + (set! funny-value new-value))] + + [define/override (on-paint) + (let ([dc (get-dc)]) + (send dc clear) + (send dc draw-rectangle 0 0 + (+ (send funny-bitmap get-width) 4) + (+ (send funny-bitmap get-height) 4)) + (send dc draw-bitmap-section funny-bitmap + 2 2 0 0 + (* (send funny-bitmap get-width) (/ funny-value max-value)) + (send funny-bitmap get-height)))] + + (super-instantiate ()) + (min-width (+ (send funny-bitmap get-width) 4)) + (min-height (+ (send funny-bitmap get-height) 4)) + (stretchable-width #f) + (stretchable-height #f))) - [define/override (on-paint) - (let ([dc (get-dc)]) - (send dc clear) - (send dc draw-rectangle 0 0 - (+ (send funny-bitmap get-width) 4) - (+ (send funny-bitmap get-height) 4)) - (send dc draw-bitmap-section funny-bitmap - 2 2 0 0 - (* (send funny-bitmap get-width) (/ funny-value max-value)) - (send funny-bitmap get-height)))] +(define (splash-get-preference name default) + (get-preference + name + (λ () + default))) +(define (splash-set-preference name value) + (put-preferences (list name) (list value))) - (super-instantiate ()) - (min-width (+ (send funny-bitmap get-width) 4)) - (min-height (+ (send funny-bitmap get-height) 4)) - (stretchable-width #f) - (stretchable-height #f))) - - (define (splash-get-preference name default) - (get-preference - name - (λ () - default))) - (define (splash-set-preference name value) - (put-preferences (list name) (list value))) - - (define (splitup-path f) - (let*-values ([(absf) (if (relative-path? f) - (build-path (current-directory) f) - f)] - [(base name _1) (split-path absf)]) - - (if base - (let-values ([(base2 name2 _2) (split-path base)]) - (if base2 - (let-values ([(base3 name3 _2) (split-path base2)]) - (build-path name3 name2 name)) - (build-path name2 name))) - name))) - - (define quit-on-close? #t) - - (define splash-frame% - (class frame% - (define/augment (on-close) - (when quit-on-close? - (exit))) - (super-new))) - - (define splash-canvas% - (class canvas% - (inherit get-dc) - (define/override (on-char evt) (char-observer evt)) - (define/override (on-paint) (splash-paint-callback (get-dc))) - (define/override (on-event evt) (splash-event-callback evt)) - (super-new))) - - (define splash-frame - (parameterize ([current-eventspace splash-eventspace]) - (instantiate splash-frame% () - (label splash-title) - (style '(no-resize-border))))) - (send splash-frame set-alignment 'center 'center) - - (define panel (make-object vertical-pane% splash-frame)) - (define splash-canvas (make-object splash-canvas% panel)) - (define h-panel (make-object horizontal-pane% panel)) - (define gauge - (if funny? - (make-object funny-gauge% h-panel) - (make-object gauge% #f splash-max-width h-panel '(horizontal)))) - (send panel stretchable-width #f) - (send panel stretchable-height #f) - (send h-panel set-alignment 'center 'top) - (send splash-canvas focus) - (send splash-canvas stretchable-width #f) - (send splash-canvas stretchable-height #f)) +(define (splitup-path f) + (let*-values ([(absf) (if (relative-path? f) + (build-path (current-directory) f) + f)] + [(base name _1) (split-path absf)]) + + (if base + (let-values ([(base2 name2 _2) (split-path base)]) + (if base2 + (let-values ([(base3 name3 _2) (split-path base2)]) + (build-path name3 name2 name)) + (build-path name2 name))) + name))) + +(define quit-on-close? #t) + +(define splash-frame% + (class frame% + (define/augment (on-close) + (when quit-on-close? + (exit))) + (super-new))) + +(define splash-canvas% + (class canvas% + (inherit get-client-size get-dc) + (define/override (on-char evt) (char-observer evt)) + (define/override (on-paint) (send (get-dc) draw-bitmap splash-cache-bitmap 0 0)) + (define/override (on-event evt) (splash-event-callback evt)) + (super-new))) + +(define splash-frame + (parameterize ([current-eventspace splash-eventspace]) + (instantiate splash-frame% () + (label splash-title) + (style '(no-resize-border))))) +(send splash-frame set-alignment 'center 'center) + +(define panel (make-object vertical-pane% splash-frame)) +(define splash-canvas (new splash-canvas% [parent panel] [style '(no-autoclear)])) +(define gauge-panel (make-object horizontal-pane% panel)) +(define gauge + (if funny? + (make-object funny-gauge% gauge-panel) + (make-object gauge% #f splash-max-width gauge-panel '(horizontal)))) +(send panel stretchable-width #f) +(send panel stretchable-height #f) +(send gauge-panel set-alignment 'center 'top) +(send splash-canvas focus) +(send splash-canvas stretchable-width #f) +(send splash-canvas stretchable-height #f) diff --git a/collects/mzlib/inflate.ss b/collects/mzlib/inflate.ss index cf7441d90a..5a8ae877b2 100644 --- a/collects/mzlib/inflate.ss +++ b/collects/mzlib/inflate.ss @@ -1,5 +1,5 @@ - -(module inflate mzscheme +#lang scheme/base +(require (for-syntax scheme/base)) (provide inflate gunzip-through-ports @@ -120,7 +120,7 @@ error in the data. */ |# - (define-struct huft (e b v)) + (define-struct huft (e b v) #:mutable) (define (huft-copy dest src) (set-huft-e! dest (huft-e src)) @@ -591,8 +591,8 @@ (set! t (vector-ref tl (bitwise-and bb ml))) ; (printf "t->e: ~s t->b: ~s\n" (huft-e t) (huft-b t)) (set! e (huft-e t)) - (if (> e 16) - (jump-to-next)) + (when (> e 16) + (jump-to-next)) (DUMPBITS (huft-b t)) ; (printf "e: ~s\n" e) (if (= e 16) ; /* then it's a literal */ @@ -928,4 +928,4 @@ void (lambda () (do-gunzip in #f name-filter)) (lambda () (close-input-port in))))])) -) +