More work on lwo loading. Useful bit - destructuring macro.
[lodematron.git] / file-lwo.lisp
bloba93bb9ce2f8f6726eed725fc14eae541e93e6455
2 (in-package :cl-lwo)
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 (defmethod group-size ((group iff-group))
32 "Return the number of bytes to read after reading the group header."
33 (- (group-size-of group) 4))
35 (defconstant +lwob-pnts-id+ (string-id "PNTS"))
36 (defconstant +lwob-srfs-id+ (string-id "SRFS"))
37 (defconstant +lwob-pols-id+ (string-id "POLS"))
38 (defconstant +lwob-surf-id+ (string-id "SURF"))
40 ;; chunks -- groups contain chunks
41 (defclass iff-chunk ()
42 ((chunk-id :accessor chunk-id-of)
43 (chunk-size :accessor chunk-size-of))
44 (:documentation "IFF file chunk"))
46 (defmethod initialize-instance :after ((self iff-chunk) &key stream)
47 "Create a iff chunk and read it in."
48 (align-for-read stream +word-align+)
49 (format *debug-io* "Chunk At ~X " (file-position stream))
50 (setf (chunk-id-of self) (read-value 'u32 stream :endian :big))
51 (setf (chunk-size-of self) (read-value 'u32 stre :endian :big)))
53 (defconstant +lwob-colr-id+ (string-id "COLR"))
54 (defconstant +lwob-flag-id+ (string-id "FLAG"))
55 (defconstant +lwob-lumi-id+ (string-id "LUMI"))
56 (defconstant +lwob-diff-id+ (string-id "DIFF"))
57 (defconstant +lwob-spec-id+ (string-id "SPEC"))
58 (defconstant +lwob-refl-id+ (string-id "REFL"))
59 (defconstant +lwob-tran-id+ (string-id "TRAN"))
60 (defconstant +lwob-timg-id+ (string-id "TIMG"))
61 (defconstant +lwob-tflg-id+ (string-id "TFLG"))
62 (defconstant +lwob-tsiz-id+ (string-id "TSIZ"))
63 (defconstant +lwob-tctr-id+ (string-id "TCTR"))
64 (defconstant +lwob-tfal-id+ (string-id "TFAL"))
65 (defconstant +lwob-tvel-id+ (string-id "TVEL"))
66 (defconstant +lwob-tclr-id+ (string-id "TCLR"))
67 (defconstant +lwob-tval-id+ (string-id "TVAL"))
68 (defconstant +lwob-tamp-id+ (string-id "TAMP"))
69 (defconstant +lwob-tfrq-id+ (string-id "TFRQ"))
70 (defconstant +lwob-tsp0-id+ (string-id "TSP0"))
71 (defconstant +lwob-tsp1-id+ (string-id "TSP1"))
72 (defconstant +lwob-tsp2-id+ (string-id "TSP2"))
73 (defconstant +lwob-ctex-id+ (string-id "CTEX"))
74 (defconstant +lwob-dtex-id+ (string-id "DTEX"))
75 (defconstant +lwob-glos-id+ (string-id "GLOS"))
77 (defclass iff-subchunk ()
78 ((subchunk-id :accessor subchunk-id-of)
79 (subchunk-size :accessor subchunk-size-of))
80 (:documentation "IFF file subchunk"))
82 (defmethod initialize-instance :around ((self iff-subchunk) &key stream)
83 "Create a iff sub chunk and read it in."
84 (format *debug-io* "Sub Chunk At ~X " (file-position stream))
85 (setf (subchunk-id-of self) (read-value 'u32 stream :endian :big))
86 (setf (subchunk-size-of self) (read-value 'u16 stream :endian :big)))
89 ;; there are three kinds of top level groups in an iff file
90 ;; FORM -- which is raw chunked data
91 ;; LIST and CAT -- which are index collections of chunks or references to chunks
92 ;; for LWO we only worry about FORMS
93 (defun iff-group-parser (group in-stream out-stream)
94 "Parse an iff group, read from in-stream, dump to out-stream."
95 (labels
96 ((skip-group ()
97 (format *debug-io* "~&Skipping unknown group ~A ~A ~T ~X"
98 (id-string (group-id-of group))
99 (id-string (group-type-of group))
100 (group-size-of group))
101 (advance-file-position in-stream (group-size group))))
102 (cond
103 ((= (group-id-of group) +form-group-id+)
104 (progn "~&Found form Group")
105 (funcall (gethash (group-type-of group) *iff-group-contents-parsers*) group in-stream out-stream))
106 ((= (group-id-of group) +cat-group-id+)
107 (skip-group))
108 ((= (group-id-of group) +list-group-id+)
109 (skip-group)))))
112 (defmacro def-group-contents-parser (form-type (group-sym in-stream-sym out-stream-sym) &rest body)
113 "Declare a parser for the chunks in an iff group"
114 `(setf (gethash ,form-type *iff-group-contents-parsers*)
115 (lambda (,group-sym ,in-stream-sym ,out-stream-sym)
116 ,@body)))
119 (defun unknown-iff-chunk-parser (chunk in-stream out-stream)
120 "Fallback for an unknown chunk"
121 (declare (ignore out-stream))
122 (format *debug-io* "~&Skipping ~A chunk of ~X bytes"
123 (id-string (chunk-id-of chunk))
124 (chunk-size-of chunk))
125 (advance-file-position in-stream (chunk-size-of chunk)))
127 (defmacro def-lwob-chunk-parser (id (chunk-sym in-sym out-sym) &body body)
128 "Create a parser to parse a chunk inside an LWOB group"
129 `(setf (gethash ,id *lwob-chunk-parsers*)
130 (lambda (,chunk-sym ,in-sym ,out-sym)
131 (declare (ignorable ,in-sym ,out-sym))
132 ,@body)))
135 (defmacro def-lwob-subchunk-parser (id (subchunk-sym in-sym out-sym) &body body)
136 "Create a parser to parse a chunk inside an LWOB group"
137 `(setf (gethash ,id *lwob-subchunk-parsers*)
138 (lambda (,subchunk-sym ,in-sym ,out-sym)
139 (declare (ignorable ,in-sym ,out-sym))
140 ,@body)))
143 (defun parse-groups (in-stream out-stream)
144 "Top level IFF File parsing function"
145 (iterate
146 (while (< (file-position in-stream) (file-length in-stream)))
147 (for group = (make-instance 'iff-group :stream in-stream))
148 (format *debug-io* "~& At ~X " (file-position in-stream))
149 (iff-group-parser group in-stream out-stream)))
152 ;; "Parse the contents of a lwob group"
153 (def-group-contents-parser +lwob-group-type+ (group in-stream out-stream)
154 ;; BEWARE group-end is captured here -- this is unhygenic.
155 (let ((group-end (+ (file-position in-stream) (group-size group))))
156 (format *debug-io* "Parsing LWOB Group that ends at ~X%" group-end)
157 (iterate
158 (while (< (file-position in-stream) group-end))
159 (for chunk = (make-instance 'iff-chunk :stream in-stream))
160 (format *debug-io* "~&Found ~A " (id-string (chunk-id-of chunk)))
161 (funcall
162 (gethash (chunk-id-of chunk) *lwob-chunk-parsers* #'unknown-iff-chunk-parser)
163 chunk in-stream out-stream))))
165 ;; Parsers for individual chunks inside an lwob group
167 ;; PNTS chunk == vertices
168 (def-lwob-chunk-parser +lwob-pnts-id+ (chunk in-stream out-stream)
169 (let ((chunk-end (+ (file-position in-stream) (chunk-size-of chunk))))
170 (iterate
171 (while (< (file-position in-stream) chunk-end))
172 (let* ((x (read-value 'float32 in-stream :endian :big) )
173 (y (read-value 'float32 in-stream :endian :big))
174 (z (read-value 'float32 in-stream :endian :big)))
175 (format *debug-io* "Point ~A ~A ~A~& " x y z)))))
178 ;; POLS chunk == polygons
179 (def-lwob-chunk-parser +lwob-pols-id+ (chunk in-stream out-stream)
180 (labels
181 ((parse-polygon ()
182 (let* ((vertex-count (logand #X3FF (read-value 'u16 in-stream :endian :big)))
183 (vertices (make-array (list vertex-count) :element-type '(unsigned-byte 16))))
184 (format *debug-io* "Parsing polygon with ~A vertices~&" vertex-count)
185 (iterate
186 (for vertex from 0 below vertex-count)
187 (setf (aref vertices vertex) (read-value 'u16 in-stream :endian :big)))
188 vertices)))
189 (let ((chunk-end (+ (file-position in-stream) (chunk-size-of chunk))))
190 (iterate
191 (while (< (file-position in-stream) chunk-end))
192 (let ((polygon (parse-polygon)))
193 (when (< (file-position in-stream) chunk-end)
194 (let ((surface (read-value 'u16 in-stream :endian :big)))
195 (when (< surface 0)
196 (let ((detail-count (read-value 's16 in-stream :endian :big)))
197 (format *debug-io* "~A Details.." detail-count)
198 (iterate
199 (for detail-index from 0 below detail-count)
200 (parse-polygon)))))))))))
202 ;; SRFS chunk == surface names
203 (def-lwob-chunk-parser +lwob-srfs-id+ (chunk in-stream out-stream)
204 (let ((chunk-end (+ (file-position in-stream) (chunk-size-of chunk))))
205 (format *debug-io* "Surface chunk~&")
206 (iterate (while (< (file-position in-stream) chunk-end))
207 (format *debug-io* "String at ~X~&" (file-position in-stream))
208 (let ((surf-name (read-value 'asciiz in-stream)))
209 (align-for-read in-stream +word-align+)
210 (format *debug-io* "Surface ~A~&" surf-name)))))
212 ;; SURF chunk == surface properties
213 (def-lwob-chunk-parser +lwob-surf-id+ (chunk in-stream out-stream)
214 (labels ((skip-subchunk (subchunk in-stream)
215 (format *debug-io* "~&Skipping unknown subchunk ~A "
216 (id-string (subchunk-id-of subchunk)))
217 (advance-file-position in-stream (subchunk-size-of subchunk))))
218 (let ((chunk-end (+ (file-position in-stream) (chunk-size-of chunk)))
219 (surface-name (read-value 'asciiz in-stream)))
220 (format *debug-io* "~&For surface ~A " surface-name)
221 (align-for-read in-stream +word-align+)
222 (iterate
223 (while (< (file-position in-stream) chunk-end))
224 (let* ((subchunk (make-instance 'iff-subchunk :stream in-stream))
225 (parser (gethash (subchunk-id-of subchunk) *lwob-subchunk-parsers*)))
226 (if parser
227 (funcall parser subchunk in-stream out-stream)
228 (skip-subchunk subchunk in-stream)))))))
230 (def-lwob-subchunk-parser +lwob-colr-id+ (chunk in-stream out-stream)
231 (let* ((red (read-value 'u8 in-stream))
232 (green (read-value 'u8 in-stream))
233 (blue (read-value 'u8 in-stream))
234 (dummy (read-value 'u8 in-stream)))
235 (format *debug-io* "Colour ~X ~X ~X " red green blue)))
237 (def-lwob-subchunk-parser +lwob-lumi-id+ (chunk in-stream out-stream)
238 (let ((luminosity (read-value 'u16 in-stream)))
239 (format *debug-io* "Luminosity ~A " (/ luminosity 256))))
241 (def-lwob-subchunk-parser +lwob-diff-id+ (chunk in-stream out-stream)
242 (let ((diffusion (read-value 'u16 in-stream)))
243 (format *debug-io* "Diffusion ~A " (/ diffusion 256))))
245 (def-lwob-subchunk-parser +lwob-spec-id+ (chunk in-stream out-stream)
246 (let ((specularity (read-value 'u16 in-stream)))
247 (format *debug-io* "Specularity ~A " (/ specularity 256))))
249 (def-lwob-subchunk-parser +lwob-refl-id+ (chunk in-stream out-stream)
250 (let ((reflectivity (read-value 'u16 in-stream)))
251 (format *debug-io* "Reflectivity ~A " (/ reflectivity 256))))
253 (def-lwob-subchunk-parser +lwob-tran-id+ (chunk in-stream out-stream)
254 (let ((transparency (read-value 'u16 in-stream)))
255 (format *debug-io* "Transparency ~A " (/ transparency 256))))
257 (def-lwob-subchunk-parser +lwob-glos-id+ (chunk in-stream out-stream)
258 (let ((glossiness (read-value 'u16 in-stream))))
259 (format *debug-io* "Glossiness ~A " (/ glossiness 1024)))
261 (defparameter *texture-context* :colour-texture)
263 (def-lwob-subchunk-parser +lwob-ctex-id+ (chunk in-stream out-stream)
264 (let ((colour-texture (read-value 'asciiz in-stream)))
265 (align-for-read in-stream +word-align+)
266 (setf *texture-context* :colour-texture)
267 (format *debug-io* "Colour texture ~A " colour-texture)))
269 (def-lwob-subchunk-parser +lwob-dtex-id+ (chunk in-stream out-stream)
270 (let ((diffuse-texture (read-value 'asciiz in-stream)))
271 (align-for-read in-stream +word-align+)
272 (setf *texture-context* :diffuse-texture)
273 (format *debug-io* "Diffuse texture ~A " diffuse-texture)))
275 (def-lwob-subchunk-parser +lwob-timg-id+ (chunk in-stream out-stream)
276 (let ((texture-name (read-value 'asciiz in-stream)))
277 (align-for-read in-stream +word-align+)
278 (format *debug-io* "Texture fname ~A" texture-name)))
281 (def-lwob-subchunk-parser +lwob-tflg-id+ (chunk in-stream out-stream)
282 (let ((texture-flags (read-value 'u16 in-stream)))
283 (destructure-bits texture-flags (xaxis yaxis zaxis world negative pixel-blending antialiasing)
284 (format *debug-io* "axes ~A ~A ~A" xaxis yaxis zaxis)
285 (format *debug-io* "world ~A" world)
286 (format *debug-io* "negative ~A" negative))))
288 (def-lwob-subchunk-parser +lwob-tsiz-id+ (chunk in-stream out-stream)
289 (let ((x (read-value 'float32 in-stream))
290 (y (read-value 'float32 in-stream))
291 (z (read-value 'float32 in-stream)))
292 (format "Size x y z ~A ~A ~A " x y z)))
294 (def-lwob-subchunk-parser +lwob-tctr-id+ (chunk in-stream out-stream)
295 (let ((x (read-value 'float32 in-stream))
296 (y (read-value 'float32 in-stream))
297 (z (read-value 'float32 in-stream)))
298 (format "Centre x y z ~A ~A ~A " x y z)))
300 (def-lwob-subchunk-parser +lwob-tfal-id+ (chunk in-stream out-stream)
301 (let ((x (read-value 'float32 in-stream))
302 (y (read-value 'float32 in-stream))
303 (z (read-value 'float32 in-stream)))
304 (format "Falloff x y z ~A ~A ~A " x y z)))
306 (def-lwob-subchunk-parser +lwob-tvel-id+ (chunk in-stream out-stream)
307 (let ((x (read-value 'float32 in-stream))
308 (y (read-value 'float32 in-stream))
309 (z (read-value 'float32 in-stream)))
310 (format "Velocity x y z ~A ~A ~A " x y z)))
312 (def-lwob-subchunk-parser +lwob-tclr-id+ (chunk in-stream out-stream)
313 (let ((x (read-value 'float32 in-stream))
314 (y (read-value 'float32 in-stream))
315 (z (read-value 'float32 in-stream)))
316 (format "Velocity x y z ~A ~A ~A " x y z)))
318 (defun parse-iff-file (output-file)
319 (with-open-file
320 (out-stream output-file :if-exists :overwrite :direction :output :if-does-not-exist :create)
321 (with-open-file
322 (in-stream #P"Future3a.lwo" :element-type '(unsigned-byte 8))
323 (parse-groups in-stream out-stream))))