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

updated to container classes

Browse Source 
original commit: 959f6449ffbad9488272027ac817c2c1b05fb002
This commit is contained in:
Robby Findler 1996-07-12 13:57:02 +00:00
parent 8577dec657
commit 594bdab54d
3 changed files with 68 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mred/edit.ss
View File

@ -140,7 +140,7 @@
(lambda () (lambda ()
(let ([c (get-canvas)]) (let ([c (get-canvas)])
(if c (if c
(let ([f (send c get-parent)]) (let ([f (ivar c frame)])
(if (null? f) (if (null? f)
#f #f
f)) f))

19
collects/mred/keys.ss
View File

@ -116,12 +116,13 @@
[ring-bell [ring-bell
(lambda (edit event) (lambda (edit event)
(send (let loop ([p (send event get-event-object)]) (let ([c (send edit get-canvas)])
(let ([parent (send p get-parent)]) (when c
(if (null? parent) (let ([f (let loop ([f c])
p (if (is-a? f wx:frame%)
(loop parent)))) f
clear-mini-panel%) (loop (send f get-parent))))])
(send f hide-search))))
(wx:bell))] (wx:bell))]
[save-file-as [save-file-as
(lambda (edit event) (lambda (edit event)
@ -813,23 +814,27 @@
(map-meta ">" "end-of-file") (map-meta ">" "end-of-file")
(map "d:DOWN" "end-of-file") (map "d:DOWN" "end-of-file")
(map "c:DOWN" "end-of-file") (map "c:end" "end-of-file")
(map "s:c:end" "select-to-end-of-file") (map "s:c:end" "select-to-end-of-file")
(map "s:d:down" "select-to-end-of-file") (map "s:d:down" "select-to-end-of-file")
(map "c:v" "next-page") (map "c:v" "next-page")
(map "a:DOWN" "next-page") (map "a:DOWN" "next-page")
(map "pagedown" "next-page") (map "pagedown" "next-page")
(map "c:DOWN" "next-page")
(map "s:c:v" "select-page-down") (map "s:c:v" "select-page-down")
(map "a:s:DOWN" "select-page-down") (map "a:s:DOWN" "select-page-down")
(map "s:pagedown" "select-page-down") (map "s:pagedown" "select-page-down")
(map "s:c:DOWN" "select-page-down")
(map-meta "v" "previous-page") (map-meta "v" "previous-page")
(map "a:up" "previous-page") (map "a:up" "previous-page")
(map "pageup" "previous-page") (map "pageup" "previous-page")
(map "c:up" "previous-page")
(map-meta "s:v" "select-page-up") (map-meta "s:v" "select-page-up")
(map "s:a:up" "select-page-up") (map "s:a:up" "select-page-up")
(map "s:pageup" "select-page-up") (map "s:pageup" "select-page-up")
(map "s:c:up" "select-page-up")
(map "c:h" "delete-previous-character") (map "c:h" "delete-previous-character")
(map "c:d" "delete-next-character") (map "c:d" "delete-next-character")

86
collects/mred/prefs.ss
View File

@ -25,46 +25,67 @@
(define-struct un/marshall (marshall unmarshall)) (define-struct un/marshall (marshall unmarshall))
(define-struct marshalled (data)) (define-struct marshalled (data))
(define-struct pref (value callbacks))
(define get-preference-box (define unmarshall
(lambda (p marshalled)
(let/ec k
(let ([unmarshall (un/marshall-unmarshall (hash-table-get marshall-unmarshall
p
(lambda () (k marshalled))))])
(unmarshall (marshalled-data marshalled))))))
(define add-preference-callback
(lambda (p callback)
(let ([ans (hash-table-get preferences p (lambda () #f))])
(cond
[(marshalled? ans) (let* ([value (unmarshall p ans)]
[pref (make-pref value (list callback))])
(hash-table-put! preferences p pref)
(callback p value)
(lambda ()
(set-pref-callbacks! pref (mzlib:function:remove callback (pref-callbacks pref) eq?))))]
[(pref? ans)
(set-pref-callbacks! ans (cons callback (pref-callbacks ans)))
(lambda ()
(set-pref-callbacks! ans (mzlib:function:remove callback (pref-callbacks ans) eq?)))]
[(not ans) (raise (mred:exn:make-exn:unknown-preference
(format "adding callback to unknown preference: ~a" p)
((debug-info-handler))))]
[else (error 'prefs.ss "robby error.4: ~a ~a" p ans)]))))
(define get-preference
(lambda (p) (lambda (p)
(let ([ans (hash-table-get preferences p (let ([ans (hash-table-get preferences p
(lambda () (lambda ()
(raise (mred:exn:make-exn:unknown-preference (raise (mred:exn:make-exn:unknown-preference
(format "unknown preference: ~a" p) (format "attempted to get unknown preference: ~a" p)
((debug-info-handler))))))]) ((debug-info-handler))))))])
(cond (cond
[(marshalled? ans) [(marshalled? ans)
(let* ([marshalled (marshalled-data ans)] (let* ([marshalled (marshalled-data ans)]
[unmarshalled [unmarshalled (unmarshall p marshalled)]
(let/ec k [pref (make-pref unmarshalled null)])
((un/marshall-unmarshall (hash-table-put! preferences p pref)
(hash-table-get marshall-unmarshall p unmarshalled)]
(lambda () (k marshalled)))) [(pref? ans) (pref-value ans)]
marshalled))]
[boxed (box unmarshalled)])
(hash-table-put! preferences p boxed)
boxed)]
[(box? ans) ans]
[else (error 'prefs.ss "robby error.1: ~a" ans)])))) [else (error 'prefs.ss "robby error.1: ~a" ans)]))))
(define get-preference (mzlib:function:compose unbox get-preference-box))
(define set-preference (define set-preference
(lambda (p value) (lambda (p value)
(let/ec k (let/ec k
(set-box! (hash-table-get preferences p (let ([pref (hash-table-get preferences p
(lambda () (lambda ()
(let ([box (box value)]) (let ([pref (make-pref value null)])
(hash-table-put! preferences p box) (k (hash-table-put! preferences p pref)))))])
(k box)))) (set-pref-value! pref value)
value)))) (for-each (lambda (x) (x p value)) (pref-callbacks pref))))))
(define set-preference-default (define set-preference-default
(lambda (p value) (lambda (p value)
(hash-table-get preferences p (hash-table-get preferences p
(lambda () (lambda ()
(hash-table-put! preferences p (box value)))) (hash-table-put! preferences p (make-pref value null))))
(set! defaults (cons (list p value) defaults)))) (set! defaults (cons (list p value) defaults))))
(define set-preference-un/marshall (define set-preference-un/marshall
@ -75,16 +96,15 @@
(define restore-defaults (define restore-defaults
(lambda () (lambda ()
(for-each (lambda (x) (apply set-preference x)) (for-each (lambda (x) (apply set-preference x)) defaults)))
defaults)))
(define save-user-preferences (define save-user-preferences
(let ([marshall-pref (let ([marshall-pref
(lambda (p ht-value) (lambda (p ht-value)
(cond (cond
[(marshalled? ht-value) (list p (marshalled-data ht-value))] [(marshalled? ht-value) (list p (marshalled-data ht-value))]
[(box? ht-value) [(pref? ht-value)
(let* ([value (unbox ht-value)] (let* ([value (pref-value ht-value)]
[marshalled [marshalled
(let/ec k (let/ec k
((un/marshall-marshall ((un/marshall-marshall
@ -108,18 +128,18 @@
(let ([parse-pref (let ([parse-pref
(lambda (p marshalled) (lambda (p marshalled)
(let/ec k (let/ec k
(let* ([ht-pref (hash-table-get preferences p (lambda () 'not-in-table))] (let* ([ht-pref (hash-table-get preferences p (lambda () #f))]
[unmarshall-struct (hash-table-get marshall-unmarshall p (lambda () #f))]) [unmarshall-struct (hash-table-get marshall-unmarshall p (lambda () #f))])
(cond (cond
[(box? ht-pref) [(and (pref? ht-pref) unmarshall-struct)
(if unmarshall-struct (set-preference p ((un/marshall-unmarshall unmarshall-struct) marshalled))]
(set-box! ht-pref ((un/marshall-unmarshall unmarshall-struct) marshalled)) [(pref? ht-pref)
(set-box! ht-pref marshalled))] (hash-table-put! preferences p (make-marshalled marshalled))]
[(marshalled? ht-pref) (set-marshalled-data! ht-pref marshalled)] [(marshalled? ht-pref) (set-marshalled-data! ht-pref marshalled)]
[(eq? 'not-in-table ht-pref) [(and (not ht-pref) unmarshall-struct)
(if unmarshall-struct (set-preference p ((un/marshall-unmarshall unmarshall-struct) marshalled))]
(hash-table-put! preferences p (box ((un/marshall-unmarshall unmarshall-struct) marshalled))) [(not ht-pref)
(hash-table-put! preferences p (make-marshalled marshalled)))] (hash-table-put! preferences p (make-marshalled marshalled))]
[else (error 'prefs.ss "robby error.3: ~a" ht-pref)]))))]) [else (error 'prefs.ss "robby error.3: ~a" ht-pref)]))))])
(lambda () (lambda ()
(mred:debug:printf 'startup "reading user preferences") (mred:debug:printf 'startup "reading user preferences")