blob: 14103109974470e194a3ff157bf2db545b677f69 (
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
|
;;;; units/container.lisp
(in-package #:wheelwork)
(defclass/std container (unit)
((units :with :a)
(cached-rect :with)
(left right top bottom :with :std 0 :doc "container's box coordinates."))
(:documentation "Just a list of units. Made into a class so that
transformation affine transformations methods can be specialzied on
whole groups of units"))
(defmethod (setf closer-mop:slot-value-using-class)
(newval class (container container) slot)
(case (closer-mop:slot-definition-name slot)
((left right top bottom)
(setf (container-cached-rect container) nil))))
(defmethod get-rect ((container container))
(with-slots (cached-rect left right top bottom) container
(or cached-rect
(setf cached-rect
(list* (vec:vec left bottom 0 1.0)
(vec:vec left top 0 1.0)
(vec:vec right top 0 1.0)
(vec:vec right bottom 0 1.0)
(vec:vec left bottom 0 1.0))))))
(defun point-in-contanier-box-p (c x y)
"Returns T if the ponit X Y is inside the bounds of the container."
(and (<= (container-left c) x (container-right c))
(<= (container-bottom c) y (container-top c))))
(defun visible-in-container-p (unit)
"Returns T if UNIT is VISIBLEP, if it is inside a CONTAINER, if any
of the corners of its bounding rectangle are inside that CONTAINER.
UNIT must implement the affine protocol."
(when (unit-visiblep unit)
(when-let ((container
(unit-container unit)))
(loop for pt in (get-rect unit)
thereis (point-in-contanier-box-p container (vec:vx pt) (vec:vy pt))))))
(defmethod drop-unit ((unit unit))
"Removes a unit from its container. Returns T if the unit actually was removed."
(when-let (container (unit-container unit))
(setf
(container-units container) (delete unit (container-units container))
(unit-container unit) nil)
t))
(defmethod add-unit ((container container) (unit unit))
"Adds a unit to the end of a container (thus affecting render
order). Makes sure to remove the unit from its current container if
necessary."
(when (unit-container unit)
(drop-unit unit))
(push unit (container-units container))
(setf (unit-container unit) container)
unit)
(defmethod cleanup ((container container))
(dolist (u (container-units container))
(cleanup u)))
(defmethod render ((container container))
(let ((current
(gl:get* :scissor-box))
(scale
(application-scale
(app-of-unit container))
))
(with-slots (left right top bottom) container
(gl:scissor (* left scale) (* scale bottom) (* scale (- right left)) (* scale (- top bottom)))
(unwind-protect
(dolist (u (container-units container))
(when (visible-in-container-p u)
(render u)))
(gl:scissor (aref current 0) (aref current 1) (aref current 2) (aref current 3))))))
|
