-cleaned up the gui demos and added Dan's new spreadsheet and documentation
svn: r1796
This commit is contained in:
Greg Cooper
parent
ff929b8fd1
commit
fdb7c27f6d
|
|
@ -21,10 +21,7 @@
|
||||||
(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)
|
|
||||||
(label-text "Binary<-->Decimal")))
|
|
||||||
|
|
||||||
(define-values-rec
|
(define-values-rec
|
||||||
[sld (mode value-b ft-slider%
|
[sld (mode value-b ft-slider%
|
||||||
|
|
|
||||||
|
|
@ -1,12 +1,12 @@
|
||||||
(require "../simple.ss")
|
(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 tenths (quotient milliseconds 100))
|
||||||
|
|
||||||
(define-values-rec
|
(define-values-rec
|
||||||
[range (* 10 (mode value-b ft-slider%
|
[range (* 10 (mode value-b ft-slider%
|
||||||
(label "Range")
|
(label "Range: ")
|
||||||
(min-value 10)
|
(min-value 10)
|
||||||
(max-value 30)
|
(max-value 30)
|
||||||
(init-value 10)))]
|
(init-value 10)))]
|
||||||
|
|
@ -16,7 +16,7 @@
|
||||||
reset)
|
reset)
|
||||||
(value-now tenths))))]
|
(value-now tenths))))]
|
||||||
[gauge (mode widget ft-gauge%
|
[gauge (mode widget ft-gauge%
|
||||||
(label "Timer")
|
(label "Elapsed: ")
|
||||||
(value gauge-value)
|
(value gauge-value)
|
||||||
(range range))]
|
(range range))]
|
||||||
[msg (mode widget ft-message%
|
[msg (mode widget ft-message%
|
||||||
|
|
|
||||||
|
|
@ -85,7 +85,7 @@
|
||||||
(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))
|
||||||
|
|
@ -109,9 +109,9 @@
|
||||||
;; 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)
|
||||||
|
|
@ -131,60 +131,13 @@
|
||||||
|
|
||||||
|
|
||||||
(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 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)))))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -221,7 +174,6 @@
|
||||||
(define ft-menu-item%
|
(define ft-menu-item%
|
||||||
(add-callback-access
|
(add-callback-access
|
||||||
list
|
list
|
||||||
'()
|
|
||||||
(add-void-set-value
|
(add-void-set-value
|
||||||
menu-item%)))
|
menu-item%)))
|
||||||
|
|
||||||
|
|
@ -235,46 +187,44 @@
|
||||||
|
|
||||||
|
|
||||||
;; Standard mixin combinations
|
;; Standard mixin combinations
|
||||||
(define (standard-lift widget value-method value-default)
|
(define (standard-lift widget value-method)
|
||||||
(add-mouse-access
|
(add-mouse-access
|
||||||
(add-focus-access
|
(add-focus-access
|
||||||
(add-callback-access
|
(add-callback-access
|
||||||
value-method
|
value-method
|
||||||
value-default
|
|
||||||
(add-signal-controls (add-void-set-value widget) (label set-label "") (enabled enable #t))))))
|
(add-signal-controls (add-void-set-value widget) (label set-label "") (enabled enable #t))))))
|
||||||
|
|
||||||
(define (standard-lift/loop widget value-method value-default)
|
(define (standard-lift/loop widget value-method)
|
||||||
(add-mouse-access
|
(add-mouse-access
|
||||||
(add-focus-access
|
(add-focus-access
|
||||||
(add-callback-access/loop
|
(add-callback-access/loop
|
||||||
value-method
|
value-method
|
||||||
value-default
|
|
||||||
(add-signal-controls widget (label set-label "") (enabled enable #t))))))
|
(add-signal-controls widget (label set-label "") (enabled enable #t))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(define ft-button%
|
(define ft-button%
|
||||||
(standard-lift button% (lambda (w e) e) undefined))
|
(standard-lift button% (lambda (w e) e)))
|
||||||
|
|
||||||
(define ft-check-box%
|
(define ft-check-box%
|
||||||
(standard-lift/loop check-box% send-for-value #f))
|
(standard-lift/loop check-box% send-for-value))
|
||||||
|
|
||||||
(define ft-radio-box%
|
(define ft-radio-box%
|
||||||
(standard-lift radio-box% send-for-selection 0))
|
(standard-lift radio-box% send-for-selection))
|
||||||
|
|
||||||
(define ft-choice%
|
(define ft-choice%
|
||||||
(standard-lift choice% send-for-selection 0))
|
(standard-lift choice% send-for-selection))
|
||||||
|
|
||||||
(define ft-slider%
|
(define ft-slider%
|
||||||
(standard-lift/loop slider% send-for-value 0))
|
(standard-lift/loop slider% send-for-value))
|
||||||
|
|
||||||
(define ft-list-box%
|
(define ft-list-box%
|
||||||
(standard-lift list-box% send-for-selection 0))
|
(standard-lift list-box% send-for-selection))
|
||||||
|
|
||||||
(define ft-text-field%
|
(define ft-text-field%
|
||||||
(add-keypress-split
|
(add-keypress-split
|
||||||
(add-focus-on-event
|
(add-focus-on-event
|
||||||
(standard-lift/loop text-field% send-for-value ""))))
|
(standard-lift/loop text-field% send-for-value))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
226
collects/frtime/demos/gui/mod-mrpanel.ss
Normal file
226
collects/frtime/demos/gui/mod-mrpanel.ss
Normal 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
816
collects/frtime/demos/gui/mod-wx-panel.ss
Normal 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
436
collects/frtime/demos/spreadsheet/ft-spread.ss
Normal 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
59
collects/frtime/demos/spreadsheet/spread-doc.txt
Normal 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
165
collects/frtime/demos/spreadsheet/ss-canvas.ss
Normal 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
74
collects/frtime/demos/spreadsheet/ss-database.ss
Normal 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))
|
||||||
Loading…
Reference in New Issue
Block a user