5 ;; -- keep track of every mesh instance ----------------------------------
7 (defparameter *meshes
* (make-hash-table :test
'eql
)
10 (defparameter *compiled-meshes
* (make-hash-table :test
'eql
)
11 "A table of compiled meshes")
13 (defparameter *bounding-boxes
* (make-hash-table :test
'eql
)
14 "A table of mesh bounding boxes")
17 ;; base mesh class type --------------------
19 (defclass base-mesh
()
20 ((face-array :accessor faces-of
:initform
(make-triangle-array 0 :adjustable t
:fill-pointer
0) :type
(vector (unsigned-byte 16) *))
21 (current-face-index :accessor current-face-index-of
:initform
0 :type fixnum
)
22 (current-vertex-index :accessor current-vertex-index-of
:initform
0 :type fixnum
)
23 (id :allocation
:class
:reader id-of
:initform
(get-universal-time)))
24 (:metaclass closer-mop
:funcallable-standard-class
)
25 (:documentation
"Base class for all meshes"))
27 (defgeneric mesh-builder
(mesh op
&optional data
)
28 (:method
((mesh base-mesh
) op
&optional data
)
30 (:add-face
(triangle-vector-push-extend data
(faces-of mesh
)) (triangle-array-dimensions (faces-of mesh
)))
31 (:set-face
(setf (triangle-aref (faces-of mesh
) (the fixnum
(current-face-index-of mesh
))) data
))
32 (:clear-face
(setf (faces-of mesh
) (make-triangle-array data
:adjustable t
:fill-pointer
0))))))
34 ;; mesh - building protocol --------------------
38 (defmethod initialize-instance :after
((self base-mesh
) &rest args
)
39 (declare (ignore args
))
40 ;; treat the object as a function
41 (setf (gethash (id-of self
) *meshes
*) self
)
42 (closer-mop:set-funcallable-instance-function
44 #'(lambda (op &optional data
) (mesh-builder self op data
))))
46 (defun make-mesh (mesh-type)
47 "Create a mesh instance and return the handle to it"
49 (make-instance mesh-type
))
52 (incf (slot-value mesh
'id
))
56 ;; expanders for individual aspects of a mesh --------------------
58 (defun expand-mesh-class-attributes (attributes)
59 "Expand the class slot defintion of the mesh attribute"
61 for
(array-name accessor-name type-name
) in attributes
63 `(,(cl-tuples::make-adorned-symbol array-name
:suffix
"ARRAY")
64 :accessor
,accessor-name
65 :initform
(,(cl-tuples::tuple-symbol type-name
:def-tuple-array-maker
) 0 :adjustable t
:fill-pointer
0))))
67 (defun make-accessor-symbol (sym)
68 "Given a symbol, suffix it with -OF so as to make an accessor name"
69 (cl-tuples::make-adorned-symbol sym
:suffix
"OF"))
72 (defun expand-mesh-setters (name attributes
)
73 "Expands the clauses used to set an attribute indexed by the current vertex index."
74 (declare (ignorable name
))
76 for
(array-name accessor-name type-name
) in attributes
78 `(,(cl-tuples::make-adorned-symbol array-name
:prefix
"SET" :package
:keyword
)
79 (setf (,(cl-tuples::tuple-symbol type-name
:def-tuple-aref
)
81 (the fixnum
(current-vertex-index-of mesh
)))
85 (defun expand-mesh-clearers (name attributes
)
86 "Expands the clauses use to clear attribute arrays in a mesh"
87 (declare (ignorable name
))
89 for
(array-name accessor-name type-name
) in attributes
91 `(,(cl-tuples::make-adorned-symbol array-name
:prefix
"CLEAR" :package
:keyword
)
92 (setf (,accessor-name mesh
)
93 (,(cl-tuples::tuple-symbol type-name
:def-tuple-array-maker
) (list data
) :adjustable t
:fill-pointer
0)))))
95 (defun expand-mesh-adders (name attributes
)
96 "Expands the clauses used to add attribute values to a mesh."
97 (declare (ignorable name
))
99 for
(array-name accessor-name type-name
) in attributes
101 `(,(cl-tuples::make-adorned-symbol array-name
:prefix
"ADD" :package
:keyword
)
102 (,(cl-tuples::tuple-symbol type-name
:def-tuple-vector-push-extend
)
104 (,accessor-name mesh
)))))
106 (defun expand-mesh-builder-function (name attributes
)
107 "Expands the form used to deefine the function used to build the mesh"
108 `(defmethod mesh-builder ((mesh ,name
) op
&optional data
)
110 ,@(expand-mesh-setters name attributes
)
111 ,@(expand-mesh-clearers name attributes
)
112 ,@(expand-mesh-adders name attributes
)
113 (:face-index
(current-face-index-of mesh
))
114 (:vertex-index
(current-vertex-index-of mesh
))
115 (:set-face-index
(setf (current-face-index-of mesh
) data
))
116 (:set-vertex-index
(setf (current-vertex-index-of mesh
) data
))
117 (otherwise (call-next-method)))))
120 (defun expand-attributes-list (attributes)
122 for
(array-name accessor-name type-name
) in attributes
123 collect
`(quote ,array-name
)))
125 (defun expand-mesh-class (name base slots attributes
)
126 "Expands the form used to declare a custom mesh class"
127 `(defclass ,name
(,@base
)
129 ,@(expand-mesh-class-attributes attributes
)
130 (attributes :initform
(list 'vertices
'faces
,@(expand-attributes-list attributes
)) :reader attributes-of
:allocation
:class
))
131 (:metaclass closer-mop
:funcallable-standard-class
)
132 (:documentation
"Custom mesh type")))
134 ;; main mesh expansion macro --------------------
136 (defmacro def-mesh-type
(name base
&rest spec
)
137 (destructuring-bind (attributes &key
(slots nil
))
139 `(progn ,(expand-mesh-class name base slots attributes
)
140 ,(expand-mesh-builder-function name attributes
))))