Permalink
Browse files

Responding to Gregory Cooper's github comments.

Changes:
-reorder and cleanup requires as suggested by Gregory
-apply Dr.Racket indentation.
Discussion at:
#138
  • Loading branch information...
1 parent 5a8618a commit 06dd61afaecdd94089d3702a8983fe53354e9d71 @paddymahoney paddymahoney committed with ghcooper Aug 23, 2012
Showing with 378 additions and 386 deletions.
  1. +378 −386 collects/frtime/animation.rkt
View
764 collects/frtime/animation.rkt
@@ -1,386 +1,378 @@
-(module animation frtime
-
- (require (except-in frtime/animation/graphics
- make-posn posn-x posn-y make-rgb)
- (for-syntax racket/base (only-in racket/function identity))
- (lifted (only-in frtime/animation/graphics posn-x)
- posn-x)
- (lifted (only-in frtime/animation/graphics posn-y)
- posn-y)
- (lifted (only-in frtime/animation/graphics make-posn)
- make-posn)
- (lifted (only-in frtime/animation/graphics make-rgb) make-rgb)
-
- racket/match
- (as-is:unchecked frtime/lang-ext lift)
- racket/class
- frtime/frlibs/list
- frtime/frlibs/math)
-
- (require (for-syntax (only-in racket/base build-list)
- (only-in racket/function identity)))
-
- (open-graphics)
-
- (define fresh-anim
- (let ([first #t])
- (lambda ([x 400] [y 400] [title "Animation - DrRacket"])
- (if first
- (set! first #f)
- (begin
- (set! window
- (open-viewport title x y))
-
- (set! pixmap
- (open-pixmap "" x y))
-
- (set! mouse-pos
- (hold ((viewport-mouse-events window)
- . ==> .
- (lambda (ev) (make-posn
- (send ev get-x)
- (send ev get-y))))
- (query-mouse-posn window)))
-
- (set! key-strokes ((viewport-key-events window) . ==> . sixkey-value))
-
- (set! left-clicks ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-down? 'left))))
- (set! middle-clicks ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-down? 'middle))))
- (set! right-clicks ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-down? 'right)))))))))
-
- (define window
- (open-viewport "Animation - DrRacket" 400 400))
-
- (define pixmap
- (open-pixmap "" 400 400))
-
- (define mouse-pos
- (hold ((viewport-mouse-events window)
- . =#=> .
- (lambda (ev) (if (send ev moving?)
- (make-posn
- (send ev get-x)
- (send ev get-y))
- nothing)))
- (query-mouse-posn window)))
-
- (define filtered-keys (viewport-key-events window))
- (define shift-down (hold (filtered-keys . ==> . sixkey-shift)))
- (define control-down (hold (filtered-keys . ==> . sixkey-control)))
- (define meta-down (hold (filtered-keys . ==> . sixkey-meta)))
- (define alt-down (hold (filtered-keys . ==> . sixkey-alt)))
- (define key-strokes ((viewport-key-events window) . ==> . sixkey-value))
- (define left-clicks ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-down? 'left))))
- (define middle-clicks ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-down? 'middle))))
- (define right-clicks ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-down? 'right))))
- (define left-releases ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-up? 'left))))
- (define middle-releases ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-up? 'middle))))
- (define right-releases ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-up? 'right))))
-
- (define-syntax (define-shape-struct stx)
- (syntax-case stx ()
- [(_ name (field ...))
- (with-syntax
- ([ctor-name (datum->syntax stx (string->symbol (format "make-~a" (syntax-e #'name))))]
- [(accessor-name ...)
- (map (lambda (fd)
- (string->symbol (format "~a-~a" (syntax-e #'name) (syntax-e fd))))
- (syntax-e #'(field ...)))]
- [(index ...)
- (build-list (length (syntax-e #'(field ...))) identity)])
- #'(begin
- (define (ctor-name field ...)
- (vector 'name field ...))
- (define (accessor-name obj)
- (vector-ref obj index))
- ...))]))
-
- (define-struct ring (center radius color))
- (define-struct solid-ellipse (ul w h color))
- (define-struct graph-string (pos text color))
- (define-struct line (p1 p2 color))
- (define-struct rect (ul w h color))
- (define-struct rrect (ur w h color))
- (define-struct curve (xmin xmax ymin ymax fn))
- (define-struct polygon (posn-list posn color))
- (define-struct solid-polygon (posn-list posn color))
- (define-struct arc (pos width height start-radians end-radians color))
- (define-struct solid-arc (pos width height start-radians end-radians color))
- (define-struct image (pos renderer))
-
- (define (prep-image file)
- (draw-pixmap-posn file))
-
- (define (make-circle center r color)
- (make-solid-ellipse (make-posn (- (posn-x center) r)
- (- (posn-y center) r))
- (* 2 r) (* 2 r) color))
-
- (define l (new-cell empty))
-
- (define (display-shapes x)
- (set-cell! l x))
-
- (define (top-level-draw-list a-los)
- (compound-lift
- (lambda (vn)
- ((clear-viewport pixmap))
- (draw-list a-los vn)
- (copy-viewport pixmap window))))
-
- (define (my-for-each proc lst v-n)
- (let ([lst (v-n lst)])
- (if (empty? lst)
- (void)
- (begin
- (proc (v-n (first lst)))
- (my-for-each proc (rest lst) v-n)))))
-
- (define (draw-list a-los v-n)
- (let loop ([a-los a-los])
- (my-for-each
- (lambda (v)
- (match (v-n v)
- [(? undefined?) (void)]
- [(ring center radius color)
- (let ([center (v-n center)]
- [radius (v-n radius)]
- [color (v-n color)])
- (unless (or (undefined? center)
- (undefined? radius))
- ((draw-ellipse pixmap)
- (make-posn (- (v-n (posn-x center)) radius)
- (- (v-n (posn-y center)) radius))
- (* 2 radius)
- (* 2 radius)
- (if (undefined? color) "black" color))))]
- [(arc pos width height start-radians end-radians color)
- (let ([pos (v-n pos)]
- [width (v-n width)]
- [height (v-n height)]
- [start-radians (v-n start-radians)]
- [end-radians (v-n end-radians)])
- ((draw-arc pixmap) pos width height start-radians end-radians color))]
- [(solid-arc pos width height start-radians end-radians color)
- (let ([pos (v-n pos)]
- [width (v-n width)]
- [height (v-n height)]
- [start-radians (v-n start-radians)]
- [end-radians (v-n end-radians)])
- ((draw-solid-arc pixmap) pos width height start-radians end-radians color))]
- [(image pos renderer)
- (let ([renderer (v-n renderer)]
- [pos (v-n pos)])
- ((renderer pixmap) pos))]
- [(solid-ellipse ul w h color)
- (let ([ul (v-n ul)]
- [w (v-n w)]
- [h (v-n h)]
- [color (v-n color)])
- (unless (or (undefined? ul)
- (undefined? w)
- (undefined? h))
- ((draw-solid-ellipse pixmap) ul w h (if (undefined? color) "black" color))))]
- [(graph-string pos text color) ((draw-string pixmap) (v-n pos) (v-n text) (v-n color))]
- [(line p1 p2 color)
- (let ([p1 (v-n p1)]
- [p2 (v-n p2)]
- [color (v-n color)])
- (unless (or (undefined? p1)
- (undefined? p2))
- ((draw-line pixmap) p1 p2 (if (undefined? color) "black" color))))]
- [(rect ul w h color)
- (let ([ul (v-n ul)]
- [w (v-n w)]
- [h (v-n h)]
- [color (v-n color)])
- (cond
- [(and (>= w 0) (>= h 0)) ((draw-solid-rectangle pixmap) ul w h color)]
- [(>= h 0) ((draw-solid-rectangle pixmap) (make-posn (+ (posn-x ul) w) (posn-y ul)) (- w) h color)]
- [(>= w 0) ((draw-solid-rectangle pixmap) (make-posn (posn-x ul) (+ (posn-y ul) h)) w (- h) color)]
- [else ((draw-solid-rectangle pixmap) (make-posn (+ (posn-x ul) w) (+ (posn-y ul) h)) (- w) (- h) color)]))]
- [(polygon pts offset color) ((draw-polygon pixmap) pts offset color)]
- [(solid-polygon pts offset color) ((draw-solid-polygon pixmap) pts offset color)]
- [(? list? x) (loop (v-n x))]
- [(? void?) (void)]))
- a-los v-n)))
-
- (define d (top-level-draw-list l))
-
- (define-struct graph-color (fn xmin xmax ymin ymax))
-
- (define (draw-graph-color pm gc)
- (let ([dp (draw-pixel pm)])
- (match gc
- [(graph-color fn xmin xmax ymin ymax)
- (let ([xincr (/ (- xmax xmin) 300)]
- [yincr (/ (- ymax ymin) 300)])
- (let loop ([i 50] [y ymin])
- (let loop ([j 50] [x xmin])
- (dp (make-posn j i) (fn x y))
- (when (< j 350)
- (loop (add1 j) (+ x xincr))))
- (when (< i 350)
- (loop (add1 i) (+ y yincr)))))])))
-
- (define (valid-posn? v)
- (and (posn? v) (number? (posn-x v)) (number? (posn-y v))))
-
-
-
- (define (key sym)
- (key-strokes
- . =#> .
- (lambda (x) (eq? x (value-now sym)))))
-
- (define (draw vp pm posl)
- ((clear-viewport pm))
- (for-each (lambda (elt)
- (cond
- [(graph-color? elt) (draw-graph-color pm elt)]
- [(string? elt) ((draw-string pm) (make-posn 8 20) elt)]
- [(valid-posn? elt) ((draw-solid-ellipse pm)
- (make-posn (- (posn-x elt) 10)
- (- (posn-y elt) 10))
- 20 20
- (make-rgb 0 .6 .6))]
- [(and (cons? elt)
- (valid-posn? (first elt))
- (valid-posn? (rest elt))) ((draw-line pm)
- (first elt)
- (rest elt)
- "black")]
- [else (void)])) posl)
- (copy-viewport pm vp))
-
- #|
- (define foldl
- (case-lambda
- [(f i l) (if (cons? l)
- (foldl f (f (first l) i) (rest l))
- i)]))
- |#
-
- (define (drop n l)
- (if (empty? l)
- empty
- (if (<= n 0)
- l
- (drop (sub1 n) (rest l)))))
-
- (define (inc-max n)
- (lambda (x) (if (>= x n)
- n
- (add1 x))))
-
- (define (dec-min n)
- (lambda (x) (if (<= x n)
- n
- (sub1 x))))
-
- (define (fix-rgb r g b)
- (let ([fix (lambda (n) (min 1 (max 0 n)))])
- (apply make-rgb (map fix (list r g b)))))
-
- (define range-control
- (lambda (up down limit [init 0])
- (accum-b
- (merge-e (up . -=> . (inc-max limit))
- (down . -=> . (dec-min 0)))
- init)))
-
- (define (keyboard-control up down limit)
- (accum-b
- (key-strokes
- . =#=> .
- (match-lambda
- [(? (lambda (x) (eq? x up))) (inc-max limit)]
- [(? (lambda (x) (eq? x down))) (dec-min 0)]
- [_ nothing]))
- 0))
-
- (define-struct wave-state (hz offset))
-
- (define (wave hz)
- (let* ([state (collect-b
- (snapshot-e (changes hz) milliseconds)
- (make-wave-state (value-now hz) 0)
- (lambda (new-freq+time old-state)
- (match new-freq+time
- [(list h1 t)
- (match old-state
- [(wave-state h0 o0)
- (make-wave-state
- h1
- (+ o0 (* .002 pi t (- h0 h1))))])])))])
- (+ (lift #f wave-state-offset state)
- (* milliseconds pi (lift #f wave-state-hz state) .002))))
-
- (define (current-and-last-value signal)
- (let ([init (value-now signal)])
- (collect-b (changes signal)
- (list init init)
- (lambda (new-value previous-two)
- (list new-value (first previous-two))))))
-
- (define (last-value signal)
- (second (current-and-last-value signal)))
-
-; (define (last-value signal)
-; (let ([init (value-now signal)])
-; (rest
-; (collect-b (changes signal)
-; (cons init init)
-; (lambda (new old-pair)
-; (cons new (first old-pair)))))))
-
- (define (posn+ . args)
- (make-posn (apply + (map posn-x args))
- (apply + (map posn-y args))))
-
- (define (posn- . args)
- (make-posn (apply - (map posn-x args))
- (apply - (map posn-y args))))
-
- (define (posn/ p s)
- (make-posn (/ (posn-x p) s)
- (/ (posn-y p) s)))
-
- (define (posn* p s)
- (make-posn (* (posn-x p) s)
- (* (posn-y p) s)))
-
- (define (posn-dot p1 p2)
- (+ (* (posn-x p1) (posn-x p2))
- (* (posn-y p1) (posn-y p2))))
-
- (define (posn-len p)
- (sqrt (+ (sqr (posn-x p)) (sqr (posn-y p)))))
-
- (define (normalize p)
- (posn/ p (posn-len p)))
-
- (define (current-mouse-pos)
- (value-now mouse-pos))
-
- (define (clip x lo hi)
- (if (< x lo)
- lo
- (if (> x hi)
- hi
- x)))
-
- (define (posn-diff p1 p2)
- (sqrt (+ (sqr (- (posn-x p1) (posn-x p2)))
- (sqr (- (posn-y p1) (posn-y p2))))))
-
- (define (posn-derivative p)
- (make-posn (derivative (posn-x p)) (derivative (posn-y p))))
-
- (define (posn-integral p)
- (make-posn (integral (posn-x p)) (integral (posn-y p))))
-
- (provide
- (except-out (all-defined-out) pixmap window draw-list l d
- make-wave-state wave-state-hz wave-state-offset)
- (all-from-out frtime/animation/graphics)))
+(module animation frtime
+
+ (require (for-syntax racket/base (only-in racket/function identity))
+ racket/match
+ racket/class
+ (except-in frtime/animation/graphics make-posn posn-x posn-y make-rgb)
+ (lifted (only-in frtime/animation/graphics posn-x) posn-x)
+ (lifted (only-in frtime/animation/graphics posn-y) posn-y)
+ (lifted (only-in frtime/animation/graphics make-posn) make-posn)
+ (lifted (only-in frtime/animation/graphics make-rgb) make-rgb)
+ (as-is:unchecked frtime/lang-ext lift)
+ frtime/frlibs/list
+ frtime/frlibs/math)
+
+ (open-graphics)
+
+ (define fresh-anim
+ (let ([first #t])
+ (lambda ([x 400] [y 400] [title "Animation - DrRacket"])
+ (if first
+ (set! first #f)
+ (begin
+ (set! window
+ (open-viewport title x y))
+
+ (set! pixmap
+ (open-pixmap "" x y))
+
+ (set! mouse-pos
+ (hold ((viewport-mouse-events window)
+ . ==> .
+ (lambda (ev) (make-posn
+ (send ev get-x)
+ (send ev get-y))))
+ (query-mouse-posn window)))
+
+ (set! key-strokes ((viewport-key-events window) . ==> . sixkey-value))
+
+ (set! left-clicks ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-down? 'left))))
+ (set! middle-clicks ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-down? 'middle))))
+ (set! right-clicks ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-down? 'right)))))))))
+
+ (define window
+ (open-viewport "Animation - DrRacket" 400 400))
+
+ (define pixmap
+ (open-pixmap "" 400 400))
+
+ (define mouse-pos
+ (hold ((viewport-mouse-events window)
+ . =#=> .
+ (lambda (ev) (if (send ev moving?)
+ (make-posn
+ (send ev get-x)
+ (send ev get-y))
+ nothing)))
+ (query-mouse-posn window)))
+
+ (define filtered-keys (viewport-key-events window))
+ (define shift-down (hold (filtered-keys . ==> . sixkey-shift)))
+ (define control-down (hold (filtered-keys . ==> . sixkey-control)))
+ (define meta-down (hold (filtered-keys . ==> . sixkey-meta)))
+ (define alt-down (hold (filtered-keys . ==> . sixkey-alt)))
+ (define key-strokes ((viewport-key-events window) . ==> . sixkey-value))
+ (define left-clicks ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-down? 'left))))
+ (define middle-clicks ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-down? 'middle))))
+ (define right-clicks ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-down? 'right))))
+ (define left-releases ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-up? 'left))))
+ (define middle-releases ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-up? 'middle))))
+ (define right-releases ((viewport-mouse-events window) . =#> . (lambda (ev) (send ev button-up? 'right))))
+
+ (define-syntax (define-shape-struct stx)
+ (syntax-case stx ()
+ [(_ name (field ...))
+ (with-syntax
+ ([ctor-name (datum->syntax stx (string->symbol (format "make-~a" (syntax-e #'name))))]
+ [(accessor-name ...)
+ (map (lambda (fd)
+ (string->symbol (format "~a-~a" (syntax-e #'name) (syntax-e fd))))
+ (syntax-e #'(field ...)))]
+ [(index ...)
+ (build-list (length (syntax-e #'(field ...))) identity)])
+ #'(begin
+ (define (ctor-name field ...)
+ (vector 'name field ...))
+ (define (accessor-name obj)
+ (vector-ref obj index))
+ ...))]))
+
+ (define-struct ring (center radius color))
+ (define-struct solid-ellipse (ul w h color))
+ (define-struct graph-string (pos text color))
+ (define-struct line (p1 p2 color))
+ (define-struct rect (ul w h color))
+ (define-struct rrect (ur w h color))
+ (define-struct curve (xmin xmax ymin ymax fn))
+ (define-struct polygon (posn-list posn color))
+ (define-struct solid-polygon (posn-list posn color))
+ (define-struct arc (pos width height start-radians end-radians color))
+ (define-struct solid-arc (pos width height start-radians end-radians color))
+ (define-struct image (pos renderer))
+
+ (define (prep-image file)
+ (draw-pixmap-posn file))
+
+ (define (make-circle center r color)
+ (make-solid-ellipse (make-posn (- (posn-x center) r)
+ (- (posn-y center) r))
+ (* 2 r) (* 2 r) color))
+
+ (define l (new-cell empty))
+
+ (define (display-shapes x)
+ (set-cell! l x))
+
+ (define (top-level-draw-list a-los)
+ (compound-lift
+ (lambda (vn)
+ ((clear-viewport pixmap))
+ (draw-list a-los vn)
+ (copy-viewport pixmap window))))
+
+ (define (my-for-each proc lst v-n)
+ (let ([lst (v-n lst)])
+ (if (empty? lst)
+ (void)
+ (begin
+ (proc (v-n (first lst)))
+ (my-for-each proc (rest lst) v-n)))))
+
+ (define (draw-list a-los v-n)
+ (let loop ([a-los a-los])
+ (my-for-each
+ (lambda (v)
+ (match (v-n v)
+ [(? undefined?) (void)]
+ [(ring center radius color)
+ (let ([center (v-n center)]
+ [radius (v-n radius)]
+ [color (v-n color)])
+ (unless (or (undefined? center)
+ (undefined? radius))
+ ((draw-ellipse pixmap)
+ (make-posn (- (v-n (posn-x center)) radius)
+ (- (v-n (posn-y center)) radius))
+ (* 2 radius)
+ (* 2 radius)
+ (if (undefined? color) "black" color))))]
+ [(arc pos width height start-radians end-radians color)
+ (let ([pos (v-n pos)]
+ [width (v-n width)]
+ [height (v-n height)]
+ [start-radians (v-n start-radians)]
+ [end-radians (v-n end-radians)])
+ ((draw-arc pixmap) pos width height start-radians end-radians color))]
+ [(solid-arc pos width height start-radians end-radians color)
+ (let ([pos (v-n pos)]
+ [width (v-n width)]
+ [height (v-n height)]
+ [start-radians (v-n start-radians)]
+ [end-radians (v-n end-radians)])
+ ((draw-solid-arc pixmap) pos width height start-radians end-radians color))]
+ [(image pos renderer)
+ (let ([renderer (v-n renderer)]
+ [pos (v-n pos)])
+ ((renderer pixmap) pos))]
+ [(solid-ellipse ul w h color)
+ (let ([ul (v-n ul)]
+ [w (v-n w)]
+ [h (v-n h)]
+ [color (v-n color)])
+ (unless (or (undefined? ul)
+ (undefined? w)
+ (undefined? h))
+ ((draw-solid-ellipse pixmap) ul w h (if (undefined? color) "black" color))))]
+ [(graph-string pos text color) ((draw-string pixmap) (v-n pos) (v-n text) (v-n color))]
+ [(line p1 p2 color)
+ (let ([p1 (v-n p1)]
+ [p2 (v-n p2)]
+ [color (v-n color)])
+ (unless (or (undefined? p1)
+ (undefined? p2))
+ ((draw-line pixmap) p1 p2 (if (undefined? color) "black" color))))]
+ [(rect ul w h color)
+ (let ([ul (v-n ul)]
+ [w (v-n w)]
+ [h (v-n h)]
+ [color (v-n color)])
+ (cond
+ [(and (>= w 0) (>= h 0)) ((draw-solid-rectangle pixmap) ul w h color)]
+ [(>= h 0) ((draw-solid-rectangle pixmap) (make-posn (+ (posn-x ul) w) (posn-y ul)) (- w) h color)]
+ [(>= w 0) ((draw-solid-rectangle pixmap) (make-posn (posn-x ul) (+ (posn-y ul) h)) w (- h) color)]
+ [else ((draw-solid-rectangle pixmap) (make-posn (+ (posn-x ul) w) (+ (posn-y ul) h)) (- w) (- h) color)]))]
+ [(polygon pts offset color) ((draw-polygon pixmap) pts offset color)]
+ [(solid-polygon pts offset color) ((draw-solid-polygon pixmap) pts offset color)]
+ [(? list? x) (loop (v-n x))]
+ [(? void?) (void)]))
+ a-los v-n)))
+
+ (define d (top-level-draw-list l))
+
+ (define-struct graph-color (fn xmin xmax ymin ymax))
+
+ (define (draw-graph-color pm gc)
+ (let ([dp (draw-pixel pm)])
+ (match gc
+ [(graph-color fn xmin xmax ymin ymax)
+ (let ([xincr (/ (- xmax xmin) 300)]
+ [yincr (/ (- ymax ymin) 300)])
+ (let loop ([i 50] [y ymin])
+ (let loop ([j 50] [x xmin])
+ (dp (make-posn j i) (fn x y))
+ (when (< j 350)
+ (loop (add1 j) (+ x xincr))))
+ (when (< i 350)
+ (loop (add1 i) (+ y yincr)))))])))
+
+ (define (valid-posn? v)
+ (and (posn? v) (number? (posn-x v)) (number? (posn-y v))))
+
+
+
+ (define (key sym)
+ (key-strokes
+ . =#> .
+ (lambda (x) (eq? x (value-now sym)))))
+
+ (define (draw vp pm posl)
+ ((clear-viewport pm))
+ (for-each (lambda (elt)
+ (cond
+ [(graph-color? elt) (draw-graph-color pm elt)]
+ [(string? elt) ((draw-string pm) (make-posn 8 20) elt)]
+ [(valid-posn? elt) ((draw-solid-ellipse pm)
+ (make-posn (- (posn-x elt) 10)
+ (- (posn-y elt) 10))
+ 20 20
+ (make-rgb 0 .6 .6))]
+ [(and (cons? elt)
+ (valid-posn? (first elt))
+ (valid-posn? (rest elt))) ((draw-line pm)
+ (first elt)
+ (rest elt)
+ "black")]
+ [else (void)])) posl)
+ (copy-viewport pm vp))
+
+ #|
+ (define foldl
+ (case-lambda
+ [(f i l) (if (cons? l)
+ (foldl f (f (first l) i) (rest l))
+ i)]))
+ |#
+
+ (define (drop n l)
+ (if (empty? l)
+ empty
+ (if (<= n 0)
+ l
+ (drop (sub1 n) (rest l)))))
+
+ (define (inc-max n)
+ (lambda (x) (if (>= x n)
+ n
+ (add1 x))))
+
+ (define (dec-min n)
+ (lambda (x) (if (<= x n)
+ n
+ (sub1 x))))
+
+ (define (fix-rgb r g b)
+ (let ([fix (lambda (n) (min 1 (max 0 n)))])
+ (apply make-rgb (map fix (list r g b)))))
+
+ (define range-control
+ (lambda (up down limit [init 0])
+ (accum-b
+ (merge-e (up . -=> . (inc-max limit))
+ (down . -=> . (dec-min 0)))
+ init)))
+
+ (define (keyboard-control up down limit)
+ (accum-b
+ (key-strokes
+ . =#=> .
+ (match-lambda
+ [(? (lambda (x) (eq? x up))) (inc-max limit)]
+ [(? (lambda (x) (eq? x down))) (dec-min 0)]
+ [_ nothing]))
+ 0))
+
+ (define-struct wave-state (hz offset))
+
+ (define (wave hz)
+ (let* ([state (collect-b
+ (snapshot-e (changes hz) milliseconds)
+ (make-wave-state (value-now hz) 0)
+ (lambda (new-freq+time old-state)
+ (match new-freq+time
+ [(list h1 t)
+ (match old-state
+ [(wave-state h0 o0)
+ (make-wave-state
+ h1
+ (+ o0 (* .002 pi t (- h0 h1))))])])))])
+ (+ (lift #f wave-state-offset state)
+ (* milliseconds pi (lift #f wave-state-hz state) .002))))
+
+ (define (current-and-last-value signal)
+ (let ([init (value-now signal)])
+ (collect-b (changes signal)
+ (list init init)
+ (lambda (new-value previous-two)
+ (list new-value (first previous-two))))))
+
+ (define (last-value signal)
+ (second (current-and-last-value signal)))
+
+ ; (define (last-value signal)
+ ; (let ([init (value-now signal)])
+ ; (rest
+ ; (collect-b (changes signal)
+ ; (cons init init)
+ ; (lambda (new old-pair)
+ ; (cons new (first old-pair)))))))
+
+ (define (posn+ . args)
+ (make-posn (apply + (map posn-x args))
+ (apply + (map posn-y args))))
+
+ (define (posn- . args)
+ (make-posn (apply - (map posn-x args))
+ (apply - (map posn-y args))))
+
+ (define (posn/ p s)
+ (make-posn (/ (posn-x p) s)
+ (/ (posn-y p) s)))
+
+ (define (posn* p s)
+ (make-posn (* (posn-x p) s)
+ (* (posn-y p) s)))
+
+ (define (posn-dot p1 p2)
+ (+ (* (posn-x p1) (posn-x p2))
+ (* (posn-y p1) (posn-y p2))))
+
+ (define (posn-len p)
+ (sqrt (+ (sqr (posn-x p)) (sqr (posn-y p)))))
+
+ (define (normalize p)
+ (posn/ p (posn-len p)))
+
+ (define (current-mouse-pos)
+ (value-now mouse-pos))
+
+ (define (clip x lo hi)
+ (if (< x lo)
+ lo
+ (if (> x hi)
+ hi
+ x)))
+
+ (define (posn-diff p1 p2)
+ (sqrt (+ (sqr (- (posn-x p1) (posn-x p2)))
+ (sqr (- (posn-y p1) (posn-y p2))))))
+
+ (define (posn-derivative p)
+ (make-posn (derivative (posn-x p)) (derivative (posn-y p))))
+
+ (define (posn-integral p)
+ (make-posn (integral (posn-x p)) (integral (posn-y p))))
+
+ (provide
+ (except-out (all-defined-out) pixmap window draw-list l d
+ make-wave-state wave-state-hz wave-state-offset)
+ (all-from-out frtime/animation/graphics)))

0 comments on commit 06dd61a

Please sign in to comment.