- fixed bugs in delay and integral, apparently introduced by more clever
compiler/garbage collector - fixed div by zero bug in pong.ss demo - removed defunct net-pong demos and ft-spread - added documentation and demo sheet for spreadsheet svn: r3329
This commit is contained in:
Greg Cooper
parent
1a70f40e4f
commit
5dcfe79801
|
|
@ -1,27 +0,0 @@
|
|||
(require (lib "animation.ss" "frtime")
|
||||
(lib "erl.ss" "frtime"))
|
||||
|
||||
(define server (new-cell (make-tid 1178 'frtime-heart)))
|
||||
|
||||
(define pos1
|
||||
(let* ([paddle-radius 20]
|
||||
[paddle1-pos (make-posn (clip (posn-x mouse-pos) 30 170) (clip (posn-y mouse-pos) 30 370))]
|
||||
[_ (bind 'paddle1-pos ((changes paddle1-pos) . ==> . (lambda (p) (list (posn-x p) (posn-y p)))))]
|
||||
[pong (switch (left-clicks
|
||||
. ==> .
|
||||
(lambda (_)
|
||||
(hold (remote-reg (value-now server) 'pong)
|
||||
(list 300 300 100 100 0 0))))
|
||||
(list 300 300 100 100 0 0))]
|
||||
[paddle2-pos (make-posn (first pong) (second pong))]
|
||||
[pos1 (make-posn (third pong) (fourth pong))]
|
||||
[p1-score (list-ref pong 4)]
|
||||
[p2-score (list-ref pong 5)])
|
||||
(display-shapes
|
||||
(list (make-circle pos1 10 "blue")
|
||||
(make-circle paddle1-pos paddle-radius "black")
|
||||
(make-circle paddle2-pos paddle-radius "black")
|
||||
(make-graph-string (make-posn 30 30) (number->string p2-score) "black")
|
||||
(make-graph-string (make-posn 350 30) (number->string p1-score) "black")
|
||||
(make-line (make-posn 0 150) (make-posn 0 250) "red")
|
||||
(make-line (make-posn 399 150) (make-posn 399 250) "red")))))
|
||||
|
|
@ -1,80 +0,0 @@
|
|||
(require
|
||||
(lib "animation.ss" "frtime")
|
||||
(lib "erl.ss" "frtime")
|
||||
(all-except (lib "match.ss") match))
|
||||
|
||||
(define client (new-cell (make-tid 1179 'frtime-heart)))
|
||||
|
||||
(define pos1
|
||||
(let ([paddle-radius 20]
|
||||
[neg-x (lambda (v) (make-posn (- (posn-x v)) (posn-y v)))]
|
||||
[neg-y (lambda (v) (make-posn (posn-x v) (- (posn-y v))))]
|
||||
[paddle2-pos (make-posn (clip (posn-x mouse-pos) 230 370) (clip (posn-y mouse-pos) 30 370))]
|
||||
[paddle1-pos (switch (left-clicks . ==> .
|
||||
(lambda (_)
|
||||
(hold ((remote-reg
|
||||
(value-now client)
|
||||
'paddle1-pos)
|
||||
. ==> .
|
||||
(lambda (l) (make-posn (first l) (second l))))
|
||||
(make-posn 30 200))))
|
||||
(make-posn 30 200))]
|
||||
[collide (match-lambda
|
||||
[(_ mp p)
|
||||
(let ([u (normalize (posn- mp p))])
|
||||
(lambda (v)
|
||||
(posn- v (posn* u (* 2 (posn-dot v u))))))])])
|
||||
(letrec ([pos1 (switch
|
||||
((merge-e
|
||||
(when-e (> (posn-x pos1) 500))
|
||||
(when-e (< (posn-x pos1) -100))
|
||||
(when-e (> (posn-y pos1) 500))
|
||||
(when-e (< (posn-y pos1) -100))) . ==> . (lambda (dummy) (posn+ (make-posn 100 100) (posn-integral vel1))))
|
||||
(posn+ (make-posn 100 100) (posn-integral vel1)))]
|
||||
[vel1 (accum-b
|
||||
(merge-e
|
||||
((merge-e
|
||||
(when-e (> (posn-x pos1) 390))
|
||||
(when-e (< (posn-x pos1) 10))) . -=> . neg-x)
|
||||
((merge-e
|
||||
(when-e (> (posn-y pos1) 390))
|
||||
(when-e (< (posn-y pos1) 10))) . -=> . neg-y)
|
||||
((merge-e
|
||||
(snapshot-e (when-e (< (posn-diff pos1 paddle1-pos)
|
||||
(+ 10 paddle-radius))) paddle1-pos pos1)
|
||||
(snapshot-e (when-e (< (posn-diff pos1 paddle2-pos)
|
||||
(+ 10 paddle-radius))) paddle2-pos pos1))
|
||||
. ==> . collide))
|
||||
(make-posn .29 .23))])
|
||||
(let ([p1-score (accum-b
|
||||
(merge-e
|
||||
((key #\r) . -=> . (lambda (x) 0))
|
||||
((snapshot-e (when-e (< (posn-x pos1) 10)) (posn-y pos1))
|
||||
. =#=> .
|
||||
(match-lambda
|
||||
[(_ y) (if (and (> y 150) (< y 250))
|
||||
add1
|
||||
nothing)])))
|
||||
0)]
|
||||
[p2-score (accum-b
|
||||
(merge-e
|
||||
((key #\r) . -=> . (lambda (x) 0))
|
||||
((snapshot-e (when-e (> (posn-x pos1) 390)) (posn-y pos1))
|
||||
. =#=> .
|
||||
(match-lambda
|
||||
[(_ y) (if (and (> y 150) (< y 250))
|
||||
add1
|
||||
nothing)])))
|
||||
0)])
|
||||
(display-shapes
|
||||
(list (make-circle pos1 10 "blue")
|
||||
(make-circle paddle1-pos paddle-radius "black")
|
||||
(make-circle paddle2-pos paddle-radius "black")
|
||||
(make-graph-string (make-posn 30 30) (number->string p2-score) "black")
|
||||
(make-graph-string (make-posn 350 30) (number->string p1-score) "black")
|
||||
(make-graph-string (make-posn 120 30) (number->string (posn-len vel1)) "black")
|
||||
(make-line (make-posn 0 150) (make-posn 0 250) "red")
|
||||
(make-line (make-posn 399 150) (make-posn 399 250) "red")))
|
||||
(bind 'pong (changes (list (posn-x paddle2-pos) (posn-y paddle2-pos)
|
||||
(posn-x pos1) (posn-y pos1)
|
||||
p1-score p2-score)))))))
|
||||
|
|
@ -65,7 +65,7 @@
|
|||
(when-e (< (posn-x pos1) -100))
|
||||
(when-e (> (posn-y pos1) 500))
|
||||
(when-e (< (posn-y pos1) -100))) . -=> . (posn+ (make-posn 100 100) (posn-integral vel1)))
|
||||
(posn+ (make-posn 100 100) (posn-integral vel1))))]
|
||||
(posn+ (make-posn 200 200) (posn-integral vel1))))]
|
||||
[vel1 (accum-b
|
||||
(merge-e
|
||||
((when-e (> (posn-x pos1) 390)) . -=> . neg-x)
|
||||
|
|
|
|||
1
collects/frtime/demos/spreadsheet/demos.sheet
Normal file
1
collects/frtime/demos/spreadsheet/demos.sheet
Normal file
File diff suppressed because one or more lines are too long
31
collects/frtime/demos/spreadsheet/doc.txt
Normal file
31
collects/frtime/demos/spreadsheet/doc.txt
Normal file
|
|
@ -0,0 +1,31 @@
|
|||
|
||||
This is an experimental spreadsheet to test FrTime and its GUI
|
||||
development capabilities. It is interesting because FrTime is used to
|
||||
implement the spreadsheet and as the language for cell formulas.
|
||||
|
||||
Usage:
|
||||
|
||||
To run the spreadsheet, open spread.ss in DrScheme, set the language level
|
||||
to (module ...), and execute.
|
||||
|
||||
Select a cell by clicking the mouse or moving with the arrow
|
||||
keys. Press enter to focus the text entry field, where you can enter
|
||||
a FrTime expression. This includes purely functional Scheme and many
|
||||
common primitives. In a cell, you can refer to another cell by name.
|
||||
Entering the formula (+ a5 c7), including the parentheses, makes the
|
||||
value of the selected cell the sum of cells a5 and c7.
|
||||
|
||||
It is also possible to refer to sequences of adjacent cells, which
|
||||
results in a list. For example, a1:5 returns a list containing the
|
||||
values of the cells a1 through a5.
|
||||
|
||||
The spreadsheet can load and save files. For several of examples of
|
||||
spreadsheet formulas, including the use of behaviors, cell sequences,
|
||||
and absolute cell references, open demos.sheet.
|
||||
|
||||
Known Bugs:
|
||||
|
||||
- Initial evaluation of a cell formula is super slow.
|
||||
- Whole-screen redraw, as when scrolling or resizing, is super slow.
|
||||
- Errors arising during re-evaluation (not during initial evaluation) go
|
||||
to the DrScheme interactions window instead of propagating to the cell.
|
||||
|
|
@ -1,436 +0,0 @@
|
|||
(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%))
|
||||
|
||||
)
|
||||
|
|
@ -1,59 +0,0 @@
|
|||
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.
|
||||
|
|
@ -205,13 +205,13 @@
|
|||
(set-cell! (ss-cell-value cell)
|
||||
(with-handlers
|
||||
([exn? (lambda (exn)
|
||||
(message-box
|
||||
#;(message-box
|
||||
"Error"
|
||||
(format "The following error occurred while evaluating a formula:~n~a"
|
||||
(exn-message exn))
|
||||
frame
|
||||
'(ok stop))
|
||||
"#<Error>")])
|
||||
exn)])
|
||||
(eval `(let ([row ,row]
|
||||
[col ,col])
|
||||
,processed-expr))))
|
||||
|
|
|
|||
|
|
@ -343,6 +343,7 @@
|
|||
(current-milliseconds))
|
||||
empty)]
|
||||
[head last]
|
||||
[dummy 0]
|
||||
[producer (proc->signal
|
||||
(lambda ()
|
||||
(let* ([now (current-milliseconds)]
|
||||
|
|
@ -352,7 +353,7 @@
|
|||
(< now (+ ms (cdadr head))))
|
||||
(caar head)
|
||||
(begin
|
||||
consumer ;; just to prevent GC
|
||||
(set! dummy consumer) ;; just to prevent GC
|
||||
(set! head (rest head))
|
||||
(loop)))))))]
|
||||
[consumer (proc->signal
|
||||
|
|
@ -380,8 +381,9 @@
|
|||
[last-time (current-milliseconds)]
|
||||
[last-val (value-now b)]
|
||||
[last-alarm 0]
|
||||
[dummy 0]
|
||||
[producer (proc->signal (lambda ()
|
||||
consumer ;; just to prevent GC
|
||||
(set! dummy consumer) ;; just to prevent GC
|
||||
accum))]
|
||||
[consumer (proc->signal void b ms-b)])
|
||||
(set-signal-thunk!
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user