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

fixed bugs, added mred:message-box

Browse Source 
original commit: bbb55e4980c850eb15afc4f0d1a1e23e6d077572
This commit is contained in:
Robby Findler 1996-11-07 23:06:21 +00:00
parent 558a3464f1
commit d971a2cd69
3 changed files with 45 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/mred/edit.ss
View File

@ -37,6 +37,21 @@
[super-set-max-width set-max-width]
[super-lock lock])
(public
[get-edit-snip
(lambda () (make-object wx:media-snip%
(make-object edit%)))]
[get-pasteboard-snip
(lambda () (make-object wx:media-snip%
(make-object pasteboard%)))]
[on-new-box
(lambda (type)
(wx:message-box (format "insert-box ~a" type))
(cond
[(= type wx:const-edit-buffer)
(get-edit-snip)]
[else (get-pasteboard-snip)]))])
(private
[auto-saved-name #f]
[auto-save-out-of-date? #t]
@ -44,7 +59,7 @@
(public
[set-max-width
(lambda (x)
(mred:debug:printf 'rewrap "set-max-width: ~a~n" x)
(mred:debug:printf 'rewrap "set-max-width: ~a" x)
(super-set-max-width x))]
[get-file (lambda (d)
(let ([v (mred:finder:get-file d)])
@ -59,7 +74,7 @@
[auto-set-wrap? (mred:preferences:get-preference 'mred:auto-set-wrap?)]
[set-auto-set-wrap
(lambda (v)
(mred:debug:printf 'rewrap "set-auto-set-wrap: ~a~n" v)
(mred:debug:printf 'rewrap "set-auto-set-wrap: ~a" v)
(set! auto-set-wrap? v)
(rewrap))]
@ -67,12 +82,12 @@
(let ([do-wrap
(lambda (new-width)
(let ([current-width (get-max-width)])
(mred:debug:printf 'rewrap "do-wrap: new-width ~a current-width ~a~n" new-width current-width)
(mred:debug:printf 'rewrap "do-wrap: new-width ~a current-width ~a" new-width current-width)
(unless (or (= current-width new-width)
(and (<= current-width 0)
(<= new-width 0)))
(set-max-width new-width)
(mred:debug:printf 'rewrap "attempted to wrap to: ~a actually wrapped to ~a~n"
(mred:debug:printf 'rewrap "attempted to wrap to: ~a actually wrapped to ~a"
new-width (get-max-width)))))])
(lambda ()
(if auto-set-wrap?
@ -91,7 +106,7 @@
(max (unbox w-box) sofar)))
0
canvases)))
(do-wrap -1))))]
(do-wrap 0))))]
[mode #f]
[set-mode
(lambda (m)

4
collects/mred/finder.ss
View File

@ -323,7 +323,8 @@
(when (eq? wx:platform 'unix)
(make-object mred:container:check-box% period-panel
do-period-in/exclusion
"Show files and directories that begin with a period"))
"Show files and directories that begin with a period")
(send period-panel stretchable-in-y #f))
(send* directory-panel
(stretchable-in-y #f)
@ -345,7 +346,6 @@
(send add-panel stretchable-in-y #f)
(send remove-panel stretchable-in-y #f)
(send result-list stretchable-in-x #t))
(send period-panel stretchable-in-y #f)
(send name-list stretchable-in-x #t)
(send top-panel stretchable-in-y #f)
(send bottom-panel stretchable-in-y #f)

68
collects/mred/panel.ss
View File

@ -11,48 +11,35 @@
(lambda (super%)
(class-asi super%
(rename [super-change-children change-children])
(inherit children get-parent)
(inherit get-parent change-children children)
(public [get-canvas% (lambda () mred:canvas:frame-title-canvas%)])
(private
[edit-mapping (make-hash-table)]
[bind
(lambda (panel edit)
(hash-table-put! edit-mapping edit panel))]
[lookup/add
(lambda (child)
(if (is-a? child wx:media-edit%)
(let ([add-new
(lambda ()
(let ([p (make-object (get-canvas%) this)])
(send p set-media child)
(send child add-canvas p)
(bind p child)
p))])
(hash-table-get edit-mapping child add-new))
child))])
(public
; this contains the edits and panels that are children of
; this panel, but the canvases of these edits are not
; necessarily immediate children, since they may be split.
[actual-children null]
[collapse
(lambda (canvas)
(letrec* ([media (send canvas get-media)]
[helper
(lambda (canvas/panel)
(let* ([parent (send canvas/panel get-parent)])
(if (is-a? parent wx:frame%)
(begin (send canvas/panel change-children
(lambda (l) (list media)))
(wx:bell))
(let* ([parents-children (ivar parent children)]
[num-children (length parents-children)])
(if (<= num-children 1)
(helper parent)
(begin (send parent delete-child canvas/panel)
(send (car (ivar parent children)) set-focus)))))))])
(if (eq? canvas/panel this)
(begin (cond
[(and (= (length children) 1)
(eq? canvas (car children)))
(void)]
[(member canvas children)
(change-children (lambda (l) (list canvas)))]
[else
(change-children
(lambda (l)
(let ([c (make-object (object-class canvas) this)])
(send c set-media media)
(list c))))])
(wx:bell))
(let* ([parent (send canvas/panel get-parent)]
[parents-children (ivar parent children)]
[num-children (length parents-children)])
(if (<= num-children 1)
(helper parent)
(begin (send parent delete-child canvas/panel)
(send (car (ivar parent children)) set-focus))))))])
(send media remove-canvas canvas)
(helper canvas)))]
@ -83,16 +70,7 @@
(add-canvas left-split)
(add-canvas right-split))
(send* left-split (set-media media) (set-focus))
(send* right-split (set-media media))
(when (eq? this parent)
(bind media new-panel))))]
[change-children
(lambda (f)
(let ([new-children (f actual-children)])
(super-change-children (lambda (l)
(map lookup/add
new-children)))
(set! actual-children new-children)))]))))
(send* right-split (set-media media))))]))))
(define horizontal-edit-panel%
(make-edit-panel% mred:container:horizontal-panel%))