diff --git a/collects/drscheme/private/drscheme-normal.ss b/collects/drscheme/private/drscheme-normal.ss index ade759ac95..a797e2b001 100644 --- a/collects/drscheme/private/drscheme-normal.ss +++ b/collects/drscheme/private/drscheme-normal.ss @@ -4,7 +4,7 @@ (lib "class.ss") (lib "cmdline.ss") (lib "bday.ss" "framework" "private")) - + ;; this used to be done by mred, but ;; since drscheme uses the -Z flag now, ;; we have to do it explicitly. @@ -18,98 +18,93 @@ [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 ;; to open. See also main.ss. (current-command-line-arguments (apply vector files-to-open)) - + (define-values (texas-independence-day? halloween?) (let* ([date (seconds->date (current-seconds))] [month (date-month date)] [day (date-day date)]) (values (and (= 3 month) (= 2 day)) (and (= 10 month) (= 31 day))))) - + (define high-color? ((get-display-depth) . > . 8)) (define special-state #f) - (define normal-bitmap #f) - (define (get-normal-bitmap) - (unless normal-bitmap - (set! normal-bitmap (make-object bitmap% (build-path (collection-path "icons") "PLT-206.png")))) - normal-bitmap) - - (define-struct magic-image (string filename bitmap)) - - (define (magic-img str img) - (make-magic-image (list->string (reverse (string->list str))) img #f)) - - ;; magic strings and their associated images. Any string in this list that's a prefix of any other - ;; is not going to be reachable; you could change that by removing the (set! key-codes null) line - ;; where the match occurs - (define magic-images - (list - (magic-img "larval" "PLT-206-larval.png") - (magic-img "mars" "PLT-206-mars.jpg"))) - - (define (load-magic-images) - (get-normal-bitmap) - (for-each - (λ (magic-image) - (unless (magic-image-bitmap magic-image) - (set-magic-image-bitmap! - magic-image - (make-object bitmap% (build-path (collection-path "icons") (magic-image-filename magic-image)))))) - magic-images)) - - (define longest-magic-string (apply max (map (λ (s) (string-length (magic-image-string s))) magic-images))) - - (define key-codes null) - (define key-codes-len 0) - - (define (add-key-code new-code) - (unless (eq? 'release new-code) - (set! key-codes - (let loop ([n longest-magic-string] - [l (cons new-code key-codes)]) - (cond - [(zero? n) null] - [(null? l) null] - [else (cons (car l) (loop (- n 1) (cdr l)))]))))) + (define normal-bitmap #f) ; set by load-magic-images - (let ([set-splash-bitmap (dynamic-require '(lib "splash.ss" "framework") 'set-splash-bitmap)]) + (define-struct magic-image (chars filename bitmap)) + + (define (magic-img str img) + (make-magic-image (reverse (string->list str)) img #f)) + + ;; magic strings and their associated images. There should not be a string + ;; in this list that is a prefix of another. + (define magic-images + (list (magic-img "larval" "PLT-206-larval.png") + (magic-img "mars" "PLT-206-mars.jpg"))) + + (define (load-magic-images) + (set! load-magic-images void) ; run only once + (unless normal-bitmap (set! normal-bitmap (icons-bitmap "PLT-206.png"))) + (for-each (λ (magic-image) + (unless (magic-image-bitmap magic-image) + (set-magic-image-bitmap! + magic-image + (icons-bitmap (magic-image-filename magic-image))))) + magic-images)) + + (define longest-magic-string + (apply max (map (λ (s) (length (magic-image-chars s))) magic-images))) + + (define key-codes null) + + (define (find-magic-image) + (define (prefix? l1 l2) + (or (null? l1) + (and (pair? l2) + (eq? (car l1) (car l2)) + (prefix? (cdr l1) (cdr l2))))) + (ormap (λ (i) (and (prefix? (magic-image-chars i) key-codes) i)) + magic-images)) + + (define (add-key-code new-code) + (let loop ([n (- longest-magic-string 2)] [l key-codes]) + (cond [(null? l) 'done] + [(zero? n) (set-cdr! l '())] + [else (loop (sub1 n) (cdr l))])) + (set! key-codes (cons new-code key-codes))) + + (let ([set-splash-bitmap + (dynamic-require '(lib "splash.ss" "framework") 'set-splash-bitmap)]) ((dynamic-require '(lib "splash.ss" "framework") 'set-splash-char-observer) (λ (evt) - (add-key-code (send evt get-key-code)) - - ;; as soon as something is typed, load the bitmaps - (load-magic-images) - - (when (andmap char? key-codes) - (let ((s (apply string key-codes))) - (cond - [(ormap (λ (m) - (if (string=? s (magic-image-string m)) - m - #f)) magic-images) - => - (λ (match) - (set! key-codes null) - (set-splash-bitmap - (if (and special-state (string=? special-state (magic-image-string match))) - (begin - (set! special-state #f) - (get-normal-bitmap)) - (begin - (set! special-state (magic-image-string match)) - (magic-image-bitmap match)))))] - [else (void)])))))) - + (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 () (define main-size 260) (define pi (atan 0 -1)) - (define eli (make-object bitmap% (build-path (collection-path "icons") "eli-purple.jpg"))) + (define eli (icons-bitmap "eli-purple.jpg")) (define bitmap (make-object bitmap% main-size main-size)) (define bdc (make-object bitmap-dc% bitmap)) @@ -153,11 +148,11 @@ (draw-single-loop hebrew-str bdc (+ (- (* 2 pi) offset) (* 2 pi)) (/ main-size 2) (/ main-size 2) 70 20 inner-color) (send splash-canvas on-paint)) - (define gc-b + (define gc-b (with-handlers ([exn:fail? (lambda (x) (printf "~s\n" (exn-message x)) #f)]) - (let ([b (make-object bitmap% (build-path (collection-path "icons") "recycle.gif"))]) + (let ([b (icons-bitmap bitmap% "recycle.gif")]) (cond [(send b ok?) (let ([gbdc (make-object bitmap-dc% b)]