blob: ded1e4140c9036e456b8d06c41a03e88771840e2 (
plain)
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
123
124
125
126
127
128
129
130
131
132
133
134
135
|
;;;; unit.lisp
(in-package #:wheelwork)
(def:class unit ()
(cached-model cached-projected-matrix cached-rectangle
:initform nil :documentation "internal caches")
((visiblep "Whether or not to render unit")
:prefix :type boolean :initform t)
((in-scene-p "Indicates if unit is considered for display & events")
:prefix :type boolean :initform nil)
((region "The screen region where this unit will be visible.")
:prefix :type region :initform *application*)
((base-height "Content's base height")
(base-width "Content's base width")
:ro :type float :initform 1.0)
((scale-x "Factor by which to resize base-width")
(scale-y "Factor by which to resize base-heght")
:type float :initform 1.0)
((rotation "Rotation in radians about objects' bounding box center")
(x "X position, → is positive direction")
(y "Y position, ↑ is positive direction")
:type float :initform 0.0)
:documentation "Fundamental display unit")
(defmethod render :around ((unit unit))
(when (unit-visiblep unit)
(if (not (eq *application* (unit-region unit)))
(let ((sb
(gl:get* :scissor-box))
(scale
(application-scale *application*)))
(with-slots (left right top bottom) (unit-region unit)
(gl:scissor (* left scale)
(* bottom scale)
(* scale (- right left))
(* scale (- top bottom)))
(call-next-method))
(gl:scissor (aref sb 0) (aref sb 1) (aref sb 2) (aref sb 3)))
(call-next-method))))
(defmethod (setf closer-mop:slot-value-using-class) :after
(newval class (unit unit) slot)
(case (closer-mop:slot-definition-name slot)
((x y scale-x scale-y rotation)
(setf (cached-model unit) nil
(cached-projected-matrix unit) nil
(cached-rectangle unit) nil))))
(defun scale-by (unit amount)
(with-accessors ((sx scale-x) (sy scale-y)) unit
(setf sx (* amount sx)
sy (* amount sy))))
(defun set-width-preserve-aspect (unit new-width)
(scale-by unit (/ new-width (width unit))))
(defun set-height-preserve-aspect (unit new-height)
(scale-by unit (/ new-height (height unit) )))
(defmethod width ((unit unit))
(with-slots (scale-x base-width) unit
(* scale-x base-width)))
(defmethod height ((unit unit))
(with-slots (scale-y base-height) unit
(* scale-y base-height)))
(defmethod (setf width) (newval (unit unit))
(with-slots (scale-x base-width) unit
(setf scale-x (coerce (/ newval base-width) 'single-float))))
(defmethod (setf height) (newval (unit unit))
(with-slots (scale-y base-height) unit
(setf scale-y (coerce (/ newval base-height) 'single-float))))
(defmethod model-matrix :around ((u unit))
(or (cached-model u)
(setf (cached-model u)
(call-next-method))))
(defmethod model-matrix ((u unit))
(let ((m (mat:meye 4)))
(with-slots (x y base-width scale-x base-height scale-y rotation) u
(let ((uw (* base-width scale-x))
(uh (* base-height scale-y)))
(mat:nmtranslate m (vec:vec x y 0.0))
(mat:nmtranslate m (vec:v* 0.5 (vec:vec uw uh 0.0)))
(mat:nmrotate m vec:+vz+ rotation)
(mat:nmtranslate m (vec:v* -0.5 (vec:vec uw uh 0.0)))
(mat:nmscale m (vec:vec uw uh 1.0))))
m))
(defun projected-matrix (unit)
(or (cached-projected-matrix unit)
(setf (cached-projected-matrix unit)
(mat:marr (mat:m* (application-projection *application*)
(model-matrix unit))))))
(defmethod get-rect ((unit unit))
(or (cached-rectangle unit)
(setf
(cached-rectangle unit)
(with-accessors ((x x) (y y) (w width) (h height) (r rotation)) unit
(let ((m
(mat:meye 4))
(tr
(vec:vec (+ x (* 0.5 w)) (+ y (* 0.5 h)) 0.0)))
(mat:nmtranslate m tr)
(mat:nmrotate m vec:+vz+ r)
(mat:nmtranslate m (vec:v* -1.0 tr))
(loop :for vec :in (list (mat:m* m (vec:vec x y 0.0 1.0))
(mat:m* m (vec:vec x (+ y h) 0.0 1.0))
(mat:m* m (vec:vec (+ x w) (+ y h) 0.0 1.0))
(mat:m* m (vec:vec (+ x w) y 0.0 1.0))
(mat:m* m (vec:vec x y 0.0 1.0)))
:collect (list (vec:vx vec)
(vec:vy vec))))))))
(defun units-intersect-p (au1 au2)
"Returns T if the two units AU1 an AU2 intersect. Both must implement GET-RECT."
(paths-intersect-p (get-rect au1) (get-rect au2)))
|
