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

a little house-cleaning

Browse Source 
* remove some commented-out code & lame old code 
* move GUI code out of demos/ subdirectory

svn: r9633
This commit is contained in:
Greg Cooper 2008-05-03 19:26:58 +00:00
parent 1880f23d65
commit f512e79edf
26 changed files with 9 additions and 2321 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
collects/frtime/demos/calculator.ss
View File

@ -1,21 +0,0 @@
(require frtime/gui)
(define op-names (list "+" "-" "*" "/"))
(define ops (list + - * /))
(define (str->num s)
(cond
[(string->number s)]
[#t 0]))
(define x
(str->num (make-text "First number:")))
(define op
(make-choice "Op:" op-names))
(define y
(str->num (make-text "Second number:")))
(make-message
(format "Result = ~a" ((list-ref ops op) x y)))

23
collects/frtime/demos/circles.ss
View File

@ -1,23 +0,0 @@
(require frtime/animation
frtime/etc
frtime/gui)
(define radius (make-slider "Radius" 100 200 150))
(define speed (* .02 (make-slider "Speed" 0 10 5)))
(define n (make-slider "Num circles" 1 10 6))
(define ratio (add1 (* .2 (make-slider "Ratio" 1 5 2))))
(define phase (wave speed))
(define center (make-posn 200 200))
(display-shapes
(build-list
n
(lambda (i)
(make-ring
(posn+ center
(posn*
(make-posn (cos phase) (sin phase))
(* radius (- 1 (expt ratio (- i))))))
(/ radius (expt ratio i))
"gray"))))

24
collects/frtime/demos/pizza.ss
View File

@ -1,24 +0,0 @@
(require frtime/gui)
(define kinds (list "New York" "Chicago" "California" "Hawaii"))
(define sizes (list "small" "medium" "large" "Texas"))
(define customer
(make-text "Customer name:"))
(define kind
(make-choice "Kind:" kinds))
(define size
(make-choice "Size:" sizes))
(define button-event
(make-button "Confirm"))
(make-message
(hold (button-event
. -=> .
(snapshot (customer kind size)
(string-append customer " ordered a "
(list-ref sizes size) " "
(list-ref kinds kind) " pizza.")))))

72
collects/frtime/demos/spreadsheet/data-synthesis.ss
View File

@ -1,72 +0,0 @@
(module data-synthesis frtime/frtime
(require "distributions.ss"
mzlib/math
)
;; num list -> num
; INPUT: Many numbers DATA
; OUTPUT: That DATA's sample mean (a.k.a mean, average)
(define (sample-mean data)
(let ([n (length data)]
[sum-y (apply + data)])
(/ sum-y n)))
;;num list -> num
; INPUT: List of numbers DATA
; OUTPUT: The sample variance of DATA
(define (sample-variance data)
(let* ([n (length data)]
[sm (sample-mean data)]
[d2 (map (lambda (x)
(sqr (- x sm)))
data)])
(/ (apply + d2)
(- n 1))))
;; NOTE:
;; The sample-mean and sample-variance of set of data are unbiased
;; and efficient estimators of the mean and variance of the probability
;; distribution that produced that data. Therefore, our best fitting
;; normal distribution to that data is a normal distribution having
;; mean equal to the sample mean and variance equal to the sample-variance.
(define (fit-normal-distribution data)
(make-normal-distribution (sample-mean data)
(sqrt (sample-variance data))))
(define (fit-uniform-distribution data)
(let ([mean (sample-mean data)]
[variance (sample-variance data)])
; (print (format "theta1: ~a" (- mean
; (sqrt (* 3 variance)))))
; (print (format "theta2: ~a" (+ mean
; (sqrt (* 3 variance)))))
(make-uniform-distribution (- mean
(sqrt (* 3 variance)))
(+ mean
(sqrt (* 3 variance))))))
; My Gamma work is screwy. See distributions.ss
;(define (fit-gamma-distribution data)
; (let ([mean (sample-mean data)]
; [variance (sample-variance data)])
; (make-gamma-distribution (/ (sqr mean)
; variance)
; (/ variance mean))))
(define (fit-exponential-distribution data)
(make-exponential-distribution (sample-mean data)))
(define (synthesize-random-data dist size)
(if (zero? size)
'()
(cons ((distribution-rand dist))
(synthesize-random-data dist (sub1 size)))))
(provide (all-defined))
)

1
collects/frtime/demos/spreadsheet/demos.sheet
View File

File diff suppressed because one or more lines are too long

433
collects/frtime/demos/spreadsheet/distributions.ss
View File

@ -1,433 +0,0 @@
(module distributions mzscheme
(require mzlib/math
)
(define RANDOM-GRAIN (sub1 (expt 2 31)))
;; A distribution has a:
;; bool continuous? : Is this distribution continuous? (#t if yes, #f if discrete)
;; (num -> num) density-f : Probability density function f(y)= p(y)
;; num mean : mean of distribution
;; num variance : variance of distribution
;; I need to think about this next one:
;; (num -> num)? mgf : moment generating function. Forgive the acronym.
(define-struct distribution (continuous?
d-func
mean
variance
rand
))
(define (print-distribution dist)
(print (format "continuous?: ~a, mean: ~a, variance: ~a"
(distribution-continuous? dist)
(distribution-mean dist)
(distribution-variance dist))))
(define (ln n)
(/ (log n)
(log e)))
(define fac
(lambda (n)
(if (zero? n)
1
(* n (fac (- n 1))))))
(define choose
(lambda (a b)
(/ (fac a)
(* (fac b)
(fac (- a b))))))
(define myround
(lambda (n)
(- n
(- n (round n)))))
;; Ultimately, mgf might be a struct, with make-uniform-mgf, make-normal-mgf, etc.
;; be special constructors for that particular struct. For now, I'll leave
;; this as the actual formula
(define (make-uniform-mgf theta1 theta2)
(lambda (t)
(/ (- (exp (* t theta2))
(exp (* t theta1)))
(* t
(- theta2 theta1)))))
(define (make-normal-mgf mu sigma)
(lambda (t)
(exp (+ (* mu t)
(/ (* (sqr t) (sqr sigma))
2)))))
;;Do I need these? Dammit!
(define (make-exponential-mgf bete)
'dummy)
(define (make-binomial-mgf n p)
'dummy)
(define (make-uniform-distribution theta1 theta2)
(make-distribution #t
(lambda (y)
;;is it appropriate to limit the domains of the
;; probability functions with conditionals like
;; this?
(if (or (< y theta1)
(< theta2 y))
0
(/ (- theta2 theta1))))
(/ (+ theta1 theta2)
2)
(/ (sqr (- theta2 theta1))
12)
(lambda ()
(uniform-random theta1 theta2))
))
(define (make-normal-distribution mu sigma)
(make-distribution #t
(lambda (y)
(* (/ (* sigma (sqrt (* 2 pi))))
(exp (- (* (/ (* 2 (sqr sigma)))
(sqr (- y mu)))))))
mu
(sqr sigma)
(lambda ()
(normal-random mu sigma))
))
(define (make-exponential-distribution beta)
;;Can I asser here that beta > 0??
(make-distribution #t
(lambda (y)
(if (< 0 y)
(* (/ beta)
(exp (/ (- y)
beta)))
0))
beta
(sqr beta)
(lambda ()
(exponential-random beta))
))
;; FUCK! The Gamma function is a big integral, equal to factorial if the
;; argument is an integer, but otherwise...crap on a stick!
; (define (make-gamma-distribution alpha beta)
; (make-distribution #t
; (lambda (y)
(define (make-binomial-distribution n p)
(make-distribution #f
(lambda (y)
;;should assert whole-number-ness here or something
(* (choose n y)
(expt p y)
(expt (- 1 p)
(- n y))))
(* n p)
(* n p (- 1 p))
(lambda ()
(binomial-random n p))
))
;
; (define (make-gamma-distribution alpha beta)
; (make-distribution #f
; (lambda (y)
; (if (<= y 0)
; 0
; (* (expt y (sub1 alpha))
; (exp (/ (- y) beta))
; (/ (* (exp (gammln alpha))
; (expt beta alpha))))))
; (* alpha beta)
; (* alpha beta beta)
; (lambda ()
; (gamma-random alpha beta))))
(define (uniform-random theta1 theta2)
(+ theta1 (* (/ (- theta2 theta1) (sub1 RANDOM-GRAIN)) (random RANDOM-GRAIN))))
(define (open-uniform-random theta1 theta2)
(+ theta1 (* (/ (- theta2 theta1) RANDOM-GRAIN) (add1 (random (sub1 RANDOM-GRAIN))))))
;; Although it might be the root of all evil, and make no sense in this context,
;; I'm going to use the Marsaglia Polar Method here with the flip-flopping
;; indicator switch because it's HOT.
(define r 0)
(define ind 1)
(define (ranf)
(open-uniform-random 0 1))
(define (standard-normal-random-guts)
(let* ([x1 (- (* 2 (ranf)) 1)]
[x2 (- (* 2 (ranf)) 1)]
[w (+ (* x1 x1) (* x2 x2))])
(if (> w 1)
(standard-normal-random-guts)
(let ([w2 (sqrt (/ (* (ln w) -2) w))])
(set! r (* x2 w2))
(* x1 w2)))))
(define (standard-normal-random)
(set! ind (- ind))
(if (> ind 0)
(standard-normal-random-guts)
r))
(define (normal-random mu sigma)
(+ (* sigma (standard-normal-random)) mu))
(define (exponential-random beta)
(let ([rand (/ (add1 (random (sub1 RANDOM-GRAIN))) RANDOM-GRAIN)])
(* (- (ln rand)) beta)))
;(define (testrand args make-dist rand target n m)
; (/ (let loopa ([t 0])
; (if (> t target)
; 0
; (+ (let loop ([i m])
; (if (> 0 i)
; 0
; (+ (if (= (apply rand
; (cons n
; args))
; t)
; 1
; 0)
; (loop (sub1 i)))))
;(loopa (add1 t)))))
;((distribution-density-f (apply make-dist args)) target)
;))
;;;pronlems if alpha is a non-integer
;(define (standard-gamma-random-guts alpha)
; (let ([v1 (ranf RANDOM-GRAIN)]
; [v2 (- (* 2 (ranf RANDOM-GRAIN)) 1)])
; (if (> (+ (* v1 v1) (* v2 v2)) 1)
; (standard-gamma-random-guts alpha)
; (let*
; ([y (/ v2 v1)]
; [am (- alpha 1)]
; [s (sqrt (+ (* 2 am) 1))]
; [x (+ (* s y) am)])
; (if (<= x 0)
; (standard-gamma-random-guts alpha)
; (if (> (ranf)
; (* (+ 1 (* y y))
; (exp (- (* am
; (ln (/ x am)))
; (* s y)))))
; (standard-gamma-random-guts alpha)
; x))))))
;
;;;problems if alpha is a non-integer, I think
;(define (standard-gamma-random alpha)
; (cond [(< alpha 1) (error "Bad alpha value for standard-gamma-random")]
; [(< alpha 6) (let loop ([x 1] [i 0])
; (if (> i alpha)
; (- (ln x))
; (loop (* x (ranf)) (add1 i))))] ; the random number here
; ; might have to be over the
; ; whole number line.
; [else (standard-gamma-random-guts alpha)]))
;
;
;;;problems if alpha is a non-integer
;(define (gamma-random alpha beta)
; (* beta (standard-gamma-random alpha)))
;; PROBLEMS with GAMMA RANDOM:
;; (1) The random gamma number generator should only take positive integers as
;; argument according to the spec in Numerical Recipes. However, according to
;; Mathematical Statistics and Applications, the alpha parameter of a gamma function
;; may not always be an integer.
;; (2) Using the code for the random number generator above seems to produce data with mean of
;; ((alpha + 1) * beta), and variance of ((alpha + 1) * beta ^ 2). I don't know what
;; is wrong with the code, but I hesitated to just throwing in something subtracting 1 from
;; alpha before running calculations because that seems unsound.
(define (gammln xx)
;Returns the value ln[(xx)] for xx > 0.
(let* ([ser 1.000000000190015]
[cof1 76.18009172947146]
[cof2 -86.50532032941677]
[cof3 24.01409824083091]
[cof4 -1.231739572450155]
[cof5 0.001208650973866179]
[cof6 -0.000005395239384953]
[x xx]
[y xx]
[tmp (- (+ x 5.5)
(* (+ x 0.5)
(ln (+ x 5.5))))]
[ser2 (+ ser
(/ cof1 (+ y 1))
(/ cof2 (+ y 2))
(/ cof3 (+ y 3))
(/ cof4 (+ y 4))
(/ cof5 (+ y 5))
(/ cof6 (+ y 6)))])
(+ (- tmp)
(ln (* 2.5066282746310005
(/ ser2
x))))))
;;more sketchy mutative stuff recommended by Numerical Recipes to optimize this craziness.
(define pg 0)
(define poldm -1.0)
(define psq -1)
(define palxm -1)
(define (poisson-random xm)
(if (> 12 xm)
(begin
(unless (= xm poldm)
(set! poldm xm)
(set! pg (exp (- xm))))
(let loop ([em 0] [t (ranf)])
(if (> t pg)
(loop (add1 em) (* t (ranf)))
em)))
(begin
(unless (= xm poldm)
(set! poldm xm)
(set! psq (sqrt (* 2.0 xm)))
(set! palxm (ln xm))
(set! pg (- (* xm palxm) (gammln (+ xm 1)))))
(poisson-random-guts xm))))
(define (poisson-random-guts xm)
(let loop ([y (tan (* (ranf) pi))])
(let ([em (+ (* psq y)
xm)])
(if (< em 0)
(loop (tan (* (ranf) pi)))
(let* ([fem (floor em)]
[t (* 0.9
(+ 1.0 (* y y))
(exp (- (* fem palxm)
(gammln (+ fem 1))
pg)))])
(if (> (ranf) t)
(loop (tan (* pi (ranf))))
fem))))))
;;These are mutating variables that are meant to store computed values to speed up sampling
(define bnold -1)
(define bpold -1)
(define boldg -1)
(define (binomial-random n pp)
;Returns as a floating-point number an integer value that is a random deviate drawn from
;a binomial distribution of n trials each of probability pp, using ran1(idum) as a source of
;uniform random deviates.
(let* ([p (if (<= pp 0.5)
pp
(- 1 pp))]
[am (* n p)])
(if (< n 25)
(let loop ([bnl 0] [j 1])
(if (<= n j)
(if (= p pp)
bnl
(- n bnl))
(if (< (ranf) p)
(loop (add1 bnl) (add1 j))
(loop bnl (add1 j)))))
(if (< am 1)
(let ([g (exp (- am))])
(let loop ([t 1] [j 0])
(if (not (<= j n))
(if (= p pp)
n
0)
(let ([t2 (* t (ranf))])
(if (< t g)
(if (< t g)
(if (= p pp)
j
(- n j))
(loop t2 (add1 j))))))))
(begin
(unless (= n bnold)
(set! boldg (gammln (+ n 1)))
(set! bnold n))
(let* ([en n]
[pc (- 1 p)]
[plog (ln p)] ; If sampling is too slow
[pclog (ln pc)] ; I can gain speed by storing some of these
[sq (sqrt (* 2 am pc))] ; in mutating, out of function variables
)
(let loop ([angle (* pi (ranf))])
(let* ([y (tan angle)]
[em (+ (* sq y) am)])
(if (or (< em 0) (>= em (+ en 1)))
(loop (* pi (ranf)))
(let ([fem (floor em)]
[t (* 1.2
sq
(+ (* y y) 1)
(exp (+ boldg
(- (gammln (+ em 1)))
(- (gammln (+ en (- em) 1)))
(* em plog)
(* (- en em) pclog))))])
(if (> (ranf) t)
(loop (* pi (ranf)))
(if (= p pp)
em
(- n em)))))))))))))
(provide (all-defined))
)
;(let loop ([x (round (binomial-random 100000 10 .4))])
; (loop (round (binomial-random 100000 10 .4))))
;(define (accumulate-mean sampler-event)
; (collect-e sampler-event
; (cons 777777 0) ;;;The number 7777777 never gets used
; (lambda (datum mean-count)
; (let ([new-count (add1 (cdr mean-count))])
; (cons (+ (/ datum new-count)
; (* (/ (cdr mean-count)
; new-count)
; (car mean-count)))
; new-count)))))
;(accumulate-mean ((changes milliseconds) . ==> . (lambda (_) (normal-random 1000000 5 30))))

32
collects/frtime/demos/spreadsheet/doc.txt
View File

@ -1,32 +0,0 @@
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.
- Does not work on MacOS

553
collects/frtime/demos/spreadsheet/preprocessor2.ss
View File

@ -1,553 +0,0 @@
(module preprocessor2 mzscheme
(require mzlib/string
mzlib/etc
)
(define (drop l n)
(if (zero? n)
l
(drop (cdr l) (sub1 n))))
(define (caddddr lst)
(car (cdr (cdr (cdr (cdr lst))))))
(define (first lst)
(car lst))
(define (take l n)
(if (zero? n)
'()
(cons (car l)
(take (cdr l)
(sub1 n)))))
;; ('a -> bool) * 'a list -> (#f or num)
(define position-of-first-satisfied-in-list
(lambda (pred l)
(let loop ((i 0) (l l))
(if (null? l) #f
(if (pred (car l)) i
(loop (+ i 1) (cdr l)))))))
(define position-of-object-in-list
(lambda (o l)
(position-of-first-satisfied-in-list (lambda (x)
(eqv? o x))
l)))
(define capitals
'(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z))
(define lower-case
(let loop ([i 97])
(if (<= i 122)
(cons (integer->char i)
(loop (add1 i)))
'())))
(define digits
'(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0))
(define (contains? i lst)
(and (not (null? lst))
(or (equal? i (car lst))
(contains? i (cdr lst)))))
(define (capital? char)
(contains? char capitals))
(define (lower-case? char)
(contains? char lower-case))
(define (digit? char)
(contains? char digits))
(define (letter? char)
(or (capital? char)
(lower-case? char)))
(define-struct cell-reference (row1 ; num
row2 ; num
row-absolute? ; bool
col1 ; num
col2 ; num
col-absolute? ; bool
))
(define (capital->col-num char)
(- (char->integer char)
65))
(define (lower-case->col-num char)
(- (char->integer char)
97))
#;(define (letter->col-num char)
(if (capital? char)
(capital->row-num char)
(lower-case->row-num char)))
(define (digit->row-num char)
(- (char->integer char)
48))
#;(define (letter-list->col-num llst)
(let loop ([num -1]
[lst llst])
(cond [(null? lst)
num]
[(capital? (car lst))
(loop (+ (* (add1 num) 26)
(capital->row-num (car lst)))
(cdr lst))]
[(lower-case? (car lst))
(loop (+ (* (add1 num) 26)
(lower-case->col-num (car lst)))
(cdr lst))])))
(define (digit-list->row-num nlist)
(let loop ([num 0]
[lst nlist])
(cond [(null? lst)
num]
[(digit? (car lst))
(loop (+ (* num 10)
(digit->row-num (car lst)))
(cdr lst))])))
(define NOT-A-CELL-REFERENCE #f)
;; char list -> cell-reference
(define (parse-ref char-list)
(let loop ([lst char-list]
[reading-col-section #t]
[row1 #f]
[row2 #f]
[row-absolute? #f]
[col1 #f]
[col2 #f]
[col-absolute? #f])
(cond [(null? lst)
(if (and row1 row2 col1 col2 (not reading-col-section))
(make-cell-reference row1 row2 row-absolute? col1 col2 col-absolute?)
NOT-A-CELL-REFERENCE)]
[reading-col-section
(cond [(equal? (car lst)
#\$)
(if (or col1 col-absolute?) ;; then already hit first $, so this must refer to numbers
(loop lst #f row1 row2 row-absolute? col1 col2 col-absolute?)
(loop (cdr lst)
#t
row1 row2 row-absolute?
col1 col2
#t))]
[(letter? (car lst))
(let ([next (position-of-first-satisfied-in-list
(lambda (o)
(or (equal? o #\$)
(equal? o #\:)
(digit? o)))
lst)])
(if col1
(if next
(if (equal? 'invalid
(letter-list->col-num (take lst
next)))
NOT-A-CELL-REFERENCE
(loop (drop lst next)
#t ; should get switched in next iteration
row1 row2 row-absolute?
col1
(letter-list->col-num (take lst
next))
col-absolute?))
NOT-A-CELL-REFERENCE
)
(if next
(if (equal? 'invalid
(letter-list->col-num (take lst
next)))
NOT-A-CELL-REFERENCE
(loop (drop lst
next)
#t
row1 row2 row-absolute?
(letter-list->col-num (take lst
next))
(letter-list->col-num (take lst next))
col-absolute?))
NOT-A-CELL-REFERENCE
)))]
[(equal? (car lst) #\:)
(if col1
(loop (cdr lst) #t row1 row2 row-absolute? col1 col2 col-absolute?)
NOT-A-CELL-REFERENCE)]
[(digit? (car lst))
(loop lst #f row1 row2 row-absolute? col1 col2 col-absolute?)]
[else NOT-A-CELL-REFERENCE])]
[else ; reading NUMBER/ROW section section
(cond [(equal? (car lst)
#\$)
(loop (cdr lst) #f row1 row2 #t col1 col2 col-absolute? ;!!
)]
[(digit? (car lst))
(let ([next (position-of-first-satisfied-in-list
(lambda (o)
(not (digit? o)))
lst)])
(if row1
(if next
NOT-A-CELL-REFERENCE
(loop '()
#f
row1
(digit-list->row-num lst)
row-absolute?
col1 col2 col-absolute?))
(if next
(loop (drop lst next)
#f
(digit-list->row-num (take lst next))
(digit-list->row-num (take lst next))
row-absolute?
col1 col2 col-absolute?)
(loop '()
#f
(digit-list->row-num lst)
(digit-list->row-num lst)
row-absolute?
col1 col2 col-absolute?))))]
[(equal? (car lst)
#\:)
(loop (cdr lst) #t
row1 row2 row-absolute?
col1 col2 col-absolute?)]
[else
NOT-A-CELL-REFERENCE])])))
;
;(define pt1 '(#\a #\b #\1 #\2))
;(define pt1- (make-cell-reference 12 12 #f 27 27 #f))
;(define pt2 '(#\$ #\a #\b #\4))
;(define pt2- (make-cell-reference 4 4 #f 27 27 #t))
;(define pt3 '(#\a #\$ #\4))
;(define pt3- (make-cell-reference 4 4 #t 0 0 #f))
;(define pt4 '(#\a #\: #\e #\5))
;(define pt4- (make-cell-reference 5 5 #f 0 4 #f))
;(define pt5 '(#\z #\1 #\: #\8))
;(define pt5- (make-cell-reference 1 8 #f 25 25 #f))
;(define pt6 '(#\$ #\a #\: #\d #\1))
;(define pt6- (make-cell-reference 1 1 #f 0 3 #t))
;(define pt7 '(#\$ #\a #\$ #\0))
;(define pt7- (make-cell-reference 0 0 #t 0 0 #t))
;
;(define (equal-cell-refs? c1 c2)
; (and (equal? (cell-reference-row1 c1)
; (cell-reference-row1 c2))
; (equal? (cell-reference-row2 c1)
; (cell-reference-row2 c2))
; (equal? (cell-reference-row-absolute? c1)
; (cell-reference-row-absolute? c2))
; (equal? (cell-reference-col1 c1)
; (cell-reference-col1 c2))
; (equal? (cell-reference-col2 c1)
; (cell-reference-col2 c2))
; (equal? (cell-reference-col-absolute? c1)
; (cell-reference-col-absolute? c2))))
;
;(equal-cell-refs? (parse-ref pt1) pt1-)
;(equal-cell-refs? (parse-ref pt2) pt2-)
;(equal-cell-refs? (parse-ref pt3) pt3-)
;(equal-cell-refs? (parse-ref pt4) pt4-)
;(equal-cell-refs? (parse-ref pt5) pt5-)
;(equal-cell-refs? (parse-ref pt6) pt6-)
;(equal-cell-refs? (parse-ref pt7) pt7-)
(define mapped-symbols
'(+
length
=
if
quote
*
seconds
add1
map))
;process: sexp symbol symbol symbol symbol num num -> sexp
;INPUT: An expression EXPR, the name of lookup procedures LOOKUP, LOOKUP-ROW, LOOKUP-COL, LOOKUP-MATRIX and the current row and column
; for the cell being processed, ROW and COL.
;OUTPUT: blah blah blah
(define (process expr lookup lookup-row lookup-col lookup-matrix row col)
(define (cell-ref->sexp cref c-row c-col)
;; cell-reference * num * num -> sexp
(let ([ref-row1 (cell-reference-row1 cref)]
[ref-col1 (cell-reference-col1 cref)]
[ref-row2 (cell-reference-row2 cref)]
[ref-col2 (cell-reference-col2 cref)]
[row-ref-expr (lambda (n)
(if (cell-reference-row-absolute? cref)
n
(list '+ 'row (- n c-row))))]
[col-ref-expr (lambda (n)
(if (cell-reference-col-absolute? cref)
n
(list '+ 'col (- n c-col))))])
(if (not (= ref-row1 ref-row2))
(if (not (= ref-col1 ref-col2))
(list lookup-matrix
(row-ref-expr ref-row1)
(row-ref-expr ref-row2)
(col-ref-expr ref-col1)
(col-ref-expr ref-col2))
(list lookup-col
(row-ref-expr ref-row1)
(row-ref-expr ref-row2)
(col-ref-expr ref-col1)))
(if (not (= ref-col1 ref-col2))
(list lookup-row
(row-ref-expr ref-row1)
(col-ref-expr ref-col1)
(col-ref-expr ref-col2))
(list lookup
(row-ref-expr ref-row1)
(col-ref-expr ref-col1))))))
;; end of cell reference handling
(cond [(symbol? expr)
(let ([parsed (parse-ref (string->list (symbol->string expr)))])
(cond [parsed (cell-ref->sexp parsed row col)]
[else ;; currently allowing all symbols.
expr]))]
[(list? expr)
(if (and (not (null? expr))
(equal? 'quote (car expr)))
expr
(map (lambda (sexp)
(process sexp lookup lookup-row lookup-col lookup-matrix row col))
expr))]
[else expr]))
;(define t1 "a:zz$1")
;(define t2 "length")
;(define t3 "(+ 3 4)")
;(define t4 "(+ 2 a3)")
;(define t5 "(if (= 3 (length A1)) (a2 $A3) 'dont-see)")
;(define t6 "(ZD941 A:d3:40)")
;
;(define p (lambda (e)
; (process (read (open-input-string e)) 'lookup 'lookup-row 'lookup-col 'lookup-matrix 1 1)))
;t1 (p t1)
;t2 (p t2)
;t3 (p t3)
;t4 (p t4)
;t5 (p t5)
;t6 (p t6)
;; ISSUES:
;; - When going from cell-references to symbols, be careful about LETTERS referring to COLUMNS
;; and NUMBERS referring to ROWS. Some procedures are still BROKEN because of this.
;;
;; - Now a lookup expression has more information about what sort of region it is looking up
;; (singleton, row, column, matrix). Use this when converting from lookup expressions to
;; cell references.
;;
;; - Now that lookup expressions contain all the information contained within cell references,
;; the intermediate step between expressions and cell references is UNNECESSARY. I should
;; have procedure's LOOKUP-EXPR->SYMBOL that take care of everything for the UNPROCESSOR.
;;
(define (letter-list->col-num llst)
(let ([col-num (let loop ([num -1]
[lst llst])
(cond [(null? lst)
num]
[(capital? (car lst))
(loop (+ (* (add1 num) 26)
(capital->col-num (car lst)))
(cdr lst))]
[(lower-case? (car lst))
(loop (+ (* (add1 num) 26)
(lower-case->col-num (car lst)))
(cdr lst))]))])
(if (>= col-num 702)
'invalid
col-num)))
; num -> char list
(define (col-num->letter-list n)
(let loop ([num n]
[lst '()])
(cond [(= -1 num)
lst]
[else (loop (sub1 (quotient num 26))
(cons (integer->char (+ 97 (remainder num 26)))
lst))])))
; num -> char list
(define (row-num->digit-list n)
(define help
(lambda (n)
(let ([r (remainder n 10)]
[q (quotient n 10)])
(if (zero? q)
(list (integer->char (+ 48 n)))
(cons (integer->char (+ 48 r))
(help q))))))
(reverse (help n)))
(define (lookup-expr->symbol expr local-row local-col)
(let* ([row-expr (cadr expr)]
[col-expr (caddr expr)]
[row-chars (cond [(number? row-expr)
(cons #\$
(row-num->digit-list row-expr))]
[(list? row-expr)
(row-num->digit-list (+ local-row
(caddr row-expr)))])]
[col-chars (cond [(number? col-expr)
(cons #\$
(col-num->letter-list col-expr))]
[(list? col-expr)
(col-num->letter-list (+ local-col
(caddr col-expr)))])])
(string->symbol (list->string (append col-chars
row-chars)))))
(define (lookup-row-expr->symbol expr local-row local-col)
(let* ([row-expr (cadr expr)]
[col1-expr (caddr expr)]
[col2-expr (cadddr expr)]
[row-chars (cond [(number? row-expr)
(cons #\$
(row-num->digit-list row-expr))]
[(list? row-expr)
(row-num->digit-list (+ local-row
(caddr row-expr)))])]
[col1-chars (cond [(number? col1-expr)
(cons #\$
(col-num->letter-list col1-expr))]
[(list? col1-expr)
(col-num->letter-list (+ local-col
(caddr col1-expr)))])]
[col2-chars (cons #\:
(cond [(number? col2-expr)
(col-num->letter-list col2-expr)]
[(list? col2-expr)
(col-num->letter-list (+ local-col
(caddr col2-expr)))]))])
(string->symbol (list->string (append col1-chars
col2-chars
row-chars)))))
(define (lookup-col-expr->symbol expr local-row local-col)
(let* ([row1-expr (cadr expr)]
[row2-expr (caddr expr)]
[col-expr (cadddr expr)]
[row1-chars (cond [(number? row1-expr)
(cons #\$
(row-num->digit-list row1-expr))]
[(list? row1-expr)
(row-num->digit-list (+ local-row
(caddr row1-expr)))])]
[row2-chars (cons #\:
(cond [(number? row2-expr)
(row-num->digit-list row2-expr)]
[(list? row2-expr)
(row-num->digit-list (+ local-row
(caddr row2-expr)))]))]
[col-chars (cond [(number? col-expr)
(cons #\$
(col-num->letter-list col-expr))]
[(list? col-expr)
(col-num->letter-list (+ local-col
(caddr col-expr)))])])
(string->symbol (list->string (append col-chars
row1-chars
row2-chars)))))
(define (lookup-matrix-expr->symbol expr local-row local-col)
(let* ([row1-expr (cadr expr)]
[row2-expr (caddr expr)]
[col1-expr (cadddr expr)]
[col2-expr (caddddr expr)]
[row1-chars (cond [(number? row1-expr)
(cons #\$
(row-num->digit-list row1-expr))]
[(list? row1-expr)
(row-num->digit-list (+ local-row
(caddr row1-expr)))])]
[row2-chars (cons #\:
(cond [(number? row2-expr)
(row-num->digit-list row2-expr)]
[(list? row2-expr)
(row-num->digit-list (+ local-row
(caddr row2-expr)))]))]
[col1-chars (cond [(number? col1-expr)
(cons #\$
(col-num->letter-list col1-expr))]
[(list? col1-expr)
(col-num->letter-list (+ local-col
(caddr col1-expr)))])]
[col2-chars (cons #\:
(cond [(number? col2-expr)
(col-num->letter-list col2-expr)]
[(list? col2-expr)
(col-num->letter-list (+ local-col
(caddr col2-expr)))]))])
(string->symbol (list->string (append col1-chars
col2-chars
row1-chars
row2-chars)))))
; sexp * symbol * symbol *symbol *symbol num * num -> sexp
(define (unprocess expr lookup lookup-row lookup-col lookup-matrix local-row local-col)
(cond [(list? expr)
(cond [(null? expr)
'()]
[(equal? (first expr) lookup)
(lookup-expr->symbol expr local-row local-col)]
[(equal? (first expr) lookup-row)
(lookup-row-expr->symbol expr local-row local-col)]
[(equal? (first expr) lookup-col)
(lookup-col-expr->symbol expr local-row local-col)]
[(equal? (first expr) lookup-matrix)
(lookup-matrix-expr->symbol expr local-row local-col)]
[(equal? (first expr) 'quote)
expr]
[else
(map (lambda (e)
(unprocess e lookup lookup-row lookup-col
lookup-matrix local-row local-col))
expr)])]
[else
expr]))
;
;(define te1
; '((lookup 3 4)
; '(lookup 3 4)
; (1 2 (lookup 0 0))
; (lookup-matrix (+ row 0) (+ row 5) (+ col 2) (+ col 5))
; (lookup-row 5 (+ col 1) (+ col 20))
; (lookup-col 3 39 (+ col 0))))
;
;(unprocess te1
; 'lookup
; 'lookup-row
; 'lookup-col
; 'lookup-matrix
; 1
; 1)
(provide process unprocess)
)

75
collects/frtime/demos/spreadsheet/quotes.ss
View File

@ -1,75 +0,0 @@
(module quotes mzscheme
(require net/url)
(require mzlib/list)
(provide no-quote? stock-quote no-quote-reason)
(define-struct no-quote (company reason))
#| ----------------------------------------------------------------------------
Stock and Fund Quotes
---------------------
procedures:
stock-quote : String -> Number
exceptions:
no-quote : (structure:no-quote String Symbol)
The goal is to send a request to some quote server,
read the page line by line, and identify the quote.
-----------------------------------------------------
First: where the information comes from and
how to indentify it within the page:
- the current source is Yahoo's page
- we look for a table cell that looks like
this: <td nowrap><b>DIGIT*.DIGITDIGIT</b></td>
|#
; String[format: String[company name]]
(define SOURCE "http://finance.yahoo.com/q?s=~a&d=v1")
; String -> (union (list String String) #f)
(define (find x)
(regexp-match "<b>([0-9\\.]*)</b></big></td>" x))
; String -> Number
(define (stock-quote company)
(let* ([URL (string->url (format SOURCE company))]
[PG (call/input-url URL get-pure-port read-a-page)]
; [_ (printf "~s~n" PG)] ; for debugging
[LN (filter find PG)]
[QT (if (pair? LN)
(cadr (find (car LN)))
(raise (make-no-quote company 'find)))])
(cond
[(string->number QT)]
[else (raise (make-no-quote company 'no-number))])))
;; Iport -> (listof String)
;; reading a page as a list of lines
(define (read-a-page ip)
(letrec ([reader (lambda ()
(let ([next (read-line)])
(cond
[(eof-object? next) '()]
[else (cons next (reader))])))])
(parameterize ([current-input-port ip])
(reader))))
#| TESTS:
(map stock-quote '(; companies
"BAC" "DELL" "IBM"
; funds
"PRSCX" "NAESX" "FRBAX"))
(with-handlers ([no-quote? (lambda (x) (eq? (no-quote-reason x) 'find))])
(stock-quote "XXX"))
|#
)

636
collects/frtime/demos/spreadsheet/spread.ss
View File

@ -1,636 +0,0 @@
(module spread frtime/frtime-big
(require mzlib/class
(all-except mred send-event)
(rename mzscheme mz:define-struct define-struct)
"preprocessor2.ss"
(lifted "ss-funcs.ss" inflate-data)
"quotes.ss"
(as-is:unchecked mzlib/match match-lambda)
(as-is:unchecked frtime/frp-core signal-value
proc->signal)
framework
(as-is:unchecked mzlib/string expr->string)
(as-is:unchecked mzlib/etc build-vector)
;(lifted mzscheme regexp-match)
(as-is:unchecked mzscheme make-hash-table hash-table-put! hash-table-get
hash-table-remove! let*-values vector-set! make-string
exn?
open-input-file open-output-file read write hash-table-map
file-exists? delete-file open-input-string eof
flush-output close-output-port dynamic-require))
;;
;; TO DO:
;;
;; rewrite cleanly
;; case-insensitive and relative identifier expansion with ranges
;; select multiple cells
;; fill row or column
;; copy and paste formula
;; disable text field when selection empty
;; allow resizing of columns
;; KNOWN BUGS:
;; when loading file, expression text field does not update
(define stock-price
(opt-lambda (name-string [seconds-between 1200])
(lift-strict (lambda (name _) (stock-quote name)) name-string (quotient seconds seconds-between))))
(define-syntax for
(syntax-rules (=)
[(_ (var = init) condn delta proc ...)
(let loop ([var init])
(when condn
proc ...
(loop (delta var))))]))
(set-cell! raise-exceptions #t)
(mz:define-struct ss-loc (row col))
(define (ss-format val)
(if (or (and (signal? val)
(undefined? (signal-value val)))
(and (not (signal? val))
(undefined? val)))
""
(format "~a" (signal-value val))))
(define (@e r c)
(ss-get-cell-value/force r c))
(define (@c r0 r1 c)
(build-list (add1 (abs (- r1 r0)))
(lambda (i)
(@e (+ i (min r1 r0)) c))))
(define (@r r c0 c1)
(build-list (add1 (abs (- c1 c0)))
(lambda (i)
(@e r (+ i (min c1 c0))))))
(define (@m r0 r1 c0 c1)
(build-list (add1 (abs (- c1 c0)))
(lambda (i)
(@c r0 r1 (+ i (min c1 c0))))))
(define frame
(instantiate frame% ("Spreadsheet") (width 600) (height 400)))
(define menu-bar
(instantiate menu-bar% (frame)))
(define file-menu
(instantiate menu% ("File" menu-bar)))
(define open-item
(instantiate menu-item%
("Open..."
file-menu
(lambda (_ event)
(cond
[(finder:get-file)
=>
(lambda (filename)
(let ([p (open-input-file filename)])
(for (i = 0) (< i cols) add1
(vector-set! vec i (make-hash-table))
(for-each (lambda (elt) #;(printf "adding ~a ~a ~a~n" (first elt) i (second elt))
(ss-set-cell-processed-expr! (first elt) i (process (second elt) '@e '@r '@c '@m (first elt) i))) (read p))))
(send canvas refresh))])))
(shortcut #\O)))
(define save-item
(instantiate menu-item%
("Save as..."
file-menu
(lambda (_ event)
(cond
[(finder:put-file)
=>
(lambda (filename)
(when (file-exists? filename)
(delete-file filename))
(let ([p (open-output-file filename)])
(for (i = 0) (i . < . cols) add1
(let ([v (hash-table-map (vector-ref vec i) (lambda (row cell) (list row (ss-cell-expr cell))))])
#;(printf "~a~n" v)
(write v p)))
(flush-output p)
(close-output-port p)))])))
(shortcut #\S)))
(define edit-menu
(instantiate menu% ("Edit" menu-bar)))
(define text-field
(instantiate text-field%
("Formula:"
frame
(lambda (this control-event)
(case (send control-event get-event-type)
[(text-field-enter) (send canvas new-expression (send this get-value))])))))
(define value-field
(instantiate text-field%
("Value:" frame void)))
(send value-field enable #f)
(define rows 1000)
(define cols 100)
(define vec
(build-vector
cols
(lambda (_) (make-hash-table))))
(mz:define-struct ss-cell (expr value updater))
(define (ss-get-cell-text row col)
(cond
[(hash-table-get (vector-ref vec col) row (lambda () #f))
=> (lambda (cell)
(let ([expr (unprocess (ss-cell-expr cell) '@e '@r '@c '@m row col)])
(if (eq? expr 'undefined)
""
(expr->string expr))))]
[else ""]))
(define (ss-get-cell-value row col)
(cond
[(hash-table-get (vector-ref vec col) row (lambda () #f))
=> ss-cell-value]
[else undefined]))
(define (fresh-ss-cell row col)
(let* ([value (new-cell)]
[ret (make-ss-cell
'undefined value
(proc->signal
(lambda () (send canvas draw-cell row col))
value))])
(hash-table-put! (vector-ref vec col) row ret)
ret))
(define (ss-get-cell-value/force row col)
(ss-cell-value (hash-table-get (vector-ref vec col) row (lambda () (fresh-ss-cell row col)))))
(define (text->processed-expr txt row col)
(let* ([expr
(with-handlers
([exn? (lambda (exn)
(message-box
"Error"
(format "The expression you entered is invalid:~n~a"
(exn-message exn))
frame
'(ok stop))
eof)])
(read (open-input-string txt)))])
(if (eof-object? expr)
'undefined
(process expr '@e '@r '@c '@m row col))))
;; should not (and does not) remove when cells are emptied
;; should not reset when expression is the same
(define (ss-set-cell-processed-expr! row col processed-expr)
(let* ([cell
(hash-table-get
(vector-ref vec col) row
(lambda ()
(fresh-ss-cell row col)))])
(when (not (equal? (ss-cell-expr cell) processed-expr))
(set-ss-cell-expr! cell processed-expr)
(set-cell! (ss-cell-value cell)
(with-handlers
([exn? (lambda (exn)
#;(message-box
"Error"
(format "The following error occurred while evaluating a formula:~n~a"
(exn-message exn))
frame
'(ok stop))
exn)])
(eval `(let ([row ,row]
[col ,col])
,processed-expr))))
;(synchronize)
(send canvas draw-cell row col))
(send canvas focus)))
(define chars-per-cell 14)
(define (take-upto n lst)
(if (and (positive? n)
(cons? lst))
(cons (first lst) (take-upto (sub1 n) (rest lst)))
empty))
(define (history-e n b)
(collect-e (changes b) (list (value-now b)) (lambda (ev acc) (take-upto n (cons ev acc)))))
(define (clip lo x hi)
(max lo (min x hi)))
(define (between x y z)
(or (<= x y z)
(<= z y x)))
(define ss-canvas%
(class canvas%
(super-instantiate ())
(inherit
refresh
get-dc
get-scroll-pos
get-client-size
set-scroll-range
set-scroll-page
init-manual-scrollbars)
(override
set-scroll-pos
on-event
on-paint
on-scroll
on-size
on-char)
(field
[can-refresh? #t]
[offscreen-dc (new bitmap-dc% (bitmap (make-object bitmap% 1280 1024 #f)))]
[char-width (inexact->exact (send offscreen-dc get-char-width))]
[cell-width (* chars-per-cell char-width)]
[cell-height (+ 2 (inexact->exact (send offscreen-dc get-char-height)))]
[left-margin (* 5 char-width)]
[top-margin cell-height]
[canvas-width-rcvr (event-receiver)]
[canvas-height-rcvr (event-receiver)]
[h-scroll-rcvr (event-receiver)]
[v-scroll-rcvr (event-receiver)]
[mouse-x-rcvr (event-receiver)]
[mouse-y-rcvr (event-receiver)]
[left-clicks (event-receiver)]
[left-releases (event-receiver)]
[key-events (event-receiver)]
[canvas-width~ (hold canvas-width-rcvr)]
[canvas-height~ (hold canvas-height-rcvr)]
[mouse-x~ (hold mouse-x-rcvr 0)]
[mouse-y~ (hold mouse-y-rcvr 0)]
[left-button-down~ (hold (merge-e (left-clicks . -=> . #t)
(left-releases . -=> . #f))
#f)]
[h-chars-per-page~ (quotient (- canvas-width~ left-margin) char-width)]
[v-cells-per-page~ (quotient (- canvas-height~ top-margin) cell-height)]
[h-scroll-range~ (max 0 (- (* cols chars-per-cell) h-chars-per-page~))]
[v-scroll-range~ (max 0 (- rows v-cells-per-page~))]
[h-scroll-pos~ (hold h-scroll-rcvr 0)]
[v-scroll-pos~ (hold v-scroll-rcvr 0)]
[h-scroll-cells~ (quotient h-scroll-pos~ chars-per-cell)]
[h-scroll-offset~ (* char-width (remainder h-scroll-pos~ chars-per-cell))]
[v-scroll-cells~ v-scroll-pos~]
[mouse-row~ (y->row mouse-y~)]
[mouse-col~ (x->col mouse-x~)]
[first-vis-row~ (y->row (add1 top-margin))]
[last-vis-row~ (y->row (sub1 canvas-height~))]
[first-vis-col~ (x->col (add1 left-margin))]
[last-vis-col~ (x->col (sub1 canvas-width~))]
[start-sel-row~
(accum-b
(merge-e
(left-clicks . -=> . (lambda (_) (value-now mouse-row~)))
(key-events . ==> . (lambda (key)
(lambda (prev)
(case (send key get-key-code)
[(up) (max 0 (sub1 prev))]
[(down) (min (sub1 rows) (add1 prev))]
[else prev])))))
0)]
[start-sel-col~
(accum-b
(merge-e
(left-clicks . -=> . (lambda (_) (value-now mouse-col~)))
(key-events . ==> . (lambda (key)
(lambda (prev)
(case (send key get-key-code)
[(left) (max 0 (sub1 prev))]
[(right) (min (sub1 cols) (add1 prev))]
[else prev])))))
0)]
[cur-sel-row~
(hold (merge-e
(changes start-sel-row~)
((changes start-sel-col~) . -=> . (value-now start-sel-row~))
((changes mouse-row~) . =#> . (lambda (_)
left-button-down~))) 0)]
[cur-sel-col~
(hold (merge-e
(changes start-sel-col~)
((changes start-sel-row~) . -=> . (value-now start-sel-col~))
((changes mouse-col~) . =#> . (lambda (_)
left-button-down~))) 0)]
[scrollbar-updater
(list
(lift-strict (lambda (pg) (set-scroll-page 'horizontal (clip 1 (- pg chars-per-cell -1) 10000))) h-chars-per-page~)
(lift-strict (lambda (pg) (set-scroll-page 'vertical (clip 1 (sub1 pg) 10000))) v-cells-per-page~)
(lift-strict (lambda (rng) (set-scroll-range 'horizontal (clip 1 rng 10000))) h-scroll-range~)
(lift-strict (lambda (rng) (set-scroll-range 'vertical (clip 1 rng 10000))) v-scroll-range~))]
[scroller ((merge-e (changes h-scroll-pos~)
(changes v-scroll-pos~)) . -=> . (refresh))]
[v-auto-scroller (merge-e
((while-e (and left-button-down~
(>= cur-sel-row~ last-vis-row~)
(< cur-sel-row~ (sub1 rows))
(not (= cur-sel-row~ start-sel-row~))) 50)
. -=> . (set-scroll-pos 'vertical (add1 (value-now v-scroll-pos~))))
((while-e (and left-button-down~
(<= cur-sel-row~ first-vis-row~)
(> cur-sel-row~ 0)
(not (= cur-sel-row~ start-sel-row~))) 50)
. -=> . (set-scroll-pos 'vertical (sub1 (value-now v-scroll-pos~))))
(key-events
. ==> .
(lambda (ev)
(case (send ev get-key-code)
[(prior) (set-scroll-pos 'vertical (max 0 (- (value-now v-scroll-pos~) (value-now v-cells-per-page~))))]
[(next) (set-scroll-pos 'vertical (min (value-now v-scroll-range~)
(+ (value-now v-scroll-pos~) (value-now v-cells-per-page~))))]))))]
[h-auto-scroller (merge-e
((while-e (and left-button-down~
(>= cur-sel-col~ last-vis-col~)
(< h-scroll-pos~ h-scroll-range~)) 50)
. -=> . (set-scroll-pos 'horizontal (+ 3 (value-now h-scroll-pos~))))
((while-e (and left-button-down~
(<= cur-sel-col~ first-vis-col~)
(> h-scroll-pos~ 0)) 50)
. -=> . (set-scroll-pos 'horizontal (+ -3 (value-now h-scroll-pos~)))))]
[highlighter (merge-e
((history-e 2 (list mouse-row~ mouse-col~))
. ==> .
(lambda (lst)
(for-each
(lambda (p)
(draw-cell (first p) (second p)))
lst)))
((history-e 2 (list start-sel-row~ start-sel-col~ cur-sel-row~ cur-sel-col~))
. ==> .
(match-lambda
[((r01 c01 rf1 cf1) (r00 c00 rf0 cf0))
(cond
[(and (= r01 rf1) (= c01 cf1))
; fresh selection: clear old selection, redraw new cell
(draw-cell-block r00 rf0 c00 cf0)
(draw-cell r01 c01)]
[else
; extended selection, so r00 = r01 and c00 = c01
(draw-cell-block rf0 rf1 (min c00 cf0 cf1) (max c00 cf0 cf1))
(draw-cell-block (min r00 rf0 rf1) (max r00 rf0 rf1) cf0 cf1)
(draw-cell-block rf0 rf1 cf0 cf1)])])))]
[focuser ((key-events . =#> . (lambda (ev) (eq? #\return (send ev get-key-code))))
. -=> . (send text-field focus))]
[text-field-switcher (lift-strict (lambda (row col)
(unless (or (negative? row)
(negative? col))
(send text-field set-value (ss-get-cell-text row col))))
start-sel-row~ start-sel-col~)]
[light-steel-blue (make-object color% "LightSteelBlue")]
[lavender (make-object color% "Lavender")]
[white (make-object color% "White")]
[line-pen (make-object pen% (make-object color% "DimGray") 1 'solid)]
[light-gray (make-object color% "LightGray")]
[trans-pen (make-object pen%)]
[default-font (send offscreen-dc get-font)]
[label-font (make-object font% 11 'roman 'normal 'bold)]
[gray-brush (make-object brush% light-gray 'solid)]
[highlight-brush (make-object brush% lavender 'solid)]
[selected-brush (make-object brush% light-steel-blue 'solid)]
[clear-brush (make-object brush% white 'solid)])
(send trans-pen set-style 'transparent)
(define (set-scroll-pos which pos)
(super set-scroll-pos which pos)
(send-event
(case which
[(horizontal) h-scroll-rcvr]
[(vertical) v-scroll-rcvr]) pos))
(define/private (x->col x)
(if (> x left-margin)
(+ h-scroll-cells~ (quotient (+ (- x left-margin) h-scroll-offset~) cell-width))
-1))
(define/private (y->row y)
(if (> y top-margin)
(+ v-scroll-cells~ (quotient (- y top-margin) cell-height))
-1))
(define/private (row->y-top row)
(snapshot/sync (v-scroll-cells~)
(+ (* cell-height (- row v-scroll-cells~))
top-margin)))
(define/private (col->x-left col)
(snapshot/sync (h-scroll-cells~ h-scroll-offset~)
(+ (* (- col h-scroll-cells~) cell-width)
(- h-scroll-offset~)
left-margin)))
#;(define foo (lift #t printf "~a ~a ~a ~a~n" cur-sel-row~ cur-sel-col~ start-sel-row~ start-sel-col~))
(define/public (draw-cell-block r0 rf c0 cf)
(let ([r0 (min r0 rf)]
[rf (max r0 rf)]
[c0 (min c0 cf)]
[cf (max c0 cf)])
(for (i = r0) (i . <= . rf) add1
(for (j = c0) (j . <= . cf) add1
(draw-cell-offscreen i j)))
(let ([x0 (col->x-left c0)]
[y0 (row->y-top r0)]
[xf (col->x-left (add1 cf))]
[yf (row->y-top (add1 rf))])
(send (get-dc)
draw-bitmap-section (send offscreen-dc get-bitmap)
x0 y0 x0 y0 (- xf x0) (- yf y0)))))
(define/public (draw-cell-block-offscreen r0 rf c0 cf)
(let ([r0 (min r0 rf)]
[rf (max r0 rf)]
[c0 (min c0 cf)]
[cf (max c0 cf)])
(for (i = r0) (i . <= . rf) add1
(for (j = c0) (j . <= . cf) add1
(draw-cell-offscreen i j)))))
(define/public (new-expression text)
(snapshot/sync (cur-sel-row~ cur-sel-col~ start-sel-row~ start-sel-col~)
(let ([r0 (min cur-sel-row~ start-sel-row~)]
[r1 (max cur-sel-row~ start-sel-row~)]
[c0 (min cur-sel-col~ start-sel-col~)]
[c1 (max cur-sel-col~ start-sel-col~)]
[processed-expr (text->processed-expr text start-sel-row~ start-sel-col~)])
(for (row = r0) (row . <= . r1) add1
(for (col = c0) (col . <= . c1) add1
(ss-set-cell-processed-expr! row col processed-expr))))
(send canvas focus)))
(define (draw-cell-offscreen row col)
(snapshot/sync (first-vis-row~
last-vis-row~
first-vis-col~ last-vis-col~
mouse-row~ mouse-col~
start-sel-row~ start-sel-col~
cur-sel-row~ cur-sel-col~)
(let ([x (col->x-left col)]
[y (row->y-top row)])
(when (and (< -1 row rows)
(< -1 col cols))
(let ([text (ss-format (ss-get-cell-value row col))])
(when (and (= row start-sel-row~)
(= col start-sel-col~))
(send value-field set-value text))
(when (and (<= first-vis-row~ row last-vis-row~)
(<= first-vis-col~ col last-vis-col~))
(send offscreen-dc set-clipping-rect
(max x (+ left-margin 1)) y cell-width cell-height)
(send offscreen-dc set-brush
(cond
[(and (between start-sel-row~ row cur-sel-row~)
(between start-sel-col~ col cur-sel-col~)) selected-brush]
[(and (= row mouse-row~)
(= col mouse-col~)) highlight-brush]
[else clear-brush]))
(send offscreen-dc draw-rectangle x y (+ cell-width 1) (+ cell-height 1))
(send offscreen-dc draw-text text
(- (+ x cell-width) 2
(let-values ([(width height descent space)
(send offscreen-dc get-text-extent text #f #f 0)])
width))
(+ y 1) #f 0 0)
(send offscreen-dc set-clipping-region #f)))))))
(define/public (draw-cell row col)
(draw-cell-offscreen row col)
(let ([x (col->x-left col)]
[y (row->y-top row)])
(send (get-dc)
draw-bitmap-section (send offscreen-dc get-bitmap)
x y x y cell-width cell-height)))
(define (get-text-width dc text)
(let-values ([(width height descent space)
(send dc get-text-extent text #f #f 0)])
width))
(define (num->char n)
(integer->char (+ n (char->integer #\A))))
(define (column->string col)
(list->string
(if (< col 26)
(list (num->char col))
(list (num->char (sub1 (quotient col 26)))
(num->char (remainder col 26))))))
(define (on-char event)
(send-event key-events event)
(synchronize))
(define (on-scroll scroll-event)
(case (send scroll-event get-direction)
[(vertical) (send-event v-scroll-rcvr (send scroll-event get-position))]
[(horizontal) (send-event h-scroll-rcvr (send scroll-event get-position))])
(synchronize))
(define (on-event event)
(case (send event get-event-type)
[(enter motion)
(send-event mouse-x-rcvr (send event get-x))
(send-event mouse-y-rcvr (send event get-y))]
[(leave)
(send-event mouse-x-rcvr -1)
(send-event mouse-y-rcvr -1)]
[(left-down) (send-event left-clicks #t)]
[(left-up) (send-event left-releases #t)])
(synchronize))
(define (on-size width height)
(let-values ([(width height) (get-client-size)])
(send-event canvas-width-rcvr width)
(send-event canvas-height-rcvr height)
(synchronize)))
(define (on-paint)
(snapshot/sync (canvas-width~
canvas-height~
first-vis-row~ last-vis-row~
first-vis-col~ last-vis-col~
h-scroll-cells~ h-scroll-offset~ v-scroll-cells~)
(let ([dc offscreen-dc])
(send dc set-clipping-region #f)
(send dc clear)
;(send dc set-pen line-pen)
;(send dc set-brush highlight-brush)
(send dc set-pen trans-pen)
(send dc set-brush gray-brush)
(send dc draw-rectangle 0 0 left-margin canvas-height~)
(send dc draw-rectangle 0 0 canvas-width~ top-margin)
(send dc set-pen line-pen)
(send dc draw-line 0 0 0 canvas-height~)
(send dc draw-line 0 0 canvas-width~ 0)
(send dc set-brush clear-brush)
(send dc set-font label-font)
;; draw horizontal rules and row labels
(for (row = first-vis-row~) (row . <= . (min last-vis-row~ (sub1 rows))) add1
(let ([y (row->y-top row)]
[text (number->string row)])
(send dc draw-line 0 y canvas-width~ y)
(send dc draw-text text (- left-margin (get-text-width dc text) 2) (add1 y) #f 0 0)))
;; draw vertical rules and column labels
(send dc draw-line left-margin 0 left-margin canvas-height~)
(send dc set-clipping-rect (+ left-margin 1) 0 (- canvas-width~ left-margin 1) canvas-height~)
(for (col = first-vis-col~) (col . <= . (min last-vis-col~ (sub1 cols))) add1
(let ([x (col->x-left col)]
[text (column->string col)])
(send dc draw-text text (+ x (quotient (- cell-width (get-text-width dc text)) 2)) 0 #f 0 0)
(send dc draw-line x 0 x canvas-height~)))
(send dc set-font default-font)
(draw-cell-block-offscreen first-vis-row~ last-vis-row~ first-vis-col~ last-vis-col~)
(send (get-dc) draw-bitmap-section (send dc get-bitmap) 0 0 0 0 canvas-width~ canvas-height~))))
(let-values ([(width height) (get-client-size)])
(send-event canvas-width-rcvr width)
(send-event canvas-height-rcvr height))
(synchronize)
(init-manual-scrollbars 1 1 1 1 0 0)
(send offscreen-dc set-pen line-pen)
(send offscreen-dc set-brush highlight-brush)))
(define canvas
(instantiate ss-canvas% (frame) (style (list 'hscroll 'vscroll))))
(send frame show #t)
(send canvas focus))

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

@ -1,165 +0,0 @@
(module ss-canvas frtime/frtime
(require
mzlib/class
frtime/list
(all-except mred send-event)
(lib "mixin-macros.ss" "frtime" "demos" "gui")
)
(require (rename frtime/frp-core 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
View File

@ -1,74 +0,0 @@
(module ss-database frtime/frtime-big
(require (rename frtime/frp-core current-custs current-custs))
(require (rename frtime/frp-core do-in-manager do-in-manager))
(require (as-is:unchecked mzscheme make-hash-table hash-table-get hash-table-put!))
;(require mzlib/string)
(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))

106
collects/frtime/demos/spreadsheet/ss-funcs.ss
View File

@ -1,106 +0,0 @@
(module ss-funcs mzscheme
(require "data-synthesis.ss"
"distributions.ss"
(only frtime/frtime undefined?)
)
;;filter: ('a -> bool) * 'a list -> 'a list
(define (filter pred lst)
(cond [(null? lst) '()]
[(pred (car lst))
(cons (car lst)
(filter pred (cdr lst)))]
[else (filter pred (cdr lst))]))
;; count : ('a -> bool) * 'a list -> num
(define (count pred lst)
(cond [(null? lst) 0]
[(pred (car lst))
(+ 1 (count pred (cdr lst)))]
[else (count pred (cdr lst))]))
;;(num U undefined) list -> num list
(define (filter-out-undefined lst)
(filter (lambda (o)
(not (undefined? o)))
lst))
; list -> num
(define (count-undefineds lst)
(count undefined? lst))
(define (name->dist-fit-func name)
(cond [(equal? name 'uniform)
fit-uniform-distribution]
[(equal? name 'normal)
fit-normal-distribution]
[(equal? name 'exponential)
fit-exponential-distribution]
; [(equal? name 'gamma)
; fit-gamma-distribution] Gamme distribution is messed up. See distributions.ss
[else (raise (format "~a not an allowable distribution name"))]))
;;('a -> bool) * 'a list * 'a list -> 'a list
(define (replace pred lst filler)
(cond [(null? lst)
'()]
[(not (pred (car lst)))
(cons (car lst)
(replace pred
(cdr lst)
filler))]
[(null? filler)
(raise "not enough filler to complete replace function")]
[(pred (car lst))
(cons (car filler)
(replace pred
(cdr lst)
(cdr filler)))]))
;;('a -> bool) * 'a list * (-> 'a) -> 'a list
(define (replace-from-generator pred lst gen)
(cond [(null? lst)
'()]
[(not (pred (car lst)))
(cons (car lst)
(replace-from-generator pred
(cdr lst)
gen))]
[(pred (car lst))
(cons (gen)
(replace-from-generator pred
(cdr lst)
gen))]))
;; symbol * (num U undefined) list -> num list
(define (inflate-data dist-name data)
(replace-from-generator undefined?
data
(distribution-rand ((name->dist-fit-func dist-name)
(filter-out-undefined data)))))
;
;(define ndata (synthesize-random-data (make-uniform-distribution 0 100)
; 10000))
;(define holy-data
; (let loop ([c 2] [lst ndata])
; (cond [(null? lst) '()]
; [(zero? c) (cons undefined
; (loop 3
; (cdr lst)))]
; [else (cons (car lst)
; (loop (sub1 c)
; (cdr lst)))])))
;(define unholy-data (inflate-data 'uniform holy-data))
;
;;"Source Mean: 0"
;"Data Mean:" (sample-mean ndata)
;"Holy-Data Mean:" (sample-mean (filter-out-undefined holy-data))
;"Unholy-Data Mean:" (sample-mean unholy-data)
;;"Source Variance: 1"
;"Data Variance:" (sample-variance ndata)
;"Holy-Data Variance:" (sample-variance (filter-out-undefined holy-data))
;"Unholy-Data Variance:" (sample-variance unholy-data)
(provide inflate-data)
)

105
collects/frtime/frp-core.ss
View File

@ -26,9 +26,7 @@
(define snap? (make-parameter #f))
(define named-dependents (make-hash-table))
(define frtime-version "0.4b -- Tue Jun 26 17:39:45 2007")
(define (compose-continuation-mark-sets2 s1 s2)
s2)
@ -197,7 +195,6 @@
[extra-cont-marks ccm])
(current-parameterization))
(if cust-sig (append producers (list cust-sig)) producers))])
;(printf "~a custodians~n" (length custs))
(when (cons? producers)
(register sig producers))
(when cust-sig
@ -223,7 +220,6 @@
(if cust-sig (cons cust-sig producers) producers)
current-box
trigger)])
;(printf "~a custodians~n" (length custs))
(when (cons? producers)
(register sig producers))
(when cust-sig
@ -247,61 +243,6 @@
(define (proc->signal:unchanged thunk . producers)
(build-signal make-signal:unchanged thunk producers))
;; mutate! : compound num -> (any -> ())
(define (procs->signal:compound ctor mutate! . args)
(let ([ccm (effective-continuation-marks)])
(do-in-manager
(let* ([cust (current-cust)]
[cust-sig (and cust (ft-cust-signal cust))]
[value (apply ctor (map value-now/no-copy args))]
#;[mutators
(foldl
(lambda (arg idx acc)
(if (signal? arg) ; behavior?
(cons (proc->signal
(let ([m (mutate! value idx)])
(lambda ()
(let ([v (value-now/no-copy arg)])
(m v)
'struct-mutator)))
arg) acc)
acc))
empty args (build-list (length args) identity))]
[sig (make-signal:compound
undefined
empty
#f
(lambda () ;mutators
(let loop ([i 0] [args args] [val value])
(if (cons? args)
(let ([fd (value-now/no-copy (car args))])
((mutate! value i) fd)
(loop (add1 i) (cdr args)
(if (undefined? fd)
undefined
val)))
val)))
(add1 (apply max 0 (cons (safe-signal-depth cust-sig) (map safe-signal-depth args))))
ccm
(parameterize ([uncaught-exception-handler
(lambda (exn) (exn-handler exn))]
[extra-cont-marks ccm])
(current-parameterization))
(if cust-sig (cons cust-sig args) args)
(apply ctor args)
(lambda () (apply ctor (map value-now args))))])
;(printf "mutators = ~a~n" mutators)
(when (cons? args)
(register sig args))
(when cust-sig
(register (make-non-scheduled sig) cust-sig))
(when cust
(set-ft-cust-constructed-sigs! cust (cons (make-weak-box sig) (ft-cust-constructed-sigs cust))))
(iq-enqueue sig)
;(printf "~n*made a compound [~a]*~n~n" (value-now/no-copy sig))
sig))))
;;;;;;;;;;;;;;;;;;;;;;;;;
@ -390,17 +331,8 @@
(do-in-manager-after
(apply values (map value-now sigs))))
#;(define-syntax value-now/sync
(syntax-rules ()
[(_ beh ...)
(begin
(! man (list 'run-thunk/stabalized (self) (lambda () (list (value-now beh) ...))))
(receive [('val v) v]
[('exn e) (raise e)]))]))
(define (kill-signal sig)
;(printf "killing~n")
(for-each
(lambda (prod)
(unregister sig prod))
@ -408,17 +340,7 @@
(set-signal-thunk! sig (lambda _ 'really-dead))
(set-signal-value! sig 'dead)
(set-signal-dependents! sig empty)
(set-signal-producers! sig empty)
#;(for-each
(lambda (c)
(set-ft-cust-constructed-sigs!
c
(filter (lambda (wbox)
(cond
[(weak-box-value wbox) => (lambda (v) (not (eq? sig v)))]
[else (begin #;(printf "empty weak box~n") #f)]))
(ft-cust-constructed-sigs c))))
(signal-custodians sig)))
(set-signal-producers! sig empty))
@ -436,16 +358,6 @@
[0]))
; *** will have to change significantly to support depth-guided recomputation ***
; Basically, I'll have to check that I'm not introducing a cycle.
; If there is no cycle, then I simply ensure that inf's depth is at least one more than
; sup's. If this requires an increase to inf's depth, then I need to propagate the
; new depth to inf's dependents. Since there are no cycles, this step is guaranteed to
; terminate. When checking for cycles, I should of course stop when I detect a pre-existing
; cycle.
; If there is a cycle, then 'inf' has (and retains) a lower depth than 'sup' (?), which
; indicates the cycle. Importantly, 'propagate' uses the external message queue whenever
; a dependency crosses an inversion of depth.
(define fix-depths
(opt-lambda (inf sup [mem empty])
(if (memq sup mem)
@ -603,9 +515,6 @@
(cust-killall! cust)
(set-ft-cust-constructed-sigs! cust empty)
(set-ft-cust-children! cust empty)
#;(for-each kill-signal
(filter identity
(map weak-box-value (ft-cust-constructed-sigs cust))))
(unregister rtn (unbox current))
(set-box! current (pfun (value-now/no-copy bhvr)))
(register rtn (unbox current))
@ -716,22 +625,16 @@
(let outer ()
(with-handlers ([exn:fail?
(lambda (exn)
(when (and cur-beh
#;(not (undefined? (signal-value cur-beh))))
;(when (empty? (continuation-mark-set->list
; (exn-continuation-marks exn) 'frtime))
;(fprintf (current-error-port) "exception while updating ~a~n" cur-beh)
(when cur-beh
(set! exn (make-exn:fail
(exn-message exn)
(compose-continuation-mark-sets2
(signal-continuation-marks
cur-beh)
(exn-continuation-marks exn))));)
;(raise exn)
(iq-enqueue (list exceptions (list exn cur-beh)))
(when (behavior? cur-beh)
(undef cur-beh)
#;(kill-signal cur-beh)))
(undef cur-beh)))
(outer))])
(set! exn-handler (uncaught-exception-handler))
(let inner ()

0
collects/frtime/demos/gui/aux-mixin-macros.ss → collects/frtime/gui/aux-mixin-macros.ss
View File

2
collects/frtime/demos/gui/demo/bindec.ss → collects/frtime/gui/demo/bindec.ss
View File

@ -1,4 +1,4 @@
(require "../simple.ss")
(require frtime/gui/simple)
(require (rename mred horizontal-panel% horizontal-panel%))
; just change this to change the range of the binary/decimal converter

3
collects/frtime/demos/gui/demo/instr.ss → collects/frtime/gui/demo/instr.ss
View File

@ -1,5 +1,4 @@
(require (lib "mixin-macros.ss" "frtime" "demos" "gui"))
(require (lib "aux-mixin-macros.ss" "frtime" "demos" "gui")) ;require the macros
(require frtime/gui/mixin-macros frtime/gui/aux-mixin-macros)
(require mzlib/class) ; require class utilities
(require mred) ; require base mred library

2
collects/frtime/demos/gui/demo/timer.ss → collects/frtime/gui/demo/timer.ss
View File

@ -1,4 +1,4 @@
(require "../simple.ss")
(require frtime/gui/simple)
(current-widget-parent (new ft-frame% (width 400) (stretchable-width #t)))

0
collects/frtime/demos/gui/doc.txt → collects/frtime/gui/doc.txt
View File

0
collects/frtime/demos/gui/fred.ss → collects/frtime/gui/fred.ss
View File

2
collects/frtime/demos/gui/info.ss → collects/frtime/gui/info.ss
View File

@ -1,3 +1,5 @@
#lang setup/infotab
(define compile-omit-paths '("demo"))
(define name "gui wrapper")

0
collects/frtime/demos/gui/mixin-macros.ss → collects/frtime/gui/mixin-macros.ss
View File

0
collects/frtime/demos/gui/mod-mrpanel.ss → collects/frtime/gui/mod-mrpanel.ss
View File

0
collects/frtime/demos/gui/mod-wx-panel.ss → collects/frtime/gui/mod-wx-panel.ss
View File

0
collects/frtime/demos/gui/simple.ss → collects/frtime/gui/simple.ss
View File

1
collects/frtime/lang-ext.ss
View File

@ -834,7 +834,6 @@
value-now
value-now/no-copy
value-now/sync
frtime-version
signal-count
signal?