CLinch/node.lisp at master · ejbs/CLinch · GitHub

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
136
137
138
139
140
141
142
143
144
145
;;;; node.lisp
;;;; Please see the licence.txt for the CLinch

(in-package #:clinch)

(defclass node ()
  ((children
    :initform nil
    :initarg  :children
    :accessor children)
   (transform
    :accessor transform
    :initform  (sb-cga:identity-matrix)
    :initarg  :transform)
   (current-transform
    :accessor current-transform
    :initform nil))
   (:documentation "A node class for creating hierarchies of objects. It caches calculations for speed. Not enough in itself, and not required."))

(defmethod initialize-instance :after ((this node) &key parent)
  (when parent
    (add-child parent this)))


(defmethod print-object ((this node) s)
  "Print function for node."
  (format s "#<NODE children: ~A ~%~A>" (length (children this)) (transform this)))

(defmethod changed? ((this node))
  "Has this node changed and not updated?"
  (null (slot-value this 'current-transform)))


(defmethod (setf changed?) (val (this node))
  "Set this node to update later."
  (setf (slot-value this 'current-transform) (if val nil t)))

(defmethod add-child ((this node) child &key)
  "Add a child. Children must implement update and render."
  (with-accessors ((children children)) this
    (unless (member child children)
      (setf children
	    (cons child children)))))

(defmethod update ((this node) &key parent force)
  "Update this and child nodes if changed."
  (when (or force (changed? this))
    (setf (current-transform this)
	  (if parent (sb-cga:matrix* (transform this) (current-transform parent))
	      (transform this)))
    (setf force t))

  (loop for child in (children this)
     do (update child :parent this :force force))

  (current-transform this))

(defmethod render ((this node) &key parent)
  "Render child objects. You don't need to build your application with nodes/render. This is just here to help."
  (when (changed? this)
    (update this :parent parent))

  (loop for i in (children this)
     do (render i :parent this)))

(defmethod render ((this list) &key parent matrix)
  "Render a list of rendables."
  (loop for i in this
     do (render i :parent parent :matrix matrix)))


(defmethod (setf transform)  ((other-node array) (this node))
  "Inherited function for setting changed?"
   (setf (slot-value this 'transform)
	 other-node)
   (setf (changed? this) t)
   (transform this))

(defmethod set-identity-transform ((this node) &key)
  "Inherited function for setting changed?"
  (setf (transform this) (sb-cga:identity-matrix)))

(defmethod m* ((this node) (that node) &optional (in-place t))
  "Inherited function for setting changed?"
  (if in-place
    (setf (transform this) (sb-cga:matrix* (transform that) (transform this)))
    (sb-cga:matrix* (transform that) (transform this))))

(defmethod transpose ((this node) &optional (in-place t))
  "Inherited function for setting changed?"
  (if in-place
      (setf (transform this) (sb-cga:transpose-matrix (transform this)))
      (sb-cga:transpose-matrix (transform this))))


(defmethod invert ((this node) &optional (in-place t))
  "Inherited function for setting changed?"
  (if in-place
      (setf (transform this) (sb-cga:inverse-matrix (transform this)))
      (sb-cga:inverse-matrix (transform this))))


(defmethod scale ((this node) x y z &optional (in-place t))
  "Inherited function for setting changed?"
  (if in-place
    (setf (transform this) (sb-cga:matrix* (sb-cga:scale* (float x)
							 (float y)
							 (float z))
					  (transform this)))
    (sb-cga:matrix* (sb-cga:scale* (float x)
							 (float y)
							 (float z))
					  (transform this))))

(defmethod translate ((this node) x y z &optional (in-place t))
  "Inherited function for setting changed?"
  (if in-place
      (setf (transform this) (sb-cga:matrix* (sb-cga:translate* (float x)
								(float y)
								(float z))
					     (transform this)))
      (sb-cga:matrix* (sb-cga:translate* (float x)
				     (float y)
				     (float z))
		      (transform this))))

(defmethod rotate ((this node) rad x y z &optional (in-place t))
  "Inherited function for setting changed?"
    (if in-place
      (setf (transform this)
	    (sb-cga:matrix* (sb-cga:rotate-around
			     (make-vector (float x)
					  (float y)
					  (float z)) (float rad))
			    (transform this)))
	    (sb-cga:matrix* (sb-cga:rotate-around
			     (make-vector (float x)
					  (float y)
					  (float z)) (float rad))
			    (transform this))))


(defmethod load-matrix ((this node) &key)
  (gl:load-matrix (or (current-transform this)
		      (transform this))))