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 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."
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-stream
))
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-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
)
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
))
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
))
143 (defun parse-groups (in-stream out-stream
)
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-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
)
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-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
))))
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
)
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 (when (< (file-position in-stream
) chunk-end
)
194 (let ((surface (read-value 'u16 in-stream
:endian
:big
)))
196 (let ((detail-count (read-value 's16 in-stream
:endian
:big
)))
197 (format *debug-io
* "~A Details.." detail-count
)
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
+)
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
*)))
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)
320 (out-stream output-file
:if-exists
:overwrite
:direction
:output
:if-does-not-exist
:create
)
322 (in-stream #P
"Future3a.lwo" :element-type
'(unsigned-byte 8))
323 (parse-groups in-stream out-stream
))))