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

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

Browse Source 
svn: r1796
This commit is contained in:
Greg Cooper 2006-01-10 17:33:31 +00:00
parent ff929b8fd1
commit fdb7c27f6d
9 changed files with 2077 additions and 354 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

87
collects/frtime/demos/gui/demo/bindec.ss
View File

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

6
collects/frtime/demos/gui/demo/timer.ss
View File

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

562
collects/frtime/demos/gui/fred.ss
View File

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

226
collects/frtime/demos/gui/mod-mrpanel.ss Normal file
View File

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

816
collects/frtime/demos/gui/mod-wx-panel.ss Normal file
View File

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

436
collects/frtime/demos/spreadsheet/ft-spread.ss Normal file
View File

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

59
collects/frtime/demos/spreadsheet/spread-doc.txt Normal file
View File

@ -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.

165
collects/frtime/demos/spreadsheet/ss-canvas.ss Normal file
View File

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

74
collects/frtime/demos/spreadsheet/ss-database.ss Normal file
View File

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