71 lines
3.3 KiB
Racket
71 lines
3.3 KiB
Racket
#lang 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)
|
|
(spawn (lambda (e s)
|
|
(match e
|
|
[(message (at-meta (mouse-event _ _ _ "button-down"))) (transition s (callback))]
|
|
[_ #f]))
|
|
(void)
|
|
(patch-seq
|
|
(let ((label-image (text label font-size foreground)))
|
|
(update-window name x y
|
|
(overlay label-image
|
|
(rectangle (+ (image-width label-image) 20)
|
|
(+ (image-height label-image) 20)
|
|
"solid"
|
|
background))))
|
|
(sub (mouse-event ? ? name ?) #:meta-level 1))))
|
|
|
|
(define (draggable-shape name orig-x orig-y image)
|
|
(struct idle (ticks x y) #:transparent)
|
|
(struct dragging (dx dy) #:transparent)
|
|
(define (move-to x y) (update-window name x y image #:z 10))
|
|
(define (mouse-sub active-pat)
|
|
(patch-seq (unsub (mouse-event ? ? ? ?) #:meta-level 1)
|
|
(sub (mouse-event ? ? active-pat ?) #:meta-level 1)))
|
|
(spawn (match-lambda**
|
|
[((message (at-meta (tick-event))) (idle ticks bx by))
|
|
(define new-ticks (+ ticks 1))
|
|
(define displacement (* (cos (* new-ticks 10 1/180 pi)) 4))
|
|
(define new-y (+ by displacement))
|
|
(transition (idle new-ticks bx new-y)
|
|
(move-to bx new-y))]
|
|
[((message (at-meta (mouse-event mx my _ "button-down"))) (idle _ bx by))
|
|
(transition (dragging (- mx bx) (- my by)) (mouse-sub ?))]
|
|
[((message (at-meta (mouse-event mx my _ "drag"))) (dragging dx dy))
|
|
(transition (dragging dx dy) (move-to (- mx dx) (- my dy)))]
|
|
[((message (at-meta (mouse-event mx my _ (or "leave" "button-up")))) (dragging dx dy))
|
|
(transition (idle 0 (- mx dx) (- my dy))
|
|
(list (move-to (- mx dx) (- my dy))
|
|
(mouse-sub name)))]
|
|
[(_ _) #f])
|
|
(idle 0 orig-x orig-y)
|
|
(patch-seq (sub (tick-event) #:meta-level 1)
|
|
(mouse-sub name)
|
|
(move-to orig-x orig-y))))
|
|
|
|
(big-bang-network #:width 640
|
|
#:height 480
|
|
(spawn (lambda (e s)
|
|
(match e
|
|
[(? patch? p)
|
|
(define-values (in out)
|
|
(patch-project/set/single p (at-meta (?! (active-window ?)))))
|
|
(transition s (update-window 'active-window-label 300 0
|
|
(text (format "~v" in) 22 "black")))]
|
|
[_ #f]))
|
|
(void)
|
|
(sub (active-window ?) #: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"))
|
|
(draggable-shape 's1 100 100 (star 40 "solid" "firebrick")))
|
|
|
|
(exit 0)
|