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

merge Greg's changes on the defunct v4 branch

Browse Source 
svn: r7940
This commit is contained in:
Eli Barzilay 2007-12-10 19:30:05 +00:00
parent 7ee83ee536
commit 9230f66f01
12 changed files with 479 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -6,7 +6,7 @@
(define (str->num s)
(cond
[(string->number s)]
[else 0]))
[#t 0]))
(define x
(str->num (make-text "First number:")))

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

@ -1,6 +1,6 @@
(require (lib "animation.ss" "frtime")
(lib "etc.ss" "frtime")
(lib "gui.scm" "frtime"))
(lib "gui.ss" "frtime"))
(define radius (make-slider "Radius" 100 200 150))
(define speed (* .02 (make-slider "Speed" 0 10 5)))

2
collects/frtime/demos/growing-points.ss
View File

@ -18,7 +18,7 @@
(sqrt (+ (sqr (- x1 x2)) (sqr (- y1 y2)))))
;; How many growing points on one side of the grid of growing points.
(define GRID-SIZE 8)
(define GRID-SIZE (make-slider "Width" 1 10 8))
;; The distance between the centers of two adjacent growing points.
(define grid-resolution (make-slider "Resolution" 2 30 20))

241
collects/frtime/demos/mirror-lens.ss Normal file
View File

@ -0,0 +1,241 @@
(require (lib "animation.ss" "frtime")
(lib "gui.ss" "frtime"))
;; Written by Evan Perillo
;; never run two display-envs at the same time or the images will overlap and not look nice
;; any relevant values can be set using the gui
;; 4 types of optical-devices can be used, concave-mirror, convex-mirror, concave-lens, and convex-lens
;; An example is already written at the bottom, just click run.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;TOP LEVEL FUNCTIONS;;;;;;;;
;creates and displays an environment with an optical device
;display-env : slider-input -> animation
(define (display-env)
(fresh-anim)
(fresh-anim 599 599)
(display-shapes (set-env (make-choice "Type of device"
(list "Concave Mirror" "Convex Lens" "Convex Mirror" "Concave Lens"))
(make-slider "Device Position" 1 599 399)
mouse-pos
(make-slider "Height" 1 100 50)
(make-slider "Focal Length" 1 110 60)
"blue")))
(define (concave-mirror x-val) ;; makes a concave mirror at x, y value determined by Base-Line
(make-object "Concave Mirror" ;; gives a name to the optical device
x-val ;; sets it at x value indicated
599 ;; determines if it converges or diverges
(lambda (h ref-h) (make-posn (posn-x mouse-pos) ref-h)) ;; stores information regarding how the light reflects off of this object in a lambda function
(lambda (f d-h) (make-posn f Base-Line))
-1 ;; determines whether this is a mirror or a Lens, ie. whether focus is negative or positive x value
))
(define (convex-lens x-val)
(make-object "Convex Lens" x-val 599
(lambda (h ref-h) (make-posn (posn-x mouse-pos) h))
(lambda (f d-h) (make-posn f Base-Line))
1))
(define (convex-mirror x-val)
(make-object "Convex Mirror" x-val 0
(lambda (h ref-h) (make-posn (posn-x mouse-pos) ref-h))
(lambda (f d-h) (make-posn f d-h))
-1))
(define (concave-lens x-val)
(make-object "Concave Lens" x-val 0
(lambda (h ref-h) (make-posn (posn-x mouse-pos) h))
(lambda (f d-h) (make-posn f d-h))
1))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;MID LEVEL FUNCTIONS;;;;;;;;
;set-env: number(Op-d type) number(Op-D x value) mouse-input number(object height) number(focal-length) string -> void (animation)
(define (set-env num x obj-pos obj-height f-length object-color)
(let* ([obj (get-object num x)]
[x-pos (posn-x obj-pos)]
[x-val (object-x-val obj)]
[y-val (object-y-val obj)]
[Focal-Length f-length]
[F (+ x-val (* (object-focus obj) Focal-Length))]
[2F (- F (- x-val F))]
[Fl (- x-val Focal-Length)]
[2Fl (- Fl Focal-Length)]
[Object-Height obj-height]
[Height (- Base-Line Object-Height)]
[Reflected-Height (+ Base-Line Object-Height)]
[Double-Height (- Base-Line (* 2 Object-Height))]
[Object-Distance (- x-val x-pos)]
[Ray1-Posn ((object-ray1 obj) Height Reflected-Height)]
[Ray2-Posn ((object-ray2 obj) F Double-Height)])
(define (in-bounds proc result)
(if (< x-pos x-val)
proc
result))
(define (create-line proc)
(in-bounds proc empty))
(define (return-string proc)
(in-bounds proc "None"))
(define (show-info proc)
(if (>= x-pos x-val)
proc
""))
(define (get-image-type)
(cond
[(string=? (object-type obj) "Convex Mirror") (return-string "Virtual Erect Smaller")]
[(string=? (object-type obj) "Concave Lens") (return-string "Virtual Erect Smaller")]
[(string=? (object-type obj) "Concave Mirror") (get-image-type-converging 2F F)]
[(string=? (object-type obj) "Convex Lens") (get-image-type-converging 2Fl Fl)]))
(define (get-image-type-converging a b)
(return-string
(cond
[(< (posn-x mouse-pos) a) "Real Inverted Smaller"]
[(= (posn-x mouse-pos) a) "Real Inverted Equal"]
[(and (> (posn-x mouse-pos) a)
(< (posn-x mouse-pos) b)) "Real Inverted Larger"]
[(= (posn-x mouse-pos) b) "None"]
[(and (> (posn-x mouse-pos) b)) "Virtual Erect Larger"])))
;;;;;;;;list of shapes to be drawn;
(append
(list
(make-line (make-posn x-val 175) (make-posn x-val 375) "black") ;optical device
(create-line (make-line (make-posn x-pos Base-Line) ;object
(make-posn x-pos Height) object-color)) ;object
(create-line (make-line (make-posn x-pos Height) ;incident ray 1
(make-posn x-val Base-Line) "green")) ;incident ray 1
(if (= x-pos x-val) null ;reflected ray 1
(create-line (make-line (make-posn x-val Base-Line) ;reflected ray 1
(get-end-posn Ray1-Posn (make-posn x-val Base-Line) 599) "green"))) ;reflected ray 1
(create-line (make-line (make-posn x-pos Height) ;incident ray 2
(make-posn x-val Height) "red")) ;incident ray 2
(create-line (make-line (make-posn x-val Height) ;reflected ray 2
(get-end-posn Ray2-Posn (make-posn x-val Height) y-val) "red")) ;reflected ray 2
(make-circle (make-posn F Base-Line) 2 "black") ;
(make-circle (make-posn 2F Base-Line) 2 "black") ; Focal Points
(make-circle (make-posn Fl Base-Line) 2 "black") ;
(make-circle (make-posn 2Fl Base-Line) 2 "black") ;
(make-graph-string (make-posn 20 20)
(format "Type of Image Created: ~a"
(get-image-type))
"black")
(make-graph-string (make-posn 20 40)
(format "ho: ~a do: ~a"
(return-string Object-Height)
(return-string Object-Distance))
object-color)
(make-graph-string (make-posn 20 60)
(format "~a ~a"
(show-info "hi: None")
(show-info "di: None"))
"black")
(make-graph-string (make-posn 20 80)
(format "~a"
(show-info "Magnification: None"))
"red")
(make-graph-string (make-posn 450 20)
(object-type obj)
"black")
(make-graph-string (make-posn 450 40)
"By: Evan Perillo"
"black"))
;;;;;;Reflected Object;;;;;;;;;;
(if (>= x-pos x-val)
(list null)
(let ((intersect (intersection Ray2-Posn (make-posn x-val Height) Ray1-Posn (make-posn x-val Base-Line))))
(if (string? intersect) (create-line (list null))
(create-line
(list
(make-line intersect (make-posn (posn-x intersect) Base-Line) "black")
(make-graph-string (make-posn 20 60)
(format "hi: ~a di: ~a"
(exact->inexact (- Base-Line (posn-y intersect)))
(exact->inexact (- x-val (posn-x intersect))))
"black")
(make-graph-string (make-posn 20 80)
(format "Magnification: ~a"
(/ (- Base-Line (posn-y intersect))
Object-Height))
"red"))))))
)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; BOTTOM LEVEL FUNCTIONS ;;;
(define Base-Line 275)
(define-struct object (type x-val y-val ray1 ray2 focus))
(define (get-object num x)
(cond [(= 0 num) (concave-mirror x)]
[(= 1 num) (convex-lens x)]
[(= 2 num) (convex-mirror x)]
[(= 3 num) (concave-lens x)]))
(define (solve-x m1 m2 b1 b2)
(if (= m1 m2)
"DNE"
(/ (- b2 b1) (- m1 m2))))
(define (solve-eq x m b)
(if (string? x)
"DNE"
(+ (* m x) b)))
(define (get-b y x m)
(- y (* x m)))
(define (get-x y m b)
(/ (- y b) m))
(define (get-slope a b)
(/ (- (posn-y b) (posn-y a))
(- (posn-x b) (posn-x a))))
(define (get-end-posn posn-a posn-b y-val)
(define (get-end-x posn-a posn-b)
(let ((slope (get-slope posn-a posn-b)))
(get-x y-val
slope
(get-b (posn-y posn-a)
(posn-x posn-a)
slope))))
(make-posn (get-end-x posn-a posn-b) y-val))
;intersection : posn posn posn posn -> posn or "DNE"
(define (intersection line1a line1b line2a line2b)
(let* ((m1 (get-slope line1a line1b))
(m2 (get-slope line2a line2b))
(b1 (get-b (posn-y line1a) (posn-x line1a) m1))
(b2 (get-b (posn-y line2a) (posn-x line2a) m2))
(x (solve-x m1 m2 b1 b2))
(y (solve-eq x m1 b1)))
(if (string? x) "DNE" (make-posn x y))))
;;;;;;;;;;;;;;;;Examples;;;;;;;;;;;;;;
(display-env) ;creates and displays an optical device environment

5
collects/frtime/demos/needles.ss
View File

@ -9,10 +9,11 @@
;; Require the animation library and the library
;; containing the build-list function.
(require (lib "animation.ss" "frtime")
(lib "etc.ss" "frtime"))
(lib "etc.ss" "frtime")
(lib "gui.ss" "frtime"))
;; How many needles on one side of the grid of needles
(define GRID-SIZE 8)
(define GRID-SIZE (make-slider "Grid size:" 1 10 8))
;; The length of a needle in pixels
(define NEEDLE-LENGTH 10)

2
collects/frtime/demos/orbit-mouse.ss
View File

@ -1,7 +1,7 @@
(require (lib "animation.ss" "frtime")
(lib "gui.ss" "frtime"))
(define radius 25)
(define radius (make-slider "Radius" 25 200 100))
(define speed (* .1 (make-slider "Speed" -15 15 6)))
(define phase (wave speed))
(define n (make-slider "# Balls" 1 6 3))

6
collects/frtime/demos/pong.ss
View File

@ -104,8 +104,10 @@
;(make-circle (delay-by ball-pos 200) 8 "lightblue")
(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 30 30) (number->string p2-score)
(if (= p2-score (delay-by p2-score 600)) "black" "red"))
(make-graph-string (make-posn 350 30) (number->string p1-score)
(if (= p1-score (delay-by p1-score 600)) "black" "red"))
;(make-graph-string (make-posn 120 30) (number->string (posn-len ball-vel)) "black")
(make-line (make-posn 0 150) (make-posn 0 250) "red")
(make-line (make-posn 399 150) (make-posn 399 250) "red")))

153
collects/frtime/demos/tile-game.ss Normal file
View File

@ -0,0 +1,153 @@
;; tile game by Dave Tucker
(require (lib "animation.ss" "frtime")
(lib "gui.ss" "frtime")
(lib "class.ss"))
(define-struct tile (row col num color))
(define-struct state (tiles blank-row blank-col))
(define hue (list-ref '(0 1 4 5) (make-choice "Color: " '("Black" "Blue" "Red" "Magenta"))))
(define reverse-keys? (make-check-box "Reverse keys? "))
(define animate? (make-check-box "Animate? " #t))
(define animation-speed (list-ref '(250 500 750) (make-choice "Animation speed: " '("Fast" "Medium" "Slow"))))
(define smoothness (list-ref '(10 20 50) (make-choice "Animation smoothness: " '("Smooth" "Normal" "Coarse"))))
(set-cell! fine-timer-granularity smoothness)
(define ((component i) bit)
(if (not (zero? (bitwise-and hue bit)))
1
(/ i 16)))
(define initial-tiles
(build-list 15
(lambda (i)
(make-tile (quotient i 4)
(remainder i 4)
i
(apply make-rgb (map (component i) '(4 2 1)))))))
(define config
(accum-b (merge-e
(left-clicks
. ==> .
(lambda (ev)
(lambda (st)
(let* ([r (quotient (send ev get-y) 100)]
[c (quotient (send ev get-x) 100)]
[st1 (caar st)]
[br (state-blank-row st1)]
[bc (state-blank-col st1)])
(cond
[(and (= r br) (not (= c bc)))
`((,(make-state
(let ([dir (quotient (- c bc) (abs (- c bc)))])
(map (lambda (t)
(if (and (= (tile-row t) r)
(or (<= (+ bc dir) (tile-col t) c)
(<= c (tile-col t) (+ bc dir))))
(make-tile (tile-row t)
(- (tile-col t) dir)
(tile-num t)
(tile-color t))
t))
(state-tiles st1)))
r
c)
,(value-now milliseconds))
,(first st))]
[(and (not (= r br)) (= c bc))
`((,(make-state
(let ([dir (quotient (- r br) (abs (- r br)))])
(map (lambda (t)
(if (and (= (tile-col t) c)
(or (<= (+ dir br) (tile-row t) r)
(<= r (tile-row t) (+ dir br))))
(make-tile (- (tile-row t) dir)
(tile-col t)
(tile-num t)
(tile-color t))
t))
(state-tiles st1)))
r
c)
,(value-now milliseconds))
,(first st))]
[#t st])))))
(key-strokes
. ==> .
(lambda (ev)
(lambda (st)
(let/ec k
(let*-values ([(st1) (caar st)]
[(br) (state-blank-row st1)]
[(bc) (state-blank-col st1)]
[(r c)
(let ([ev (if (value-now reverse-keys?)
(case ev
[(left) 'right]
[(right) 'left]
[(up) 'down]
[(down) 'up])
ev)])
(case ev
[(left) (if (< bc 3)
(values br (add1 bc))
(k st))]
[(right) (if (> bc 0)
(values br (sub1 bc))
(k st))]
[(up) (if (< br 3)
(values (add1 br) bc)
(k st))]
[(down) (if (> br 0)
(values (sub1 br) bc)
(k st))]
[else (k st)]))])
`((,(make-state (map (lambda (t)
(if (and (= (tile-row t) r) (= (tile-col t) c))
(make-tile br bc (tile-num t) (tile-color t))
t))
(state-tiles st1))
r
c)
,(value-now milliseconds))
,(first st))))))))
(let ([init-state (make-state initial-tiles 3 3)]
[init-time (- (value-now milliseconds) 1000)])
(list (list init-state init-time)
(list init-state init-time)))))
(define (tile->shape t)
(make-rect (make-posn (+ 1 (* (tile-col t) 100))
(+ 1 (* (tile-row t) 100)))
98
98
(tile-color t)))
(define (tile-pos t)
(make-posn (+ 1 (* (tile-col t) 100))
(+ 1 (* (tile-row t) 100))))
(define (linear-comb x1 x2 frac)
(+ (* frac x1) (* (- 1 frac) x2)))
(define (blend-posns p1 p2 frac)
(make-posn (linear-comb (posn-x p1) (posn-x p2) frac)
(linear-comb (posn-y p1) (posn-y p2) frac)))
(define (tiles->shape t0 t1 frac)
(make-rect (blend-posns (tile-pos t0) (tile-pos t1) frac)
98
98
(tile-color t0)))
(display-shapes
(if animate?
(map (lambda (t1 t2)
(tiles->shape t1 t2 (min 1 (/ (- milliseconds (cadar config))
animation-speed))))
(state-tiles (caar config))
(state-tiles (caadr config)))
(map tile->shape (state-tiles (caar config)))))

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

@ -386,14 +386,14 @@
(define (extract k evs)
(if (mpair? evs)
(let ([ev (mcar evs)])
(if (pair? evs)
(let ([ev (car evs)])
(if (or (eq? ev undefined) (undefined? (erest ev)))
(extract k (mcdr evs))
(extract k (cdr evs))
(begin
(let ([val (efirst (erest ev))])
(set-mcar! evs (erest ev))
(k val)))))))
;(set-mcar! evs (erest ev))
(k val (cons (erest ev) (rest evs)))))))))
(define (kill-signal sig)
@ -768,12 +768,13 @@
#;(not (undefined? (signal-value cur-beh))))
;(when (empty? (continuation-mark-set->list
; (exn-continuation-marks exn) 'frtime))
(set! exn (make-exn:fail
(exn-message exn)
(compose-continuation-mark-sets2
(signal-continuation-marks
cur-beh)
(exn-continuation-marks exn))));)
(fprintf (current-error-port) "exception while updating ~a~n" 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)

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

@ -317,7 +317,7 @@
(send obj meth (value-now arg) ...)
(send obj meth arg ...))]))
;; Depricated
;; Deprecated
(define (magic dtime thunk)
(let* ([last-time (current-milliseconds)]
[ret (let ([myself #f])
@ -336,22 +336,17 @@
ret))
;; Depricated
;; Deprecated
(define (make-time-b ms)
(let ([ret (proc->signal void)])
(set-signal-thunk! ret
(lambda ()
(let ([t (current-milliseconds)])
(schedule-alarm (+ ms t) ret)
(schedule-alarm (+ (value-now ms) t) ret)
t)))
(set-signal-value! ret ((signal-thunk ret)))
ret))
(define milliseconds (make-time-b 20))
(define time-b milliseconds)
(define seconds
(let ([ret (proc->signal void)])
(set-signal-thunk! ret
@ -379,7 +374,7 @@
[ms (value-now ms-b)])
(let loop ()
(if (or (empty? (mcdr head))
(< now (+ ms (cdar (mcdr head)))))
(< now (+ ms (cdr (mcar (mcdr head))))))
(car (mcar head))
(begin
(set! dummy consumer) ;; just to prevent GC
@ -545,13 +540,13 @@
(when (ormap undefined? streams)
;(fprintf (current-error-port) "had an undefined stream~n")
(set! streams (fix-streams streams args)))
(let loop ()
(extract (lambda (the-event)
(let loop ([streams streams])
(extract (lambda (the-event strs)
(when proc-k
(call/cc
(lambda (k)
(set! esc k)
(proc-k the-event)))) (loop))
(proc-k the-event)))) (loop strs))
streams))
(set! streams (map signal-value args))
out)])
@ -644,6 +639,13 @@
(iq-enqueue rtn)
rtn))))
(define (make-mutable lst)
(printf "make-mutable called on ~a~n" lst)
lst
#;(if (pair? lst)
(mcons (first lst) (make-mutable (rest lst)))
lst))
(define (event-processor proc . args)
(let* ([out (econs undefined undefined)]
[proc/emit (proc
@ -654,10 +656,11 @@
[streams (map signal-value args)]
[thunk (lambda ()
(when (ormap undefined? streams)
(printf "some streams were undefined~n")
;(fprintf (current-error-port) "had an undefined stream~n")
(set! streams (fix-streams streams args)))
(let loop ()
(extract (lambda (the-event) (proc/emit the-event) (loop))
(let loop ([streams streams])
(extract (lambda (the-event strs) (proc/emit the-event) (loop strs))
streams))
(set! streams (map signal-value args))
out)])
@ -685,7 +688,12 @@
[(_ [ev k] ...)
()]))
;;;;;;;;;;;;;;;;;;;;;;
(define fine-timer-granularity (new-cell 20))
(define milliseconds (make-time-b fine-timer-granularity))
(define time-b milliseconds)
;;;;;;;;;;;;;;;;;;;;;;
;; Command Lambda
@ -846,6 +854,7 @@
snapshot/apply
magic
milliseconds
fine-timer-granularity
seconds
delay-by
inf-delay

47
collects/frtime/mzscheme-core.ss
View File

@ -202,27 +202,32 @@
(let ([deps (make-hash-table)])
(lambda ()
(begin0
(proc (lambda (obj)
(if (behavior? obj)
(begin
(case (hash-table-get deps obj 'absent)
[(absent) (hash-table-put! deps obj 'new)]
[(old) (hash-table-put! deps obj 'alive)]
[(new) (void)])
(value-now obj))
obj)))
(hash-table-for-each
deps
(lambda (k v)
(case v
[(new) (hash-table-put! deps k 'old)
#;(printf "reg~n")
(register rtn k)]
[(alive) (hash-table-put! deps k 'old)]
[(old) (hash-table-remove! deps k)
#;(printf "unreg~n")
(unregister rtn k)])))
#;(printf "count = ~a~n" (hash-table-count deps))))))
(let/ec esc
(with-handlers ([exn:fail? (lambda (exn) #f)])
(proc (lambda (obj)
(if (behavior? obj)
(begin
(case (hash-table-get deps obj 'absent)
[(absent) (hash-table-put! deps obj 'new)
(register rtn obj)
(iq-enqueue rtn)
(esc #f)]
[(old) (hash-table-put! deps obj 'alive)]
[(new) (void)])
(value-now obj))
obj))))
(hash-table-for-each
deps
(lambda (k v)
(case v
[(new) (hash-table-put! deps k 'old)
#;(printf "reg~n")
(register rtn k)]
[(alive) (hash-table-put! deps k 'old)]
[(old) (hash-table-remove! deps k)
#;(printf "unreg~n")
(unregister rtn k)])))
#;(printf "count = ~a~n" (hash-table-count deps)))))))
(iq-enqueue rtn)
rtn))

14
collects/frtime/mzscheme-utils.ss
View File

@ -18,7 +18,7 @@
letrec
match
cons car cdr pair? null?
caar cdar cadr cddr caddr cdddr cadddr cddddr
caar caadr cdar cadar cadr cddr caddr cdddr cadddr cddddr
make-struct-type
make-struct-field-accessor
make-struct-field-mutator
@ -34,7 +34,7 @@
and
or
cond when unless ;case
else =>
; else =>
map ormap andmap assoc member)
(rename mzscheme mzscheme:if if)
(rename "lang-ext.ss" lift lift)
@ -151,6 +151,12 @@
(define (cadr v)
(car (cdr v)))
(define (cadar v)
(car (cdar v)))
(define (caadr v)
(car (cadr v)))
(define (cddr v)
(cdr (cdr v)))
@ -275,6 +281,7 @@
(define (dont-optimize x) x)
(provide cond
else =>
and
or
or-undef
@ -284,6 +291,9 @@
ormap
andmap
caar
caadr
cdar
cadar
cadr
cddr
caddr