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

better key handling

Browse Source 
svn: r4084
This commit is contained in:
Eli Barzilay 2006-08-17 20:19:12 +00:00
parent 4c9868bf8c
commit bc9f5abc34
1 changed files with 71 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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)]