-
Notifications
You must be signed in to change notification settings - Fork 2
/
Copy path3.rkt
executable file
·122 lines (105 loc) · 3.51 KB
/
3.rkt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
#!/usr/bin/env racket
#lang racket
(require racket/match)
(require "sracket.rkt")
(require "ground-scheme.rkt")
(require "grand-syntax.rkt")
(slayer-init #:title "GRASP 3: draggable rectangles with draggable rectangles\
that can be taken outside")
(define (screen-size)
`(640 480))
(keydn 'escape exit)
(define ((_ . message) _)
(apply _ message))
(define (set-stage! stage)
(set-display-procedure! (lambda () (draw-image! (stage 'as-image))))
(mousemove (lambda (x y dx dy) (stage 'mouse-move x y dx dy)))
(keydn 'mouse-left (lambda (x y) (stage 'mouse-down x y)))
(keyup 'mouse-left (lambda (x y) (stage 'mouse-up x y))))
(define (box #:left left #:top top #:width width #:height height
#:background-color color . elements)
(let ((dragged-element #false)
(hovered-element #false)
(image (rectangle width height color)))
(define (self . message)
(match message
(`(position) `(,left ,top))
(`(move-by! ,dx ,dy)
(set! left (+ left dx))
(set! top (+ top dy)))
(`(mouse-down ,x ,y)
(let ((acquired (self 'acquire-hovered-element!)))
(when acquired
(set! dragged-element acquired))))
(`(mouse-up ,x ,y)
(when dragged-element
(self 'install-element! dragged-element)
(set! dragged-element #false))
(self 'mouse-move x y 0 0)
(when hovered-element
(hovered-element 'mouse-up (- x left) (- y top))))
(`(acquire-hovered-element!)
(and hovered-element
(or (and-let* ((acquired (hovered-element
'acquire-hovered-element!))
(`(,x ,y) (hovered-element 'position)))
(acquired 'move-by! x y)
acquired)
(let ((acquired hovered-element))
(set! hovered-element #false)
(set! elements (filter (lambda (_) (isnt _ eq? acquired))
elements))
acquired))))
(`(install-element! ,element)
(if hovered-element
(let ((`(,x ,y) (hovered-element 'position)))
(element 'move-by! (- x) (- y))
(hovered-element 'install-element! element))
(set! elements `(,element . ,elements))))
(`(mouse-move ,x ,y ,dx ,dy)
(when dragged-element
(dragged-element 'move-by! dx dy))
(let ((hovered (find (_ 'embraces? (- x left) (- y top))
elements)))
(unless (eq? hovered hovered-element)
(when hovered-element
(hovered-element 'mouse-out))
(when hovered
(hovered 'mouse-over))
(set! hovered-element hovered))
(when hovered
(hovered 'mouse-move (- x left) (- y top) dx dy))))
(`(embraces? ,x ,y) (and (is left <= x <= (+ left width))
(is top <= y <= (+ top height))))
(`(as-image)
(fill-image! image color)
(fold-right (lambda (element image)
(let ((`(,x ,y) (element 'position)))
(draw-image! (element 'as-image) x y image)
image))
image
`(,@(if dragged-element
`(,dragged-element)
'())
,@elements)))
(`(mouse-over)
(out "mouse-over "self))
(`(mouse-out)
(out "mouse-out "self)))
)
self))
(define stage
(let ((`(,w ,h) (screen-size)))
(box #:left 0 #:top 0 #:width w #:height h
#:background-color #x77000000
(box #:left 10 #:top 10 #:width 200 #:height 200
#:background-color #x77cc00
(box #:left 10 #:top 10 #:width 50 #:height 50
#:background-color #x0077cc)
(box #:left 140 #:top 140 #:width 50 #:height 50
#:background-color #xcc0077))
(box #:left (- w 210) #:top (- h 210) #:width 200 #:height 200
#:background-color #x7700cc
(box #:left 140 #:top 140 #:width 50 #:height 50
#:background-color #xcc7700)))))
(set-stage! stage)