Update big-bang.rkt to the new Syndicate/Racket HLL.
This commit is contained in:
parent
8ca2b1ac0c
commit
3bc95aeaeb
|
@ -23,6 +23,7 @@
|
||||||
asserted
|
asserted
|
||||||
retracted
|
retracted
|
||||||
rising-edge
|
rising-edge
|
||||||
|
(rename-out [core:message message])
|
||||||
|
|
||||||
suspend-script
|
suspend-script
|
||||||
|
|
||||||
|
@ -34,6 +35,8 @@
|
||||||
syndicate-effects-available?
|
syndicate-effects-available?
|
||||||
suspend-script*
|
suspend-script*
|
||||||
|
|
||||||
|
? ;; from pattern.rkt
|
||||||
|
|
||||||
;;
|
;;
|
||||||
|
|
||||||
schedule-action!
|
schedule-action!
|
||||||
|
|
|
@ -23,24 +23,27 @@
|
||||||
(define (draggable-shape name orig-x orig-y image)
|
(define (draggable-shape name orig-x orig-y image)
|
||||||
(define (window-at x y) (window name x y 10 (seal image)))
|
(define (window-at x y) (window name x y 10 (seal image)))
|
||||||
(define (mouse-left-event-type? t) (member t '("leave" "button-up")))
|
(define (mouse-left-event-type? t) (member t '("leave" "button-up")))
|
||||||
(define (idle ticks x y)
|
;;
|
||||||
;; TODO: Once "tail-calls" between `state`s are fixed, remove the
|
;; N.B. Currently (9 July 2016), fields are not properly
|
||||||
;; ugly returning-of-an-immediately-called-thunk-from-the-
|
;; garbage-collected on tail-calls between states, as you pick up
|
||||||
;; termination-handlers here and in `dragging`.
|
;; and put down shapes, you'll see their field-tables grow.
|
||||||
((state [#:collect [(ticks ticks) (x x) (y y)]
|
;;
|
||||||
(assert (window-at x y) #:meta-level 1)
|
(define (idle ticks0 x0 y0)
|
||||||
|
(react (field [ticks ticks0] [x x0] [y y0])
|
||||||
|
(assert (window-at (x) (y)) #:meta-level 1)
|
||||||
(on (message (tick-event) #:meta-level 1)
|
(on (message (tick-event) #:meta-level 1)
|
||||||
(define new-ticks (+ ticks 1))
|
(ticks (+ (ticks) 1))
|
||||||
(define displacement (* (cos (* new-ticks 10 1/180 pi)) 4))
|
(y (+ (y) (* (cos (* (ticks) 10 1/180 pi)) 4))))
|
||||||
(values new-ticks x (+ y displacement)))]
|
(stop-when (message (mouse-event $mx $my name "button-down") #:meta-level 1)
|
||||||
[(message (mouse-event $mx $my name "button-down") #:meta-level 1)
|
(dragging mx my (- mx (x)) (- my (y))))))
|
||||||
(lambda () (dragging mx my (- mx x) (- my y)))])))
|
(define (dragging mx0 my0 dx dy)
|
||||||
(define (dragging mx my dx dy)
|
(react (field [mx mx0] [my my0])
|
||||||
((state [#:collect [(mx mx) (my my)]
|
(assert (window-at (- (mx) dx) (- (my) dy)) #:meta-level 1)
|
||||||
(assert (window-at (- mx dx) (- my dy)) #:meta-level 1)
|
(on (message (mouse-event $nmx $nmy _ "drag") #:meta-level 1)
|
||||||
(on (message (mouse-event $mx $my _ "drag") #:meta-level 1) (values mx my))]
|
(mx nmx)
|
||||||
[(message (mouse-event $mx $my _ (? mouse-left-event-type? $t)) #:meta-level 1)
|
(my nmy))
|
||||||
(lambda () (idle 0 (- mx dx) (- my dy)))])))
|
(stop-when (message (mouse-event $mx $my _ (? mouse-left-event-type? $t)) #:meta-level 1)
|
||||||
|
(idle 0 (- mx dx) (- my dy)))))
|
||||||
(actor (idle 0 orig-x orig-y)))
|
(actor (idle 0 orig-x orig-y)))
|
||||||
|
|
||||||
(big-bang-dataspace #:width 640
|
(big-bang-dataspace #:width 640
|
||||||
|
|
Loading…
Reference in New Issue