diff --git a/collects/combinator-parser/examples/combinator-example.ss b/collects/combinator-parser/examples/combinator-example.ss index 7fadcb66ab..5d804300cb 100644 --- a/collects/combinator-parser/examples/combinator-example.ss +++ b/collects/combinator-parser/examples/combinator-example.ss @@ -37,8 +37,13 @@ (define-simple-terminals keywords (lam (O_paren "(") (C_paren ")"))) + (define string->symbol* + (case-lambda + [(one) (string->symbol one)] + [(one two three) (error 'string->symbol* "Cannot accept so many arguments")])) + (define-terminals ids - ((id "variable" string->symbol) (number (lambda (x) (read (open-input-string x)))))) + ((id "variable" string->symbol*) (number (lambda (x) (read (open-input-string x)))))) (define app (sequence (O_paren (repeat (eta expr)) C_paren) diff --git a/collects/embedded-gui/private/program-editor.ss b/collects/embedded-gui/private/program-editor.ss index 7274f2ee43..a9f67b8d0f 100644 --- a/collects/embedded-gui/private/program-editor.ss +++ b/collects/embedded-gui/private/program-editor.ss @@ -72,15 +72,15 @@ is being reset. ; (super on-insert start len) ; (end-edit-sequence)) - (define/override (after-insert start len) + (define/augment (after-insert start len) (alert-of-modify) ;(begin-edit-sequence) - (super after-insert start len) + #;(super after-insert start len) ;(end-edit-sequence) ) - (define/override (after-delete start len) + (define/augment (after-delete start len) (alert-of-modify) - (super after-delete start len)) + #;(super after-delete start len)) (super-new))) (define program-editor% diff --git a/collects/frtime/gui/mod-mrpanel.ss b/collects/frtime/gui/mod-mrpanel.ss deleted file mode 100644 index 239c9199b7..0000000000 --- a/collects/frtime/gui/mod-mrpanel.ss +++ /dev/null @@ -1,229 +0,0 @@ -(module mod-mrpanel mzscheme - (require mzlib/class - mzlib/class100 - (prefix wx: mred/private/kernel) - mred/private/lock - mred/private/const - mred/private/check - mred/private/helper - mred/private/wx - mred/private/kw - "mod-wx-panel.ss" - mred/private/mrwindow - mred/private/mrcontainer - mred/private/mrtabgroup - mred/private/mrgroupbox) - - (provide #|pane% - vertical-pane% - horizontal-pane% - grow-box-spacer-pane% - panel% - vertical-panel% - horizontal-panel% - tab-panel% - group-box-panel%|# - free-vert-pane% - free-horiz-pane%) - - (define-keywords pane%-keywords - subarea%-keywords - container%-keywords - area%-keywords) - - (define pane% - (class100*/kw (make-subarea% (make-container% area%)) () - [(parent) pane%-keywords] - (private-field [wx #f]) - (sequence - (let* ([who (cond ; yuck! - we do this to make h-p and v-p subclasses of p - [(is-a? this vertical-pane%) 'vertical-pane] - [(is-a? this horizontal-pane%) 'horizontal-pane] - [(is-a? this grow-box-spacer-pane%) 'grow-box-spacer-pane] - [(is-a? this free-vert-pane%) 'free-vert-pane] - [(is-a? this free-horiz-pane%) 'free-horiz-pane] - [else 'pane])] - [cwho `(constructor ,who)]) - (check-container-parent cwho parent) - (as-entry - (lambda () - (super-init (lambda () (set! wx (make-object (case who - [(vertical-pane) wx-vertical-pane%] - [(horizontal-pane) wx-horizontal-pane%] - [(grow-box-spacer-pane) wx-grow-box-pane%] - [(free-vert-pane) wx-free-vert-pane%] - [(free-horiz-pane) wx-free-horiz-pane%] - [else wx-pane%]) - this this (mred->wx-container parent) null)) wx) - (lambda () wx) - (lambda () - (check-container-ready cwho parent)) - parent) - (send (send wx area-parent) add-child wx))) - (send parent after-new-child this))))) - - (define vertical-pane% (class100*/kw pane% () [(parent) pane%-keywords] (sequence (super-init parent)))) - (define horizontal-pane% (class100*/kw pane% () [(parent) pane%-keywords] (sequence (super-init parent)))) - (define grow-box-spacer-pane% (class100*/kw pane% () [(parent) pane%-keywords] (sequence (super-init parent)))) - (define free-vert-pane% (class100*/kw pane% () [(parent) pane%-keywords] (sequence (super-init parent)))) - (define free-horiz-pane% (class100*/kw pane% () [(parent) pane%-keywords] (sequence (super-init parent)))) - - (define-keywords panel%-keywords - window%-keywords - subarea%-keywords - container%-keywords - area%-keywords) - - (define panel% - (class100*/kw (make-area-container-window% (make-window% #f (make-subarea% (make-container% area%)))) (subwindow<%>) - [(parent [style null]) panel%-keywords] - (private-field [wx #f]) - (sequence - (let* ([who (cond ; yuck! - we do this to make h-p and v-p subclasses of p - [(is-a? this tab-panel%) 'tab-panel] - [(is-a? this group-box-panel%) 'group-box-panel] - [(is-a? this vertical-panel%) 'vertical-panel] - [(is-a? this horizontal-panel%) 'horizontal-panel] - [else 'panel])] - [cwho `(constructor ,who)]) - (check-container-parent cwho parent) - (check-style cwho #f '(border deleted) style) - (as-entry - (lambda () - (super-init (lambda () (set! wx (make-object (case who - [(vertical-panel tab-panel group-box-panel) wx-vertical-panel%] - [(horizontal-panel) wx-horizontal-panel%] - [else wx-panel%]) - this this (mred->wx-container parent) style)) wx) - (lambda () wx) - (lambda () (check-container-ready cwho parent)) - #f parent #f) - (unless (memq 'deleted style) - (send (send wx area-parent) add-child wx)))) - (send parent after-new-child this))))) - - (define vertical-panel% (class100*/kw panel% () [(parent [style null]) panel%-keywords] (sequence (super-init parent style)))) - (define horizontal-panel% (class100*/kw panel% () [(parent [style null]) panel%-keywords] (sequence (super-init parent style)))) - - (define list-append append) - - (define tab-panel% - (class100*/kw vertical-panel% () - [(choices parent [callback (lambda (b e) (void))] [style null] [font no-val]) panel%-keywords] - (sequence - (let ([cwho '(constructor tab-panel)]) - (unless (and (list? choices) (andmap label-string? choices)) - (raise-type-error (who->name cwho) "list of strings (up to 200 characters)" choices)) - (check-callback cwho callback) - (check-container-parent cwho parent) - (check-style cwho #f '(deleted no-border) style) - (check-font cwho font)) - (super-init parent (if (memq 'deleted style) - '(deleted) - null))) - - (private-field - [tabs (make-object tab-group% #f choices this (lambda (c e) (callback this e)) - (if (memq 'no-border style) - null - '(border)) - font)]) - (sequence - (send (mred->wx this) set-first-child-is-hidden)) - - (private-field - [save-choices (map string->immutable-string choices)] - [hidden-tabs? #f]) - - (public - [get-number (lambda () (length save-choices))] - [append (entry-point - (lambda (n) - (check-label-string '(method tab-panel% append) n) - (let ([n (string->immutable-string n)]) - (set! save-choices (list-append save-choices (list n))) - (send (mred->wx tabs) append n))))] - [get-selection (lambda () (and (pair? save-choices) - (send (mred->wx tabs) get-selection)))] - [set-selection (entry-point - (lambda (i) - (check-item 'set-selection i) - (send (mred->wx tabs) set-selection i)))] - [delete (entry-point - (lambda (i) - (check-item 'delete i) - (set! save-choices (let loop ([p 0][l save-choices]) - (if (= p i) - (cdr l) - (cons (car l) (loop (add1 p) (cdr l)))))) - (send (mred->wx tabs) delete i)))] - [set-item-label (entry-point - (lambda (i s) - (check-item 'set-item-label i) - (check-label-string '(method tab-panel% set-item-label) s) - (let ([s (string->immutable-string s)]) - (set! save-choices (let loop ([save-choices save-choices][i i]) - (if (zero? i) - (cons s (cdr save-choices)) - (cons (car save-choices) (loop (cdr save-choices) (sub1 i)))))) - (send (mred->wx tabs) set-label i s))))] - [set - (entry-point (lambda (l) - (unless (and (list? l) (andmap label-string? l)) - (raise-type-error (who->name '(method tab-panel% set)) - "list of strings (up to 200 characters)" l)) - (set! save-choices (map string->immutable-string l)) - (send (mred->wx tabs) set l)))] - [get-item-label (entry-point - (lambda (i) - (check-item 'get-item-label i) - (list-ref save-choices i)))]) - - (private - [check-item - (lambda (method n) - (check-non-negative-integer `(method tab-panel% ,method) n) - (let ([m (length save-choices)]) - (unless (< n m) - (raise-mismatch-error (who->name `(method tab-panel% ,method)) - (if (zero? m) - "panel has no tabs; given index: " - (format "panel has only ~a tabs, indexed 0 to ~a; given out-of-range index: " - m (sub1 m))) - n))))]))) - - - (define group-box-panel% - (class100*/kw vertical-panel% () - [(label parent [style null] [font no-val]) panel%-keywords] - (sequence - (let ([cwho '(constructor group-box-panel)]) - (check-label-string cwho label) - (check-container-parent cwho parent) - (check-style cwho #f '(deleted) style) - (check-font cwho font)) - - ;; Technically a bad way to change margin defaults, since it's - ;; implemented with an update after creation: - (when (eq? horiz-margin no-val) (set! horiz-margin 2)) - (when (eq? vert-margin no-val) (set! vert-margin 2)) - - (super-init parent (if (memq 'deleted style) - '(deleted) - null))) - - (private-field - [gbox (make-object group-box% label this null font)] - [lbl label]) - (sequence - (send (mred->wx this) set-first-child-is-hidden)) - - (override - [set-label (entry-point - (lambda (s) - (check-label-string '(method group-box-panel% set-label) s) - (set! lbl (if (immutable? s) - s - (string->immutable-string s))) - (send gbox set-label s)))] - [get-label (lambda () lbl)])))) diff --git a/collects/frtime/gui/mod-wx-panel.ss b/collects/frtime/gui/mod-wx-panel.ss deleted file mode 100644 index dd45859c0f..0000000000 --- a/collects/frtime/gui/mod-wx-panel.ss +++ /dev/null @@ -1,816 +0,0 @@ -(module mod-wx-panel mzscheme - (require mzlib/class - mzlib/class100 - mzlib/list - (prefix wx: mred/private/kernel) - mred/private/lock - mred/private/const - mred/private/helper - mred/private/check - mred/private/wx - mred/private/wxwindow - mred/private/wxitem - mred/private/wxcontainer) - - (provide (protect wx-panel% - wx-vertical-panel% - wx-horizontal-panel% - wx-pane% - wx-vertical-pane% - wx-horizontal-pane% - wx-grow-box-pane% - wx-free-vert-pane% - wx-free-horiz-pane%)) - - (define wx:windowless-panel% - (class100 object% (prnt x y w h style) - (private-field - [pos-x 0] [pos-y 0] [width 1] [height 1] - [parent prnt]) - (public - [drag-accept-files (lambda () (void))] - [on-drop-file (lambda () (void))] - [on-set-focus (lambda () (void))] - [on-kill-focus (lambda () (void))] - [set-focus (lambda () (void))] - [on-size (lambda () (void))] - [enable (lambda () (void))] - [show (lambda (on?) (void))] - [is-shown-to-root? (lambda () (send parent is-shown-to-root?))] - [is-enabled-to-root? (lambda () (send parent is-enabled-to-root?))] - [get-parent (lambda () parent)] - [get-client-size (lambda (wb hb) - (when wb (set-box! wb width)) - (when hb (set-box! hb height)))] - [set-size (lambda (x y w h) - (unless (negative? x) (set! pos-x x)) - (unless (negative? y) (set! pos-y y)) - (unless (negative? w) (set! width w)) - (unless (negative? h) (set! height h)))] - [get-x (lambda () pos-x)] - [get-y (lambda () pos-y)] - [get-width (lambda () width)] - [get-height (lambda () height)]) - (sequence (super-init)))) - - (define tab-h-border (if (eq? (system-type) 'unix) - 2 - 3)) - (define tab-v-bottom-border (if (memq (system-type) '(macosx macos)) - 0 - 2)) - - (define (wx-make-basic-panel% wx:panel% stretch?) - (class100* (wx-make-container% (make-item% wx:panel% 0 0 stretch? stretch?)) (wx-basic-panel<%>) (parent style) - (inherit get-x get-y get-width get-height - min-width min-height set-min-width set-min-height - x-margin y-margin - get-client-size area-parent - get-hard-minimum-size - get-top-level) - - (rename [super-set-focus set-focus]) - - (private-field - ;; cache to prevent on-size from recomputing its result every - ;; time. when curr-width is #f, cache invalid. - curr-width - curr-height - - ;; list of child-info structs corresponding to the children. (#f - ;; if no longer valid.) - [children-info null] - - ;; Not used by linear panels - [h-align 'center] [v-align 'center] - - ;; Needed for windowless panes - [move-children? #f] - - [ignore-redraw-request? #f]) - - (override - [has-tabbing-children? (lambda () #t)] - - [set-focus ; dispatch focus to a child panel - (lambda () - (if (null? children) - (super-set-focus) - (send (car children) set-focus)))] - - [ext-dx (lambda () (if hidden-child - tab-h-border - 0))] - [ext-dy (lambda () (if hidden-child - (let-values ([(mw mh) (get-hard-minimum-size)]) - (- mh tab-v-bottom-border 1)) - 0))]) - - (private-field - ;; list of panel's contents. - [children null] - [hidden-child #f] - [curr-border const-default-border] - [border? (memq 'border style)]) - - (public - [need-move-children (lambda () (set! move-children? #t))] - - [get-children (lambda () children)] - [get-hidden-child (lambda () hidden-child)] - [set-first-child-is-hidden (lambda () - (set! hidden-child (car children)) - (let ([i (send hidden-child get-info)]) - (set-min-width (child-info-x-min i)) - (set-min-height (child-info-y-min i))))] - - [border - (case-lambda - [() curr-border] - [(new-val) - (check-margin-integer '(method area-container<%> border) new-val) - (set! curr-border new-val) - (force-redraw)])] - - ;; add-child: adds an existing child to the panel. - ;; input: new-child: item% descendant to add - ;; returns: nothing - ;; effects: adds new-child to end of list of children. - [add-child - (lambda (new-child) - (unless (eq? this (send new-child area-parent)) - (raise-mismatch-error 'add-child - "not a child of this container: " - (wx->proxy new-child))) - (when (memq new-child children) - (raise-mismatch-error 'add-child "child already active: " - (wx->proxy new-child))) - (change-children - (lambda (l) - (append l (list new-child)))))] - - ;; change-children: changes the list of children. - ;; input: f is a function which takes the current list of children - ;; and returns a new list of children. - ;; returns: nothing - ;; effects: sets the list of children to the value of applying f. - [change-children - (lambda (f) - (let ([new-children (f children)]) ;; hidden child, if any , must be first! - (unless (andmap (lambda (child) - (eq? this (send child area-parent))) - new-children) - (raise-mismatch-error 'change-children - (format - (string-append - "not all members of the returned list are " - "children of the container ~e; list: ") - (wx->proxy this)) - (map wx->proxy (remq hidden-child new-children)))) - (let loop ([l new-children]) - (unless (null? l) - (if (memq (car l) (cdr l)) - (raise-mismatch-error 'change-children - "child in the returned list twice: " - (wx->proxy (car l))) - (loop (cdr l))))) - ;; show all new children, hide all deleted children. - (let ([added-children (list-diff new-children children)] - [removed-children (list-diff children new-children)]) - (let ([non-window (ormap (lambda (child) - (and (not (is-a? child wx:window%)) - child)) - removed-children)]) - (when non-window - (raise-mismatch-error 'change-children - (format "cannot delete non-window area in ~e: " - (wx->proxy this)) - non-window))) - - ;; Newly-added children may have been removed when - ;; disabled, or now added into a disabled panel: - (for-each (lambda (child) (send child queue-active)) - added-children) - - (let ([top (get-top-level)]) - (for-each (lambda (child) (send top show-child child #f)) - removed-children) - (set! children new-children) - (force-redraw) - (for-each (lambda (child) (send top show-child child #t)) - added-children)))))] - - ;; delete-child: removes a child from the panel. - ;; input: child: child to delete. - ;; returns: nothing - ;; effects: removes child from list; forces redraw. - [delete-child - (lambda (child) - (unless (memq child children) - (raise-mismatch-error 'delete-child - "not a child of this container or child is not active: " - (wx->proxy child))) - (change-children (lambda (child-list) - (remq child child-list))))] - - ;; get-children-info: returns children info list, recomputing it - ;; if needed. - ;; input: none - ;; returns: list of child-info structs. - ;; effects: upon exit, children-info is eq? to result. - [get-children-info - (lambda () - (unless children-info - (let* ([childs children] - [info (map (lambda (child) - (send child get-info)) - childs)]) - (if (and (= (length childs) (length children)) - (andmap eq? childs children)) - ;; Got the info for the right set of children - (set! children-info info) - - ;; During the call to some get-info, the set of children changed; - ;; try again - (get-children-info)))) - children-info)] - - [child-redraw-request - (lambda (from) - (unless (or ignore-redraw-request? - (not (memq from children))) - (force-redraw)))] - - ;; do-graphical-size: creates a function which returns the minimum - ;; possible size for a horizontal-panel% or vertical-panel% object. - ;; input: compute-x/compute-y: functions which take the current x/y - ;; location, the amount of spacing which will come after the - ;; current object, and the list of child-info structs beginning - ;; with the current object, and return the new x/y locations. - ;; returns: a thunk which returns the minimum possible size of the - ;; entire panel (not just client) as a list of two elements: - ;; (min-x min-y). - [do-graphical-size - (lambda (compute-x compute-y) - (letrec ([gms-help - (lambda (kid-info x-accum y-accum first?) - (if (null? kid-info) - (list x-accum y-accum) - (gms-help - (cdr kid-info) - (compute-x x-accum kid-info (and hidden-child first?)) - (compute-y y-accum kid-info (and hidden-child first?)) - #f)))]) - (let-values ([(client-w client-h) - (get-two-int-values (lambda (a b) (get-client-size a b)))]) - (let* ([border (border)] - [min-client-size - (gms-help (get-children-info) - (* 2 border) (* 2 border) - #t)] - [delta-w (- (get-width) client-w)] - [delta-h (- (get-height) client-h)]) - (list (+ delta-w (car min-client-size) (if hidden-child (* 2 tab-h-border) 0)) - (+ delta-h (cadr min-client-size)))))))] - - ;; do-get-min-graphical-size: poll children and return minimum possible - ;; size, as required by the graphical representation of the tree, - ;; of the panel. - ;; input: none - ;; returns: minimum full size (as a list, width & height) of the - ;; container. - ;; effects: none - [get-graphical-min-size (lambda () (void))] - [do-get-graphical-min-size - (lambda () - (do-graphical-size - (lambda (x-accum kid-info first?) - (max x-accum (+ (* 2 (border)) - (child-info-x-min (car kid-info))))) - (lambda (y-accum kid-info first?) - (max y-accum (+ (* 2 (border)) - (child-info-y-min (car kid-info)))))))]) - - (override - [force-redraw - (lambda () - (set! children-info #f) - (set! curr-width #f) - (let ([parent (area-parent)]) - (send parent child-redraw-request this)))] - - ;; get-min-size: poll children and return minimum possible size - ;; for the container which considers the user min sizes. - ;; input: none - ;; returns: minimum full size (as a list, width & height) of - ;; container. - ;; effects: none. - [get-min-size - (lambda () - (let ([graphical-min-size (get-graphical-min-size)]) - (list (+ (* 2 (x-margin)) - (max (car graphical-min-size) (min-width))) - (+ (* 2 (y-margin)) - (max (cadr graphical-min-size) (min-height))))))] - - [on-container-resize - (lambda () - (let-values ([(client-width client-height) - (get-two-int-values (lambda (a b) (get-client-size a b)))]) - (unless (and (number? curr-width) - (number? curr-height) - (= curr-width client-width) - (= curr-height client-height) - (not move-children?)) - (set! curr-width client-width) - (set! curr-height client-height) - (set! move-children? #f) - (redraw client-width client-height))))] - - [init-min (lambda (x) (if border? 8 0))]) - - (public - ;; place-children: determines where each child of panel should be - ;; placed. - ;; input: children-info: list of (int int bool bool) - ;; width/height: size of panel's client area. - ;; returns: list of placement info for children; each item in list - ;; is a list of 4 elements, consisting of child's x-posn, - ;; y-posn, x-size, y-size (including margins). Items are in same - ;; order as children-info list. - [place-children (lambda (l w h) (void))] - [check-place-children - (lambda (children-info width height) - (unless (and (list? children-info) - (andmap (lambda (x) (and (list? x) - (= 4 (length x)) - (integer? (car x)) (not (negative? (car x))) (exact? (car x)) - (integer? (cadr x)) (not (negative? (cadr x))) (exact? (cadr x)))) - children-info)) - (raise-type-error (who->name '(method area-container-window<%> place-children)) - "list of (list of non-negative-integer non-negative-integer boolean boolean)" - children-info)) - (check-non-negative-integer '(method area-container-window<%> place-children) width) - (check-non-negative-integer '(method area-container-window<%> place-children) height))] - [do-place-children - (lambda (children-info width height) - (check-place-children children-info width height) - (let loop ([children-info children-info]) - (if (null? children-info) - null - (let ([curr-info (car children-info)]) - (cons - (list - 0 0 - (car curr-info) ; child-info-x-min - (cadr curr-info)) ; child-info-y-min - (loop (cdr children-info)))))))]) - - (private-field - [curr-spacing const-default-spacing]) - - (public - [spacing ; does nothing! - (case-lambda - [() curr-spacing] - [(new-val) - (check-margin-integer '(method area-container<%> spacing) new-val) - (set! curr-spacing new-val)])] - - [do-align (lambda (h v set-h set-v) - (unless (memq h '(left center right)) - (raise-type-error 'set-alignment "horizontal alignment symbol: left, center, or right" h)) - (unless (memq v '(top center bottom)) - (raise-type-error 'set-alignment "vertical alignment symbol: top, center, or bottom" v)) - (set-h h) - (set-v (case v [(top) 'left] [(center) 'center] [(bottom) 'right])))] - [alignment (lambda (h v) - (do-align h v (lambda (h) (set! h-align h)) (lambda (h) (set! v-align v))) - (force-redraw))] - [get-alignment (lambda () (values h-align v-align))] - - ;; redraw: redraws panel and all children - ;; input: width, height: size of area area in panel. - ;; returns: nothing - ;; effects: places children at default positions in panel. - [redraw - (lambda (width height) - (let ([children-info (get-children-info)] - [children children]) ; keep list of children matching children-info - (let ([l (place-children (map (lambda (i) - (list (child-info-x-min i) (child-info-y-min i) - (child-info-x-stretch i) (child-info-y-stretch i))) - (if hidden-child - (cdr children-info) - children-info)) - (if hidden-child - (- width (* 2 tab-h-border)) - width) - (if hidden-child - (- height (child-info-y-min (car children-info))) ;; 2-pixel border here, too - height))]) - (unless (and (list? l) - (= (length l) (- (length children-info) (if hidden-child 1 0))) - (andmap (lambda (x) (and (list? x) - (= 4 (length x)) - (andmap (lambda (x) (and (integer? x) (exact? x))) x))) - l)) - (raise-mismatch-error 'container-redraw - "result from place-children is not a list of 4-integer lists with the correct length: " - l)) - (when hidden-child - ;; This goes with the hack for macos and macosx below - (send hidden-child set-phantom-size width height)) - (panel-redraw children children-info (if hidden-child - (cons (list 0 0 width - (if (memq (system-type) '(macos macosx)) ;; Yucky hack - (child-info-y-min (car children-info)) - height)) - (let ([dy (child-info-y-min (car children-info))]) - (map (lambda (i) - (list (+ (car i) tab-h-border) - (+ dy (cadr i) (- tab-v-bottom-border) -1) - (caddr i) - (cadddr i))) - l))) - l)))))] - [panel-redraw - (lambda (childs child-infos placements) - (for-each - (lambda (child info placement) - (let-values ([(x y w h) (apply values placement)]) - (let ([minw (child-info-x-min info)] - [minh (child-info-y-min info)] - [xm (child-info-x-margin info)] - [ym (child-info-y-margin info)]) - (dynamic-wind - (lambda () (set! ignore-redraw-request? #t)) - (lambda () - (send child set-size - (max 0 (+ x xm)) (max 0 (+ y ym)) - (- (max minw w) (* 2 xm)) - (- (max minh h) (* 2 ym)))) - (lambda () (set! ignore-redraw-request? #f))) - (send child on-container-resize)))) - childs - child-infos - placements))]) - (sequence - (super-init style parent -1 -1 0 0 style)))) - - (define (wx-make-pane% wx:panel% stretch?) - (class100 (make-container-glue% (make-glue% (wx-make-basic-panel% wx:panel% stretch?))) args - (inherit get-parent get-x get-y need-move-children get-children) - (rename [super-set-size set-size]) - (override - [on-visible - (lambda () - (for-each (lambda (c) (send c queue-visible)) (get-children)))] - [on-active - (lambda () - (for-each (lambda (c) (send c queue-active)) (get-children)))] - - [get-window (lambda () (send (get-parent) get-window))] - [set-size (lambda (x y w h) - (super-set-size x y w h) - (need-move-children))] - [dx (lambda () (get-x))] - [dy (lambda () (get-y))]) - (sequence - (apply super-init args)))) - - (define (wx-make-panel% wx:panel%) - (class100 (make-container-glue% (make-window-glue% (wx-make-basic-panel% wx:panel% #t))) args - (rename [super-on-visible on-visible] - [super-on-active on-active]) - (inherit get-children) - (override - [on-visible - (lambda () - (for-each (lambda (c) (send c queue-visible)) (get-children)) - (super-on-visible))] - [on-active - (lambda () - (for-each (lambda (c) (send c queue-active)) (get-children)) - (super-on-active))]) - (sequence (apply super-init args)))) - - (define (wx-make-linear-panel% wx-panel%) - (class100 wx-panel% args - (private-field - [major-align-pos 'left] - [minor-align-pos 'center]) - - (inherit force-redraw border get-width get-height - get-graphical-min-size) - (private-field [curr-spacing const-default-spacing]) - (override - [spacing - (case-lambda - [() curr-spacing] - [(new-val) - (check-margin-integer '(method area-container<%> spacing) new-val) - (set! curr-spacing new-val) - (force-redraw)])]) - (public - [minor-align (lambda (a) (set! minor-align-pos a) (force-redraw))] - [major-align (lambda (a) (set! major-align-pos a) (force-redraw))] - [major-offset (lambda (space) - (case major-align-pos - [(center) (quotient space 2)] - [(left) 0] - [(right) space]))] - [minor-offset (lambda (width size) - (case minor-align-pos - [(center) (quotient (- width size) 2)] - [(left) 0] - [(right) (- width size)]))] - - [do-get-alignment (lambda (pick) (values (pick major-align-pos minor-align-pos) - (case (pick minor-align-pos major-align-pos) - [(left) 'top] [(center) 'center] [(right) 'bottom])))] - - ;; place-linear-children: implements place-children functions for - ;; horizontal-panel% or vertical-panel% classes. - ;; input: child-major-size: function which takes a child-info struct - ;; and returns the child's minimum size in the major direction - ;; of the panel. - ;; child-major-stretch: function which takes a child-info - ;; struct and returns the child's stretchability in the major - ;; direction of the panel. - ;; child-minor-size/child-minor-stretch: see above. - ;; major-dim/minor-dim: functions which take the width and the - ;; height of the panel and return the panel's major and minor - ;; dimensions, respectively. - ;; get-h-info/get-v-info: functions which take info lists - ;; describing the major and minor directions and select the - ;; appropriate one. - ;; returns: a function which takes the children info, the width and the - ;; height of the panel's client and returns a list which contains - ;; posn&size info for each child. - [place-linear-children - (lambda (kid-info width height - child-major-size - child-major-stretch - child-major-offset - child-minor-size - child-minor-stretch - child-minor-position - major-dim minor-dim - get-x-info get-y-info) - (letrec ([count-stretchable - (lambda (kid-info) - (if (null? kid-info) - 0 - (let ([curr-info (car kid-info)]) - (if (child-major-stretch curr-info) - (add1 (count-stretchable (cdr kid-info))) - (count-stretchable (cdr kid-info))))))]) - (let* ([spacing (spacing)] - [border (border)] - [full-w (get-width)] - [full-h (get-height)] - [delta-list (list - (- full-w width) - (- full-h height))] - [num-stretchable (count-stretchable kid-info)] - [extra-space (- (major-dim width height) - (- (apply - major-dim - (get-graphical-min-size)) - (apply major-dim delta-list)))] - [extra-per-stretchable (if (zero? num-stretchable) - 0 - (inexact->exact - (floor - (/ extra-space - num-stretchable))))] - [leftover (- extra-space (* extra-per-stretchable num-stretchable))] - [num-children (length kid-info)] - [major-offset (if (= num-stretchable 0) - (child-major-offset extra-space) - 0)]) - (letrec - ([pc-help - (lambda (kid-info left-edge leftover) - (if (null? kid-info) - null - (let* ([curr-info (car kid-info)] - [rest (cdr kid-info)] - [major-posn left-edge] - [next-leftover (if (zero? leftover) - 0 - (- leftover 1))] - [extra-this-stretchable (if (zero? leftover) - extra-per-stretchable - (+ extra-per-stretchable 1))] - [major-size - (if (child-major-stretch curr-info) - (+ extra-this-stretchable - (child-major-size curr-info)) - (child-major-size curr-info))] - [minor-posn (if (child-minor-stretch - curr-info) - border - (inexact->exact - (round - (child-minor-position - (minor-dim width height) - (child-minor-size curr-info)))))] - [minor-size (if (child-minor-stretch - curr-info) - (- (minor-dim width height) - (* 2 border)) - (child-minor-size - curr-info))]) - (cons - (list - (get-x-info major-posn minor-posn) - (get-y-info major-posn minor-posn) - (get-x-info major-size minor-size) - (get-y-info major-size minor-size)) - (pc-help rest - (+ major-size major-posn spacing) - next-leftover)))))]) - (pc-help kid-info (+ border major-offset) leftover)))))]) - - (sequence (apply super-init args)))) - - ;; horizontal-panel%: a panel which arranges its children in an evenly - ;; spaced horizontal row. Items are vertically centered (or stretched - ;; to fit the dialog box if they are stretchable). The items are evenly - ;; spaced horizontally, with any extra space divided evenly among the - ;; stretchable items. - (define (wx-make-horizontal-panel% wx-linear-panel%) - (class100 wx-linear-panel% args - (inherit major-align minor-align do-align do-get-alignment major-offset minor-offset - spacing border do-graphical-size place-linear-children check-place-children) - (override - [alignment (lambda (h v) (do-align h v - (lambda (x) (major-align x)) - (lambda (x) (minor-align x))))] - [get-alignment (lambda () (do-get-alignment (lambda (x y) x)))] - - [do-get-graphical-min-size - (lambda () - (do-graphical-size - (lambda (x-accum kid-info hidden?) - (+ x-accum (child-info-x-min (car kid-info)) - (if (or hidden? (null? (cdr kid-info))) - 0 - (spacing)))) - (lambda (y-accum kid-info hidden?) - (max y-accum - (+ (child-info-y-min (car kid-info)) - (* 2 (border)))))))] - [do-place-children - (lambda (l w h) - (check-place-children l w h) - (place-linear-children l w h - car ; child-info-x-min - caddr ; child-info-x-stretch - (lambda (s) (major-offset s)) - cadr ; child-info-y-min - cadddr ; child-info-y-stretch - (lambda (s t) (minor-offset s t)) - (lambda (width height) width) - (lambda (width height) height) - (lambda (major minor) major) - (lambda (major minor) minor)))]) - (sequence (apply super-init args)))) - - ;; vertical-panel%. See horizontal-panel%, but reverse - ;; "horizontal" and "vertical." - (define (wx-make-vertical-panel% wx-linear-panel%) - (class100 wx-linear-panel% args - (inherit major-align minor-align do-align do-get-alignment major-offset minor-offset - spacing border do-graphical-size place-linear-children check-place-children) - (override - [alignment (lambda (h v) (do-align h v - (lambda (x) (minor-align x)) - (lambda (x) (major-align x))))] - [get-alignment (lambda () (do-get-alignment (lambda (x y) y)))] - - [do-get-graphical-min-size - (lambda () - (do-graphical-size - (lambda (x-accum kid-info hidden?) - (max x-accum - (+ (child-info-x-min (car kid-info)) - (* 2 (border))))) - (lambda (y-accum kid-info hidden?) - (+ y-accum (child-info-y-min (car kid-info)) - (if (or (null? (cdr kid-info)) hidden?) - 0 - (spacing))))))] - - [do-place-children - (lambda (l w h) - (check-place-children l w h) - (place-linear-children l w h - cadr ; child-info-y-min - cadddr ; child-info-y-stretch - (lambda (s) (major-offset s)) - car ; child-info-x-min - caddr ; child-info-x-stretch - (lambda (s t) (minor-offset s t)) - (lambda (width height) height) - (lambda (width height) width) - (lambda (major minor) minor) - (lambda (major minor) major)))]) - (sequence (apply super-init args)))) - - ;; NEW -- specifies that panel should _not_ - ;; contribute to either horizontal or vertical - ;; geometry - (define (wx-make-free-vertical-panel% wx-linear-panel%) - (class100 wx-linear-panel% args - (inherit major-align minor-align do-align do-get-alignment major-offset minor-offset - spacing border do-graphical-size place-linear-children check-place-children) - (override - [alignment (lambda (h v) (do-align h v - (lambda (x) (minor-align x)) - (lambda (x) (major-align x))))] - [get-alignment (lambda () (do-get-alignment (lambda (x y) y)))] - - [do-get-graphical-min-size - (lambda () - (do-graphical-size - (lambda (x-accum kid-info hidden?) - (max x-accum - (+ (child-info-x-min (car kid-info)) - (* 2 (border))))) - (lambda (y-accum kid-info hidden?) - 0)))] - - [do-place-children - (lambda (l w h) - (check-place-children l w h) - (place-linear-children l w h - cadr ; child-info-y-min - cadddr ; child-info-y-stretch - (lambda (s) (major-offset s)) - car ; child-info-x-min - caddr ; child-info-x-stretch - (lambda (s t) (minor-offset s t)) - (lambda (width height) height) - (lambda (width height) width) - (lambda (major minor) minor) - (lambda (major minor) major)))]) - (sequence (apply super-init args)))) - - (define (wx-make-free-horizontal-panel% wx-linear-panel%) - (class100 wx-linear-panel% args - (inherit major-align minor-align do-align do-get-alignment major-offset minor-offset - spacing border do-graphical-size place-linear-children check-place-children) - (override - [alignment (lambda (h v) (do-align h v - (lambda (x) (major-align x)) - (lambda (x) (minor-align x))))] - [get-alignment (lambda () (do-get-alignment (lambda (x y) x)))] - - [do-get-graphical-min-size - (lambda () - (do-graphical-size - (lambda (x-accum kid-info hidden?) - 0) - (lambda (y-accum kid-info hidden?) - (max y-accum - (+ (child-info-y-min (car kid-info)) - (* 2 (border)))))))] - [do-place-children - (lambda (l w h) - (check-place-children l w h) - (place-linear-children l w h - car ; child-info-x-min - caddr ; child-info-x-stretch - (lambda (s) (major-offset s)) - cadr ; child-info-y-min - cadddr ; child-info-y-stretch - (lambda (s t) (minor-offset s t)) - (lambda (width height) width) - (lambda (width height) height) - (lambda (major minor) major) - (lambda (major minor) minor)))]) - (sequence (apply super-init args)))) - - (define wx-panel% (wx-make-panel% wx:panel%)) - (define wx-linear-panel% (wx-make-linear-panel% wx-panel%)) - (define wx-horizontal-panel% (wx-make-horizontal-panel% wx-linear-panel%)) - (define wx-vertical-panel% (wx-make-vertical-panel% wx-linear-panel%)) - - (define wx-pane% (wx-make-pane% wx:windowless-panel% #t)) - (define wx-grow-box-pane% - (class100 (wx-make-pane% wx:windowless-panel% #f) (mred proxy parent style) - (override - [init-min (lambda (x) (if (or (eq? (system-type) 'macos) - (eq? (system-type) 'macosx)) - 15 - 0))]) - (sequence - (super-init mred proxy parent style)))) - (define wx-linear-pane% (wx-make-linear-panel% wx-pane%)) - (define wx-horizontal-pane% (wx-make-horizontal-panel% wx-linear-pane%)) - (define wx-vertical-pane% (wx-make-vertical-panel% wx-linear-pane%)) - (define wx-free-vert-pane% (wx-make-free-vertical-panel% wx-linear-pane%)) - (define wx-free-horiz-pane% (wx-make-free-horizontal-panel% wx-linear-pane%)))