-cleaned up the gui demos and added Dan's new spreadsheet and documentation

svn: r1796

collects/frtime/demos/gui/demo/bindec.ss

@@ -1,46 +1,43 @@
-(require "../simple.ss")
+(require "../simple.ss")
-(require (rename (lib "mred.ss" "mred") horizontal-panel% horizontal-panel%))
+(require (rename (lib "mred.ss" "mred") horizontal-panel% horizontal-panel%))
-
+
-; just change this to change the range of the binary/decimal converter
+; just change this to change the range of the binary/decimal converter
-(define SIZE 10) 
+(define SIZE 10) 
-
+
-(define (bool-lst->num bool-lst)
+(define (bool-lst->num bool-lst)
-  (let loop ([lst bool-lst] [sum 0] [pow 0])
+  (let loop ([lst bool-lst] [sum 0] [pow 0])
-    (if (empty? lst)
+    (if (empty? lst)
-        sum
+        sum
-        (loop (cdr lst) 
+        (loop (cdr lst) 
-              (+ sum
+              (+ sum
-                 (if (car lst)
+                 (if (car lst)
-                     (expt 2 pow)
+                     (expt 2 pow)
-                     0))
+                     0))
-              (add1 pow)))))
+              (add1 pow)))))
-
+
-(define (place-num->bool loc num)
+(define (place-num->bool loc num)
-  (if (= 0 loc)
+  (if (= 0 loc)
-      (odd? num)
+      (odd? num)
-      (place-num->bool (sub1 loc) (quotient num 2))))
+      (place-num->bool (sub1 loc) (quotient num 2))))
-
+
-
+
-(current-widget-parent (new ft-frame% 
+(current-widget-parent (new ft-frame% (label "Binary<-->Decimal")))
-                            (its-width 0)
+
-                            (its-height 0)
+(define-values-rec
-                            (label-text "Binary<-->Decimal")))
+  [sld (mode value-b ft-slider%
-
+             (min-value 0)
-(define-values-rec
+             (max-value (sub1 (expt 2 SIZE)))
-  [sld (mode value-b ft-slider%
+             (value-set (changes 
-             (min-value 0)
+                           (bool-lst->num
-             (max-value (sub1 (expt 2 SIZE)))
+                            boxes))))]
-             (value-set (changes 
+  
-                           (bool-lst->num
+  [boxes (parameterize ([current-widget-parent
-                            boxes))))]
+                         (mode widget horizontal-panel%)])
-  
+           (build-list SIZE ; build-list is right associative.
-  [boxes (parameterize ([current-widget-parent
+                       (lambda (i)
-                         (mode widget horizontal-panel%)])
+                         (mode value-b ft-check-box%
-           (build-list SIZE ; build-list is right associative.
+                               (label (number->string (expt 2 i)))
-                       (lambda (i)
+                               (value-set 
-                         (mode value-b ft-check-box%
+                                (changes (place-num->bool i sld)))))))])
-                               (label (number->string (expt 2 i)))
+
-                               (value-set 
-                                (changes (place-num->bool i sld)))))))])
-
 (send (current-widget-parent) show #t)

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%

collects/frtime/demos/gui/fred.ss

@@ -1,306 +1,256 @@
-(module fred (lib "frtime.ss" "frtime")
+(module fred (lib "frtime.ss" "frtime")
-  (require "mixin-macros.ss"
+  (require "mixin-macros.ss"
-           ;"r-label.ss"
+           ;"r-label.ss"
-           (lib "class.ss")
+           (lib "class.ss")
-           (lib "string.ss")
+           (lib "string.ss")
-           (all-except (lib "mred.ss" "mred") send-event)
+           (all-except (lib "mred.ss" "mred") send-event)
-           (lib "framework.ss" "framework"))
+           (lib "framework.ss" "framework"))
-  
+  
-  (define-syntax add-signal-controls
+  (define-syntax add-signal-controls
-    (syntax-rules ()
+    (syntax-rules ()
-      [(_ src (field-name0 update-call0 default-val0) clause ...)
+      [(_ src (field-name0 update-call0 default-val0) clause ...)
-       ((behavior->callbacks field-name0 update-call0)
+       ((behavior->callbacks field-name0 update-call0)
-        default-val0
+        default-val0
-        (add-signal-controls src clause ...))]
+        (add-signal-controls src clause ...))]
-      [(_ src)
+      [(_ src)
-       src]))
+       src]))
-  
+  
-
+
-  
+  
-  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-  ;; Helpers
+  ;; Helpers
-  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-  
+  
-  ;; adding assumed methods
+  ;; adding assumed methods
-  (define (add-void-set-value super-class)
+  (define (add-void-set-value super-class)
-    (class super-class
+    (class super-class
-      (define/public (set-value v) (void))
+      (define/public (set-value v) (void))
-      (super-new)))
+      (super-new)))
-  
+  
-  (define (add-focus-now super-class)
+  (define (add-focus-now super-class)
-    (class super-class
+    (class super-class
-      (super-new)
+      (super-new)
-      (inherit focus)
+      (inherit focus)
-      (define/public (focus-now _) (focus))))
+      (define/public (focus-now _) (focus))))
-  
+  
-  (define (callback->pub-meth super-class)
+  (define (callback->pub-meth super-class)
-    (class super-class
+    (class super-class
-      (define/public (callback-method w e) (void))
+      (define/public (callback-method w e) (void))
-      (super-new (callback (lambda (w e) (callback-method w e))))))
+      (super-new (callback (lambda (w e) (callback-method w e))))))
-  
+  
-  
+  
-  ;; *-event-processor init-argument values
+  ;; *-event-processor init-argument values
-  (define event-is-val
+  (define event-is-val
-    (lambda (es)
+    (lambda (es)
-      (map-e car es)))
+      (map-e car es)))
-  
+  
-  ; (send x get-mouse-events) returns a split procedure over the event-type
+  ; (send x get-mouse-events) returns a split procedure over the event-type
-  (define split-mouse-events/type
+  (define split-mouse-events/type
-    (lambda (evt-src)
+    (lambda (evt-src)
-      (split (map-e cadr evt-src) (lambda (evt) (send evt get-event-type)))))
+      (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
+  ; (send x get-key-events) returns a split procedure over the key code
-  (define split-key-events/type
+  (define split-key-events/type
-    (lambda (evt-src)
+    (lambda (evt-src)
-      (split (map-e cadr evt-src) (lambda (evt) (send evt get-key-code)))))
+      (split (map-e cadr evt-src) (lambda (evt) (send evt get-key-code)))))
-  
+  
-  
+  
-  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-  ;; make state available as eventstreams
+  ;; make state available as eventstreams
-  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-  
+  
-  (define (add-mouse-access super-class)
+  (define (add-mouse-access super-class)
-    ((callbacks->args-evts mouse-events ; Name of event stream
+    ((callbacks->args-evts mouse-events ; Name of event stream
-                           on-subwindow-event ; proc overriding
+                           on-subwindow-event ; proc overriding
-                           (window evt) ; arguments for on-subwindow-event. Caused by super being a macro
+                           (window evt) ; arguments for on-subwindow-event. Caused by super being a macro
-                           )
+                           )
-     super-class))
+     super-class))
-  
+  
-  
+  
-  (define (add-focus-access super-class)
+  (define (add-focus-access super-class)
-    ((callbacks->args-evts focus-events on-focus (is-focused?))
+    ((callbacks->args-evts focus-events on-focus (is-focused?))
-     super-class))
+     super-class))
-  
+  
-  (define (add-keypress-split super-class)
+  (define (add-keypress-split super-class)
-    ((callbacks->args-evts key-events on-subwindow-char (w e))
+    ((callbacks->args-evts key-events on-subwindow-char (w e))
-     super-class))
+     super-class))
-  
+  
-  
+  
-  
+  
-  #|
+  #|
-  (define (add-value-b super-class default)
+  (define (add-value-b super-class default)
-    (class super-class
+    (class super-class
-      (super-new)
+      (super-new)
-      (inherit get-value-e)
+      (inherit get-value-e)
-      (define/public (get-value-b) (hold (get-value-e) default))))
+      (define/public (get-value-b) (hold (get-value-e) default))))
-  |#
+  |#
-  
+  
-  (define (add-callback-access val-ext default-val super-class)
+  (define (add-callback-access val-ext super-class)
-    (class ((callbacks->args-evts set-value-events
+    (class ((callbacks->args-evts set-value-events
-                                  set-value
+                                  set-value
-                                  (v))
+                                  (v))
-            ((callbacks->args-evts callback-events
+            ((callbacks->args-evts callback-events
-                                   callback-method
+                                   callback-method
-                                   (w e))
+                                   (w e))
-             (callback->pub-meth super-class)))
+             (callback->pub-meth super-class)))
-      (super-new (set-value-events-event-processor event-is-val)
+      (super-new (set-value-events-event-processor event-is-val)
-                 (callback-events-event-processor (lambda (es)
+                 (callback-events-event-processor (lambda (es)
-                                                    (map-e (lambda (e) (apply val-ext e)) es))))
+                                                    (map-e (lambda (e) (apply val-ext e)) es))))
-      (inherit get-set-value-events get-callback-events)
+      (inherit get-set-value-events get-callback-events)
-      (define value-e (merge-e (get-set-value-events)
+      (define value-e (merge-e (get-set-value-events)
-                               (get-callback-events)))
+                               (get-callback-events)))
-      (define value-b (hold value-e (val-ext this #f)))
+      (define value-b (hold value-e (val-ext this #f)))
-      (define/public (get-value-e) value-e)
+      (define/public (get-value-e) value-e)
-      (define/public (get-value-b) value-b)
+      (define/public (get-value-b) value-b)
-      ))
+      ))
-  
+  
-  
+  
-  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-  ;; using events to drive object interaction
+  ;; using events to drive object interaction
-  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-  
+  
-  (define (add-callback-access/loop val-ext default-val super-class)
+  (define (add-callback-access/loop val-ext super-class)
-    ((events->callbacks value-set set-value)
+    ((events->callbacks value-set set-value)
-     (add-callback-access val-ext default-val super-class)))
+     (add-callback-access val-ext super-class)))
-  
+  
-  
+  
-  (define (add-focus-on-event super-class)
+  (define (add-focus-on-event super-class)
-    ((events->callbacks focus-when focus-now)
+    ((events->callbacks focus-when focus-now)
-     (add-focus-now super-class)))
+     (add-focus-now super-class)))
-  
+  
-  
+  
-  
+  
-    ;; Special case widgets
+    ;; Special case widgets
-  (define (in-string itm)
+  (define (in-string itm)
-    (if (undefined? itm)
+    (if (undefined? itm)
-        ""
+        ""
-        (if (string? itm)
+        (if (string? itm)
-            itm
+            itm
-            (expr->string itm))))
+            (expr->string itm))))
-  
+  
-  
+  
-  
+  
-  (define ft-frame%
+  (define ft-frame%
-    (class (add-mouse-access (add-keypress-split (add-signal-controls frame% (label set-label ""))))
+    (class ((callbacks->args-evts resize-events on-size (w h))
-      ; Members, initialized
+            (add-mouse-access 
-      (init-field (its-width 800) (its-height 600) (label-text "") (x-loc 0) (y-loc 0))
+             (add-keypress-split 
-      #|
+              (add-signal-controls frame% 
-      ;(make-prog-control label-text set-label)
+                                   (label set-label "")))))
-      
+      (super-new)
-      ; 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 ft-message% 
-      (define mouse-x-e (event-receiver))
+    (add-mouse-access
-      (define mouse-x-b (hold mouse-x-e 0))
+     (add-focus-access
-      (define mouse-y-e (event-receiver))
+      (add-signal-controls message% (label set-label "") (enabled enable #t)))))
-      (define mouse-y-b (hold mouse-y-e 0))
+  
-      
+  #;(define ft-autoresize-label% 
-      ; Overridden methods
+    (add-mouse-access
-      (override on-size on-subwindow-event)
+     (add-focus-access
-      
+      (add-signal-controls autoresize-label% (text set-label-text "") (enabled enable #t)))))
-      ; Overrides on-size from frame% to update width-e and height-e
+  
-      (define (on-size new-width new-height)
+  
-        (begin
+  (define specialized-gauge%
-          (send-event width-e new-width)
+    (class gauge%
-          (send-event height-e new-height)
+      (init value)
-          
+      
-          (super on-size new-width new-height)))
+      (super-new)
-      
+      
-      (define (on-subwindow-event a-window event)
+      (inherit set-value)
-        (begin
+      #;(set-value value)))
-          (case (send event get-event-type)
+  
-            [(enter motion)
+  (define ft-gauge%
-             (send-event mouse-x-e (+ (send a-window get-x) (send event get-x)))
+    (add-mouse-access
-             (send-event mouse-y-e (+ (send a-window get-y) (send event get-y)))])
+     (add-focus-access
-          (super on-subwindow-event a-window event)))
+      (add-signal-controls specialized-gauge% 
-      
+                           (label set-label "") 
-      ; Public Members    
+                           (enabled enable #t)
-      (public get-width-b get-height-b get-mouse-x get-mouse-y)
+                           (value set-value 0)
-      
+                           (range set-range 1)))))
-      ; Returns a behavior of the width of the frame
+  
-      (define (get-width-b) width-b)
+  (define ft-menu-item%
-      
+    (add-callback-access
-      ; Returns a behavior of the height of the frame
+     list
-      (define (get-height-b) height-b)
+     (add-void-set-value
-      
+      menu-item%)))
-      (define (get-mouse-x) mouse-x-b)
+  
-      (define (get-mouse-y) mouse-y-b)
+  
-      |#
+  
-      (super-new (label (in-string (value-now label-text))) 
+  (define (send-for-value w e)
-                 (width its-width) 
+    (send w get-value))
-                 (height its-height)
+  
-                 (x x-loc)
+  (define (send-for-selection w e)
-                 (y y-loc)
+    (send w get-selection))
-                 #;(style '(float metal)))))
+  
-  
+  
-  
+  ;; Standard mixin combinations
-
+  (define (standard-lift widget value-method)
-  
+    (add-mouse-access
-  (define ft-message% 
+     (add-focus-access
-    (add-mouse-access
+      (add-callback-access
-     (add-focus-access
+       value-method
-      (add-signal-controls message% (label set-label "") (enabled enable #t)))))
+       (add-signal-controls (add-void-set-value widget) (label set-label "") (enabled enable #t))))))
-  
+  
-  #;(define ft-autoresize-label% 
+  (define (standard-lift/loop widget value-method)
-    (add-mouse-access
+    (add-mouse-access
-     (add-focus-access
+     (add-focus-access
-      (add-signal-controls autoresize-label% (text set-label-text "") (enabled enable #t)))))
+      (add-callback-access/loop
-  
+       value-method
-  
+       (add-signal-controls widget (label set-label "") (enabled enable #t))))))
-  (define specialized-gauge%
+  
-    (class gauge%
+  
-      (init value)
+  
-      
+  (define ft-button%
-      (super-new)
+    (standard-lift button% (lambda (w e) e)))  
-      
+  
-      (inherit set-value)
+  (define ft-check-box%
-      #;(set-value value)))
+    (standard-lift/loop check-box% send-for-value))
-  
+  
-  (define ft-gauge%
+  (define ft-radio-box%
-    (add-mouse-access
+    (standard-lift radio-box% send-for-selection))
-     (add-focus-access
+  
-      (add-signal-controls specialized-gauge% 
+  (define ft-choice%
-                           (label set-label "") 
+    (standard-lift choice% send-for-selection))
-                           (enabled enable #t)
+  
-                           (value set-value 0)
+  (define ft-slider%
-                           (range set-range 1)))))
+    (standard-lift/loop slider% send-for-value))
-  
+  
-  (define ft-menu-item%
+  (define ft-list-box% 
-    (add-callback-access
+    (standard-lift list-box% send-for-selection))
-     list
+  
-     '()
+  (define ft-text-field%
-     (add-void-set-value
+    (add-keypress-split
-      menu-item%)))
+     (add-focus-on-event
-  
+      (standard-lift/loop text-field% send-for-value))))
-  
+  
-  
+ 
-  (define (send-for-value w e)
+  
-    (send w get-value))
+  
-  
+  
-  (define (send-for-selection w e)
+  
-    (send w get-selection))
+  (provide ft-frame%
-  
+           ft-message%
-  
+           ;ft-autoresize-label%
-  ;; Standard mixin combinations
+           ft-gauge%
-  (define (standard-lift widget value-method value-default)
+           ft-button%
-    (add-mouse-access
+           ft-check-box%
-     (add-focus-access
+           ft-radio-box%
-      (add-callback-access
+           ft-choice%
-       value-method
+           ft-slider%
-       value-default
+           ft-list-box%
-       (add-signal-controls (add-void-set-value widget) (label set-label "") (enabled enable #t))))))
+           ft-text-field%
-  
+           ft-menu-item%
-  (define (standard-lift/loop widget value-method value-default)
+           menu%
-    (add-mouse-access
+           menu-bar%
-     (add-focus-access
+           finder:get-file
-      (add-callback-access/loop
+           finder:put-file
-       value-method
+           split-mouse-events/type
-       value-default
+           split-key-events/type
-       (add-signal-controls widget (label set-label "") (enabled enable #t))))))
+           (all-from (lib "class.ss"))
-  
+           (all-from "mixin-macros.ss"))) 
-  
+
-  
+
-  (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"))) 
-
-
-

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)]))))

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%)))

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)
+        "<undefined>"
+        (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%))
+  
+  )

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.

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))
+  )

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))