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))
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 stream
: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 (defmethod iff-group-parser ((group iff-group
) in-stream out-fn
)
94 "Parse an iff group, read from in-stream, dump to out-fn."
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
))))
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-fn
))
106 ((= (group-id-of group
) +cat-group-id
+)
108 ((= (group-id-of group
) +list-group-id
+)
112 (defmacro def-group-contents-parser
(form-type (group-sym in-stream-sym out-fn-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-fn-sym
)
119 (defun unknown-iff-chunk-parser (chunk in-stream out-fn
)
120 "Fallback for an unknown chunk"
121 (declare (ignore out-fn
))
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 ,chunk-sym
,in-sym
,out-sym
))
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 ,subchunk-sym
,in-sym
,out-sym
))
143 (defun parse-groups (in-stream out-fn
)
144 "Top level IFF File parsing function"
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-fn
)))
152 ;; "Parse the contents of a lwob group"
153 (def-group-contents-parser +lwob-group-type
+ (group in-stream out-fn
)
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
)
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
)))
162 (gethash (chunk-id-of chunk
) *lwob-chunk-parsers
* #'unknown-iff-chunk-parser
)
163 chunk in-stream out-fn
))))
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-fn
)
169 (let ((chunk-end (+ (file-position in-stream
) (chunk-size-of chunk
))))
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-fn
)
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
)
186 (for vertex from
0 below vertex-count
)
187 (setf (aref vertices vertex
) (read-value 'u16 in-stream
:endian
:big
)))
189 (let ((chunk-end (+ (file-position in-stream
) (chunk-size-of chunk
))))
191 (while (< (file-position in-stream
) chunk-end
))
192 (let ((polygon (parse-polygon)))
193 (declare (ignorable polygon
))
194 (when (< (file-position in-stream
) chunk-end
)
195 (let ((surface (read-value 'u16 in-stream
:endian
:big
)))
197 (let ((detail-count (read-value 's16 in-stream
:endian
:big
)))
198 (format *debug-io
* "~A Details.." detail-count
)
200 (for detail-index from
0 below detail-count
)
201 (parse-polygon)))))))))))
203 ;; SRFS chunk == surface names
204 (def-lwob-chunk-parser +lwob-srfs-id
+ (chunk in-stream out-fn
)
205 (let ((chunk-end (+ (file-position in-stream
) (chunk-size-of chunk
))))
206 (format *debug-io
* "Surface chunk~&")
207 (iterate (while (< (file-position in-stream
) chunk-end
))
208 (format *debug-io
* "String at ~X~&" (file-position in-stream
))
209 (let ((surf-name (read-value 'asciiz in-stream
)))
210 (align-for-read in-stream
+word-align
+)
211 (format *debug-io
* "Surface ~A~&" surf-name
)))))
213 ;; SURF chunk == surface properties
214 (def-lwob-chunk-parser +lwob-surf-id
+ (chunk in-stream out-fn
)
215 (labels ((skip-subchunk (subchunk in-stream
)
216 (format *debug-io
* "~&Skipping unknown subchunk ~A "
217 (id-string (subchunk-id-of subchunk
)))
218 (advance-file-position in-stream
(subchunk-size-of subchunk
))))
219 (let ((chunk-end (+ (file-position in-stream
) (chunk-size-of chunk
)))
220 (surface-name (read-value 'asciiz in-stream
)))
221 (format *debug-io
* "~&For surface ~A " surface-name
)
222 (align-for-read in-stream
+word-align
+)
224 (while (< (file-position in-stream
) chunk-end
))
225 (let* ((subchunk (make-instance 'iff-subchunk
:stream in-stream
))
226 (parser (gethash (subchunk-id-of subchunk
) *lwob-subchunk-parsers
*)))
228 (funcall parser subchunk in-stream out-fn
)
229 (skip-subchunk subchunk in-stream
)))))))
231 (def-lwob-subchunk-parser +lwob-colr-id
+ (chunk in-stream out-fn
)
232 (let* ((red (read-value 'u8 in-stream
))
233 (green (read-value 'u8 in-stream
))
234 (blue (read-value 'u8 in-stream
))
235 (dummy (read-value 'u8 in-stream
)))
236 (declare (ignorable dummy
))
237 (format *debug-io
* "Colour ~X ~X ~X " red green blue
)))
239 (def-lwob-subchunk-parser +lwob-lumi-id
+ (chunk in-stream out-fn
)
240 (let ((luminosity (read-value 'u16 in-stream
)))
241 (format *debug-io
* "Luminosity ~A " (/ luminosity
256))))
243 (def-lwob-subchunk-parser +lwob-diff-id
+ (chunk in-stream out-fn
)
244 (let ((diffusion (read-value 'u16 in-stream
)))
245 (format *debug-io
* "Diffusion ~A " (/ diffusion
256))))
247 (def-lwob-subchunk-parser +lwob-spec-id
+ (chunk in-stream out-fn
)
248 (let ((specularity (read-value 'u16 in-stream
)))
249 (format *debug-io
* "Specularity ~A " (/ specularity
256))))
251 (def-lwob-subchunk-parser +lwob-refl-id
+ (chunk in-stream out-fn
)
252 (let ((reflectivity (read-value 'u16 in-stream
)))
253 (format *debug-io
* "Reflectivity ~A " (/ reflectivity
256))))
255 (def-lwob-subchunk-parser +lwob-tran-id
+ (chunk in-stream out-fn
)
256 (let ((transparency (read-value 'u16 in-stream
)))
257 (format *debug-io
* "Transparency ~A " (/ transparency
256))))
259 (def-lwob-subchunk-parser +lwob-glos-id
+ (chunk in-stream out-fn
)
260 (let ((glossiness (read-value 'u16 in-stream
)))
261 (format *debug-io
* "Glossiness ~A " (/ glossiness
1024))))
263 (defparameter *texture-context
* :colour-texture
)
265 (def-lwob-subchunk-parser +lwob-ctex-id
+ (chunk in-stream out-fn
)
266 (let ((colour-texture (read-value 'asciiz in-stream
)))
267 (align-for-read in-stream
+word-align
+)
268 (setf *texture-context
* :colour-texture
)
269 (format *debug-io
* "Colour texture ~A " colour-texture
)))
271 (def-lwob-subchunk-parser +lwob-dtex-id
+ (chunk in-stream out-fn
)
272 (let ((diffuse-texture (read-value 'asciiz in-stream
)))
273 (align-for-read in-stream
+word-align
+)
274 (setf *texture-context
* :diffuse-texture
)
275 (format *debug-io
* "Diffuse texture ~A " diffuse-texture
)))
277 (def-lwob-subchunk-parser +lwob-timg-id
+ (chunk in-stream out-fn
)
278 (let ((texture-name (read-value 'asciiz in-stream
)))
279 (align-for-read in-stream
+word-align
+)
280 (format *debug-io
* "Texture fname ~A" texture-name
)))
282 (def-lwob-subchunk-parser +lwob-tflg-id
+ (chunk in-stream out-fn
)
283 (let ((texture-flags (read-value 'u16 in-stream
)))
284 (destructure-bits texture-flags
(xaxis yaxis zaxis world negative pixel-blending antialiasing
)
285 (format *debug-io
* "axes ~A ~A ~A" xaxis yaxis zaxis
)
286 (format *debug-io
* "world ~A" world
)
287 (format *debug-io
* "negative ~A" negative
))))
289 (def-lwob-subchunk-parser +lwob-tsiz-id
+ (chunk in-stream out-fn
)
290 (let ((x (read-value 'float32 in-stream
))
291 (y (read-value 'float32 in-stream
))
292 (z (read-value 'float32 in-stream
)))
293 (format "Size x y z ~A ~A ~A " x y z
)))
295 (def-lwob-subchunk-parser +lwob-tctr-id
+ (chunk in-stream out-fn
)
296 (let ((x (read-value 'float32 in-stream
))
297 (y (read-value 'float32 in-stream
))
298 (z (read-value 'float32 in-stream
)))
299 (format "Centre x y z ~A ~A ~A " x y z
)))
301 (def-lwob-subchunk-parser +lwob-tfal-id
+ (chunk in-stream out-fn
)
302 (let ((x (read-value 'float32 in-stream
))
303 (y (read-value 'float32 in-stream
))
304 (z (read-value 'float32 in-stream
)))
305 (format "Falloff x y z ~A ~A ~A " x y z
)))
307 (def-lwob-subchunk-parser +lwob-tvel-id
+ (chunk in-stream out-fn
)
308 (let ((x (read-value 'float32 in-stream
))
309 (y (read-value 'float32 in-stream
))
310 (z (read-value 'float32 in-stream
)))
311 (format "Velocity x y z ~A ~A ~A " x y z
)))
313 (def-lwob-subchunk-parser +lwob-tclr-id
+ (chunk in-stream out-fn
)
314 (let* ((red (read-value 'u8 in-stream
))
315 (green (read-value 'u8 in-stream
))
316 (blue (read-value 'u8 in-stream
)))
317 (read-value 'u8 in-stream
)
318 (format *debug-io
* "Colour ~X ~X ~X " red green blue
)))
320 (defun parse-iff-file (input-file output-fn
)
322 (in-stream input-file
:element-type
'(unsigned-byte 8))
323 (parse-groups in-stream output-fn
)))