diff --git a/notes/mred/MrEd_100.txt b/notes/mred/MrEd_100.txt index 2e7a02b1..6699fdd0 100644 --- a/notes/mred/MrEd_100.txt +++ b/notes/mred/MrEd_100.txt @@ -1085,12 +1085,16 @@ the-color-database only has a find-color method; the others were TODO: Miscellaneous Cleanup ----------------------------- -Filter overlapping controls for tabbing! - Move the editor margin settings into ps-setup%? +Blit: b&w in color -> monochrome + +null => #f in class + +Filter overlapping controls for tabbing! + Add `on-tab' to canvas<%>? Add a `shutdown?' predicate. -Blit: b&w in color -> monochrome +on-new-child method of area-container<%> diff --git a/src/mred/wrap/mred.ss b/src/mred/wrap/mred.ss index 4a95da4d..e6b76b55 100644 --- a/src/mred/wrap/mred.ss +++ b/src/mred/wrap/mred.ss @@ -348,6 +348,28 @@ [else (list i)])) (ivar f children)))) +(define (filter-overlapping l) + (if (null? l) + null + (let* ([rest (filter-overlapping (cdr l))] + [first (car l)] + [f (cdr first)] + [x (car f)] + [y (cadr f)] + [x2 (+ x (caddr f))] + [y2 (+ y (cadddr f))]) + (if (ormap (lambda (other) + (let* ([p (cdr other)] + [px (car p)] + [py (cadr p)] + [px2 (+ px (caddr p))] + [py2 (+ py (cadddr p))]) + (and (or (<= x px x2) (<= x px2 x2)) + (or (<= y py y2) (<= y py2 y2))))) + rest) + rest + (cons first rest))))) + ;;;;;;;;;;;;;;; wx- Class Construction ;;;;;;;;;;;;;;;;;;;; ; ------------- Mixins for common functionality -------------- @@ -708,7 +730,8 @@ [normal-move (lambda () (let* ([o (if (or (is-a? o wx:canvas%) (is-a? o wx:item%)) o #f)] - [dests (map object->position (container->children panel o #t))] + [dests (filter-overlapping + (map object->position (container->children panel o #t)))] [pos (if o (object->position o) (list 'x 0 0 1 1))] [o (traverse (cadr pos) (caddr pos) (cadddr pos) (list-ref pos 4) (case code @@ -2516,6 +2539,7 @@ reflow-container container-size get-children change-children place-children + on-new-child add-child delete-child border spacing set-alignment get-alignment)) @@ -2525,6 +2549,7 @@ (define (make-container% %) ; % implements area<%> (class* % (area-container<%> internal-container<%>) (mk-wx get-wx-panel parent) (public + [on-new-child (lambda (c) (void))] [reflow-container (entry-point (lambda () (send (send (get-wx-panel) get-top-level) force-redraw)))] [get-children (entry-point (lambda () (map wx->proxy (ivar (get-wx-panel) children))))] [border (param get-wx-panel 'border)] @@ -2788,7 +2813,8 @@ (private [wx #f]) (sequence - (super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) label parent cursor)))) + (super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) label parent cursor) + (as-exit (lambda () (send parent on-new-child this)))))) ;--------------------- Final mred class construction -------------------- @@ -3317,7 +3343,8 @@ -1 -1 ds ds style))) wx) - parent)))) + parent) + (send parent on-new-child this)))) (define editor-canvas% (class basic-canvas% (parent [buffer #f] [style null] [scrolls-per-page 100]) @@ -3388,7 +3415,8 @@ wx)) parent) (when buffer - (set-editor buffer))))) + (set-editor buffer)) + (send parent on-new-child this)))) ;-------------------- Final panel interfaces and class constructions -------------------- @@ -3409,7 +3437,8 @@ [else wx-pane%]) this this (mred->wx-container parent) null)) wx) (lambda () wx) parent) - (send (send wx area-parent) add-child wx))))))) + (send (send wx area-parent) add-child wx))) + (send parent on-new-child this))))) (define vertical-pane% (class pane% (parent) (sequence (super-init parent)))) (define horizontal-pane% (class pane% (parent) (sequence (super-init parent)))) @@ -3432,7 +3461,8 @@ [else wx-panel%]) this this (mred->wx-container parent) style)) wx) (lambda () wx) #f parent #f) - (send (send wx area-parent) add-child wx))))))) + (send (send wx area-parent) add-child wx))) + (send parent on-new-child this))))) (define vertical-panel% (class panel% args (sequence (apply super-init args)))) (define horizontal-panel% (class panel% args (sequence (apply super-init args))))