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

...

Browse Source 
original commit: 4ae921dceac6b3244c4ff496b91855111d2d4633
This commit is contained in:
Robby Findler 1998-09-15 22:48:42 +00:00
parent 0172b6a3f7
commit edfc1cfb98
6 changed files with 113 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/framework/canvas.ss
View File

@ -2,6 +2,9 @@
(import mred^
[preferences : framework:preferences^])
;; wx: this need to collude with
;; the edit, since the edit has the right callbacks.
(define make-wide-snip%
(lambda (super%)
(class-asi super%
@ -10,7 +13,6 @@
(private
[wide-snips null]
[tall-snips null]
[autowrap-snips (preferences:get 'framework:auto-set-wrap?)]
[update-snip-size
(lambda (width?)
(lambda (s)
@ -65,7 +67,7 @@
(set-max-width snip-width))
(when snip-media
(send snip-media set-max-width
(if autowrap-snips?
(if (send snip-media auto-wrap)
snip-width
0))))
(let ([snip-height (- (unbox height)
@ -76,10 +78,6 @@
(set-min-height snip-height)
(set-max-height snip-height)))))))))))])
(public
[set-autowrap-snips
(lambda (x)
(set! autowrap-snips? x)
(for-each (update-snip-size #t) wide-snips))]
[add-wide-snip
(lambda (snip)
(set! wide-snips (cons snip wide-snips))
@ -94,4 +92,4 @@
(for-each (update-snip-size #t) wide-snips)
(for-each (update-snip-size #f) tall-snips))]))))
(define wide-snip% (make-wide-snip-canvas% editor-canvas%)))
(define wide-snip% (make-wide-snip% editor-canvas%)))

9
collects/framework/finder.ss
View File

@ -10,8 +10,8 @@
[mzlib:function : mzlib:function^]
[mzlib:file : mzlib:file^])
(rename [put-file -put-file]
[get-file -get-file])
(rename [-put-file put-file]
[-get-file get-file])
(define dialog-parent-parameter (make-parameter #f))
@ -51,7 +51,7 @@
; the finder-dialog% class controls the user interface for dialogs
(define finder-dialog%
(class dialog-box% (parent-win
(class dialog% (parent-win
save-mode?
replace-ok?
multi-mode?
@ -124,8 +124,7 @@
(char=? (string-ref s 0) #\.))
rest]
[(directory-exists? (build-path dir s))
(cons (string-append s (get-slash))
rest)]
(cons s rest)]
[(or (not file-filter)
(mzlib:string:regexp-match-exact?
file-filter s))

1
collects/framework/group.ss
View File

@ -1,6 +1,7 @@
(unit/sig framework:group^
(import mred^
[exit : framework:exit^]
[frame : framework:frame^]
[mzlib:function : mzlib:function^]
[mzlib:file : mzlib:file^])

174
collects/framework/panel.ss
View File

@ -1,81 +1,93 @@
(unit/sig framework:panel^
(import mred^
[mzlib:function : mzlib:function^])
(define make-edit%
(lambda (super%)
(class-asi super%
(rename [super-change-children change-children])
(inherit get-parent change-children children)
(public [get-canvas% (lambda () editor-canvas%)])
(private
[split-edits null])
(public
[collapse
(lambda (canvas)
(let ([media (send canvas get-media)])
(if (memq media split-edits)
(letrec ([helper
(lambda (canvas/panel)
(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))))])
(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)) focus))))))])
(send media remove-canvas canvas)
(helper canvas))
(bell))))]
[split
(opt-lambda (canvas [panel% horizontal-panel%])
(let* ([frame (ivar canvas frame)]
[media (send canvas get-media)]
[canvas% (object-class canvas)]
[parent (send canvas get-parent)]
[new-panel #f]
[left-split #f]
[right-split #f]
[before #t])
(set! split-edits (cons media split-edits))
(dynamic-wind
(lambda ()
(set! before (send frame delay-updates))
(send frame delay-updates #t))
(lambda ()
(set! new-panel (make-object panel% parent))
(set! left-split (make-object canvas% new-panel))
(set! right-split (make-object canvas% new-panel))
(send parent change-children
(lambda (l)
(let ([before (remq new-panel l)])
(map (lambda (x) (if (eq? x canvas)
new-panel
x))
before)))))
(lambda () (send frame delay-updates before)))
(send* media (remove-canvas canvas)
(add-canvas left-split)
(add-canvas right-split))
(send* left-split (set-media media) (focus))
(send* right-split (set-media media))))]))))
(define horizontal-edit%
(make-edit% horizontal-panel%))
(define vertical-edit%
(make-edit% vertical-panel%)))
(unit/sig framework:panel^
(import mred-interfaces^
[mzlib:function : mzlib:function^])
(define single<%> (interface (panel%)))
(define make-single%
(mixin (panel<%>) (single<%>) args
(sequence
(apply super-init args))))
(define single% vertical-panel%)
(define edit<%>
(interface ()
get-canvas%
collapse
split))
(define make-edit%
(mixin (panel<%>) (edit<%>) args
(rename [super-change-children change-children])
(inherit get-parent change-children children)
(public [get-canvas% (lambda () editor-canvas%)])
(private
[split-edits null])
(public
[collapse
(lambda (canvas)
(let ([media (send canvas get-media)])
(if (memq media split-edits)
(letrec ([helper
(lambda (canvas/panel)
(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))))])
(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)) focus))))))])
(send media remove-canvas canvas)
(helper canvas))
(bell))))]
[split
(opt-lambda (canvas [panel% horizontal-panel%])
(let* ([frame (ivar canvas frame)]
[media (send canvas get-media)]
[canvas% (object-class canvas)]
[parent (send canvas get-parent)]
[new-panel #f]
[left-split #f]
[right-split #f]
[before #t])
(set! split-edits (cons media split-edits))
(dynamic-wind
(lambda ()
(set! before (send frame delay-updates))
(send frame delay-updates #t))
(lambda ()
(set! new-panel (make-object panel% parent))
(set! left-split (make-object canvas% new-panel))
(set! right-split (make-object canvas% new-panel))
(send parent change-children
(lambda (l)
(let ([before (mzlib:function:remq new-panel l)])
(map (lambda (x) (if (eq? x canvas)
new-panel
x))
before)))))
(lambda () (send frame delay-updates before)))
(send* media (remove-canvas canvas)
(add-canvas left-split)
(add-canvas right-split))
(send* left-split (set-media media) (focus))
(send* right-split (set-media media))))])
(sequence (apply super-init args))))
(define horizontal-edit%
(make-edit% horizontal-panel%))
(define vertical-edit%
(make-edit% vertical-panel%)))

3
collects/framework/prefs.ss
View File

@ -2,6 +2,7 @@
(import mred^
[exn : framework:exn^]
[exit : framework:exit^]
[panel : framework:panel^]
[mzlib:pretty-print : mzlib:pretty-print^]
[mzlib:function : mzlib:function^])
@ -559,7 +560,7 @@
(send menu stretchable-in-x #f)
menu))]
[popup-menu (make-popup-menu)]
[single-panel (make-object vertical-panel%; This should be single-panel%. wx:
[single-panel (make-object panel:single%
panel '(border))]
[bottom-panel (make-object horizontal-panel% panel)]
[ensure-constructed

12
collects/framework/sig.ss
View File

@ -38,7 +38,11 @@
version))
(define-signature framework:panel^
(make-edit%
(make-single%
single<%>
single%
make-edit%
edit<%>
horizontal-edit%
vertical-edit%))
@ -171,8 +175,8 @@
media-snip%))
(define-signature framework:canvas^
(make-wide-snip-canvas%
wide-snip-canvas%))
(make-wide-snip%
wide-snip%))
(define-signature framework:frame^
(empty<%>
@ -203,7 +207,7 @@
pasteboard-info-file%))
(define-signature framework:group^
(frame-group%
(%
the-frame-group))
(define-signature framework:handler^