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

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

@ -19,6 +19,11 @@
(current-command-line-arguments) (current-command-line-arguments)
(args filenames filenames))) (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))
@ -32,84 +37,74 @@
(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) (define normal-bitmap #f) ; set by load-magic-images
(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-struct magic-image (chars filename bitmap))
(define (magic-img str img) (define (magic-img str img)
(make-magic-image (list->string (reverse (string->list str))) img #f)) (make-magic-image (reverse (string->list str)) img #f))
;; magic strings and their associated images. Any string in this list that's a prefix of any other ;; magic strings and their associated images. There should not be a string
;; is not going to be reachable; you could change that by removing the (set! key-codes null) line ;; in this list that is a prefix of another.
;; where the match occurs
(define magic-images (define magic-images
(list (list (magic-img "larval" "PLT-206-larval.png")
(magic-img "larval" "PLT-206-larval.png") (magic-img "mars" "PLT-206-mars.jpg")))
(magic-img "mars" "PLT-206-mars.jpg")))
(define (load-magic-images) (define (load-magic-images)
(get-normal-bitmap) (set! load-magic-images void) ; run only once
(for-each (unless normal-bitmap (set! normal-bitmap (icons-bitmap "PLT-206.png")))
(λ (magic-image) (for-each (λ (magic-image)
(unless (magic-image-bitmap magic-image) (unless (magic-image-bitmap magic-image)
(set-magic-image-bitmap! (set-magic-image-bitmap!
magic-image magic-image
(make-object bitmap% (build-path (collection-path "icons") (magic-image-filename magic-image)))))) (icons-bitmap (magic-image-filename magic-image)))))
magic-images)) magic-images))
(define longest-magic-string (apply max (map (λ (s) (string-length (magic-image-string s))) magic-images))) (define longest-magic-string
(apply max (map (λ (s) (length (magic-image-chars s))) magic-images)))
(define key-codes null) (define key-codes null)
(define key-codes-len 0)
(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) (define (add-key-code new-code)
(unless (eq? 'release new-code) (let loop ([n (- longest-magic-string 2)] [l key-codes])
(set! key-codes (cond [(null? l) 'done]
(let loop ([n longest-magic-string] [(zero? n) (set-cdr! l '())]
[l (cons new-code key-codes)]) [else (loop (sub1 n) (cdr l))]))
(cond (set! key-codes (cons new-code key-codes)))
[(zero? n) null]
[(null? l) null]
[else (cons (car l) (loop (- n 1) (cdr l)))])))))
(let ([set-splash-bitmap (dynamic-require '(lib "splash.ss" "framework") 'set-splash-bitmap)]) (let ([set-splash-bitmap
(dynamic-require '(lib "splash.ss" "framework") 'set-splash-bitmap)])
((dynamic-require '(lib "splash.ss" "framework") 'set-splash-char-observer) ((dynamic-require '(lib "splash.ss" "framework") 'set-splash-char-observer)
(λ (evt) (λ (evt)
(add-key-code (send evt get-key-code)) (let ([ch (send evt get-key-code)])
(when (char? ch)
;; as soon as something is typed, load the bitmaps ;; as soon as something is typed, load the bitmaps
(load-magic-images) (load-magic-images)
(add-key-code ch)
(when (andmap char? key-codes) (let ([match (find-magic-image)])
(let ((s (apply string key-codes))) (when match
(cond (set! key-codes null)
[(ormap (λ (m) (set-splash-bitmap
(if (string=? s (magic-image-string m)) (if (eq? special-state match)
m (begin (set! special-state #f) normal-bitmap)
#f)) magic-images) (begin (set! special-state match)
=> (magic-image-bitmap match)))))))))))
(λ (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)]))))))
(when (eb-bday?) (when (eb-bday?)
(let () (let ()
(define main-size 260) (define main-size 260)
(define pi (atan 0 -1)) (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 bitmap (make-object bitmap% main-size main-size))
(define bdc (make-object bitmap-dc% bitmap)) (define bdc (make-object bitmap-dc% bitmap))
@ -157,7 +152,7 @@
(with-handlers ([exn:fail? (lambda (x) (with-handlers ([exn:fail? (lambda (x)
(printf "~s\n" (exn-message x)) (printf "~s\n" (exn-message x))
#f)]) #f)])
(let ([b (make-object bitmap% (build-path (collection-path "icons") "recycle.gif"))]) (let ([b (icons-bitmap bitmap% "recycle.gif")])
(cond (cond
[(send b ok?) [(send b ok?)
(let ([gbdc (make-object bitmap-dc% b)] (let ([gbdc (make-object bitmap-dc% b)]