PCX Loading works
[lodematron.git] / file-md2.lisp
blob43b906699e86949c1af58096794d63a856a0e60a
2 (in-package :lodematron)
4 (defun null-terminate (vector)
5 "Return the given sequence stripped of trailing zeros"
6 (let
7 ((zeroat (position 0 vector)))
8 (if zeroat
9 (subseq vector 0 zeroat)
10 vector)))
12 (defparameter *MD2-ANORMS*
13 '#(
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
179 ((ident :u32)
180 (version :u32)
181 ;; don't rely on skin info in header - it's most likely balls
182 (skinwidth :u32)
183 (skinheight :u32)
184 (framesize :u32)
185 (nskins :u32)
186 (nvertices :u32)
187 (nuvs :u32)
188 (ntris :u32)
189 (nglcmds :u32)
190 (nframes :u32)
191 (skin-offset :u32)
192 (uv-offset :u32)
193 (tris-offset :u32)
194 (frames-offset :u32)
195 (glcmds-offset :u32)
196 (end-offset :u32)))
199 (define-binary-class md2-skin-name
200 ((name :u8 :array-size 64)))
202 (define-binary-class md2-vector
203 ((x :float32)
204 (y :float32)
205 (z :float32)))
207 (define-binary-class md2-uv
208 ((u :s32)
209 (v :s32)))
211 (define-binary-class md2-triangle
212 ((vertex-indices :u16 :array-size 3)
213 (uv-indices :u16 :array-size 3)))
215 (define-binary-class md2-vertex
216 ((position :u8 :array-size 3)
217 (normal-index :u8)))
219 (define-binary-class md2-frame-header
220 ((scale :md2-vector)
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)
228 (let ((result nil))
229 (iterate
230 (for i from 0 below n)
231 (collecting (babel:octets-to-string (read-value :u8 stream :array-size 64))))
232 result))
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)))))
240 result))
242 (defun parse-md2-triangles (offset n stream)
243 (file-position stream offset)
244 (let ((result (make-array n)))
245 (iterate
246 (for i from 0 below n)
247 (setf (aref result i) (read-value :md2-triangle stream)))
248 result))
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)))
255 (iterate
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)
262 (iterate
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))))
266 frames))
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"
272 (iterate
273 (for index from 0 below (length vertices))
274 (for vertex in-vector vertices)
275 (setf (vertex3d-aref target index)
276 (vertex3d*
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) 2) (z-of scale)) (z-of translation))
280 1.0)))
281 (values))
284 (defun processs-normals (vertices)
285 (iterate
286 (for vertex in vertices)
287 (collecting (aref *MD2-ANORMS* (normal-index-of vertex)))))
289 (defun process-uvs (uvs swidth theight)
290 (iterate
291 (for uv in uvs)
292 (collecting (vector2d* (/ (u-of uv) swidth) (/ (v-of uv) theight)))))
294 (defun pose-faces (target tris)
295 (iterate
296 (for tri in-vector tris)
297 (for index from 0 below (length tris))
298 (setf (triangle-aref target index)
299 (triangle*
300 (aref (vertex-indices-of tri) 0)
301 (aref (vertex-indices-of tri) 1)
302 (aref (vertex-indices-of tri) 2))))
303 (values))
305 ;; (collecting (cons
306 ;; (list :vertices
307 ;; (aref (vertex-indices-of tri) 0)
308 ;; (aref (vertex-indices-of tri) 1)
309 ;; (aref (vertex-indices-of tri) 2))
310 ;; (list :uvs
311 ;; (aref (uv-indices-of tri) 0)
312 ;; (aref (uv-indices-of tri) 1)
313 ;; (aref (uv-indices-of tri) 2))))))
315 (defclass md2 ()
316 ((sts :accessor sts-of :initarg :sts)
317 (frames :accessor frames-of :initarg :frames)
318 (tris :accessor tris-of :initarg :tris)
319 (skins :accessor skins-of :initform (make-hash-table :test 'equal))))
322 (defun parse-md2-file (stream)
323 "Read in an md2 file from the stream"
324 (let*
325 ((header
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))
328 (let*
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))))
333 result)))
335 ;; skins --
336 (defun is-pcx (x)
337 "Test whether file extension is pcx"
338 (let ((name (namestring x))) (string-equal "pcx" (subseq name (- (length name) 3)))))
340 (defun directory-scan (directory-name)
341 "Scan a directory and get a list of skin names"
342 (let ((directory-name-length (length (namestring (merge-pathnames directory-name))))
343 (directory-list (cl-fad:list-directory (merge-pathnames directory-name))))
344 (mapcar #'(lambda (x)
345 (let ((name (namestring x)))
346 (subseq (namestring name) directory-name-length (- (length name) 4))))
347 (remove-if-not #'is-pcx directory-list))))
349 ;; animation --
350 (defmethod pose ((model md2) (mesh simple-mesh) frame-name skin-name)
351 "Set the pose of mesh based on an md2 frame"
352 (let ((frame (gethash frame-name (frames-of model))))
353 (when frame
354 (let ((header (car frame))
355 (vertices (cdr frame)))
356 ;; problem when we texture -- 1:1 mapping betewen index and vertex is lost..
357 ;; maybe md2 mesh with it's own texture - or reallocate and renumber vertices?
358 ;; just a new mesh type with extra attributes
359 (setf (vertices-of mesh) (make-vertex3d-array (length vertices)))
360 (pose-vertices (vertices-of mesh) (scale-of header) (translation-of header) vertices)
361 (setf (faces-of mesh) (make-triangle-array (length (tris-of model))))
362 (pose-faces (faces-of mesh) (tris-of model))))))
364 (defmethod repose ((model md2) (mesh simple-mesh) frame-name skin-name)
365 "Change the pose of an exising mesh already initialised with the md2"
366 (let ((frame (gethash frame-name (frames-of model))))
367 (when frame
368 (let ((header (car frame))
369 (vertices (cdr frame)))
370 ;; problem when we texture -- 1:1 mapping betewen index and vertex is lost..
371 ;; maybe md2 mesh with it's own texture - or reallocate and renumber vertices?
372 ;; just a new mesh type with extra attributes
373 (pose-vertices (vertices-of mesh) (scale-of header) (translation-of header) vertices)
374 (pose-faces (faces-of mesh) (tris-of model))))))
378 ;; (let ((
379 ;; (mesh :clear-vertices)
380 ;; (let ((pose-frame (get-frame-of mesh)))
381 ;; (iterate
382 ;; (for vertex in (cdr frame)