52 lines
2.3 KiB
Racket
52 lines
2.3 KiB
Racket
#lang racket ;; -*- racket -*-
|
|
|
|
(require "../main.rkt")
|
|
(require "../big-bang.rkt")
|
|
|
|
(define (button #:background [background "grey"]
|
|
#:foreground [foreground "white"]
|
|
#:font-size [font-size 22]
|
|
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))
|
|
(assert (window name x y 0
|
|
(seal
|
|
(overlay label-image
|
|
(rectangle (+ (image-width label-image) 20)
|
|
(+ (image-height label-image) 20)
|
|
"solid"
|
|
background))))))))
|
|
|
|
(define (draggable-shape name orig-x orig-y image)
|
|
(define (move-to x y) (assert (update-window name x y image #:z 10)))
|
|
(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))]))
|
|
(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))]))
|
|
(actor (idle 0 orig-x orig-y)))
|
|
|
|
(big-bang-network #: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")))))
|
|
(button #:background "red" 'stop-button 0 0 "Exit"
|
|
(lambda () (assert! 'stop #:meta-level 1)))
|
|
(draggable-shape 'c1 50 50 (circle 30 "solid" "orange"))
|
|
(draggable-shape 's1 100 100 (star 40 "solid" "firebrick")))
|
|
|
|
(exit 0)
|