file-lwo.lisp

   1
   2 (in-package :lodematron)
   3
   4
   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"))
   9
  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))
  13
  14 ;; lwob group header
  15 (defconstant +lwob-group-type+ (string-id "LWOB"))
  16
  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"))
  22
  23
  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)))
  30
  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))
  34
  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"))
  39
  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"))
  45
  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)))
  52
  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"))
  76
  77 (defclass iff-subchunk ()
  78   ((subchunk-id :accessor subchunk-id-of)
  79    (subchunk-size :accessor subchunk-size-of))
  80   (:documentation "IFF file subchunk"))
  81
  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)))
  87
  88
  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."
  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-fn))
 106       ((= (group-id-of group) +cat-group-id+)
 107        (skip-group))
 108       ((= (group-id-of group) +list-group-id+)
 109        (skip-group)))))
 110
 111
 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)
 116           ,@body)))
 117
 118
 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)))
 126
 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))
 132            ,@body)))
 133
 134
 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))
 140            ,@body)))
 141
 142
 143 (defun parse-groups (in-stream out-fn)
 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-fn)))
 150
 151
 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)
 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-fn))))
 164
 165 ;; Parsers for individual chunks inside an lwob group
 166
 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))))
 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)))))
 176
 177
 178 ;; POLS chunk == polygons
 179 (def-lwob-chunk-parser +lwob-pols-id+ (chunk in-stream out-fn)
 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)))))))))))
 201
 202 ;; SRFS chunk == surface names
 203 (def-lwob-chunk-parser +lwob-srfs-id+ (chunk in-stream out-fn)
 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)))))
 211
 212 ;; SURF chunk == surface properties
 213 (def-lwob-chunk-parser +lwob-surf-id+ (chunk in-stream out-fn)
 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-fn)
 228                 (skip-subchunk subchunk in-stream)))))))
 229
 230 (def-lwob-subchunk-parser +lwob-colr-id+ (chunk in-stream out-fn)
 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)))
 236
 237 (def-lwob-subchunk-parser +lwob-lumi-id+ (chunk in-stream out-fn)
 238   (let ((luminosity (read-value 'u16 in-stream)))
 239     (format *debug-io* "Luminosity ~A " (/ luminosity 256))))
 240
 241 (def-lwob-subchunk-parser +lwob-diff-id+ (chunk in-stream out-fn)
 242   (let ((diffusion (read-value 'u16 in-stream)))
 243     (format *debug-io* "Diffusion ~A " (/ diffusion 256))))
 244
 245 (def-lwob-subchunk-parser +lwob-spec-id+ (chunk in-stream out-fn)
 246   (let ((specularity (read-value 'u16 in-stream)))
 247     (format *debug-io* "Specularity ~A " (/ specularity 256))))
 248
 249 (def-lwob-subchunk-parser +lwob-refl-id+ (chunk in-stream out-fn)
 250   (let ((reflectivity (read-value 'u16 in-stream)))
 251     (format *debug-io* "Reflectivity ~A " (/ reflectivity 256))))
 252
 253 (def-lwob-subchunk-parser +lwob-tran-id+ (chunk in-stream out-fn)
 254   (let ((transparency (read-value 'u16 in-stream)))
 255     (format *debug-io* "Transparency ~A " (/ transparency 256))))
 256
 257 (def-lwob-subchunk-parser +lwob-glos-id+ (chunk in-stream out-fn)
 258   (let ((glossiness (read-value 'u16 in-stream)))
 259     (format *debug-io* "Glossiness ~A " (/ glossiness 1024))))
 260
 261 (defparameter *texture-context* :colour-texture)
 262
 263 (def-lwob-subchunk-parser +lwob-ctex-id+ (chunk in-stream out-fn)
 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)))
 268
 269 (def-lwob-subchunk-parser +lwob-dtex-id+ (chunk in-stream out-fn)
 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)))
 274
 275 (def-lwob-subchunk-parser +lwob-timg-id+ (chunk in-stream out-fn)
 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)))
 279
 280 (def-lwob-subchunk-parser +lwob-tflg-id+ (chunk in-stream out-fn)
 281   (let ((texture-flags (read-value 'u16 in-stream)))
 282     (destructure-bits texture-flags (xaxis yaxis zaxis world negative pixel-blending antialiasing)
 283       (format *debug-io* "axes ~A ~A ~A" xaxis yaxis zaxis)
 284       (format *debug-io* "world ~A" world)
 285       (format *debug-io* "negative ~A" negative))))
 286
 287 (def-lwob-subchunk-parser +lwob-tsiz-id+ (chunk in-stream out-fn)
 288   (let ((x (read-value 'float32 in-stream))
 289         (y (read-value 'float32 in-stream))
 290         (z (read-value 'float32 in-stream)))
 291     (format "Size x y z ~A ~A ~A " x y z)))
 292
 293 (def-lwob-subchunk-parser +lwob-tctr-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 "Centre x y z ~A ~A ~A " x y z)))
 298
 299 (def-lwob-subchunk-parser +lwob-tfal-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 "Falloff x y z ~A ~A ~A " x y z)))
 304
 305 (def-lwob-subchunk-parser +lwob-tvel-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 "Velocity x y z ~A ~A ~A " x y z)))
 310
 311 (def-lwob-subchunk-parser +lwob-tclr-id+ (chunk in-stream out-fn)
 312   (let* ((red (read-value 'u8 in-stream))
 313          (green (read-value 'u8 in-stream))
 314          (blue (read-value 'u8 in-stream))
 315          (dummy (read-value 'u8 in-stream)))
 316     (format *debug-io* "Colour ~X ~X ~X " red green blue)))
 317
 318 (defun parse-iff-file (input-file output-fn)
 319   (with-open-file
 320       (in-stream input-file :element-type '(unsigned-byte 8))
 321     (parse-groups in-stream output-fn)))
 322
 323
 324
 325
 326