2 (in-package :lodematron
)
4 (defun null-terminate (vector)
5 "Return the given sequence stripped of trailing zeros"
7 ((zeroat (position 0 vector
)))
9 (subseq vector
0 zeroat
)
12 (defparameter *MD2-ANORMS
*
14 '( -
0.525731 0.000000 0.850651 )
15 '( -
0.442863 0.238856 0.864188 )
16 '( -
0.295242 0.000000 0.955423 )
17 '( -
0.309017 0.500000 0.809017 )
18 '( -
0.162460 0.262866 0.951056 )
19 '( 0.000000 0.000000 1.000000 )
20 '( 0.000000 0.850651 0.525731 )
21 '( -
0.147621 0.716567 0.681718 )
22 '( 0.147621 0.716567 0.681718 )
23 '( 0.000000 0.525731 0.850651 )
24 '( 0.309017 0.500000 0.809017 )
25 '( 0.525731 0.000000 0.850651 )
26 '( 0.295242 0.000000 0.955423 )
27 '( 0.442863 0.238856 0.864188 )
28 '( 0.162460 0.262866 0.951056 )
29 '( -
0.681718 0.147621 0.716567 )
30 '( -
0.809017 0.309017 0.500000 )
31 '( -
0.587785 0.425325 0.688191 )
32 '( -
0.850651 0.525731 0.000000 )
33 '( -
0.864188 0.442863 0.238856 )
34 '( -
0.716567 0.681718 0.147621 )
35 '( -
0.688191 0.587785 0.425325 )
36 '( -
0.500000 0.809017 0.309017 )
37 '( -
0.238856 0.864188 0.442863 )
38 '( -
0.425325 0.688191 0.587785 )
39 '( -
0.716567 0.681718 -
0.147621 )
40 '( -
0.500000 0.809017 -
0.309017 )
41 '( -
0.525731 0.850651 0.000000 )
42 '( 0.000000 0.850651 -
0.525731 )
43 '( -
0.238856 0.864188 -
0.442863 )
44 '( 0.000000 0.955423 -
0.295242 )
45 '( -
0.262866 0.951056 -
0.162460 )
46 '( 0.000000 1.000000 0.000000 )
47 '( 0.000000 0.955423 0.295242 )
48 '( -
0.262866 0.951056 0.162460 )
49 '( 0.238856 0.864188 0.442863 )
50 '( 0.262866 0.951056 0.162460 )
51 '( 0.500000 0.809017 0.309017 )
52 '( 0.238856 0.864188 -
0.442863 )
53 '( 0.262866 0.951056 -
0.162460 )
54 '( 0.500000 0.809017 -
0.309017 )
55 '( 0.850651 0.525731 0.000000 )
56 '( 0.716567 0.681718 0.147621 )
57 '( 0.716567 0.681718 -
0.147621 )
58 '( 0.525731 0.850651 0.000000 )
59 '( 0.425325 0.688191 0.587785 )
60 '( 0.864188 0.442863 0.238856 )
61 '( 0.688191 0.587785 0.425325 )
62 '( 0.809017 0.309017 0.500000 )
63 '( 0.681718 0.147621 0.716567 )
64 '( 0.587785 0.425325 0.688191 )
65 '( 0.955423 0.295242 0.000000 )
66 '( 1.000000 0.000000 0.000000 )
67 '( 0.951056 0.162460 0.262866 )
68 '( 0.850651 -
0.525731 0.000000 )
69 '( 0.955423 -
0.295242 0.000000 )
70 '( 0.864188 -
0.442863 0.238856 )
71 '( 0.951056 -
0.162460 0.262866 )
72 '( 0.809017 -
0.309017 0.500000 )
73 '( 0.681718 -
0.147621 0.716567 )
74 '( 0.850651 0.000000 0.525731 )
75 '( 0.864188 0.442863 -
0.238856 )
76 '( 0.809017 0.309017 -
0.500000 )
77 '( 0.951056 0.162460 -
0.262866 )
78 '( 0.525731 0.000000 -
0.850651 )
79 '( 0.681718 0.147621 -
0.716567 )
80 '( 0.681718 -
0.147621 -
0.716567 )
81 '( 0.850651 0.000000 -
0.525731 )
82 '( 0.809017 -
0.309017 -
0.500000 )
83 '( 0.864188 -
0.442863 -
0.238856 )
84 '( 0.951056 -
0.162460 -
0.262866 )
85 '( 0.147621 0.716567 -
0.681718 )
86 '( 0.309017 0.500000 -
0.809017 )
87 '( 0.425325 0.688191 -
0.587785 )
88 '( 0.442863 0.238856 -
0.864188 )
89 '( 0.587785 0.425325 -
0.688191 )
90 '( 0.688191 0.587785 -
0.425325 )
91 '( -
0.147621 0.716567 -
0.681718 )
92 '( -
0.309017 0.500000 -
0.809017 )
93 '( 0.000000 0.525731 -
0.850651 )
94 '( -
0.525731 0.000000 -
0.850651 )
95 '( -
0.442863 0.238856 -
0.864188 )
96 '( -
0.295242 0.000000 -
0.955423 )
97 '( -
0.162460 0.262866 -
0.951056 )
98 '( 0.000000 0.000000 -
1.000000 )
99 '( 0.295242 0.000000 -
0.955423 )
100 '( 0.162460 0.262866 -
0.951056 )
101 '( -
0.442863 -
0.238856 -
0.864188 )
102 '( -
0.309017 -
0.500000 -
0.809017 )
103 '( -
0.162460 -
0.262866 -
0.951056 )
104 '( 0.000000 -
0.850651 -
0.525731 )
105 '( -
0.147621 -
0.716567 -
0.681718 )
106 '( 0.147621 -
0.716567 -
0.681718 )
107 '( 0.000000 -
0.525731 -
0.850651 )
108 '( 0.309017 -
0.500000 -
0.809017 )
109 '( 0.442863 -
0.238856 -
0.864188 )
110 '( 0.162460 -
0.262866 -
0.951056 )
111 '( 0.238856 -
0.864188 -
0.442863 )
112 '( 0.500000 -
0.809017 -
0.309017 )
113 '( 0.425325 -
0.688191 -
0.587785 )
114 '( 0.716567 -
0.681718 -
0.147621 )
115 '( 0.688191 -
0.587785 -
0.425325 )
116 '( 0.587785 -
0.425325 -
0.688191 )
117 '( 0.000000 -
0.955423 -
0.295242 )
118 '( 0.000000 -
1.000000 0.000000 )
119 '( 0.262866 -
0.951056 -
0.162460 )
120 '( 0.000000 -
0.850651 0.525731 )
121 '( 0.000000 -
0.955423 0.295242 )
122 '( 0.238856 -
0.864188 0.442863 )
123 '( 0.262866 -
0.951056 0.162460 )
124 '( 0.500000 -
0.809017 0.309017 )
125 '( 0.716567 -
0.681718 0.147621 )
126 '( 0.525731 -
0.850651 0.000000 )
127 '( -
0.238856 -
0.864188 -
0.442863 )
128 '( -
0.500000 -
0.809017 -
0.309017 )
129 '( -
0.262866 -
0.951056 -
0.162460 )
130 '( -
0.850651 -
0.525731 0.000000 )
131 '( -
0.716567 -
0.681718 -
0.147621 )
132 '( -
0.716567 -
0.681718 0.147621 )
133 '( -
0.525731 -
0.850651 0.000000 )
134 '( -
0.500000 -
0.809017 0.309017 )
135 '( -
0.238856 -
0.864188 0.442863 )
136 '( -
0.262866 -
0.951056 0.162460 )
137 '( -
0.864188 -
0.442863 0.238856 )
138 '( -
0.809017 -
0.309017 0.500000 )
139 '( -
0.688191 -
0.587785 0.425325 )
140 '( -
0.681718 -
0.147621 0.716567 )
141 '( -
0.442863 -
0.238856 0.864188 )
142 '( -
0.587785 -
0.425325 0.688191 )
143 '( -
0.309017 -
0.500000 0.809017 )
144 '( -
0.147621 -
0.716567 0.681718 )
145 '( -
0.425325 -
0.688191 0.587785 )
146 '( -
0.162460 -
0.262866 0.951056 )
147 '( 0.442863 -
0.238856 0.864188 )
148 '( 0.162460 -
0.262866 0.951056 )
149 '( 0.309017 -
0.500000 0.809017 )
150 '( 0.147621 -
0.716567 0.681718 )
151 '( 0.000000 -
0.525731 0.850651 )
152 '( 0.425325 -
0.688191 0.587785 )
153 '( 0.587785 -
0.425325 0.688191 )
154 '( 0.688191 -
0.587785 0.425325 )
155 '( -
0.955423 0.295242 0.000000 )
156 '( -
0.951056 0.162460 0.262866 )
157 '( -
1.000000 0.000000 0.000000 )
158 '( -
0.850651 0.000000 0.525731 )
159 '( -
0.955423 -
0.295242 0.000000 )
160 '( -
0.951056 -
0.162460 0.262866 )
161 '( -
0.864188 0.442863 -
0.238856 )
162 '( -
0.951056 0.162460 -
0.262866 )
163 '( -
0.809017 0.309017 -
0.500000 )
164 '( -
0.864188 -
0.442863 -
0.238856 )
165 '( -
0.951056 -
0.162460 -
0.262866 )
166 '( -
0.809017 -
0.309017 -
0.500000 )
167 '( -
0.681718 0.147621 -
0.716567 )
168 '( -
0.681718 -
0.147621 -
0.716567 )
169 '( -
0.850651 0.000000 -
0.525731 )
170 '( -
0.688191 0.587785 -
0.425325 )
171 '( -
0.587785 0.425325 -
0.688191 )
172 '( -
0.425325 0.688191 -
0.587785 )
173 '( -
0.425325 -
0.688191 -
0.587785 )
174 '( -
0.587785 -
0.425325 -
0.688191 )
175 '( -
0.688191 -
0.587785 -
0.425325 ) )
176 "Normal lookup table used by md2 normal quantizer" )
178 (define-binary-class md2-header
181 ;; don't rely on skin info in header - it's most likely balls
199 (define-binary-class md2-skin-name
200 ((name :u8
:array-size
64)))
202 (define-binary-class md2-vector
207 (define-binary-class md2-uv
211 (define-binary-class md2-triangle
212 ((vertex-indices :u32
:array-size
3)
213 (uv-indices :u32
:array-size
3)))
215 (define-binary-class md2-vertex
216 ((position :u8
:array-size
3)
219 (define-binary-class md2-frame-header
221 (translation :md2-vector
)
222 (name :u8
:array-size
16)))
224 ;; parsing -- aka file reading
226 (defun parse-md2-skin-names (offset n stream
)
227 (file-position stream offset
)
230 (for i from
0 below n
)
231 (collecting (babel:octets-to-string
(read-value 'u8 stream
:array-size
64))))
235 (defun parse-md2-uvs (offset n stream
)
236 (file-position stream offset
)
237 (let ((result (iterate
238 (for i from
0 below n
)
239 (collecting (read-value 'md2-uv stream
)))))
242 (defun parse-md2-triangles (offset n stream
)
243 (file-position stream offset
)
244 (let ((result (make-array n
)))
246 (for i from
0 below n
)
247 (setf (aref result i
) (read-value 'md2-triangle stream
))
251 (defun parse-md2-frames (offset n size nverts stream
)
252 "Return a hash table that maps a set of frame names to vertices"
253 (file-position stream offset
)
254 (let ((frames (make-hash-table :test
'equal
:size n
)))
256 (for i from
0 below n
)
257 (file-position stream
(+ offset
(* i size
)))
258 (let* ((header (read-value 'md2-frame-header stream
))
259 (vertices (make-array (list nverts
)))
260 (name (babel:octets-to-string
(null-terminate (name-of header
)))))
261 (format t
"Parsing header ~A~%" name
)
263 (for j from
0 below nverts
)
264 (setf (aref vertices j
) (read-value 'md2-vertex stream
)))
265 (setf (gethash name frames
) (cons header vertices
))))
268 ;; posing -- aka animation.
270 (defun pose-vertices (target scale translation vertices
)
271 "Return an array of vertices using the given frames scale and translation"
273 (for index from
0 below
(length vertices
))
274 (for vertex in-vector vertices
)
275 (setf (vertex3d-aref target index
)
277 (+ (* (aref (position-of vertex
) 0) (x-of scale
)) (x-of translation
))
278 (+ (* (aref (position-of vertex
) 1) (y-of scale
)) (y-of translation
))
279 (+ (* (aref (position-of vertex
) 1) (z-of scale
)) (z-of translation
))
284 (defun processs-normals (vertices)
286 (for vertex in vertices
)
287 (collecting (aref *MD2-ANORMS
* (normal-index-of vertex
)))))
289 (defun process-uvs (uvs swidth theight
)
292 (collecting (vector2d* (/ (u-of uv
) swidth
) (/ (v-of uv
) theight
)))))
294 (defun pose-faces (target tris
)
296 (for tri in-vector tris
)
297 (for index from
0 below
(length tris
))
298 (setf (triangle-aref target index
)
300 (aref (vertex-indices-of tri
) 0)
301 (aref (vertex-indices-of tri
) 1)
302 (aref (vertex-indices-of tri
) 2))))
307 ;; (aref (vertex-indices-of tri) 0)
308 ;; (aref (vertex-indices-of tri) 1)
309 ;; (aref (vertex-indices-of tri) 2))
311 ;; (aref (uv-indices-of tri) 0)
312 ;; (aref (uv-indices-of tri) 1)
313 ;; (aref (uv-indices-of tri) 2))))))
316 ((sts :accessor sts-of
:initarg
:sts
)
317 (frames :accessor frames-of
:initarg
:frames
)
318 (tris :accessor tris-of
:initarg
:tris
)))
322 (defun parse-md2-file (stream)
323 "Read in an md2 file from the stream"
326 (read-value 'md2-header stream
)))
327 (format *debug-io
* "~D Skins ~D Vertices ~D UVS ~D Tris" (nskins-of header
) (nvertices-of header
) (nuvs-of header
) (ntris-of header
))
329 ((result (make-instance 'md2
330 :frames
(parse-md2-frames (frames-offset-of header
) (nframes-of header
) (framesize-of header
) (nvertices-of header
) stream
)
331 :sts
(parse-md2-uvs (uv-offset-of header
) (nuvs-of header
) stream
)
332 :tris
(parse-md2-triangles (tris-offset-of header
) (ntris-of header
) stream
))))
336 (defmethod pose ((model md2
) (mesh simple-mesh
) frame-name skin-name
)
337 "Set the pose of mesh based on an md2 frame"
338 (let ((frame (gethash frame-name
(frames-of model
))))
340 (let ((header (car frame
))
341 (vertices (cdr frame
)))
342 ;; problem when we texture -- 1:1 mapping betewen index and vertex is lost..
343 ;; maybe md2 mesh with it's own texture - or reallocate and renumber vertices?
344 ;; just a new mesh type with extra attributes
346 (setf (vertices-of mesh
) (make-vertex3d-array (length vertices
)))
347 (pose-vertices (vertices-of mesh
) (scale-of header
) (translation-of header
) vertices
)
348 (setf (faces-of mesh
) (make-triangle-array (length (tris-of model
))))
349 (pose-faces (faces-of mesh
) (tris-of model
))))))
351 (defmethod repose ((model md2
) (mesh simple-mesh
) frame-name skin-name
)
352 "Change the pose of an exising mesh already initialised with the md2"
353 (let ((frame (gethash frame-name
(frames-of model
))))
355 (let ((header (car frame
))
356 (vertices (cdr frame
)))
357 ;; problem when we texture -- 1:1 mapping betewen index and vertex is lost..
358 ;; maybe md2 mesh with it's own texture - or reallocate and renumber vertices?
359 ;; just a new mesh type with extra attributes
360 (pose-vertices (vertices-of mesh
) (scale-of header
) (translation-of header
) vertices
)
361 (pose-faces (faces-of mesh
) (tris-of model
))))))
366 ;; (mesh :clear-vertices)
367 ;; (let ((pose-frame (get-frame-of mesh)))
369 ;; (for vertex in (cdr frame)
