file-md2.lisp

   1
   2 (in-package :lodematron)
   3
   4 (defun null-terminate (vector)
   5   (let
   6       ((zeroat (position 0 vector)))
   7     (if zeroat
   8         (subseq vector 0 zeroat)
   9          vector)))
  10
  11 (defparameter *MD2-ANORMS*
  12   '#(
  13   '( -0.525731  0.000000  0.850651 )
  14   '( -0.442863  0.238856  0.864188 )
  15   '( -0.295242  0.000000  0.955423 )
  16   '( -0.309017  0.500000  0.809017 )
  17   '( -0.162460  0.262866  0.951056 )
  18   '(  0.000000  0.000000  1.000000 )
  19   '(  0.000000  0.850651  0.525731 )
  20   '( -0.147621  0.716567  0.681718 )
  21   '(  0.147621  0.716567  0.681718 )
  22   '(  0.000000  0.525731  0.850651 )
  23   '(  0.309017  0.500000  0.809017 )
  24   '(  0.525731  0.000000  0.850651 )
  25   '(  0.295242  0.000000  0.955423 )
  26   '(  0.442863  0.238856  0.864188 )
  27   '(  0.162460  0.262866  0.951056 )
  28   '( -0.681718  0.147621  0.716567 )
  29   '( -0.809017  0.309017  0.500000 )
  30   '( -0.587785  0.425325  0.688191 )
  31   '( -0.850651  0.525731  0.000000 )
  32   '( -0.864188  0.442863  0.238856 )
  33   '( -0.716567  0.681718  0.147621 )
  34   '( -0.688191  0.587785  0.425325 )
  35   '( -0.500000  0.809017  0.309017 )
  36   '( -0.238856  0.864188  0.442863 )
  37   '( -0.425325  0.688191  0.587785 )
  38   '( -0.716567  0.681718 -0.147621 )
  39   '( -0.500000  0.809017 -0.309017 )
  40   '( -0.525731  0.850651  0.000000 )
  41   '(  0.000000  0.850651 -0.525731 )
  42   '( -0.238856  0.864188 -0.442863 )
  43   '(  0.000000  0.955423 -0.295242 )
  44   '( -0.262866  0.951056 -0.162460 )
  45   '(  0.000000  1.000000  0.000000 )
  46   '(  0.000000  0.955423  0.295242 )
  47   '( -0.262866  0.951056  0.162460 )
  48   '(  0.238856  0.864188  0.442863 )
  49   '(  0.262866  0.951056  0.162460 )
  50   '(  0.500000  0.809017  0.309017 )
  51   '(  0.238856  0.864188 -0.442863 )
  52   '(  0.262866  0.951056 -0.162460 )
  53   '(  0.500000  0.809017 -0.309017 )
  54   '(  0.850651  0.525731  0.000000 )
  55   '(  0.716567  0.681718  0.147621 )
  56   '(  0.716567  0.681718 -0.147621 )
  57   '(  0.525731  0.850651  0.000000 )
  58   '(  0.425325  0.688191  0.587785 )
  59   '(  0.864188  0.442863  0.238856 )
  60   '(  0.688191  0.587785  0.425325 )
  61   '(  0.809017  0.309017  0.500000 )
  62   '(  0.681718  0.147621  0.716567 )
  63   '(  0.587785  0.425325  0.688191 )
  64   '(  0.955423  0.295242  0.000000 )
  65   '(  1.000000  0.000000  0.000000 )
  66   '(  0.951056  0.162460  0.262866 )
  67   '(  0.850651 -0.525731  0.000000 )
  68   '(  0.955423 -0.295242  0.000000 )
  69   '(  0.864188 -0.442863  0.238856 )
  70   '(  0.951056 -0.162460  0.262866 )
  71   '(  0.809017 -0.309017  0.500000 )
  72   '(  0.681718 -0.147621  0.716567 )
  73   '(  0.850651  0.000000  0.525731 )
  74   '(  0.864188  0.442863 -0.238856 )
  75   '(  0.809017  0.309017 -0.500000 )
  76   '(  0.951056  0.162460 -0.262866 )
  77   '(  0.525731  0.000000 -0.850651 )
  78   '(  0.681718  0.147621 -0.716567 )
  79   '(  0.681718 -0.147621 -0.716567 )
  80   '(  0.850651  0.000000 -0.525731 )
  81   '(  0.809017 -0.309017 -0.500000 )
  82   '(  0.864188 -0.442863 -0.238856 )
  83   '(  0.951056 -0.162460 -0.262866 )
  84   '(  0.147621  0.716567 -0.681718 )
  85   '(  0.309017  0.500000 -0.809017 )
  86   '(  0.425325  0.688191 -0.587785 )
  87   '(  0.442863  0.238856 -0.864188 )
  88   '(  0.587785  0.425325 -0.688191 )
  89   '(  0.688191  0.587785 -0.425325 )
  90   '( -0.147621  0.716567 -0.681718 )
  91   '( -0.309017  0.500000 -0.809017 )
  92   '(  0.000000  0.525731 -0.850651 )
  93   '( -0.525731  0.000000 -0.850651 )
  94   '( -0.442863  0.238856 -0.864188 )
  95   '( -0.295242  0.000000 -0.955423 )
  96   '( -0.162460  0.262866 -0.951056 )
  97   '(  0.000000  0.000000 -1.000000 )
  98   '(  0.295242  0.000000 -0.955423 )
  99   '(  0.162460  0.262866 -0.951056 )
 100   '( -0.442863 -0.238856 -0.864188 )
 101   '( -0.309017 -0.500000 -0.809017 )
 102   '( -0.162460 -0.262866 -0.951056 )
 103   '(  0.000000 -0.850651 -0.525731 )
 104   '( -0.147621 -0.716567 -0.681718 )
 105   '(  0.147621 -0.716567 -0.681718 )
 106   '(  0.000000 -0.525731 -0.850651 )
 107   '(  0.309017 -0.500000 -0.809017 )
 108   '(  0.442863 -0.238856 -0.864188 )
 109   '(  0.162460 -0.262866 -0.951056 )
 110   '(  0.238856 -0.864188 -0.442863 )
 111   '(  0.500000 -0.809017 -0.309017 )
 112   '(  0.425325 -0.688191 -0.587785 )
 113   '(  0.716567 -0.681718 -0.147621 )
 114   '(  0.688191 -0.587785 -0.425325 )
 115   '(  0.587785 -0.425325 -0.688191 )
 116   '(  0.000000 -0.955423 -0.295242 )
 117   '(  0.000000 -1.000000  0.000000 )
 118   '(  0.262866 -0.951056 -0.162460 )
 119   '(  0.000000 -0.850651  0.525731 )
 120   '(  0.000000 -0.955423  0.295242 )
 121   '(  0.238856 -0.864188  0.442863 )
 122   '(  0.262866 -0.951056  0.162460 )
 123   '(  0.500000 -0.809017  0.309017 )
 124   '(  0.716567 -0.681718  0.147621 )
 125   '(  0.525731 -0.850651  0.000000 )
 126   '( -0.238856 -0.864188 -0.442863 )
 127   '( -0.500000 -0.809017 -0.309017 )
 128   '( -0.262866 -0.951056 -0.162460 )
 129   '( -0.850651 -0.525731  0.000000 )
 130   '( -0.716567 -0.681718 -0.147621 )
 131   '( -0.716567 -0.681718  0.147621 )
 132   '( -0.525731 -0.850651  0.000000 )
 133   '( -0.500000 -0.809017  0.309017 )
 134   '( -0.238856 -0.864188  0.442863 )
 135   '( -0.262866 -0.951056  0.162460 )
 136   '( -0.864188 -0.442863  0.238856 )
 137   '( -0.809017 -0.309017  0.500000 )
 138   '( -0.688191 -0.587785  0.425325 )
 139   '( -0.681718 -0.147621  0.716567 )
 140   '( -0.442863 -0.238856  0.864188 )
 141   '( -0.587785 -0.425325  0.688191 )
 142   '( -0.309017 -0.500000  0.809017 )
 143   '( -0.147621 -0.716567  0.681718 )
 144   '( -0.425325 -0.688191  0.587785 )
 145   '( -0.162460 -0.262866  0.951056 )
 146   '(  0.442863 -0.238856  0.864188 )
 147   '(  0.162460 -0.262866  0.951056 )
 148   '(  0.309017 -0.500000  0.809017 )
 149   '(  0.147621 -0.716567  0.681718 )
 150   '(  0.000000 -0.525731  0.850651 )
 151   '(  0.425325 -0.688191  0.587785 )
 152   '(  0.587785 -0.425325  0.688191 )
 153   '(  0.688191 -0.587785  0.425325 )
 154   '( -0.955423  0.295242  0.000000 )
 155   '( -0.951056  0.162460  0.262866 )
 156   '( -1.000000  0.000000  0.000000 )
 157   '( -0.850651  0.000000  0.525731 )
 158   '( -0.955423 -0.295242  0.000000 )
 159   '( -0.951056 -0.162460  0.262866 )
 160   '( -0.864188  0.442863 -0.238856 )
 161   '( -0.951056  0.162460 -0.262866 )
 162   '( -0.809017  0.309017 -0.500000 )
 163   '( -0.864188 -0.442863 -0.238856 )
 164   '( -0.951056 -0.162460 -0.262866 )
 165   '( -0.809017 -0.309017 -0.500000 )
 166   '( -0.681718  0.147621 -0.716567 )
 167   '( -0.681718 -0.147621 -0.716567 )
 168   '( -0.850651  0.000000 -0.525731 )
 169   '( -0.688191  0.587785 -0.425325 )
 170   '( -0.587785  0.425325 -0.688191 )
 171   '( -0.425325  0.688191 -0.587785 )
 172   '( -0.425325 -0.688191 -0.587785 )
 173   '( -0.587785 -0.425325 -0.688191 )
 174   '( -0.688191 -0.587785 -0.425325 ) )
 175   "Normal lookup table used by md2 normal quantizer"   )
 176
 177 (define-binary-class md2-header
 178     ((ident :u32)
 179      (version :u32)
 180      ;; don't rely on skin info in header - it's most likely balls
 181      (skinwidth :u32)
 182      (skinheight :u32)
 183      (framesize :u32)
 184      (nskins :u32)
 185      (nvertices :u32)
 186      (nuvs :u32)
 187      (ntris :u32)
 188      (nglcmds :u32)
 189      (nframes :u32)
 190      (skin-offset :u32)
 191      (uv-offset :u32)
 192      (tris-offset :u32)
 193      (frames-offset :u32)
 194      (glcmds-offset :u32)
 195      (end-offset :u32)))
 196
 197
 198 (define-binary-class md2-skin-name
 199     ((name :u8 :array-size 64)))
 200
 201 (define-binary-class md2-vector
 202     ((x :float32)
 203      (y :float32)
 204      (z :float32)))
 205
 206 (define-binary-class md2-uv
 207     ((u :s32)
 208      (v :s32)))
 209
 210 (define-binary-class md2-triangle
 211     ((vertex-indices :u32 :array-size 3)
 212       (uv-indices :u32 :array-size 3)))
 213
 214 (define-binary-class md2-vertex
 215     ((position :u8 :array-size 3)
 216      (normal-index :u8)))
 217
 218 (define-binary-class md2-frame-header
 219     ((scale :md2-vector)
 220      (translate :md2-vector)
 221      (name :u8 :array-size 16)))
 222
 223
 224 (defun parse-md2-skin-names (offset n stream)
 225   (file-position stream offset)
 226   (let ((result nil))
 227     (iterate
 228       (for i from 0 below n)
 229       (collecting (babel:octets-to-string (read-value 'u8 stream :array-size 64))))
 230     result))
 231
 232
 233 (defun parse-md2-uvs (offset n stream)
 234   (file-position stream offset)
 235   (let ((result (iterate
 236                   (for i from 0 below n)
 237                   (collecting (read-value 'md2-uv stream)))))
 238     result))
 239
 240 (defun parse-md2-triangles (offset n stream)
 241   (file-position stream offset)
 242   (let ((result (iterate
 243                   (for i from 0 below n)
 244                   (collecting (read-value 'md2-triangle stream)))))
 245     result))
 246
 247
 248 (defun parse-md2-frames (offset n size nverts stream)
 249   (file-position stream offset)
 250   (format *debug-io* "~A Frames~%" n)
 251   (let ((frames
 252           (iterate
 253             (for i from 0 below n)
 254             (format *debug-io* "Parsing frame ~A~%" i)
 255             (file-position stream (+ offset (* i size)))
 256             (format *debug-io* "File read from ~X~%" (file-position stream))
 257             (collecting
 258              (let ((header (read-value 'md2-frame-header stream)))
 259                (format *debug-io* "Header Name ~A~%" (babel::octets-to-string (null-terminate (name-of header)))
 260                        (let ((vertices
 261                               (iterate
 262                                 (for j from 0 below nverts)
 263                                 (collecting (read-value 'md2-vertex stream)))))
 264                          (cons header vertices))))))))
 265     frames))
 266
 267 (defun process-vertices (scale translation vertices)
 268   (iterate
 269     (for vertex in vertices)
 270     (collecting
 271      (list
 272       (+ (* (aref  (position-of vertex) 0) (x-of scale)) (x-of translation))
 273       (+ (* (aref  (position-of vertex) 1) (y-of scale)) (y-of translation))
 274       (+ (* (aref  (position-of vertex) 1) (z-of scale)) (z-of translation))))))
 275
 276 (defun processs-normals (vertices)
 277   (iterate
 278     (for vertex in vertices)
 279     (collecting (aref *MD2-ANORMS* (normal-index-of vertex)))))
 280
 281 (defun process-uvs (uvs swidth theight)
 282   (iterate
 283     (for uv in uvs)
 284     (collecting (vector2d* (/ (u-of uv) swidth) (/ (v-of uv) theight)))))
 285
 286 (defun process-faces (tris)
 287   (iterate
 288     (for tri in tris)
 289     (collecting (cons
 290                  (list :vertices
 291                       (aref  (vertex-indices-of tri) 0)
 292                       (aref  (vertex-indices-of tri) 1)
 293                       (aref  (vertex-indices-of tri) 2))
 294                  (list :uvs
 295                        (aref  (uv-indices-of tri) 0)
 296                        (aref  (uv-indices-of tri) 1)
 297                        (aref  (uv-indices-of tri) 2))))))
 298
 299
 300 (defun parse-md2-file (stream out)
 301   (let*
 302       ((header
 303          (read-value 'md2-header stream)))
 304     (format *debug-io* "~D Skins ~D Vertices ~D UVS ~D Tris" (nskins-of header) (nvertices-of header) (nuvs-of header) (ntris-of header))
 305     (let*
 306         ((skins  (parse-md2-skin-names (skin-offset-of header) (nskins-of header) stream))
 307          (uvs (parse-md2-uvs (uv-offset-of header) (nuvs-of header) stream))
 308          (tris (parse-md2-triangles (tris-offset-of header) (ntris-of header) stream))
 309          (frames (parse-md2-frames (frames-offset-of header) (nframes-of header) (nvertices-of header) stream)))
 310       (iterate
 311         (for frame in frames)
 312         (destructuring-bind (header vertices)
 313             frame
 314           (format ":vertices ~A"
 315                   (process-vertices (scale-of header) (translation-of header)))
 316           (format ":texcoords ~A" (process-uvs uvs
 317                                                (coerce
 318                                                 (skinwidth-of header) 'single-float)
 319                                                (coerce
 320                                                 (skinheight-of header) 'single-float)))
 321           (format ":normals ~A" (process-normals vertices))
 322           (format ":faces ~A " (process-faces tris)))))))
 323
 324
 325 ;;
 326 ;; test code
 327 ;;
 328 ;; (defparameter *md2-file* (open (merge-pathnames #P"dalekx/tris.md2") :direction :input :element-type '(unsigned-byte 8)))
 329
 330 ;; (defparameter *header* (read-value 'md2-header *md2-file*))
 331
 332 ;; (defparameter *uvs* (parse-md2-uvs (uv-offset-of *header*) (nuvs-of *header*) *md2-file*))
 333
 334 ;; (defparameter *tris* (parse-md2-triangles (tris-offset-of *header*) (ntris-of *header*) *md2-file*))
 335
 336 ;; (defparameter *frames* (parse-md2-frames (frames-offset-of *header*) (nframes-of *header*) (framesize-of *header*) (nvertices-of *header*) *md2-file*))
 337
 338 ;; (format *debug-io* "~D Skins ~D Vertices ~D UVS ~D Tris" (nskins-of *header*) (nvertices-of *header*) (nuvs-of *header*) (ntris-of *header*))
 339
 340
 341 ;; (close *md2-file*)