1#lang racket/base 2(require racket/class 3 "../syntax.rkt" 4 "wx.rkt") 5 6(provide keymap% 7 map-command-as-meta-key) 8 9(define map-command-as-meta? #f) 10 11(define/top (map-command-as-meta-key [bool? v]) 12 (set! map-command-as-meta? v)) 13 14(define (as-meta-key k) 15 (case (system-type) 16 [(macosx) (if map-command-as-meta? 17 k 18 #f)] 19 [else k])) 20 21(define (as-cmd-key k) 22 (case (system-type) 23 [(macosx) k] 24 [else #f])) 25 26(define keylist 27 #hash(("leftbutton" . mouse-left) 28 ("rightbutton" . mouse-right) 29 ("middlebutton" . mouse-middle) 30 ("leftbuttondouble" . mouse-left-double) 31 ("rightbuttondouble" . mouse-right-double) 32 ("middlebuttondouble" . mouse-middle-double) 33 ("leftbuttontriple" . mouse-left-triple) 34 ("rightbuttontriple" . mouse-right-triple) 35 ("middlebuttontriple" . mouse-middle-triple) 36 ("leftbuttonseq" . mouse-left) 37 ("rightbuttonseq" . mouse-right) 38 ("middlebuttonseq" . mouse-middle) 39 ("wheelup" . wheel-up) 40 ("wheeldown" . wheel-down) 41 ("wheelleft" . wheel-left) 42 ("wheelright" . wheel-right) 43 ("esc" . escape) 44 ("delete" . #\rubout) 45 ("del" . #\rubout) 46 ("insert" . insert) 47 ("ins" . insert) 48 ("add" . add) 49 ("subtract" . subtract) 50 ("multiply" . multiply) 51 ("divide" . divide) 52 ("backspace" . #\backspace) 53 ("back" . #\backspace) 54 ("return" . #\return) 55 ("enter" . #\return) 56 ("tab" . #\tab) 57 ("space" . #\space) 58 ("right" . right) 59 ("left" . left) 60 ("up" . up) 61 ("down" . down) 62 ("home" . home) 63 ("end" . end) 64 ("pageup" . prior) 65 ("pagedown" . next) 66 ("semicolon" . #\;) 67 ("colon" . #\:) 68 ("numpad0" . numpad0) 69 ("numpad1" . numpad1) 70 ("numpad2" . numpad2) 71 ("numpad3" . numpad3) 72 ("numpad4" . numpad4) 73 ("numpad5" . numpad5) 74 ("numpad6" . numpad6) 75 ("numpad7" . numpad7) 76 ("numpad8" . numpad8) 77 ("numpad9" . numpad9) 78 ("numpadenter" . numpad-enter) 79 ("f1" . f1) 80 ("f2" . f2) 81 ("f3" . f3) 82 ("f4" . f4) 83 ("f5" . f5) 84 ("f6" . f6) 85 ("f7" . f7) 86 ("f8" . f8) 87 ("f9" . f9) 88 ("f10" . f10) 89 ("f11" . f11) 90 ("f12" . f12) 91 ("f13" . f13) 92 ("f14" . f14) 93 ("f15" . f15) 94 ("f16" . f16) 95 ("f17" . f17) 96 ("f18" . f18) 97 ("f19" . f19) 98 ("f20" . f20) 99 ("f21" . f21) 100 ("f22" . f22) 101 ("f23" . f23) 102 ("f24" . f24))) 103(define rev-keylist 104 (make-immutable-hash 105 (hash-map keylist (lambda (k v) (cons v k))))) 106 107(define-struct kmfunc (name f)) 108 109(define-struct key (code 110 111 shift-on? 112 shift-off? 113 ctrl-on? 114 ctrl-off? 115 alt-on? 116 alt-off? 117 meta-on? 118 meta-off? 119 cmd-on? 120 cmd-off? 121 caps-on? 122 caps-off? 123 altgr-on? 124 altgr-off? 125 126 score 127 128 check-other? 129 fullset? 130 131 [fname #:mutable] 132 133 isprefix? 134 seqprefix)) 135 136(define-local-member-name 137 chain-handle-key-event 138 get-best-score 139 chain-handle-mouse-event 140 get-best-mouse-score 141 cycle-check 142 chain-check-grab) 143 144(defclass keymap% object% 145 146 (super-new) 147 148 (define functions (make-hash)) 149 (define keys (make-hash)) 150 151 (define prefix #f) 152 (define prefixed? #f) 153 154 (define active-mouse-function #f) 155 156 (define grab-key-function #f) 157 (define grab-mouse-function #f) 158 (define on-break #f) 159 160 (define chain-to null) 161 162 (define last-time 0) 163 (define last-x 0) 164 (define last-y 0) 165 (define click-count 0) 166 (define last-code #f) 167 (define last-button #f) 168 169 (define double-interval (get-double-click-threshold)) 170 171 (def/public (reset) 172 (set! prefix #f) 173 (set! prefixed? #f) 174 175 (for-each (lambda (c) 176 (send c reset)) 177 chain-to)) 178 179 (def/public (break-sequence) 180 (set! prefix #f) 181 182 (when on-break 183 (let ([f on-break]) 184 (set! on-break #f) 185 (f))) 186 187 (for-each (lambda (c) 188 (send c break-sequence)) 189 chain-to)) 190 191 (def/public (set-break-sequence-callback [(make-procedure 0) f]) 192 (let ([old on-break]) 193 (set! on-break f) 194 (when old (old)))) 195 196 (define/private (find-key code other-code alt-code other-alt-code caps-code 197 shift? ctrl? alt? meta? cmd? caps? altgr? 198 prefix) 199 (for*/fold ([best-key #f] 200 [best-score -1]) 201 ([findk (in-list (list code other-code alt-code other-alt-code caps-code))] 202 [key (in-list (hash-ref keys findk null))]) 203 (if (and (or (eqv? (key-code key) code) 204 (and (key-check-other? key) 205 (or (eqv? (key-code key) other-code) 206 (eqv? (key-code key) alt-code) 207 (eqv? (key-code key) other-alt-code) 208 (eqv? (key-code key) caps-code)))) 209 (or (and (key-shift-on? key) shift?) 210 (and (key-shift-off? key) (not shift?)) 211 (and (not (key-shift-on? key)) (not (key-shift-off? key)))) 212 (or (and (key-ctrl-on? key) ctrl?) 213 (and (key-ctrl-off? key) (not ctrl?)) 214 (and (not (key-ctrl-on? key)) (not (key-ctrl-off? key)))) 215 (or (and (key-alt-on? key) alt?) 216 (and (key-alt-off? key) (not alt?)) 217 (and (not (key-alt-on? key)) (not (key-alt-off? key)))) 218 (or (and (key-meta-on? key) meta?) 219 (and (key-meta-off? key) (not meta?)) 220 (and (not (key-meta-on? key)) (not (key-meta-off? key)))) 221 (or (and (key-cmd-on? key) cmd?) 222 (and (key-cmd-off? key) (not cmd?)) 223 (and (not (key-cmd-on? key)) (not (key-cmd-off? key)))) 224 (or (and (key-caps-on? key) caps?) 225 (and (key-caps-off? key) (not caps?)) 226 (and (not (key-caps-on? key)) (not (key-caps-off? key)))) 227 (or (and (key-altgr-on? key) altgr?) 228 (and (key-altgr-off? key) (not altgr?)) 229 (and (not (key-altgr-on? key)) (not (key-altgr-off? key)))) 230 (eq? (key-seqprefix key) prefix)) 231 (let ([score (+ (key-score key) 232 (if (eqv? (key-code key) code) 233 0 234 (if (eqv? (key-code key) other-alt-code) 235 -4 236 -2)))]) 237 (if (score . > . best-score) 238 (values key score) 239 (values best-key best-score))) 240 (values best-key best-score)))) 241 242 (define/private (do-map-function code shift ctrl alt meta cmd caps altgr check-other? 243 fname prev isprefix? fullset?) 244 ;; look for existing key mapping: 245 (let ([key 246 (ormap (lambda (key) 247 (and (eqv? (key-code key) code) 248 (eq? (key-shift-on? key) (shift . > . 0)) 249 (eq? (key-shift-off? key) (shift . < . 0)) 250 (eq? (key-ctrl-on? key) (ctrl . > . 0)) 251 (eq? (key-ctrl-off? key) (ctrl . < . 0)) 252 (eq? (key-alt-on? key) (alt . > . 0)) 253 (eq? (key-alt-off? key) (alt . < . 0)) 254 (eq? (key-meta-on? key) (meta . > . 0)) 255 (eq? (key-meta-off? key) (meta . < . 0)) 256 (eq? (key-cmd-on? key) (cmd . > . 0)) 257 (eq? (key-cmd-off? key) (cmd . < . 0)) 258 (eq? (key-caps-on? key) (caps . > . 0)) 259 (eq? (key-caps-off? key) (caps . < . 0)) 260 (eq? (key-altgr-on? key) (altgr . > . 0)) 261 (eq? (key-altgr-off? key) (altgr . < . 0)) 262 (eq? (key-check-other? key) check-other?) 263 (eq? (key-seqprefix key) prev) 264 key)) 265 (hash-ref keys code null))]) 266 267 (if key 268 ;; Found existing 269 (if (not (eq? isprefix? (key-isprefix? key))) 270 ;; prefix vs no-prefix mismatch: 271 (let ([s 272 (string-append 273 (if (meta . > . 0) "m:" "") 274 (if (meta . < . 0) "~m:" "") 275 (if (cmd . > . 0) "d:" "") 276 (if (cmd . < . 0) "~d:" "") 277 (if (alt . > . 0) "a:" "") 278 (if (alt . < . 0) "~a:" "") 279 (if (ctrl . > . 0) "c:" "") 280 (if (ctrl . < . 0) "~c:" "") 281 (if (shift . > . 0) "s:" "") 282 (if (shift . < . 0) "~s:" "") 283 (if (caps . > . 0) "l:" "") 284 (if (caps . < . 0) "~l:" "") 285 (if (altgr . > . 0) "g:" "") 286 (if (altgr . < . 0) "~g:" "") 287 (or (hash-ref rev-keylist code #f) 288 (format "~c" code)))]) 289 (error (method-name 'keymap% 'map-function) 290 "~s is already mapped as a ~aprefix key" 291 s (if isprefix? "non-" ""))) 292 (begin 293 (set-key-fname! key (string->immutable-string fname)) 294 key)) 295 ;; Create new 296 (let ([newkey (make-key 297 code 298 (shift . > . 0) (shift . < . 0) 299 (ctrl . > . 0) (ctrl . < . 0) 300 (alt . > . 0) (alt . < . 0) 301 (meta . > . 0) (meta . < . 0) 302 (cmd . > . 0) (cmd . < . 0) 303 (caps . > . 0) (caps . < . 0) 304 (altgr . > . 0) (altgr . < . 0) 305 (+ (if (shift . > . 0) 1 0) 306 (if (shift . < . 0) 5 0) 307 (if (ctrl . > . 0) 1 0) 308 (if (ctrl . < . 0) 5 0) 309 (if (alt . > . 0) 1 0) 310 (if (alt . < . 0) 5 0) 311 (if (meta . > . 0) 1 0) 312 (if (meta . < . 0) 5 0) 313 (if (cmd . > . 0) 1 0) 314 (if (cmd . < . 0) 5 0) 315 (if (caps . > . 0) 1 0) 316 (if (caps . < . 0) 5 0) 317 (if (altgr . > . 0) 1 0) 318 (if (altgr . < . 0) 5 0) 319 ;; Baseline score, so we can subtract for 320 ;; other-key matches when allowed by 321 ;; `check-other?`: 322 6) 323 check-other? 324 fullset? 325 (string->immutable-string fname) 326 isprefix? 327 prev)]) 328 (hash-set! keys code (cons newkey (hash-ref keys code null))) 329 newkey)))) 330 331 (define/private (get-code str) 332 (let ([code (hash-ref keylist (string-downcase str) #f)]) 333 (if code 334 (values code (member str '("leftbuttonseq" 335 "middlebuttonseq" 336 "rightbuttonseq"))) 337 (if (= 1 (string-length str)) 338 (values (string-ref str 0) 339 #f) 340 (values #f #f))))) 341 342 (def/public (map-function [string? keys] 343 [string? fname]) 344 (if (string=? keys "") 345 (error (method-name 'keymap% 'map-function) 346 "bad key string: ~e" 347 keys) 348 (let loop ([seq (regexp-split #rx";" keys)] 349 [prev-key #f]) 350 (let ([str (car seq)]) 351 (define (bad-string msg) 352 (error (method-name 'keymap% 'map-function) 353 "bad keymap string: ~e~a: ~a" 354 str 355 (if (equal? str keys) 356 "" 357 (format " within ~e" keys)) 358 msg)) 359 (let-values ([(str default-off?) 360 (if (regexp-match? #rx"^:" str) 361 (values (substring str 1) #t) 362 (values str #f))]) 363 (let sloop ([str str] 364 [downs null] 365 [ups null] 366 [others? #f]) 367 (cond 368 [(regexp-match? #rx"^[?]:" str) 369 (sloop (substring str 2) downs ups #t)] 370 [(regexp-match? #rx"^~[SsCcAaMmDdLlGg]:" str) 371 (let ([c (char-downcase (string-ref str 1))]) 372 (if (memv c downs) 373 (bad-string (format "inconsistent ~a: modifier state" c)) 374 (sloop (substring str 3) downs (cons c ups) others?)))] 375 [(regexp-match? #rx"^[SsCcAaMmDdLlGg]:" str) 376 (let ([c (char-downcase (string-ref str 0))]) 377 (if (memv c ups) 378 (bad-string (format "inconsistent ~a: modifier state" c)) 379 (sloop (substring str 2) (cons c downs) ups others?)))] 380 [else 381 (let-values ([(code fullset?) (get-code str)]) 382 (if (not code) 383 (bad-string "unrecognized key name") 384 (let-values ([(downs code) 385 (if (and (char? code) 386 ((char->integer code) . > . 0) 387 ((char->integer code) . < . 127) 388 (char-alphabetic? code)) 389 (cond 390 [(memq #\s downs) 391 (if (or (and (eq? (system-type) 'macosx) 392 (not (memq #\m downs)) 393 (not (memq #\d downs))) 394 (and (eq? (system-type) 'windows) 395 (or (not (memq #\c downs)) 396 (memq #\m downs)))) 397 (values downs (char-upcase code)) 398 (values downs code))] 399 [(char-upper-case? code) 400 (values (cons #\s downs) code)] 401 [else 402 (values downs code)]) 403 (values downs code))]) 404 (let ([newkey 405 (let ([modval (lambda (c [default-off? default-off?]) 406 (cond 407 [(memq c downs) 1] 408 [(memq c ups) -1] 409 [else (if default-off? -1 0)]))]) 410 (do-map-function code 411 (modval #\s) 412 (modval #\c) 413 (modval #\a) 414 (modval #\m) 415 (modval #\d) 416 (modval #\l #f) 417 (modval #\g #f) 418 others? 419 fname 420 prev-key 421 (not (null? (cdr seq))) 422 fullset?))]) 423 (if (null? (cdr seq)) 424 (void) 425 (loop (cdr seq) newkey))))))]))))))) 426 427 (define/private (handle-event code other-code alt-code other-alt-code caps-code 428 shift? ctrl? alt? meta? cmd? caps? altgr? 429 score) 430 (let-values ([(key found-score) 431 (find-key code other-code alt-code other-alt-code caps-code 432 shift? ctrl? alt? meta? cmd? caps? altgr? prefix)]) 433 (set! prefix #f) 434 435 (if (and key (found-score . >= . score)) 436 (if (key-isprefix? key) 437 (begin 438 (set! prefix key) 439 (values #t #f #f)) 440 (values #t 441 (key-fname key) 442 (key-fullset? key))) 443 (values #f #f #f)))) 444 445 (define/public (get-best-score code other-code alt-code other-alt-code caps-code 446 shift? ctrl? alt? meta? cmd? caps? altgr?) 447 (let-values ([(key score) 448 (find-key code other-code alt-code other-alt-code caps-code 449 shift? ctrl? alt? meta? cmd? caps? altgr? prefix)]) 450 (for/fold ([s (if key score -1)]) 451 ([c (in-list chain-to)]) 452 (max s 453 (send c get-best-score code other-code alt-code other-alt-code caps-code 454 shift? ctrl? alt? meta? cmd? caps? altgr?))))) 455 456 (def/public (set-grab-key-function [(make-procedure 4) grab]) 457 (set! grab-key-function grab)) 458 459 (def/public (remove-grab-key-function) 460 (set! grab-key-function #f)) 461 462 (def/public (handle-key-event [any? obj] [key-event% event]) 463 (let ([code (send event get-key-code)]) 464 (if (or (eq? code 'shift) 465 (eq? code 'rshift) 466 (eq? code 'control) 467 (eq? code 'rcontrol) 468 (eq? code 'release)) 469 (or prefixed? 470 (chain-check-grab obj event)) 471 (let ([score (get-best-score 472 code 473 (send event get-other-shift-key-code) 474 (send event get-other-altgr-key-code) 475 (send event get-other-shift-altgr-key-code) 476 (send event get-other-caps-key-code) 477 (send event get-shift-down) 478 (send event get-control-down) 479 (send event get-alt-down) 480 (as-meta-key (send event get-meta-down)) 481 (as-cmd-key (send event get-meta-down)) 482 (send event get-caps-down) 483 (send event get-control+meta-is-altgr))]) 484 (let ([was-prefixed? prefixed?]) 485 486 (let* ([r (chain-handle-key-event obj event #f prefixed? score)] 487 [r (if (and (zero? r) 488 was-prefixed?) 489 (begin 490 (reset) 491 ;; try again without prefix: 492 (chain-handle-key-event obj event #f #f score)) 493 r)]) 494 (when (r . >= . 0) 495 (reset)) 496 (not (zero? r)))))))) 497 498 (define/private (other-handle-key-event obj event grab try-prefixed? score) 499 (for/fold ([r 0]) 500 ([c (in-list chain-to)] 501 #:when (r . <= . 0)) 502 (let ([r2 (send c chain-handle-key-event obj event grab try-prefixed? score)]) 503 (if (r2 . > . 0) 504 (begin 505 (reset) 506 r2) 507 (if (r2 . < . 0) 508 r2 509 r))))) 510 511 (define/public (chain-handle-key-event obj event grab only-prefixed? score) 512 ;; results: 0 = no match, 1 = match, -1 = matched prefix 513 (set! last-time (send event get-time-stamp)) 514 (set! last-button #f) 515 (let ([grab (or grab-key-function 516 grab)]) 517 (if (and only-prefixed? (not prefixed?)) 518 0 519 (let ([sub-result (other-handle-key-event obj event grab only-prefixed? score)]) 520 (if (sub-result . > . 0) 521 sub-result 522 (let-values ([(h? fname fullset?) 523 (handle-event (send event get-key-code) 524 (send event get-other-shift-key-code) 525 (send event get-other-altgr-key-code) 526 (send event get-other-shift-altgr-key-code) 527 (send event get-other-caps-key-code) 528 (send event get-shift-down) 529 (send event get-control-down) 530 (send event get-alt-down) 531 (as-meta-key (send event get-meta-down)) 532 (as-cmd-key (send event get-meta-down)) 533 (send event get-caps-down) 534 (send event get-control+meta-is-altgr) 535 score)]) 536 (if h? 537 (if fname 538 (begin 539 (reset) 540 (if (and grab 541 (grab fname this obj event)) 542 1 543 (if (call-function fname obj event) 544 1 545 0))) 546 (if prefix 547 (begin 548 (set! prefixed? #t) 549 -1) 550 ;; shouldn't get here 551 0)) 552 (let ([result 553 (if (sub-result . < . 0) 554 (begin 555 (set! prefixed? #t) 556 -1) 557 0)]) 558 (if (and (zero? result) 559 grab-key-function 560 (grab-key-function #f this obj event)) 561 1 562 result))))))))) 563 564 (define/public (chain-check-grab obj event) 565 (or (and grab-key-function #t) 566 (for/or ([c (in-list chain-to)]) 567 (send c chain-check-grab obj event)))) 568 569 (def/public (set-grab-mouse-function [(make-procedure 4) grab]) 570 (set! grab-mouse-function grab)) 571 572 (def/public (remove-grab-mouse-function) 573 (set! grab-mouse-function #f)) 574 575 (define/private (adjust-button-code code click-count) 576 (case click-count 577 [(0) code] 578 [(1) (case code 579 [(mouse-right) 'mouse-right-double] 580 [(mouse-left) 'mouse-left-double] 581 [(mouse-middle) 'mouse-middle-double])] 582 [else (case code 583 [(mouse-right) 'mouse-right-triple] 584 [(mouse-left) 'mouse-left-triple] 585 [(mouse-middle) 'mouse-middle-triple])])) 586 587 (def/public (handle-mouse-event [any? obj][mouse-event% event]) 588 (let ([score (get-best-mouse-score event)]) 589 (not (zero? (chain-handle-mouse-event obj event #f 0 score))))) 590 591 (define/public (get-best-mouse-score event) 592 (cond 593 [(not (send event button-down?)) 594 (if active-mouse-function 595 100 596 (or (ormap (lambda (c) 597 (and (not (zero? (send c get-best-mouse-score event))) 598 100)) 599 chain-to) 600 -1))] 601 [else 602 (let ([code (cond 603 [(send event get-right-down) 'mouse-right] 604 [(send event get-left-down) 'mouse-left] 605 [(send event get-middle-down) 'mouse-middle] 606 [else #f])]) 607 (if (not code) 608 -1 609 (let ([code 610 (if (and (eq? code last-button) 611 (= (send event get-x) last-x) 612 (= (send event get-y) last-y) 613 ((abs (- (send event get-time-stamp) last-time)) . < . double-interval)) 614 (adjust-button-code code click-count) 615 code)]) 616 (get-best-score code #f #f #f #f 617 (send event get-shift-down) 618 (send event get-control-down) 619 (send event get-alt-down) 620 (as-meta-key (send event get-meta-down)) 621 (as-cmd-key (send event get-meta-down)) 622 (send event get-caps-down) 623 #f))))])) 624 625 (define/private (other-handle-mouse-event obj event grab try-state score) 626 (for/fold ([result 0]) 627 ([c (in-list chain-to)] 628 #:when (result . <= . 0)) 629 (let ([r (send c chain-handle-mouse-event obj event grab try-state score)]) 630 (cond 631 [(r . > . 0) 632 (reset) 633 r] 634 [(zero? r) result] 635 [else r])))) 636 637 (define/public (chain-handle-mouse-event obj event grab try-state score) 638 (let ([grab (or grab-mouse-function grab)]) 639 (define (step1) 640 (cond 641 [(and (not prefix) 642 (try-state . >= . 0)) 643 (let ([r (other-handle-mouse-event obj event grab 1 score)]) 644 (cond 645 [(r . > . 0) r] 646 [(try-state . > . 0) r] 647 [else (step2 -1)]))] 648 [(and prefix (try-state . < . 0)) 649 (other-handle-mouse-event obj event grab -1 score)] 650 [else (step2 try-state)])) 651 (define (step2 try-state) 652 (cond 653 [(not (send event button-down?)) 654 (when (and (not (send event dragging?)) 655 (not (send event button-up?))) 656 ;; we must have missed the button-up 657 (set! active-mouse-function #f)) 658 (if (not active-mouse-function) 659 (other-handle-mouse-event obj event grab -1 score) 660 (let ([v (if (and grab 661 (grab active-mouse-function this obj event)) 662 1 663 (if (call-function active-mouse-function obj event) 664 1 665 0))]) 666 (when (send event button-up?) 667 (set! active-mouse-function #f)) 668 v))] 669 [else 670 (let ([code (cond 671 [(send event get-right-down) 'mouse-right] 672 [(send event get-left-down) 'mouse-left] 673 [(send event get-middle-down) 'mouse-middle] 674 [else #f])]) 675 (if (not code) 676 0 ;; FIXME: should we call grab here? 677 (let ([orig-code code] 678 [code 679 (if (and (eq? code last-button) 680 (= (send event get-x) last-x) 681 (= (send event get-y) last-y)) 682 (if ((abs (- (send event get-time-stamp) last-time)) . < . double-interval) 683 (begin0 684 (adjust-button-code code click-count) 685 (set! click-count (add1 click-count))) 686 (begin 687 (set! click-count 1) 688 code)) 689 (begin 690 (set! last-button code) 691 (set! click-count 1) 692 code))]) 693 (set! last-time (send event get-time-stamp)) 694 (set! last-x (send event get-x)) 695 (set! last-y (send event get-y)) 696 697 (let loop ([code code]) 698 (let-values ([(h? fname fullset?) (handle-event code 699 #f #f #f #f 700 (send event get-shift-down) 701 (send event get-control-down) 702 (send event get-alt-down) 703 (as-meta-key (send event get-meta-down)) 704 (as-cmd-key (send event get-meta-down)) 705 (send event get-caps-down) 706 #f 707 score)]) 708 (cond 709 [(and h? fname) 710 (reset) 711 (when fullset? 712 (set! active-mouse-function fname)) 713 (cond 714 [(and grab (grab fname this obj event)) 1] 715 [(call-function fname obj event) 1] 716 [else 0])] 717 [h? 718 (let ([r (other-handle-mouse-event obj event grab try-state score)]) 719 (if (r . > . 0) 720 r 721 -1))] 722 [else 723 (set! last-code code) 724 (if (not (eqv? last-code orig-code)) 725 (loop orig-code) 726 (let ([result (other-handle-mouse-event obj event grab try-state score)]) 727 (if (and (zero? result) 728 grab-mouse-function 729 (grab-mouse-function #f this obj event)) 730 1 731 result)))]))))))])) 732 (step1))) 733 734 (def/public (add-function [string? name] [(make-procedure 2) f]) 735 (hash-set! functions 736 (string->immutable-string name) 737 f)) 738 739 (def/public (call-function [string? name] [any? obj] [event% event] [any? [try-chained? #f]]) 740 (let ([f (hash-ref functions name #f)]) 741 (cond 742 [f 743 (f obj event) 744 #t] 745 [try-chained? 746 (ormap (lambda (c) 747 (send c call-function name obj event #t)) 748 chain-to)] 749 [else 750 (error 'keymap "no function ~e" name)]))) 751 752 (def/public (is-function-added? [string? name]) 753 (and (hash-ref functions name #f) #t)) 754 755 (def/public (get-double-click-interval) 756 double-interval) 757 758 (def/public (set-double-click-interval [exact-positive-integer? d]) 759 (set! double-interval d)) 760 761 (define/public (cycle-check km) 762 (ormap (lambda (c) 763 (or (eq? km c) 764 (send c cycle-check km))) 765 chain-to)) 766 767 (def/public (chain-to-keymap [keymap% km] [any? prefix?]) 768 (unless (or (eq? km this) 769 (cycle-check km) 770 (send km cycle-check this)) 771 (set! chain-to (if prefix? 772 (cons km chain-to) 773 (append chain-to (list km)))))) 774 775 (def/public (remove-chained-keymap [keymap% km]) 776 (set! chain-to (remq km chain-to)))) 777