Adding blender exporter
[lodematron.git] / file-lwo.lisp
blob29ee8ba40c55fe1f2282a88b286dc794f0b033f5
2 (in-package :lodematron)
5 ;; top level iff forms (groups)
6 (defconstant +form-group-id+ (string-id "FORM"))
7 (defconstant +cat-group-id+ (string-id "CAT "))
8 (defconstant +list-group-id+ (string-id "LIST"))
10 (defparameter *iff-group-contents-parsers* (make-hash-table))
11 (defparameter *lwob-chunk-parsers* (make-hash-table))
12 (defparameter *lwob-subchunk-parsers* (make-hash-table))
14 ;; lwob group header
15 (defconstant +lwob-group-type+ (string-id "LWOB"))
17 (defclass iff-group ()
18 ((group-id :accessor group-id-of)
19 (group-size :accessor group-size-of)
20 (group-type :accessor group-type-of))
21 (:documentation "IFF Top level grouping"))
24 (defmethod initialize-instance :after ((self iff-group) &key stream)
25 "Create a group from a stream"
26 (align-for-read stream +word-align+)
27 (setf (group-id-of self) (read-value 'u32 stream :endian :big))
28 (setf (group-size-of self) (read-value 'u32 stream :endian :big))
29 (setf (group-type-of self) (read-value 'u32 stream :endian :big)))
31 (defgeneric group-size (group))
33 (defmethod group-size ((group iff-group))
34 "Return the number of bytes to read after reading the group header."
35 (- (group-size-of group) 4))
37 (defconstant +lwob-pnts-id+ (string-id "PNTS"))
38 (defconstant +lwob-srfs-id+ (string-id "SRFS"))
39 (defconstant +lwob-pols-id+ (string-id "POLS"))
40 (defconstant +lwob-surf-id+ (string-id "SURF"))
42 ;; chunks -- groups contain chunks
43 (defclass iff-chunk ()
44 ((chunk-id :accessor chunk-id-of)
45 (chunk-size :accessor chunk-size-of))
46 (:documentation "IFF file chunk"))
48 (defmethod initialize-instance :after ((self iff-chunk) &key stream)
49 "Create a iff chunk and read it in."
50 (align-for-read stream +word-align+)
51 (format *debug-io* "Chunk At ~X " (file-position stream))
52 (setf (chunk-id-of self) (read-value 'u32 stream :endian :big))
53 (setf (chunk-size-of self) (read-value 'u32 stream :endian :big)))
55 (defconstant +lwob-colr-id+ (string-id "COLR"))
56 (defconstant +lwob-flag-id+ (string-id "FLAG"))
57 (defconstant +lwob-lumi-id+ (string-id "LUMI"))
58 (defconstant +lwob-diff-id+ (string-id "DIFF"))
59 (defconstant +lwob-spec-id+ (string-id "SPEC"))
60 (defconstant +lwob-refl-id+ (string-id "REFL"))
61 (defconstant +lwob-tran-id+ (string-id "TRAN"))
62 (defconstant +lwob-timg-id+ (string-id "TIMG"))
63 (defconstant +lwob-tflg-id+ (string-id "TFLG"))
64 (defconstant +lwob-tsiz-id+ (string-id "TSIZ"))
65 (defconstant +lwob-tctr-id+ (string-id "TCTR"))
66 (defconstant +lwob-tfal-id+ (string-id "TFAL"))
67 (defconstant +lwob-tvel-id+ (string-id "TVEL"))
68 (defconstant +lwob-tclr-id+ (string-id "TCLR"))
69 (defconstant +lwob-tval-id+ (string-id "TVAL"))
70 (defconstant +lwob-tamp-id+ (string-id "TAMP"))
71 (defconstant +lwob-tfrq-id+ (string-id "TFRQ"))
72 (defconstant +lwob-tsp0-id+ (string-id "TSP0"))
73 (defconstant +lwob-tsp1-id+ (string-id "TSP1"))
74 (defconstant +lwob-tsp2-id+ (string-id "TSP2"))
75 (defconstant +lwob-ctex-id+ (string-id "CTEX"))
76 (defconstant +lwob-dtex-id+ (string-id "DTEX"))
77 (defconstant +lwob-glos-id+ (string-id "GLOS"))
79 (defclass iff-subchunk ()
80 ((subchunk-id :accessor subchunk-id-of)
81 (subchunk-size :accessor subchunk-size-of))
82 (:documentation "IFF file subchunk"))
84 (defmethod initialize-instance :around ((self iff-subchunk) &key stream)
85 "Create a iff sub chunk and read it in."
86 (format *debug-io* "Sub Chunk At ~X " (file-position stream))
87 (setf (subchunk-id-of self) (read-value 'u32 stream :endian :big))
88 (setf (subchunk-size-of self) (read-value 'u16 stream :endian :big)))
91 (defgeneric iff-group-parser (group in-stream out-fn))
93 ;; there are three kinds of top level groups in an iff file
94 ;; FORM -- which is raw chunked data
95 ;; LIST and CAT -- which are index collections of chunks or references to chunks
96 ;; for LWO we only worry about FORMS
97 (defmethod iff-group-parser ((group iff-group) in-stream out-fn)
98 "Parse an iff group, read from in-stream, dump to out-fn."
99 (labels
100 ((skip-group ()
101 (format *debug-io* "~&Skipping unknown group ~A ~A ~T ~X"
102 (id-string (group-id-of group))
103 (id-string (group-type-of group))
104 (group-size-of group))
105 (advance-file-position in-stream (group-size group))))
106 (cond
107 ((= (group-id-of group) +form-group-id+)
108 (progn "~&Found form Group")
109 (funcall (gethash (group-type-of group) *iff-group-contents-parsers*) group in-stream out-fn))
110 ((= (group-id-of group) +cat-group-id+)
111 (skip-group))
112 ((= (group-id-of group) +list-group-id+)
113 (skip-group)))))
116 (defmacro def-group-contents-parser (form-type (group-sym in-stream-sym out-fn-sym) &rest body)
117 "Declare a parser for the chunks in an iff group"
118 `(setf (gethash ,form-type *iff-group-contents-parsers*)
119 (lambda (,group-sym ,in-stream-sym ,out-fn-sym)
120 ,@body)))
123 (defun unknown-iff-chunk-parser (chunk in-stream out-fn)
124 "Fallback for an unknown chunk"
125 (declare (ignore out-fn))
126 (format *debug-io* "~&Skipping ~A chunk of ~X bytes"
127 (id-string (chunk-id-of chunk))
128 (chunk-size-of chunk))
129 (advance-file-position in-stream (chunk-size-of chunk)))
131 (defmacro def-lwob-chunk-parser (id (chunk-sym in-sym out-sym) &body body)
132 "Create a parser to parse a chunk inside an LWOB group"
133 `(setf (gethash ,id *lwob-chunk-parsers*)
134 (lambda (,chunk-sym ,in-sym ,out-sym)
135 (declare (ignorable ,chunk-sym ,in-sym ,out-sym))
136 ,@body)))
139 (defmacro def-lwob-subchunk-parser (id (subchunk-sym in-sym out-sym) &body body)
140 "Create a parser to parse a chunk inside an LWOB group"
141 `(setf (gethash ,id *lwob-subchunk-parsers*)
142 (lambda (,subchunk-sym ,in-sym ,out-sym)
143 (declare (ignorable ,subchunk-sym ,in-sym ,out-sym))
144 ,@body)))
147 (defun parse-groups (in-stream out-fn)
148 "Top level IFF File parsing function"
149 (iterate
150 (while (< (file-position in-stream) (file-length in-stream)))
151 (for group = (make-instance 'iff-group :stream in-stream))
152 (format *debug-io* "~& At ~X " (file-position in-stream))
153 (iff-group-parser group in-stream out-fn)))
156 ;; "Parse the contents of a lwob group"
157 (def-group-contents-parser +lwob-group-type+ (group in-stream out-fn)
158 ;; BEWARE group-end is captured here -- this is unhygenic.
159 (let ((group-end (+ (file-position in-stream) (group-size group))))
160 (format *debug-io* "Parsing LWOB Group that ends at ~X%" group-end)
161 (iterate
162 (while (< (file-position in-stream) group-end))
163 (for chunk = (make-instance 'iff-chunk :stream in-stream))
164 (format *debug-io* "~&Found ~A " (id-string (chunk-id-of chunk)))
165 (funcall
166 (gethash (chunk-id-of chunk) *lwob-chunk-parsers* #'unknown-iff-chunk-parser)
167 chunk in-stream out-fn))))
169 ;; Parsers for individual chunks inside an lwob group
171 ;; PNTS chunk == vertices
172 (def-lwob-chunk-parser +lwob-pnts-id+ (chunk in-stream out-fn)
173 (let ((chunk-end (+ (file-position in-stream) (chunk-size-of chunk))))
174 (iterate
175 (while (< (file-position in-stream) chunk-end))
176 (let* ((x (read-value 'float32 in-stream :endian :big) )
177 (y (read-value 'float32 in-stream :endian :big))
178 (z (read-value 'float32 in-stream :endian :big)))
179 (format *debug-io* "Point ~A ~A ~A~& " x y z)))))
182 ;; POLS chunk == polygons
183 (def-lwob-chunk-parser +lwob-pols-id+ (chunk in-stream out-fn)
184 (labels
185 ((parse-polygon ()
186 (let* ((vertex-count (logand #X3FF (read-value 'u16 in-stream :endian :big)))
187 (vertices (make-array (list vertex-count) :element-type '(unsigned-byte 16))))
188 (format *debug-io* "Parsing polygon with ~A vertices~&" vertex-count)
189 (iterate
190 (for vertex from 0 below vertex-count)
191 (setf (aref vertices vertex) (read-value 'u16 in-stream :endian :big)))
192 vertices)))
193 (let ((chunk-end (+ (file-position in-stream) (chunk-size-of chunk))))
194 (iterate
195 (while (< (file-position in-stream) chunk-end))
196 (let ((polygon (parse-polygon)))
197 (declare (ignorable polygon))
198 (when (< (file-position in-stream) chunk-end)
199 (let ((surface (read-value 'u16 in-stream :endian :big)))
200 (when (< surface 0)
201 (let ((detail-count (read-value 's16 in-stream :endian :big)))
202 (format *debug-io* "~A Details.." detail-count)
203 (iterate
204 (for detail-index from 0 below detail-count)
205 (parse-polygon)))))))))))
207 ;; SRFS chunk == surface names
208 (def-lwob-chunk-parser +lwob-srfs-id+ (chunk in-stream out-fn)
209 (let ((chunk-end (+ (file-position in-stream) (chunk-size-of chunk))))
210 (format *debug-io* "Surface chunk~&")
211 (iterate (while (< (file-position in-stream) chunk-end))
212 (format *debug-io* "String at ~X~&" (file-position in-stream))
213 (let ((surf-name (read-value 'asciiz in-stream)))
214 (align-for-read in-stream +word-align+)
215 (format *debug-io* "Surface ~A~&" surf-name)))))
217 ;; SURF chunk == surface properties
218 (def-lwob-chunk-parser +lwob-surf-id+ (chunk in-stream out-fn)
219 (labels ((skip-subchunk (subchunk in-stream)
220 (format *debug-io* "~&Skipping unknown subchunk ~A "
221 (id-string (subchunk-id-of subchunk)))
222 (advance-file-position in-stream (subchunk-size-of subchunk))))
223 (let ((chunk-end (+ (file-position in-stream) (chunk-size-of chunk)))
224 (surface-name (read-value 'asciiz in-stream)))
225 (format *debug-io* "~&For surface ~A " surface-name)
226 (align-for-read in-stream +word-align+)
227 (iterate
228 (while (< (file-position in-stream) chunk-end))
229 (let* ((subchunk (make-instance 'iff-subchunk :stream in-stream))
230 (parser (gethash (subchunk-id-of subchunk) *lwob-subchunk-parsers*)))
231 (if parser
232 (funcall parser subchunk in-stream out-fn)
233 (skip-subchunk subchunk in-stream)))))))
235 (def-lwob-subchunk-parser +lwob-colr-id+ (chunk in-stream out-fn)
236 (let* ((red (read-value 'u8 in-stream))
237 (green (read-value 'u8 in-stream))
238 (blue (read-value 'u8 in-stream))
239 (dummy (read-value 'u8 in-stream)))
240 (declare (ignorable dummy))
241 (format *debug-io* "Colour ~X ~X ~X " red green blue)))
243 (def-lwob-subchunk-parser +lwob-lumi-id+ (chunk in-stream out-fn)
244 (let ((luminosity (read-value 'u16 in-stream)))
245 (format *debug-io* "Luminosity ~A " (/ luminosity 256))))
247 (def-lwob-subchunk-parser +lwob-diff-id+ (chunk in-stream out-fn)
248 (let ((diffusion (read-value 'u16 in-stream)))
249 (format *debug-io* "Diffusion ~A " (/ diffusion 256))))
251 (def-lwob-subchunk-parser +lwob-spec-id+ (chunk in-stream out-fn)
252 (let ((specularity (read-value 'u16 in-stream)))
253 (format *debug-io* "Specularity ~A " (/ specularity 256))))
255 (def-lwob-subchunk-parser +lwob-refl-id+ (chunk in-stream out-fn)
256 (let ((reflectivity (read-value 'u16 in-stream)))
257 (format *debug-io* "Reflectivity ~A " (/ reflectivity 256))))
259 (def-lwob-subchunk-parser +lwob-tran-id+ (chunk in-stream out-fn)
260 (let ((transparency (read-value 'u16 in-stream)))
261 (format *debug-io* "Transparency ~A " (/ transparency 256))))
263 (def-lwob-subchunk-parser +lwob-glos-id+ (chunk in-stream out-fn)
264 (let ((glossiness (read-value 'u16 in-stream)))
265 (format *debug-io* "Glossiness ~A " (/ glossiness 1024))))
267 (defparameter *texture-context* :colour-texture)
269 (def-lwob-subchunk-parser +lwob-ctex-id+ (chunk in-stream out-fn)
270 (let ((colour-texture (read-value 'asciiz in-stream)))
271 (align-for-read in-stream +word-align+)
272 (setf *texture-context* :colour-texture)
273 (format *debug-io* "Colour texture ~A " colour-texture)))
275 (def-lwob-subchunk-parser +lwob-dtex-id+ (chunk in-stream out-fn)
276 (let ((diffuse-texture (read-value 'asciiz in-stream)))
277 (align-for-read in-stream +word-align+)
278 (setf *texture-context* :diffuse-texture)
279 (format *debug-io* "Diffuse texture ~A " diffuse-texture)))
281 (def-lwob-subchunk-parser +lwob-timg-id+ (chunk in-stream out-fn)
282 (let ((texture-name (read-value 'asciiz in-stream)))
283 (align-for-read in-stream +word-align+)
284 (format *debug-io* "Texture fname ~A" texture-name)))
286 (def-lwob-subchunk-parser +lwob-tflg-id+ (chunk in-stream out-fn)
287 (let ((texture-flags (read-value 'u16 in-stream)))
288 (destructure-bits texture-flags (xaxis yaxis zaxis world negative pixel-blending antialiasing)
289 (format *debug-io* "axes ~A ~A ~A" xaxis yaxis zaxis)
290 (format *debug-io* "world ~A" world)
291 (format *debug-io* "negative ~A" negative))))
293 (def-lwob-subchunk-parser +lwob-tsiz-id+ (chunk in-stream out-fn)
294 (let ((x (read-value 'float32 in-stream))
295 (y (read-value 'float32 in-stream))
296 (z (read-value 'float32 in-stream)))
297 (format "Size x y z ~A ~A ~A " x y z)))
299 (def-lwob-subchunk-parser +lwob-tctr-id+ (chunk in-stream out-fn)
300 (let ((x (read-value 'float32 in-stream))
301 (y (read-value 'float32 in-stream))
302 (z (read-value 'float32 in-stream)))
303 (format "Centre x y z ~A ~A ~A " x y z)))
305 (def-lwob-subchunk-parser +lwob-tfal-id+ (chunk in-stream out-fn)
306 (let ((x (read-value 'float32 in-stream))
307 (y (read-value 'float32 in-stream))
308 (z (read-value 'float32 in-stream)))
309 (format "Falloff x y z ~A ~A ~A " x y z)))
311 (def-lwob-subchunk-parser +lwob-tvel-id+ (chunk in-stream out-fn)
312 (let ((x (read-value 'float32 in-stream))
313 (y (read-value 'float32 in-stream))
314 (z (read-value 'float32 in-stream)))
315 (format "Velocity x y z ~A ~A ~A " x y z)))
317 (def-lwob-subchunk-parser +lwob-tclr-id+ (chunk in-stream out-fn)
318 (let* ((red (read-value 'u8 in-stream))
319 (green (read-value 'u8 in-stream))
320 (blue (read-value 'u8 in-stream)))
321 (read-value 'u8 in-stream)
322 (format *debug-io* "Colour ~X ~X ~X " red green blue)))
324 (defun parse-iff-file (input-file output-fn)
325 (with-open-file
326 (in-stream input-file :element-type '(unsigned-byte 8))
327 (parse-groups in-stream output-fn)))