diff --git a/collects/frtime/demos/gui/demo/bindec.ss b/collects/frtime/demos/gui/demo/bindec.ss index 1d51169d15..8bbeececa5 100644 --- a/collects/frtime/demos/gui/demo/bindec.ss +++ b/collects/frtime/demos/gui/demo/bindec.ss @@ -1,46 +1,43 @@ -(require "../simple.ss") -(require (rename (lib "mred.ss" "mred") horizontal-panel% horizontal-panel%)) - -; just change this to change the range of the binary/decimal converter -(define SIZE 10) - -(define (bool-lst->num bool-lst) - (let loop ([lst bool-lst] [sum 0] [pow 0]) - (if (empty? lst) - sum - (loop (cdr lst) - (+ sum - (if (car lst) - (expt 2 pow) - 0)) - (add1 pow))))) - -(define (place-num->bool loc num) - (if (= 0 loc) - (odd? num) - (place-num->bool (sub1 loc) (quotient num 2)))) - - -(current-widget-parent (new ft-frame% - (its-width 0) - (its-height 0) - (label-text "Binary<-->Decimal"))) - -(define-values-rec - [sld (mode value-b ft-slider% - (min-value 0) - (max-value (sub1 (expt 2 SIZE))) - (value-set (changes - (bool-lst->num - boxes))))] - - [boxes (parameterize ([current-widget-parent - (mode widget horizontal-panel%)]) - (build-list SIZE ; build-list is right associative. - (lambda (i) - (mode value-b ft-check-box% - (label (number->string (expt 2 i))) - (value-set - (changes (place-num->bool i sld)))))))]) - +(require "../simple.ss") +(require (rename (lib "mred.ss" "mred") horizontal-panel% horizontal-panel%)) + +; just change this to change the range of the binary/decimal converter +(define SIZE 10) + +(define (bool-lst->num bool-lst) + (let loop ([lst bool-lst] [sum 0] [pow 0]) + (if (empty? lst) + sum + (loop (cdr lst) + (+ sum + (if (car lst) + (expt 2 pow) + 0)) + (add1 pow))))) + +(define (place-num->bool loc num) + (if (= 0 loc) + (odd? num) + (place-num->bool (sub1 loc) (quotient num 2)))) + + +(current-widget-parent (new ft-frame% (label "Binary<-->Decimal"))) + +(define-values-rec + [sld (mode value-b ft-slider% + (min-value 0) + (max-value (sub1 (expt 2 SIZE))) + (value-set (changes + (bool-lst->num + boxes))))] + + [boxes (parameterize ([current-widget-parent + (mode widget horizontal-panel%)]) + (build-list SIZE ; build-list is right associative. + (lambda (i) + (mode value-b ft-check-box% + (label (number->string (expt 2 i))) + (value-set + (changes (place-num->bool i sld)))))))]) + (send (current-widget-parent) show #t) \ No newline at end of file diff --git a/collects/frtime/demos/gui/demo/timer.ss b/collects/frtime/demos/gui/demo/timer.ss index 5910352e81..5856cc0e4e 100644 --- a/collects/frtime/demos/gui/demo/timer.ss +++ b/collects/frtime/demos/gui/demo/timer.ss @@ -1,12 +1,12 @@ (require "../simple.ss") -(current-widget-parent (new ft-frame% (its-width 400) (its-height 0))) +(current-widget-parent (new ft-frame% (label "Timer") (width 400) (height 100))) (define tenths (quotient milliseconds 100)) (define-values-rec [range (* 10 (mode value-b ft-slider% - (label "Range") + (label "Range: ") (min-value 10) (max-value 30) (init-value 10)))] @@ -16,7 +16,7 @@ reset) (value-now tenths))))] [gauge (mode widget ft-gauge% - (label "Timer") + (label "Elapsed: ") (value gauge-value) (range range))] [msg (mode widget ft-message% diff --git a/collects/frtime/demos/gui/fred.ss b/collects/frtime/demos/gui/fred.ss index cf61933d48..0ca36bff13 100644 --- a/collects/frtime/demos/gui/fred.ss +++ b/collects/frtime/demos/gui/fred.ss @@ -1,306 +1,256 @@ -(module fred (lib "frtime.ss" "frtime") - (require "mixin-macros.ss" - ;"r-label.ss" - (lib "class.ss") - (lib "string.ss") - (all-except (lib "mred.ss" "mred") send-event) - (lib "framework.ss" "framework")) - - (define-syntax add-signal-controls - (syntax-rules () - [(_ src (field-name0 update-call0 default-val0) clause ...) - ((behavior->callbacks field-name0 update-call0) - default-val0 - (add-signal-controls src clause ...))] - [(_ src) - src])) - - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Helpers - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; adding assumed methods - (define (add-void-set-value super-class) - (class super-class - (define/public (set-value v) (void)) - (super-new))) - - (define (add-focus-now super-class) - (class super-class - (super-new) - (inherit focus) - (define/public (focus-now _) (focus)))) - - (define (callback->pub-meth super-class) - (class super-class - (define/public (callback-method w e) (void)) - (super-new (callback (lambda (w e) (callback-method w e)))))) - - - ;; *-event-processor init-argument values - (define event-is-val - (lambda (es) - (map-e car es))) - - ; (send x get-mouse-events) returns a split procedure over the event-type - (define split-mouse-events/type - (lambda (evt-src) - (split (map-e cadr evt-src) (lambda (evt) (send evt get-event-type))))) - - ; (send x get-key-events) returns a split procedure over the key code - (define split-key-events/type - (lambda (evt-src) - (split (map-e cadr evt-src) (lambda (evt) (send evt get-key-code))))) - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; make state available as eventstreams - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define (add-mouse-access super-class) - ((callbacks->args-evts mouse-events ; Name of event stream - on-subwindow-event ; proc overriding - (window evt) ; arguments for on-subwindow-event. Caused by super being a macro - ) - super-class)) - - - (define (add-focus-access super-class) - ((callbacks->args-evts focus-events on-focus (is-focused?)) - super-class)) - - (define (add-keypress-split super-class) - ((callbacks->args-evts key-events on-subwindow-char (w e)) - super-class)) - - - - #| - (define (add-value-b super-class default) - (class super-class - (super-new) - (inherit get-value-e) - (define/public (get-value-b) (hold (get-value-e) default)))) - |# - - (define (add-callback-access val-ext default-val super-class) - (class ((callbacks->args-evts set-value-events - set-value - (v)) - ((callbacks->args-evts callback-events - callback-method - (w e)) - (callback->pub-meth super-class))) - (super-new (set-value-events-event-processor event-is-val) - (callback-events-event-processor (lambda (es) - (map-e (lambda (e) (apply val-ext e)) es)))) - (inherit get-set-value-events get-callback-events) - (define value-e (merge-e (get-set-value-events) - (get-callback-events))) - (define value-b (hold value-e (val-ext this #f))) - (define/public (get-value-e) value-e) - (define/public (get-value-b) value-b) - )) - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; using events to drive object interaction - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define (add-callback-access/loop val-ext default-val super-class) - ((events->callbacks value-set set-value) - (add-callback-access val-ext default-val super-class))) - - - (define (add-focus-on-event super-class) - ((events->callbacks focus-when focus-now) - (add-focus-now super-class))) - - - - ;; Special case widgets - (define (in-string itm) - (if (undefined? itm) - "" - (if (string? itm) - itm - (expr->string itm)))) - - - - (define ft-frame% - (class (add-mouse-access (add-keypress-split (add-signal-controls frame% (label set-label "")))) - ; Members, initialized - (init-field (its-width 800) (its-height 600) (label-text "") (x-loc 0) (y-loc 0)) - #| - ;(make-prog-control label-text set-label) - - ; Private members, internal - (define width-e (event-receiver)) - (define width-b (hold width-e its-width)) - (define height-e (event-receiver)) - (define height-b (hold height-e its-height)) - - (define mouse-x-e (event-receiver)) - (define mouse-x-b (hold mouse-x-e 0)) - (define mouse-y-e (event-receiver)) - (define mouse-y-b (hold mouse-y-e 0)) - - ; Overridden methods - (override on-size on-subwindow-event) - - ; Overrides on-size from frame% to update width-e and height-e - (define (on-size new-width new-height) - (begin - (send-event width-e new-width) - (send-event height-e new-height) - - (super on-size new-width new-height))) - - (define (on-subwindow-event a-window event) - (begin - (case (send event get-event-type) - [(enter motion) - (send-event mouse-x-e (+ (send a-window get-x) (send event get-x))) - (send-event mouse-y-e (+ (send a-window get-y) (send event get-y)))]) - (super on-subwindow-event a-window event))) - - ; Public Members - (public get-width-b get-height-b get-mouse-x get-mouse-y) - - ; Returns a behavior of the width of the frame - (define (get-width-b) width-b) - - ; Returns a behavior of the height of the frame - (define (get-height-b) height-b) - - (define (get-mouse-x) mouse-x-b) - (define (get-mouse-y) mouse-y-b) - |# - (super-new (label (in-string (value-now label-text))) - (width its-width) - (height its-height) - (x x-loc) - (y y-loc) - #;(style '(float metal))))) - - - - - (define ft-message% - (add-mouse-access - (add-focus-access - (add-signal-controls message% (label set-label "") (enabled enable #t))))) - - #;(define ft-autoresize-label% - (add-mouse-access - (add-focus-access - (add-signal-controls autoresize-label% (text set-label-text "") (enabled enable #t))))) - - - (define specialized-gauge% - (class gauge% - (init value) - - (super-new) - - (inherit set-value) - #;(set-value value))) - - (define ft-gauge% - (add-mouse-access - (add-focus-access - (add-signal-controls specialized-gauge% - (label set-label "") - (enabled enable #t) - (value set-value 0) - (range set-range 1))))) - - (define ft-menu-item% - (add-callback-access - list - '() - (add-void-set-value - menu-item%))) - - - - (define (send-for-value w e) - (send w get-value)) - - (define (send-for-selection w e) - (send w get-selection)) - - - ;; Standard mixin combinations - (define (standard-lift widget value-method value-default) - (add-mouse-access - (add-focus-access - (add-callback-access - value-method - value-default - (add-signal-controls (add-void-set-value widget) (label set-label "") (enabled enable #t)))))) - - (define (standard-lift/loop widget value-method value-default) - (add-mouse-access - (add-focus-access - (add-callback-access/loop - value-method - value-default - (add-signal-controls widget (label set-label "") (enabled enable #t)))))) - - - - (define ft-button% - (standard-lift button% (lambda (w e) e) undefined)) - - (define ft-check-box% - (standard-lift/loop check-box% send-for-value #f)) - - (define ft-radio-box% - (standard-lift radio-box% send-for-selection 0)) - - (define ft-choice% - (standard-lift choice% send-for-selection 0)) - - (define ft-slider% - (standard-lift/loop slider% send-for-value 0)) - - (define ft-list-box% - (standard-lift list-box% send-for-selection 0)) - - (define ft-text-field% - (add-keypress-split - (add-focus-on-event - (standard-lift/loop text-field% send-for-value "")))) - - - - - - - (provide ft-frame% - ft-message% - ;ft-autoresize-label% - ft-gauge% - ft-button% - ft-check-box% - ft-radio-box% - ft-choice% - ft-slider% - ft-list-box% - ft-text-field% - ft-menu-item% - menu% - menu-bar% - finder:get-file - finder:put-file - split-mouse-events/type - split-key-events/type - (all-from (lib "class.ss")) - (all-from "mixin-macros.ss"))) - - - +(module fred (lib "frtime.ss" "frtime") + (require "mixin-macros.ss" + ;"r-label.ss" + (lib "class.ss") + (lib "string.ss") + (all-except (lib "mred.ss" "mred") send-event) + (lib "framework.ss" "framework")) + + (define-syntax add-signal-controls + (syntax-rules () + [(_ src (field-name0 update-call0 default-val0) clause ...) + ((behavior->callbacks field-name0 update-call0) + default-val0 + (add-signal-controls src clause ...))] + [(_ src) + src])) + + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Helpers + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; adding assumed methods + (define (add-void-set-value super-class) + (class super-class + (define/public (set-value v) (void)) + (super-new))) + + (define (add-focus-now super-class) + (class super-class + (super-new) + (inherit focus) + (define/public (focus-now _) (focus)))) + + (define (callback->pub-meth super-class) + (class super-class + (define/public (callback-method w e) (void)) + (super-new (callback (lambda (w e) (callback-method w e)))))) + + + ;; *-event-processor init-argument values + (define event-is-val + (lambda (es) + (map-e car es))) + + ; (send x get-mouse-events) returns a split procedure over the event-type + (define split-mouse-events/type + (lambda (evt-src) + (split (map-e cadr evt-src) (lambda (evt) (send evt get-event-type))))) + + ; (send x get-key-events) returns a split procedure over the key code + (define split-key-events/type + (lambda (evt-src) + (split (map-e cadr evt-src) (lambda (evt) (send evt get-key-code))))) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; make state available as eventstreams + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (add-mouse-access super-class) + ((callbacks->args-evts mouse-events ; Name of event stream + on-subwindow-event ; proc overriding + (window evt) ; arguments for on-subwindow-event. Caused by super being a macro + ) + super-class)) + + + (define (add-focus-access super-class) + ((callbacks->args-evts focus-events on-focus (is-focused?)) + super-class)) + + (define (add-keypress-split super-class) + ((callbacks->args-evts key-events on-subwindow-char (w e)) + super-class)) + + + + #| + (define (add-value-b super-class default) + (class super-class + (super-new) + (inherit get-value-e) + (define/public (get-value-b) (hold (get-value-e) default)))) + |# + + (define (add-callback-access val-ext super-class) + (class ((callbacks->args-evts set-value-events + set-value + (v)) + ((callbacks->args-evts callback-events + callback-method + (w e)) + (callback->pub-meth super-class))) + (super-new (set-value-events-event-processor event-is-val) + (callback-events-event-processor (lambda (es) + (map-e (lambda (e) (apply val-ext e)) es)))) + (inherit get-set-value-events get-callback-events) + (define value-e (merge-e (get-set-value-events) + (get-callback-events))) + (define value-b (hold value-e (val-ext this #f))) + (define/public (get-value-e) value-e) + (define/public (get-value-b) value-b) + )) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; using events to drive object interaction + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (add-callback-access/loop val-ext super-class) + ((events->callbacks value-set set-value) + (add-callback-access val-ext super-class))) + + + (define (add-focus-on-event super-class) + ((events->callbacks focus-when focus-now) + (add-focus-now super-class))) + + + + ;; Special case widgets + (define (in-string itm) + (if (undefined? itm) + "" + (if (string? itm) + itm + (expr->string itm)))) + + + + (define ft-frame% + (class ((callbacks->args-evts resize-events on-size (w h)) + (add-mouse-access + (add-keypress-split + (add-signal-controls frame% + (label set-label ""))))) + (super-new) + )) + + + + + (define ft-message% + (add-mouse-access + (add-focus-access + (add-signal-controls message% (label set-label "") (enabled enable #t))))) + + #;(define ft-autoresize-label% + (add-mouse-access + (add-focus-access + (add-signal-controls autoresize-label% (text set-label-text "") (enabled enable #t))))) + + + (define specialized-gauge% + (class gauge% + (init value) + + (super-new) + + (inherit set-value) + #;(set-value value))) + + (define ft-gauge% + (add-mouse-access + (add-focus-access + (add-signal-controls specialized-gauge% + (label set-label "") + (enabled enable #t) + (value set-value 0) + (range set-range 1))))) + + (define ft-menu-item% + (add-callback-access + list + (add-void-set-value + menu-item%))) + + + + (define (send-for-value w e) + (send w get-value)) + + (define (send-for-selection w e) + (send w get-selection)) + + + ;; Standard mixin combinations + (define (standard-lift widget value-method) + (add-mouse-access + (add-focus-access + (add-callback-access + value-method + (add-signal-controls (add-void-set-value widget) (label set-label "") (enabled enable #t)))))) + + (define (standard-lift/loop widget value-method) + (add-mouse-access + (add-focus-access + (add-callback-access/loop + value-method + (add-signal-controls widget (label set-label "") (enabled enable #t)))))) + + + + (define ft-button% + (standard-lift button% (lambda (w e) e))) + + (define ft-check-box% + (standard-lift/loop check-box% send-for-value)) + + (define ft-radio-box% + (standard-lift radio-box% send-for-selection)) + + (define ft-choice% + (standard-lift choice% send-for-selection)) + + (define ft-slider% + (standard-lift/loop slider% send-for-value)) + + (define ft-list-box% + (standard-lift list-box% send-for-selection)) + + (define ft-text-field% + (add-keypress-split + (add-focus-on-event + (standard-lift/loop text-field% send-for-value)))) + + + + + + + (provide ft-frame% + ft-message% + ;ft-autoresize-label% + ft-gauge% + ft-button% + ft-check-box% + ft-radio-box% + ft-choice% + ft-slider% + ft-list-box% + ft-text-field% + ft-menu-item% + menu% + menu-bar% + finder:get-file + finder:put-file + split-mouse-events/type + split-key-events/type + (all-from (lib "class.ss")) + (all-from "mixin-macros.ss"))) + + + diff --git a/collects/frtime/demos/gui/mod-mrpanel.ss b/collects/frtime/demos/gui/mod-mrpanel.ss new file mode 100644 index 0000000000..3b08aac1d8 --- /dev/null +++ b/collects/frtime/demos/gui/mod-mrpanel.ss @@ -0,0 +1,226 @@ +(module mod-mrpanel mzscheme + (require (lib "class.ss") + (lib "class100.ss") + (prefix wx: (lib "kernel.ss" "mred" "private")) + (lib "lock.ss" "mred" "private") + (lib "const.ss" "mred" "private") + (lib "check.ss" "mred" "private") + (lib "helper.ss" "mred" "private") + (lib "wx.ss" "mred" "private") + (lib "kw.ss" "mred" "private") + "mod-wx-panel.ss" + (lib "mrwindow.ss" "mred" "private") + (lib "mrcontainer.ss" "mred" "private") + (lib "mrtabgroup.ss" "mred" "private") + (lib "mrgroupbox.ss" "mred" "private")) + + (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-car! (list-tail save-choices i) s) + (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/demos/gui/mod-wx-panel.ss b/collects/frtime/demos/gui/mod-wx-panel.ss new file mode 100644 index 0000000000..5e40e189d5 --- /dev/null +++ b/collects/frtime/demos/gui/mod-wx-panel.ss @@ -0,0 +1,816 @@ +(module mod-wx-panel mzscheme + (require (lib "class.ss") + (lib "class100.ss") + (lib "list.ss") + (prefix wx: (lib "kernel.ss" "mred" "private")) + (lib "lock.ss" "mred" "private") + (lib "const.ss" "mred" "private") + (lib "helper.ss" "mred" "private") + (lib "check.ss" "mred" "private") + (lib "wx.ss" "mred" "private") + (lib "wxwindow.ss" "mred" "private") + (lib "wxitem.ss" "mred" "private") + (lib "wxcontainer.ss" "mred" "private")) + + (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%))) \ No newline at end of file diff --git a/collects/frtime/demos/spreadsheet/ft-spread.ss b/collects/frtime/demos/spreadsheet/ft-spread.ss new file mode 100644 index 0000000000..4284948428 --- /dev/null +++ b/collects/frtime/demos/spreadsheet/ft-spread.ss @@ -0,0 +1,436 @@ +(module ft-spread (lib "frtime-big.ss" "frtime") + ;; TODO + ;; 2) scroll/row & col labels + ;; 3) copy/paste/multiple selection + ;; + ;; Make namespace safer + ;; letters + + + + (require (lib "simple.ss" "frtime" "demos" "gui")) + (require "ss-canvas.ss") + (require "ss-database.ss") + (require (lib "string.ss")) + (require (as-is:unchecked mzscheme make-hash-table hash-table-get hash-table-put! + open-input-string open-output-file open-input-file + write read delete-file close-output-port close-input-port + flush-output + current-namespace)) + + (require (rename (lib "frp-core.ss" "frtime") do-in-manager do-in-manager)) + (require (rename (lib "frp-core.ss" "frtime") super-lift super-lift)) + (require (rename (lib "frp-core.ss" "frtime") current-custs current-custs)) + (require (rename (lib "mred.ss" "mred") bitmap-dc% bitmap-dc%) + (rename (lib "mred.ss" "mred") bitmap% bitmap%)) + (require (lib "mod-mrpanel.ss" "frtime" "demos" "gui")) + (require (all-except (lib "mred.ss" "mred") send-event)) + (require (lib "unit.ss")) + + + ;(rename mzscheme current-namespace current-namespace) + (require (as-is:unchecked (lib "plt-pretty-big-text.ss" "lang") namespace-set-variable-value!)) + + ;;;;;;;;;;;; + ;; Constants + + ;; Initial and maximum dimensions of the spreadhseet + (define INIT_VIEW_WIDTH 800) + (define INIT_VIEW_HEIGHT 500) + (define MAX_VIEW_WIDTH 800) + (define MAX_VIEW_HEIGHT 500) + + ;; Cell dimensions + (define COL_WIDTH 120) + (define ROW_HEIGHT 21) + + ;; Number of visible columns and rows + (define VIS_COLS (round (/ MAX_VIEW_WIDTH COL_WIDTH))) + (define VIS_ROWS (round (/ MAX_VIEW_HEIGHT ROW_HEIGHT))) + + ;; Cell value placement (padding from cell border) + (define VERT_BUFF 3) + (define HORIZ_BUFF 3) + + ;; Label constants + (define LBL_WIDTH 60) + (define LBL_FONT (make-object font% 10 'default)) + + + ;; Constant grid background used + (define GRID_BACKGROUND + (let r-loop ([c-row 0] [r-lst '()]) + (if (> c-row VIS_ROWS) + r-lst + (let c-loop ([c-col 0] [c-lst '()]) + (if (> c-col VIS_COLS) + (r-loop (add1 c-row) + (cons (make-line + #f + 0 + (* c-row ROW_HEIGHT) + MAX_VIEW_WIDTH) + (append c-lst + r-lst))) + (c-loop (add1 c-col) + (cons (make-line + #t + (* c-col COL_WIDTH) + 0 + MAX_VIEW_HEIGHT) + c-lst))))))) + + ;; customized toString + (define (custom->string x) + (if (undefined? x) + "" + (if (string? x) + x + (lift-strict expr->string x)))) + + ;;;;;;;;;;;;;;;;; + ;; Key Generation + ; -- used to uniquely identify each cell -- + + ; produces a key given a row and column + (define (rowXcol->key r c) + (string->symbol (format "~ax~a" r c))) + + ; produces a key given a posn struct + (define (posn->key p) + (string->symbol (format "~ax~a" (posn-x p) (posn-y p)))) + + ;; Namespace manipulation to bind values appropriately + (define (parameterize-namespace row col get-cell-val data thunk) + (parameterize ([current-namespace (current-namespace)]) + (namespace-set-variable-value! 'row row) + (namespace-set-variable-value! 'col col) + (namespace-set-variable-value! 'get-cell-val get-cell-val) + (namespace-set-variable-value! 'data data) + (thunk))) + + ;; Creates a list of formatted strings + ;; for use as row and column label strings + (define (make-loc-string str base max) + (build-list + max + (lambda (i) + (format str (+ i base))))) + + ;; Creates a string representation of the current + ;; state of the cells + (define (flush-text data) + (let r-loop ([c-row 0] [r-lst '()]) + (if (>= c-row VIS_ROWS) + r-lst + (let c-loop ([c-col 0] [c-lst '()]) + (if (>= c-col VIS_COLS) + (r-loop (add1 c-row) (append c-lst r-lst)) + (c-loop (add1 c-col) + (let ([vnd (value-now (data (rowXcol->key c-row c-col)))]) + (if (string=? vnd "") + c-lst + (cons (list (rowXcol->key c-row c-col) + vnd) + c-lst))))))))) + + ; add global hashtable mapping window to its parent object + ;; Spreadsheet object + (define spreadsheet% + (class object% + (init (load-from-file #f)) + (super-new) + +#| (define filename-str (new-cell + (if load-from-file + load-from-file + "Untitled")))|# + + ;; List of cell address and values loaded from the file specified + (define binding-lst (if load-from-file + (read (open-input-file load-from-file)) + '())) + + ;; parameters for the current cell row and column + ; -- available in cell formulas -- + (define row (make-parameter -1)) + (define col (make-parameter -1)) + + + + + ;; establish the root window + (current-widget-parent + (new ft-frame% (label "Spreadsheet") + (width MAX_VIEW_WIDTH) + (height MAX_VIEW_HEIGHT) + (key-events-event-processor split-key-events/type))#;(default-parent)) + + (send (current-widget-parent) show #t) + + ;; Used to determine if there is multiple selection + (define control-down? + (hold (merge-e + (map-e (lambda (_) #t) ((send (current-widget-parent) get-key-events) 'control)) + (map-e (lambda (_) #f) ((send (current-widget-parent) get-key-events) 'release))) + #f)) + + + ;; Spreadsheet content + (define-values-rec + ;;;;;;;;;;;;;;;;;;; + ;; Menu bar & items + [menu-bar (new menu-bar% (parent (current-widget-parent)))] + [file-menu (new menu% (label "File") (parent menu-bar))] + [load-events (value-e (new ft-menu-item% (label "Load...") (parent file-menu)))] + [save-events (value-e (new ft-menu-item% (label "Save As...") (parent file-menu)))] + + ;;;;;;;;;;;;;;;;;;;;;;; + ;; Formula entry widget + [formula (mode widget ft-text-field% (label "Formula:") + ;(init-val "") + (value-set (merge-e + last-selected-cell-text-e + (map-e (lambda (_) (value-now copy-buffer)) + paste-e))) + (key-events-event-processor split-key-events/type) + (focus-when selecting-clicks))] + + ;;;;;;;;;;;;;;;;;;;;;;; + ;; Organizational Panes + + ; canvas, row labels, and column label master container + [can-and-all-lbls-pane (new vertical-pane% (parent (current-widget-parent)))] + ; holds column labels + [col-lbl-pane (new free-horiz-pane% (parent can-and-all-lbls-pane) (stretchable-height #f) (alignment '(left top)))] + ; holds row labels pane and canvas + [row-lbl-and-can-pane (new horizontal-pane% (parent can-and-all-lbls-pane))] + ; holds row labels + [row-lbl-pane (new free-vert-pane% (parent row-lbl-and-can-pane) + (min-width LBL_WIDTH) + (alignment '(right top)) + (stretchable-width #f) + )] + + ;;;;;;;;;;;;;;;;;; + ;; Formula Storage + + [data + (let ([d + (make-accessor/initial-bindings (send formula get-value-b) + commit-e + (map posn->key currently-selected-cells) + binding-lst) + ]) + (lambda (k) + (super-lift + d + k)))] + + + ;;;;;;;;;;;;;;;;;;;;; + ;; Formula Evaluation + + [eval-it + (lambda (r c) + (let ([s (data (rowXcol->key r c))]) + (if (or (undefined? s) (string=? s "")) + "" + (parameterize-namespace + row + col + get-cell-val + data + (lambda () + (super-lift + (lambda (v) + (eval + (read + (open-input-string + (string-append + (format + "(parameterize ([row ~a][col ~a])" + (cadr v) (caddr v)) + (string-append + (car v) + ")")))))) + (list s r c)))))))] + + ;; Events for committing the formula to formula storage + [commit-e ((send formula get-key-events) #\return)] + ;; Events for putting the copy buffer into the formula widget + [paste-e ((send formula get-key-events) 'f2)] + ;; List of cells that are currently selected + [currently-selected-cells + (hold + (collect-e + selecting-clicks + '() + (lambda (evt accum) + (if (value-now control-down?) + (cons evt accum) + (list evt)))) + '())] + + ;; An event stream carrying an occurence when a cell is selected, + ;; whose value is the formula of that cell + [last-selected-cell-text-e + (map-e + (lambda (evt) + (let ([vn (value-now (data (posn->key evt)))]) + (if (undefined? vn) + "" + vn))) + selecting-clicks)] + + ;; Behavior storing the last copied formula + [copy-buffer + (let ([f-v (send formula get-value-b)]) + (hold + (map-e + (lambda (_) (value-now f-v)) + ((send formula get-key-events) 'f1)) + ""))] + + ;;;;;;;;;;;;;;;;; + ;; Value Accessor + ; -- is available in formulas -- + [get-cell-val (lambda (c r) (if (and (= r (row)) (= c (col))) + (begin + (error 'get-cell-val "cannot read own value!") + undefined) + ;(let ([the-data (data (rowXcol->key r c))]) + ; (if (string=? the-data "") + ; undefined + (eval-it #;(data (rowXcol->key r c)) r c) + ; )) + ))] + + ;; List of blue boxes to be used to indicate selection + [selected-cell-bg (map + (lambda (elt) + (let ([is-valid? (not (or (empty? currently-selected-cells) + (undefined? + (car currently-selected-cells))))]) + (make-select-box + (if is-valid? + (* COL_WIDTH (- (posn-y elt) hscroll-b)) + (+ MAX_VIEW_WIDTH COL_WIDTH)) + (if is-valid? + (* ROW_HEIGHT (- (posn-x elt) vscroll-b)) + (+ MAX_VIEW_HEIGHT ROW_HEIGHT)) + (add1 COL_WIDTH) + (add1 ROW_HEIGHT)))) + currently-selected-cells)] + + ;;;;;;;;; + ;; Canvas + ; -- used to draw the cells, values, and selections + [can (new spread-canvas% + (parent row-lbl-and-can-pane) + (grid-lines GRID_BACKGROUND) + (content all-val-pics) + (min-width INIT_VIEW_WIDTH) + (min-height INIT_VIEW_HEIGHT) + (style '(vscroll hscroll)) + (select-area selected-cell-bg))] + + ;; vertical scrolling offset (behavior) + [vscroll-b (hold (map-e (lambda (evt) + (send evt get-position)) + ((send can get-scroll-events) 'vertical)) 0)] + + ;; horizontal scrolling offset (behavior) + [hscroll-b (hold (map-e (lambda (evt) + (send evt get-position)) + ((send can get-scroll-events) 'horizontal)) 0)] + + + ;; Column Labels + ;; spacer is used to align column labels + [spacer (new ft-message% (parent col-lbl-pane) (min-width LBL_WIDTH))] + ;; list of labels indicating columns + [col-labels (map + (lambda (str) (parameterize ([current-widget-parent col-lbl-pane]) + (mode widget ft-message% (label str) + (min-width COL_WIDTH) + (stretchable-width #f) + (horiz-margin 0) + (font LBL_FONT)))) + (make-loc-string "(~a, )" hscroll-b VIS_COLS))] + + ;; Row Labels + ;; list of labels indicating the row + [row-labels (map (lambda (str) (parameterize ([current-widget-parent row-lbl-pane]) + (mode widget ft-message% (label str) + (vert-margin 0) + (min-height 0) + (min-width LBL_WIDTH) + (stretchable-width #f) + (font LBL_FONT)))) + (make-loc-string "( ,~a)" vscroll-b VIS_ROWS))] + + ;; List of values (with spacial information) for drawing in the canvas + [all-val-pics + (let r-loop ([c-row 0] [r-lst '()]) + (if (>= c-row VIS_ROWS) + r-lst + (let c-loop ([c-col 0] [c-lst '()]) + (if (>= c-col VIS_COLS) + (r-loop (add1 c-row) (append c-lst r-lst)) + (c-loop (add1 c-col) + (cons + (make-text-disp + (+ HORIZ_BUFF (* c-col COL_WIDTH)) + (+ VERT_BUFF (* c-row ROW_HEIGHT)) + (custom->string (eval-it (+ c-row vscroll-b) + (+ c-col hscroll-b)))) + c-lst))))))] + + ;; Mouse click events that indicate a new/additional selection + [selecting-clicks (map-e + (lambda (evt) + (let ([m-x (value-now (send can get-mouse-x))] + [m-y (value-now (send can get-mouse-y))] + [x-off (value-now hscroll-b)] + [y-off (value-now vscroll-b)]) + (make-posn + (+ y-off (floor (/ m-y ROW_HEIGHT))) + (+ x-off (floor (/ m-x COL_WIDTH)))))) + (send can get-l-clicks))]) + + ;; Handle loading events + (for-each-e! + load-events + (lambda (le) + (thread (lambda () + (cond [(finder:get-file) + => + (lambda (filename) + (new spreadsheet% (load-from-file filename)))]))))) + + ;; Handle saving events + (for-each-e! + save-events + (lambda (se) + (thread (lambda () + (cond [(finder:put-file) + => + (lambda (filename) + (when (file-exists? filename) + (delete-file filename)) + (let ([p (open-output-file filename)]) + (write (flush-text data) p ) + (flush-output p) + (close-output-port p)))]))))) + + (send can set-scroll-range 'vertical 3000) + (send can set-scroll-range 'horizontal 3000) + (send (current-widget-parent) show #t) + + )) + + ;; start up a spredsheet when module is required + (define s (new spreadsheet%)) + + ) diff --git a/collects/frtime/demos/spreadsheet/spread-doc.txt b/collects/frtime/demos/spreadsheet/spread-doc.txt new file mode 100644 index 0000000000..d3ddd9159f --- /dev/null +++ b/collects/frtime/demos/spreadsheet/spread-doc.txt @@ -0,0 +1,59 @@ +This document explains basic usage of Dan Ignatoff's spreadsheet, +which is in ft-spread.ss. + +File Menu +--------- +Load: Loads a saved spreadsheed in a new window. +Save: Saves the current spreadsheet +(Save is not sensitive to state, it merely +stores the formulas of the cells) + +Interactions +------------ +Clicking on a cell selects the cell. If you are +pressing ctrl, it will add the cell to the current +group of cells being selected. If you are not +pressing ctrl, then only the last selected cell +will be selected. + +Whevever a cell is selected, the formula buffer +is cleared and replaced with the content of that +cell. + +After a cell is selected, type a formula into the +formula field. + +Pressing return sets the formulas of all selected +cells to be the formula in the formula field. + +Pressing f1 will set the copy buffer (not visualized) +to be the current value of the text field. + +Pressing f2 will clear the formula buffer, and +set it to the current value of the copy buffer. + +Cell Language +------------- +The language usable in the cells is FrTime, +with the following additions: + +'row' and 'col' are parameters that store the +row and column of the cell in which they are +part of the formula. + +(get-cell-val column row) +get-cell-val evaluates the formula at the +specified column and row, and returns the value. + +examples: +(get-cell-val 0 0) +gets the value of the cell at (0,0) + +(get-cell-val (col) 0) +gets the value of the cell in the same column +as the cell where this is the forumla, whose row +is zero. + +(get-cell-val (+ 1 (col)) (row)) +gets the value of the cell immediately to the +right of the cell where this is the formula. diff --git a/collects/frtime/demos/spreadsheet/ss-canvas.ss b/collects/frtime/demos/spreadsheet/ss-canvas.ss new file mode 100644 index 0000000000..3583dceebe --- /dev/null +++ b/collects/frtime/demos/spreadsheet/ss-canvas.ss @@ -0,0 +1,165 @@ +(module ss-canvas (lib "frtime.ss" "frtime") + + (require + + (lib "class.ss") + (lib "list.ss" "frtime") + + (all-except (lib "mred.ss" "mred") send-event) + (lib "mixin-macros.ss" "frtime" "demos" "gui") + ) + (require (rename (lib "frp-core.ss" "frtime") super-lift super-lift)) + + + + (define-struct line (vert? x y len)) + (define-struct text-disp (x y string)) + (define-struct select-box (x y w h)) + + + (define (draw-line a-line dc) + (let ([vert? (line-vert? a-line)] + [x (line-x a-line)] + [y (line-y a-line)] + [len (line-len a-line)]) + (send dc draw-line + x + y + (if vert? + x + (+ x len)) + (if vert? + (+ y len) + y)))) + + (define (draw-text a-text dc) + (send dc draw-text + (text-disp-string a-text) + (text-disp-x a-text) + (text-disp-y a-text))) + + (define (draw-select-box a-sb dc) + (let ([b (send dc get-brush)]) + (send dc set-brush "lightsteelblue" 'opaque) + (send dc draw-rectangle + (select-box-x a-sb) + (select-box-y a-sb) + (select-box-w a-sb) + (select-box-h a-sb)) + (send dc set-brush b))) + + + (define spread-canvas% + (class ((callbacks->args-evts scroll-events + on-scroll + (s-evt)) + canvas%) + (init (grid-lines '()) (content '()) (select-area '())) + (inherit get-dc) + (super-new (scroll-events-event-processor + (lambda (es) + (split (map-e car es) (lambda (e) (send e get-direction)))))) + + (define text-values content) + (define grid grid-lines) + (define selection select-area) + + (define offscreen-dc (new bitmap-dc% (bitmap (make-object bitmap% 1280 1024 #f)))) + + (for-each-e! (merge-e (changes text-values) + (changes selection)) + (lambda (_) (on-paint)) + this) + + (define/override (on-paint) + (let ([texts (value-now text-values)] + [select-bx (value-now selection)]) + + (send offscreen-dc clear) + (send offscreen-dc set-pen "black" 1 'solid) + + (for-each + (lambda (s) + (draw-select-box s offscreen-dc)) + select-bx) + + (for-each + (lambda (l) + (draw-line l offscreen-dc)) + grid) + + (for-each + (lambda (t) + (draw-text t offscreen-dc)) + texts) + + + + (send (get-dc) draw-bitmap (send offscreen-dc get-bitmap) 0 0))) + + (define all-mouse (event-receiver)) + + (define (harvest-mouse getter match) + (map-e (lambda (evt) + (getter evt)) + (filter-e + (lambda (evt) + (let ([type (send evt get-event-type)]) + (ormap (lambda (x) (eq? x type)) match))) + all-mouse))) + + + (define identity (lambda (x) x)) + + (define mouse-x-e (harvest-mouse (lambda (e) (send e get-x)) '(enter motion))) + (define mouse-x-b (hold mouse-x-e)) + (define mouse-y-e (harvest-mouse (lambda (e) (send e get-y)) '(enter motion))) + (define mouse-y-b (hold mouse-y-e)) + (define l-clicks-e (harvest-mouse identity '(left-down))) + (define m-clicks-e (harvest-mouse identity '(middle-down))) + (define r-clicks-e (harvest-mouse identity '(right-down))) + (define l-release-e (harvest-mouse identity '(left-up))) + (define m-release-e (harvest-mouse identity '(middle-up))) + (define r-release-e (harvest-mouse identity '(right-up))) + (define l-down? (hold (merge-e (map-e (lambda (e) #t) l-clicks-e) + (map-e (lambda (e) #f) l-release-e)) + #f)) + + (define/override (on-subwindow-event a-window event) + (begin + (send-event all-mouse event) + (super on-subwindow-event a-window event)) + #;(begin + (case (send event get-event-type) + [(enter motion) + (send-event mouse-x-e (send event get-x)) + (send-event mouse-y-e (send event get-y))] + [(left-down) + (send-event l-clicks-e event)] + [(middle-down) + (send-event m-clicks-e event)] + [(right-down) + (send-event r-clicks-e event)]) + (super on-subwindow-event a-window event))) + + (define/public (get-mouse-x) mouse-x-b) + (define/public (get-mouse-y) mouse-y-b) + (define/public (get-l-clicks) l-clicks-e) + (define/public (get-m-clicks) m-clicks-e) + (define/public (get-r-clicks) r-clicks-e) + (define/public (get-all-clicks) (merge-e l-clicks-e + m-clicks-e + r-clicks-e)) + (define/public (get-l-down?) l-down?) + + )) + + + + + + (define-struct posn (x y)) + (define-struct animation (pic pos)) + + (provide (all-defined)) + ) \ No newline at end of file diff --git a/collects/frtime/demos/spreadsheet/ss-database.ss b/collects/frtime/demos/spreadsheet/ss-database.ss new file mode 100644 index 0000000000..5aacd4eade --- /dev/null +++ b/collects/frtime/demos/spreadsheet/ss-database.ss @@ -0,0 +1,74 @@ +(module ss-database (lib "frtime-big.ss" "frtime") + (require (rename (lib "frp-core.ss" "frtime") current-custs current-custs)) + (require (rename (lib "frp-core.ss" "frtime") do-in-manager do-in-manager)) + (require (as-is:unchecked mzscheme make-hash-table hash-table-get hash-table-put!)) + ;(require (lib "string.ss")) + + (define-struct rcvXbeh (rcv beh)) + + (define put-text-at! + (lambda (ht txt key) + (lambda () + (parameterize ([current-custs '()]) + (let* ([rcv (event-receiver)] + [hld (hold rcv txt)] + [both (make-rcvXbeh rcv hld)]) + (hash-table-put! ht key both) + both))))) + + (define update-value + (lambda (ht k v) + (send-event + (rcvXbeh-rcv + (hash-table-get + ht + k + (put-text-at! ht v k))) + v))) + + (define retreive-value + (lambda (ht k) + (rcvXbeh-beh + (hash-table-get ht k (put-text-at! ht "" k))))) + + + ;; put-text-at! is used in both the setter and + ;; getter, so that things will be in sync + (define (split-through-list-b evt fn) + (let* ([ht-text (make-hash-table)] + [sig (map-e (lambda (val-e) + (map (lambda (key) + (update-value ht-text key val-e)) + (fn val-e))) + evt)]) + (lambda (x) + sig + (retreive-value ht-text x)))) + + (define (split-through-list-b/init evt fn bindings) + (let* ([ht-text (make-hash-table)] + [sig (map-e (lambda (val-e) + (map (lambda (key) + (update-value ht-text key val-e)) + (fn val-e))) + evt)]) + (for-each ; bindings are of the form ((key val) ...) + (lambda (lst) + (update-value ht-text (car lst) (cadr lst)) + (printf "~a~n" lst)) + bindings) + (lambda (x) + sig + (retreive-value ht-text x)))) + + (define (make-accessor formula commit-e currently-selected-cells) + (split-through-list-b (commit-e . -=> . (value-now formula)) + (lambda (_) (value-now currently-selected-cells)))) + + (define (make-accessor/initial-bindings formula commit-e currently-selected-cells bindings) + (split-through-list-b/init (commit-e . -=> . (value-now formula)) + (lambda (_) (value-now currently-selected-cells)) + bindings)) + + (provide make-accessor + make-accessor/initial-bindings)) \ No newline at end of file