syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Actually-runnable syndicate/actor big-bang example.

This commit is contained in:
Tony Garnock-Jones 2016-06-14 03:49:47 -04:00
parent f21e58dacb
commit b857ce7bcd
1 changed files with 28 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
racket/doc/big-bang.rkt.txt
View File

@ -1,7 +1,8 @@
#lang racket ;; -*- racket -*-
(require "../main.rkt")
(require "../big-bang.rkt")
(require (only-in syndicate seal))
(require syndicate/actor)
(require syndicate/big-bang)
(define (button #:background [background "grey"]
#:foreground [foreground "white"]
@ -9,40 +10,46 @@
name x y label callback)
(define label-image (text label font-size foreground))
(actor (forever
(on (message (at-meta (mouse-event ? ? name "button-down"))) (callback))
(on (message (mouse-event _ _ name "button-down") #:meta-level 1) (callback))
(assert (window name x y 0
(seal
(overlay label-image
(rectangle (+ (image-width label-image) 20)
(+ (image-height label-image) 20)
"solid"
background))))))))
background))))
#:meta-level 1))))
(define (draggable-shape name orig-x orig-y image)
(define (move-to x y) (assert (update-window name x y image #:z 10)))
(define (window-at x y) (window name x y 10 (seal image)))
(define (mouse-left-event-type? t) (member t '("leave" "button-up")))
(define (idle ticks x y)
(state [#:collect [(ticks ticks) (x x) (y y)]
(move-to x y)
(on (message (at-meta (tick-event)))
(define new-ticks (+ ticks 1))
(define displacement (* (cos (* new-ticks 10 1/180 pi)) 4))
(values new-ticks x (+ y displacement)))]
[(message (at-meta (mouse-event mx my name "button-down")))
(dragging mx my (- mx x) (- my y))]))
;; TODO: Once "tail-calls" between `state`s are fixed, remove the
;; ugly returning-of-an-immediately-called-thunk-from-the-
;; termination-handlers here and in `dragging`.
((state [#:collect [(ticks ticks) (x x) (y y)]
(assert (window-at x y) #:meta-level 1)
(on (message (tick-event) #:meta-level 1)
(define new-ticks (+ ticks 1))
(define displacement (* (cos (* new-ticks 10 1/180 pi)) 4))
(values new-ticks x (+ y displacement)))]
[(message (mouse-event $mx $my name "button-down") #:meta-level 1)
(lambda () (dragging mx my (- mx x) (- my y)))])))
(define (dragging mx my dx dy)
(state [#:collect [(mx mx) (my my)]
(move-to (- mx dx) (- my dy))
(on (message (at-meta (mouse-event mx my ? "drag"))) (values mx my))]
[(message (at-meta (mouse-event mx my ? (or "leave" "button-up"))))
(idle 0 (- mx dx) (- my dy))]))
((state [#:collect [(mx mx) (my my)]
(assert (window-at (- mx dx) (- my dy)) #:meta-level 1)
(on (message (mouse-event $mx $my _ "drag") #:meta-level 1) (values mx my))]
[(message (mouse-event $mx $my _ (? mouse-left-event-type? $t)) #:meta-level 1)
(lambda () (idle 0 (- mx dx) (- my dy)))])))
(actor (idle 0 orig-x orig-y)))
(big-bang-dataspace #:width 640
#:height 480
(actor (forever
(on (asserted (active-window $id) #:meta-level 1)
(update-window 'active-window-label 300 0
(text (format "~v" id) 22 "black")))))
(during (active-window $id) #:meta-level 1
(assert (window 'active-window-label 300 0 0
(seal (text (format "~v" id) 22 "black")))
#:meta-level 1))))
(button #:background "red" 'stop-button 0 0 "Exit"
(lambda () (assert! 'stop #:meta-level 1)))
(draggable-shape 'c1 50 50 (circle 30 "solid" "orange"))