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 (defgeneric group-size (group))
  32
  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))
  36
  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"))
  41
  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"))
  47
  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)))
  54
  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"))
  78
  79 (defclass iff-subchunk ()
  80   ((subchunk-id :accessor subchunk-id-of)
  81    (subchunk-size :accessor subchunk-size-of))
  82   (:documentation "IFF file subchunk"))
  83
  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)))
  89
  90
  91 (defgeneric iff-group-parser (group in-stream out-fn))
  92
  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)))))
 114
 115
 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)))
 121
 122
 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)))
 130
 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)))
 137
 138
 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)))
 145
 146
 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)))
 154
 155
 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))))
 168
 169 ;; Parsers for individual chunks inside an lwob group
 170
 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)))))
 180
 181
 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)))))))))))
 206
 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)))))
 216
 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)))))))
 234
 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)))
 242
 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))))
 246
 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))))
 250
 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))))
 254
 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))))
 258
 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))))
 262
 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))))
 266
 267 (defparameter *texture-context* :colour-texture)
 268
 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)))
 274
 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)))
 280
 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)))
 285
 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))))
 292
 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)))
 298
 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)))
 304
 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)))
 310
 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)))
 316
 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)))
 323
 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)))
 328
 329
 330
 331
 332