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

changed canvas scrollbar interface, finished &-based shortcuts

Browse Source 
original commit: 395bbc81deb0394584ce6c2679717e3dcbe40264
This commit is contained in:
Matthew Flatt 1998-12-06 05:10:06 +00:00
parent eb66b01fd5
commit 3bbdda03fc
1 changed files with 97 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

149
src/mred/wrap/mred.ss
View File

@ -64,22 +64,7 @@
(semaphore-post monitor-sema)))))])) (semaphore-post monitor-sema)))))]))
(define (entry-point f) ; entry-point macros in macros.ss
(lambda () (as-entry f)))
(define (entry-point-1 f)
(lambda (x) (as-entry (lambda () (f x)))))
(define (entry-point-2 f)
(lambda (x y) (as-entry (lambda () (f x y)))))
(define (entry-point-3 f)
(lambda (x y z) (as-entry (lambda () (f x y z)))))
(define (entry-point-0-1 f)
(case-lambda
[() (as-entry f)]
[(x) (as-entry (lambda () (f x)))]))
(define (entry-point-1-2 f)
(case-lambda
[(x) (as-entry (lambda () (f x)))]
[(x y) (as-entry (lambda () (f x y)))]))
(define (as-exit f) (define (as-exit f)
; (unless (eq? monitor-owner (current-thread)) (error 'monitor-exit "not in monitored area")) ; (unless (eq? monitor-owner (current-thread)) (error 'monitor-exit "not in monitored area"))
@ -162,6 +147,9 @@
(define top-level-windows (make-hash-table-weak)) (define top-level-windows (make-hash-table-weak))
(define (key-regexp c)
(regexp (format "(^|[^&])&[~a~a]" (char-downcase c) (char-upcase c))))
;;;;;;;;;;;;;;; Focus-tabbing helpers ;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;; Focus-tabbing helpers ;;;;;;;;;;;;;;;;;;;;
(define (traverse x y w h dir dests) (define (traverse x y w h dir dests)
@ -706,7 +694,12 @@
(when o (when o
(if (is-a? o wx:radio-box%) (if (is-a? o wx:radio-box%)
(send o button-focus (if forward? 0 (sub1 (send o number)))) (send o button-focus (if forward? 0 (sub1 (send o number))))
(send o set-focus)))))]) (begin
(send o set-focus)
(when (and (is-a? o wx-text-editor-canvas%)
(send o is-single-line?))
(let ([e (send o get-editor)])
(send e set-position 0 (send e last-position) #f #t 'local))))))))])
(if (is-a? o wx:radio-box%) (if (is-a? o wx:radio-box%)
(let ([n (send o number)] (let ([n (send o number)]
[s (send o button-focus -1)] [s (send o button-focus -1)]
@ -738,7 +731,7 @@
#f #f
;; Move selection/hit control based on & shortcuts ;; Move selection/hit control based on & shortcuts
(let* ([objs (container->children panel #f)] (let* ([objs (container->children panel #f)]
[re (regexp (format "(^|[^&])&~a" code))]) [re (key-regexp code)])
(ormap (ormap
(lambda (o) (lambda (o)
(let* ([win (wx->proxy o)] (let* ([win (wx->proxy o)]
@ -1432,6 +1425,7 @@
[else (not meta?)]))]) [else (not meta?)]))])
(public (public
[set-single-line (lambda () (set! single-line-canvas? #t))] [set-single-line (lambda () (set! single-line-canvas? #t))]
[is-single-line? (lambda () single-line-canvas?)]
[set-line-count (lambda (n) [set-line-count (lambda (n)
(if n (if n
(begin (begin
@ -3218,6 +3212,7 @@
(define canvas% (define canvas%
(class basic-canvas% (parent [style null]) (class basic-canvas% (parent [style null])
(inherit get-client-size)
(sequence (sequence
(check-container-parent 'canvas parent) (check-container-parent 'canvas parent)
(check-style '(constructor canvas) #f '(border hscroll vscroll) style)) (check-style '(constructor canvas) #f '(border hscroll vscroll) style))
@ -3236,24 +3231,44 @@
(lambda (x y) (send wx view-start x y)))))] (lambda (x y) (send wx view-start x y)))))]
[scroll (entry-point-2 (lambda (x y) [scroll (entry-point-2 (lambda (x y)
(check-dimension '(method canvas% scroll) x) (when x (check-fraction '(method canvas% scroll) x))
(check-dimension '(method canvas% scroll) y) (when y (check-fraction '(method canvas% scroll) y))
(send wx scroll (or x -1) (or y -1))))] (send wx scroll (or x -1) (or y -1))))]
[set-scrollbars (letrec ([set-scrollbars [init-auto-scrollbars
(case-lambda (lambda (w h x y)
[(h-pixels v-pixels x-len y-len x-page y-page x-val y-val) (when w (check-gauge-integer '(method canvas% init-auto-scrollbars) w))
(set-scrollbars h-pixels v-pixels x-len y-len x-page y-page x-val y-val #t)] (when h (check-gauge-integer '(method canvas% init-auto-scrollbars) h))
[(h-pixels v-pixels x-len y-len x-page y-page x-val y-val man?) (check-fraction '(method canvas% init-auto-scrollbars) x)
(as-entry (check-fraction '(method canvas% init-auto-scrollbars) y)
(lambda () (let-values ([(cw ch) (get-client-size)])
(let ([rc (lambda (x) (send wx set-scrollbars (if w 1 0) (if h 1 0)
(when x (check-gauge-integer '(method canvas% set-scrollbars) x)))]) (or w 0) (or h 0) 1 1
(rc h-pixels) (if w (inexact->exact (floor (* x (max 0 (- w cw))))) 0)
(rc v-pixels) (if h (inexact->exact (floor (* y (max 0 (- h ch))))) 0)
(send wx set-scrollbars (or h-pixels 0) (or v-pixels 0) #t)))]
x-len y-len x-page y-page x-val y-val man?))))])])
set-scrollbars)] [init-manual-scrollbars
(lambda (x-len y-len x-page y-page x-val y-val)
(let ([who '(method canvas% init-auto-scrollbars)])
(when x-len (check-range-integer who x-len))
(when y-len (check-range-integer who y-len))
(check-gauge-integer who x-page)
(check-gauge-integer who y-page)
(check-range-integer who x-val)
(check-range-integer who y-val)
(when (and x-len (< x-len x-val))
(raise-mismatch-error (who->name who)
(format "horizontal value: ~e larger than the horizontal range: "
x-val)
x-len))
(when (and y-len (< y-len y-val))
(raise-mismatch-error (who->name who)
(format "vertical value: ~e larger than the vertical range: "
y-val)
y-len)))
(send wx set-scrollbars (if x-len 1 0) (if y-len 1 0)
(or x-len 0) (or y-len 0) x-page y-page x-val y-val #f))]
[get-scroll-pos (entry-point-1 (lambda (d) (send wx get-scroll-pos d)))] [get-scroll-pos (entry-point-1 (lambda (d) (send wx get-scroll-pos d)))]
[set-scroll-pos (entry-point-2 (lambda (d v) (send wx set-scroll-pos d v)))] [set-scroll-pos (entry-point-2 (lambda (d v) (send wx set-scroll-pos d v)))]
@ -3406,7 +3421,7 @@
(raise-mismatch-error (constructor-name 'menu-bar) "the specified frame already has a menu bar: " p))) (raise-mismatch-error (constructor-name 'menu-bar) "the specified frame already has a menu bar: " p)))
(define wx-menu-item% (define wx-menu-item%
(class* wx:menu-item% (wx<%>) (mred) (class* wx:menu-item% (wx<%>) (mred menu-data)
(private (private
[keymap #f]) [keymap #f])
(public (public
@ -3415,7 +3430,8 @@
[swap-keymap (lambda (parent k) [swap-keymap (lambda (parent k)
(send (mred->wx parent) swap-item-keymap keymap k) (send (mred->wx parent) swap-item-keymap keymap k)
(set-keymap k))] (set-keymap k))]
[get-mred (lambda () mred)]) [get-mred (lambda () mred)]
[get-menu-data (lambda () menu-data)]) ; for meta-shortcuts
(sequence (sequence
(super-init)))) (super-init))))
@ -3430,7 +3446,28 @@
[disabled? #f] [disabled? #f]
[keymap (make-object wx:keymap%)]) [keymap (make-object wx:keymap%)])
(public (public
[handle-key (lambda (event) (as-exit (lambda () (send keymap handle-key-event this event))))] [handle-key (lambda (event)
(as-exit
(lambda ()
(or (send keymap handle-key-event this event)
(and (wx:shortcut-visible-in-label? #t)
(send event get-meta-down)
(char? (send event get-key-code))
(let ([c (send event get-key-code)])
(and (or (char-alphabetic? c)
(char-numeric? c))
(let ([re (key-regexp c)])
(ormap
(lambda (i)
(let* ([data (send (mred->wx i) get-menu-data)]
[label (car data)]
[menu (cdr data)])
(if (regexp-match re label)
(begin
(send menu select)
#t)
#f)))
items)))))))))]
[get-mred (lambda () mred)] [get-mred (lambda () mred)]
[get-items (lambda () items)] [get-items (lambda () items)]
[append-item (lambda (item menu title) [append-item (lambda (item menu title)
@ -3554,7 +3591,7 @@
(sequence (sequence
(as-entry (as-entry
(lambda () (lambda ()
(set! wx (make-object wx-menu-item% this)) (set! wx (make-object wx-menu-item% this #f))
(set! wx-parent (mred->wx parent)) (set! wx-parent (mred->wx parent))
(super-init wx))) (super-init wx)))
(restore)))) (restore))))
@ -3583,6 +3620,7 @@
(lambda (l) (lambda (l)
(check-string '(method labelled-menu-item<%> set-label) l) (check-string '(method labelled-menu-item<%> set-label) l)
(set! label l) (set! label l)
(set-car! (send wx get-menu-data) l) ; for meta-shortcuts
(set! plain-label (wx:label->plain-label l)) (set! plain-label (wx:label->plain-label l))
(when shown? (when shown?
(if in-menu? (if in-menu?
@ -3621,7 +3659,7 @@
(sequence (sequence
(as-entry (as-entry
(lambda () (lambda ()
(set! wx (set-wx (make-object wx-menu-item% this))) (set! wx (set-wx (make-object wx-menu-item% this (cons label #f))))
(set! wx-parent (mred->wx parent)) (set! wx-parent (mred->wx parent))
(super-init wx) (super-init wx)
(when keymap (send wx set-keymap keymap)))) (when keymap (send wx set-keymap keymap))))
@ -3769,7 +3807,8 @@
(as-entry (as-entry
(lambda () (lambda ()
(super-init #f void) (super-init #f void)
(set! item (make-object sub-menu-item% this label parent help-string))))))) (set! item (make-object sub-menu-item% this label parent help-string))
(set-cdr! (send (mred->wx item) get-menu-data) (mred->wx this))))))) ; for meta-shortcuts
(define popup-menu% (define popup-menu%
(class basic-menu% ([title #f]) (class basic-menu% ([title #f])
@ -4160,22 +4199,22 @@
(send f show #t) (send f show #t)
(and ok? (send t get-value))))])) (and ok? (send t get-value))))]))
(define get-choice-from-user (define get-choices-from-user
(case-lambda (case-lambda
[(title message choices) (get-choice-from-user title message choices #f null '(single))] [(title message choices) (get-choices-from-user title message choices #f null '(single))]
[(title message choices parent) (get-choice-from-user title message choices parent null '(single))] [(title message choices parent) (get-choices-from-user title message choices parent null '(single))]
[(title message choices parent init-vals) (get-choice-from-user title message choices parent init-vals '(single))] [(title message choices parent init-vals) (get-choices-from-user title message choices parent init-vals '(single))]
[(title message choices parent init-vals style) [(title message choices parent init-vals style)
(check-string 'get-choice-from-user title) (check-string 'get-choices-from-user title)
(check-string/false 'get-choice-from-user message) (check-string/false 'get-choices-from-user message)
(unless (andmap string? choices) (unless (andmap string? choices)
(raise-type-error 'get-choice-from-user parent "list of strings" choices)) (raise-type-error 'get-choices-from-user parent "list of strings" choices))
(check-top-level-parent/false 'get-choice-from-user parent) (check-top-level-parent/false 'get-choices-from-user parent)
(unless (and (list? init-vals) (andmap (lambda (x) (integer? x) (exact? x) (not (negative? x))) init-vals)) (unless (and (list? init-vals) (andmap (lambda (x) (integer? x) (exact? x) (not (negative? x))) init-vals))
(raise-type-error 'get-choice-from-user "list of exact non-negative integers" init-vals)) (raise-type-error 'get-choices-from-user "list of exact non-negative integers" init-vals))
(check-style 'get-choice-from-user '(single multiple extended) null style) (check-style 'get-choices-from-user '(single multiple extended) null style)
(when (and (memq 'single style) (> (length init-vals) 1)) (when (and (memq 'single style) (> (length init-vals) 1))
(raise-mismatch-error 'get-choice-from-user (raise-mismatch-error 'get-choices-from-user
(format "multiple initial-selection indices provided with ~e style: " 'single) (format "multiple initial-selection indices provided with ~e style: " 'single)
init-vals)) init-vals))
(let* ([f (make-object dialog% title parent box-width)] (let* ([f (make-object dialog% title parent box-width)]
@ -4194,7 +4233,7 @@
(for-each (lambda (i) (for-each (lambda (i)
(when (>= i (send l get-number)) (when (>= i (send l get-number))
(raise-mismatch-error (raise-mismatch-error
'get-choice-from-user 'get-choices-from-user
(format "inital-selection list specifies an out-of-range index (~e choices provided): " (format "inital-selection list specifies an out-of-range index (~e choices provided): "
(send l get-number)) (send l get-number))
i)) i))
@ -4668,6 +4707,12 @@
(define check-gauge-integer (check-bounded-integer 1 10000 #f)) (define check-gauge-integer (check-bounded-integer 1 10000 #f))
(define (check-fraction who x)
(unless (and (real? x) (<= 0.0 x 1.0))
(raise-type-error (who->name who)
"real number in [0.0, 1.0]"
x)))
(define (check-non-negative-integer who i) (define (check-non-negative-integer who i)
(unless (and (integer? i) (exact? i) (not (negative? i))) (unless (and (integer? i) (exact? i) (not (negative? i)))
(raise-type-error (who->name who) "non-negative exact integer" i))) (raise-type-error (who->name who) "non-negative exact integer" i)))