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

...

Browse Source 
original commit: 6880cf28580fea0cd1ffcaec91560fd124ca22b6
This commit is contained in:
Robby Findler 2000-02-19 20:19:21 +00:00
parent dc8723de7e
commit c36e157147
1 changed files with 33 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
collects/framework/keymap.ss
View File

@ -39,7 +39,7 @@
(override (override
[map-function [map-function
(lambda (keyname fname) (lambda (keyname fname)
(super-map-function keyname fname) (super-map-function (canonicalize-keybinding-string keyname) fname)
(hash-table-put! function-table (string->symbol keyname) fname))]) (hash-table-put! function-table (string->symbol keyname) fname))])
(public (public
@ -64,18 +64,18 @@
(sequence (sequence
(apply super-init args)))) (apply super-init args))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;; ;;;;;;;; ;;;;;;; ;;;;;;;;
;;;;;;; canonicalize ;;;;;;;; ;;;;;;; canonicalize-keybinding-string ;;;;;;;;
;;;;;;; ;;;;;;;; ;;;;;;; ;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; canonicalize-keybinding-string : string -> string ;; canonicalize-keybinding-string : string -> string
;; The result can be used with string=? to determine ;; The result can be used with string=? to determine
;; if two key bindings refer to the same key. ;; if two key bindings refer to the same key.
;; Assumes a well-formed keystring. ;; Assumes a well-formed keystring.
(define (canonicalize-keybinding-string str) (define (canonicalize-keybinding-string str)
(let* ([chars (string->list str)] (let* ([chars (map char-downcase (string->list str))]
[separated-keys [separated-keys
(map (map
canonicalize-single-keybinding-string canonicalize-single-keybinding-string
@ -91,12 +91,13 @@
string-append string-append
(cons (cons
(car strs) (car strs)
(let loop ([keys (cdr strs)]) (let loop ([sepd-strs (cdr strs)])
(cond (cond
[(null? keys) null] [(null? sepd-strs) null]
[else (list* sep [else (list*
(car keys) sep
(loop (cdr keys)))])))))) (car sepd-strs)
(loop (cdr sepd-strs)))]))))))
;; canonicalize-single-keybinding-string : (listof char) -> string ;; canonicalize-single-keybinding-string : (listof char) -> string
(define (canonicalize-single-keybinding-string chars) (define (canonicalize-single-keybinding-string chars)
@ -108,7 +109,7 @@
[(null? mods) null] [(null? mods) null]
[(null? (cdr mods)) null] [(null? (cdr mods)) null]
[else (cons (car mods) (loop (cdr mods)))]))] [else (cons (car mods) (loop (cdr mods)))]))]
[key (cdr (mzlib:function:last-pair mods/key))] [key (car (mzlib:function:last-pair mods/key))]
[shift (if neg? #f 'd/c)] [shift (if neg? #f 'd/c)]
[control (if neg? #f 'd/c)] [control (if neg? #f 'd/c)]
[alt (if neg? #f 'd/c)] [alt (if neg? #f 'd/c)]
@ -120,7 +121,7 @@
(cond (cond
[(eq? val #t) (string char)] [(eq? val #t) (string char)]
[(eq? val #f) (string #\~ char)] [(eq? val #f) (string #\~ char)]
[(eq? val 'd/c) ""]))]) [(eq? val 'd/c) #f]))])
(for-each (lambda (mod) (for-each (lambda (mod)
(let ([val (not (char=? (car mod) #\~))]) (let ([val (not (char=? (car mod) #\~))])
@ -133,13 +134,16 @@
[(#\d) (set! command val)] [(#\d) (set! command val)]
[(#\m) (set! meta val)]))) [(#\m) (set! meta val)])))
mods) mods)
(join-strings #\: (list (join-strings ":"
(do-key #\a alt) (mzlib:function:filter
(do-key #\c control) (lambda (x) x)
(do-key #\d command) (list
(do-key #\m meta) (do-key #\a alt)
(do-key #\s shift) (do-key #\c control)
(apply string-append key))))) (do-key #\d command)
(do-key #\m meta)
(do-key #\s shift)
(apply string key))))))
;; split-out : char (listof char) -> (listof (listof char)) ;; split-out : char (listof char) -> (listof (listof char))
;; splits a list of characters at its first argument ;; splits a list of characters at its first argument
@ -148,10 +152,11 @@
[this-split null] [this-split null]
[all-split null]) [all-split null])
(cond (cond
[(null? chars) (reverse all-split)] [(null? chars)
(reverse (cons (reverse this-split) all-split))]
[else (let ([char (car chars)]) [else (let ([char (car chars)])
(cond (cond
[(char=? split-char chars) [(char=? split-char char)
(loop (cdr chars) (loop (cdr chars)
null null
(cons (reverse this-split) all-split))] (cons (reverse this-split) all-split))]
@ -160,11 +165,11 @@
(cons char this-split) (cons char this-split)
all-split)]))]))) all-split)]))])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;; ;;;;;;;; ;;;;;;; ;;;;;;;;
;;;;;;; end canonicalize ;;;;;;;; ;;;;;;; end canonicalize-keybinding-string ;;;;;;;;
;;;;;;; ;;;;;;;; ;;;;;;; ;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-meta-prefix-list key) (define (make-meta-prefix-list key)
(list (string-append "m:" key) (list (string-append "m:" key)