More md2 handling

[lodematron.git] / file-md2.lisp

(in-package :lodematron)

(defun null-terminate (vector)
  "Return the given sequence stripped of trailing zeros"
  (let 
      ((zeroat (position 0 vector)))
    (if zeroat
        (subseq vector 0 zeroat)
         vector)))
    
(defparameter *MD2-ANORMS* 
  '#(
  '( -0.525731  0.000000  0.850651 )
  '( -0.442863  0.238856  0.864188 )
  '( -0.295242  0.000000  0.955423 )
  '( -0.309017  0.500000  0.809017 )
  '( -0.162460  0.262866  0.951056 )
  '(  0.000000  0.000000  1.000000 )
  '(  0.000000  0.850651  0.525731 )
  '( -0.147621  0.716567  0.681718 )
  '(  0.147621  0.716567  0.681718 )
  '(  0.000000  0.525731  0.850651 )
  '(  0.309017  0.500000  0.809017 )
  '(  0.525731  0.000000  0.850651 )
  '(  0.295242  0.000000  0.955423 )
  '(  0.442863  0.238856  0.864188 )
  '(  0.162460  0.262866  0.951056 )
  '( -0.681718  0.147621  0.716567 )
  '( -0.809017  0.309017  0.500000 )
  '( -0.587785  0.425325  0.688191 )
  '( -0.850651  0.525731  0.000000 )
  '( -0.864188  0.442863  0.238856 )
  '( -0.716567  0.681718  0.147621 )
  '( -0.688191  0.587785  0.425325 )
  '( -0.500000  0.809017  0.309017 )
  '( -0.238856  0.864188  0.442863 )
  '( -0.425325  0.688191  0.587785 )
  '( -0.716567  0.681718 -0.147621 )
  '( -0.500000  0.809017 -0.309017 )
  '( -0.525731  0.850651  0.000000 )
  '(  0.000000  0.850651 -0.525731 )
  '( -0.238856  0.864188 -0.442863 )
  '(  0.000000  0.955423 -0.295242 )
  '( -0.262866  0.951056 -0.162460 )
  '(  0.000000  1.000000  0.000000 )
  '(  0.000000  0.955423  0.295242 )
  '( -0.262866  0.951056  0.162460 )
  '(  0.238856  0.864188  0.442863 )
  '(  0.262866  0.951056  0.162460 )
  '(  0.500000  0.809017  0.309017 )
  '(  0.238856  0.864188 -0.442863 )
  '(  0.262866  0.951056 -0.162460 )
  '(  0.500000  0.809017 -0.309017 )
  '(  0.850651  0.525731  0.000000 )
  '(  0.716567  0.681718  0.147621 )
  '(  0.716567  0.681718 -0.147621 )
  '(  0.525731  0.850651  0.000000 )
  '(  0.425325  0.688191  0.587785 )
  '(  0.864188  0.442863  0.238856 )
  '(  0.688191  0.587785  0.425325 )
  '(  0.809017  0.309017  0.500000 )
  '(  0.681718  0.147621  0.716567 )
  '(  0.587785  0.425325  0.688191 )
  '(  0.955423  0.295242  0.000000 )
  '(  1.000000  0.000000  0.000000 )
  '(  0.951056  0.162460  0.262866 )
  '(  0.850651 -0.525731  0.000000 )
  '(  0.955423 -0.295242  0.000000 )
  '(  0.864188 -0.442863  0.238856 )
  '(  0.951056 -0.162460  0.262866 )
  '(  0.809017 -0.309017  0.500000 )
  '(  0.681718 -0.147621  0.716567 )
  '(  0.850651  0.000000  0.525731 )
  '(  0.864188  0.442863 -0.238856 )
  '(  0.809017  0.309017 -0.500000 )
  '(  0.951056  0.162460 -0.262866 )
  '(  0.525731  0.000000 -0.850651 )
  '(  0.681718  0.147621 -0.716567 )
  '(  0.681718 -0.147621 -0.716567 )
  '(  0.850651  0.000000 -0.525731 )
  '(  0.809017 -0.309017 -0.500000 )
  '(  0.864188 -0.442863 -0.238856 )
  '(  0.951056 -0.162460 -0.262866 )
  '(  0.147621  0.716567 -0.681718 )
  '(  0.309017  0.500000 -0.809017 )
  '(  0.425325  0.688191 -0.587785 )
  '(  0.442863  0.238856 -0.864188 )
  '(  0.587785  0.425325 -0.688191 )
  '(  0.688191  0.587785 -0.425325 )
  '( -0.147621  0.716567 -0.681718 )
  '( -0.309017  0.500000 -0.809017 )
  '(  0.000000  0.525731 -0.850651 )
  '( -0.525731  0.000000 -0.850651 )
  '( -0.442863  0.238856 -0.864188 )
  '( -0.295242  0.000000 -0.955423 )
  '( -0.162460  0.262866 -0.951056 )
  '(  0.000000  0.000000 -1.000000 )
  '(  0.295242  0.000000 -0.955423 )
  '(  0.162460  0.262866 -0.951056 )
  '( -0.442863 -0.238856 -0.864188 )
  '( -0.309017 -0.500000 -0.809017 )
  '( -0.162460 -0.262866 -0.951056 )
  '(  0.000000 -0.850651 -0.525731 )
  '( -0.147621 -0.716567 -0.681718 )
  '(  0.147621 -0.716567 -0.681718 )
  '(  0.000000 -0.525731 -0.850651 )
  '(  0.309017 -0.500000 -0.809017 )
  '(  0.442863 -0.238856 -0.864188 )
  '(  0.162460 -0.262866 -0.951056 )
  '(  0.238856 -0.864188 -0.442863 )
  '(  0.500000 -0.809017 -0.309017 )
  '(  0.425325 -0.688191 -0.587785 )
  '(  0.716567 -0.681718 -0.147621 )
  '(  0.688191 -0.587785 -0.425325 )
  '(  0.587785 -0.425325 -0.688191 )
  '(  0.000000 -0.955423 -0.295242 )
  '(  0.000000 -1.000000  0.000000 )
  '(  0.262866 -0.951056 -0.162460 )
  '(  0.000000 -0.850651  0.525731 )
  '(  0.000000 -0.955423  0.295242 )
  '(  0.238856 -0.864188  0.442863 )
  '(  0.262866 -0.951056  0.162460 )
  '(  0.500000 -0.809017  0.309017 )
  '(  0.716567 -0.681718  0.147621 )
  '(  0.525731 -0.850651  0.000000 )
  '( -0.238856 -0.864188 -0.442863 )
  '( -0.500000 -0.809017 -0.309017 )
  '( -0.262866 -0.951056 -0.162460 )
  '( -0.850651 -0.525731  0.000000 )
  '( -0.716567 -0.681718 -0.147621 )
  '( -0.716567 -0.681718  0.147621 )
  '( -0.525731 -0.850651  0.000000 )
  '( -0.500000 -0.809017  0.309017 )
  '( -0.238856 -0.864188  0.442863 )
  '( -0.262866 -0.951056  0.162460 )
  '( -0.864188 -0.442863  0.238856 )
  '( -0.809017 -0.309017  0.500000 )
  '( -0.688191 -0.587785  0.425325 )
  '( -0.681718 -0.147621  0.716567 )
  '( -0.442863 -0.238856  0.864188 )
  '( -0.587785 -0.425325  0.688191 )
  '( -0.309017 -0.500000  0.809017 )
  '( -0.147621 -0.716567  0.681718 )
  '( -0.425325 -0.688191  0.587785 )
  '( -0.162460 -0.262866  0.951056 )
  '(  0.442863 -0.238856  0.864188 )
  '(  0.162460 -0.262866  0.951056 )
  '(  0.309017 -0.500000  0.809017 )
  '(  0.147621 -0.716567  0.681718 )
  '(  0.000000 -0.525731  0.850651 )
  '(  0.425325 -0.688191  0.587785 )
  '(  0.587785 -0.425325  0.688191 )
  '(  0.688191 -0.587785  0.425325 )
  '( -0.955423  0.295242  0.000000 )
  '( -0.951056  0.162460  0.262866 )
  '( -1.000000  0.000000  0.000000 )
  '( -0.850651  0.000000  0.525731 )
  '( -0.955423 -0.295242  0.000000 )
  '( -0.951056 -0.162460  0.262866 )
  '( -0.864188  0.442863 -0.238856 )
  '( -0.951056  0.162460 -0.262866 )
  '( -0.809017  0.309017 -0.500000 )
  '( -0.864188 -0.442863 -0.238856 )
  '( -0.951056 -0.162460 -0.262866 )
  '( -0.809017 -0.309017 -0.500000 )
  '( -0.681718  0.147621 -0.716567 )
  '( -0.681718 -0.147621 -0.716567 )
  '( -0.850651  0.000000 -0.525731 )
  '( -0.688191  0.587785 -0.425325 )
  '( -0.587785  0.425325 -0.688191 )
  '( -0.425325  0.688191 -0.587785 )
  '( -0.425325 -0.688191 -0.587785 )
  '( -0.587785 -0.425325 -0.688191 )
  '( -0.688191 -0.587785 -0.425325 ) )
  "Normal lookup table used by md2 normal quantizer"   )

(define-binary-class md2-header
    ((ident :u32)
     (version :u32)
     ;; don't rely on skin info in header - it's most likely balls
     (skinwidth :u32)
     (skinheight :u32)
     (framesize :u32)
     (nskins :u32)
     (nvertices :u32)
     (nuvs :u32)
     (ntris :u32)
     (nglcmds :u32)
     (nframes :u32)
     (skin-offset :u32)
     (uv-offset :u32)
     (tris-offset :u32)
     (frames-offset :u32)
     (glcmds-offset :u32)
     (end-offset :u32)))


(define-binary-class md2-skin-name
    ((name :u8 :array-size 64)))

(define-binary-class md2-vector
    ((x :float32)
     (y :float32)
     (z :float32)))

(define-binary-class md2-uv
    ((u :s16)
     (v :s16)))

(define-binary-class md2-triangle
    ((vertex-indices :u16 :array-size 3)
      (uv-indices :u16 :array-size 3)))

(define-binary-class md2-vertex
    ((position :u8 :array-size 3)
     (normal-index :u8)))

(define-binary-class md2-frame-header
    ((scale :md2-vector)
     (translation :md2-vector)
     (name :u8 :array-size 16)))

(def-mesh-type md2-mesh (simple-mesh) nil 
               :slots
               ((uvs :accessor uvs-of  :initform (make-vector2d-array 0 :adjustable t :fill-pointer 0 ))
                (uv-index :accessor uvs-tris-of :initform (make-triangle-array 0 :adjustable t :fill-pointer 0))
                (skin :accessor skin-of)))

;; parsing -- aka file reading

(defun parse-md2-skin-names (offset n stream)
  (file-position stream offset)
  (let ((result nil))
    (iterate
      (for i from 0 below n)
      (collecting (babel:octets-to-string (read-value :u8 stream :array-size 64))))
    result))


(defun parse-md2-uvs (offset n stream)
  (file-position stream offset)
  (let ((result (make-array n)))
    (iterate 
      (for i from 0 below n)
      (setf (aref result i) (read-value :md2-uv stream)))
    result))

(defun parse-md2-triangles (offset n stream)
  (file-position stream offset)
  (let ((result (make-array n)))
    (iterate 
     (for i from 0 below n)
     (setf (aref result i) (read-value :md2-triangle stream)))
  result))


(defun parse-md2-frames (offset n size nverts stream)
  "Return a hash table that maps a set of frame names to vertices"
  (file-position stream offset)
  (let ((frames (make-hash-table :test 'equal :size n)))
          (iterate 
            (for i from 0 below n)
            (file-position stream (+ offset (* i size)))
            (let* ((header (read-value :md2-frame-header stream))
                   (vertices (make-array (list nverts)))
                   (name (babel:octets-to-string (null-terminate  (name-of header)))))
              (format t "Parsing header ~A~%" name)
              (iterate 
                (for j from 0 below nverts)
                (setf (aref vertices  j) (read-value :md2-vertex stream)))
                      (setf (gethash name frames) (cons header vertices))))
          frames))

;; posing -- aka animation.

(defun pose-vertices (target scale translation vertices)
  "Return an array of vertices using the given frames scale and translation"
  (iterate
   (for index from 0 below (length vertices))
   (for vertex in-vector vertices)
   (setf (vertex3d-aref target index)
         (vertex3d* 
          (+ (* (aref  (position-of vertex) 0) (x-of scale)) (x-of translation))
          (+ (* (aref  (position-of vertex) 1) (y-of scale)) (y-of translation))
          (+ (* (aref  (position-of vertex) 2) (z-of scale)) (z-of translation))
          1.0)))
  (values))



(defun pose-faces (target tris)
  "Populate na array of faces"
  (iterate
    (for tri in-vector tris)
    (for index from 0 below (length tris))
    (setf (triangle-aref target index) 
          (triangle* 
           (aref  (vertex-indices-of tri) 0)
           (aref  (vertex-indices-of tri) 1)
           (aref  (vertex-indices-of tri) 2))))
    (values))

(defun pose-skin (target uvs skin)
  "Poopulate an array of vu coordinates"
  (iterate
    (for uv in-vector uvs)
    (vector2d-vector-push-extend 
     (vector2d* 
       (coerce (/ (u-of uv) (width-of skin)) 'single-float)
       (coerce (/ (v-of uv) (height-of skin)) 'single-float))
     target))
  (values))

(defun pose-skin-indices (target tris)
  "Populate an array of face indices to st vectors"
  (iterate
    (for st-face in tris)
    (triangle-vector-push-extend 
      (triangle*
       (aref (uv-indices-of st-face) 0)
       (aref (uv-indices-of st-face) 1)
       (aref (uv-indices-of st-face) 2))
      target))
  (values))


;;      (collecting (cons 
;;                  (list :vertices
;;                        (aref  (vertex-indices-of tri) 0)
;;                        (aref  (vertex-indices-of tri) 1)
;;                        (aref  (vertex-indices-of tri) 2))
;;                  (list :uvs 
;;                        (aref  (uv-indices-of tri) 0)
;;                        (aref  (uv-indices-of tri) 1)
;;                        (aref  (uv-indices-of tri) 2))))))

(defclass md2 ()
  ((sts :accessor sts-of :initarg :sts)
   (frames :accessor frames-of :initarg :frames)
   (tris :accessor tris-of :initarg :tris)
   (filename :reader filename-of :initarg :fname)
   (skins :accessor skins-of :initarg :skins)))


;; skins --
(defun is-pcx (x)
  "Test whether file extension is pcx"
  (let ((name (namestring x))) (string-equal "pcx" (subseq name (- (length name) 3)))))

(defun directory-scan (directory-name)
  "Scan a directory and get a list of skin names"
  (let ((directory-name-length (length (namestring (merge-pathnames directory-name))))
        (directory-list (cl-fad:list-directory (merge-pathnames directory-name))))
    (mapcar #'(lambda (x) 
                (let ((name (namestring x)))
                  (cons 
                   x
                   (subseq (namestring name) directory-name-length (- (length name) 4)))))
            (remove-if-not #'is-pcx directory-list))))
    
(defun parse-md2-skins (directory)
  (let ((result (make-hash-table :test 'equal)))
    (mapcar #'(lambda (x)
                (setf (gethash (cdr x) result) (parse-pcx-file (car x)))) 
            (directory-scan directory))
    result))
  
(defun parse-md2-file (filename)
  "Read in an md2 file from the stream"
  (with-open-file (stream (merge-pathnames filename)   :direction :input :element-type '(unsigned-byte 8)) 
    (let* 
        ((header
          (read-value :md2-header stream)))
;;      (format *debug-io* "~D Skins ~D Vertices ~D UVS ~D Tris" (nskins-of header) (nvertices-of header) (nuvs-of header) (ntris-of header))
      (with-accessors ((frames-offset frames-offset-of) (nframes nframes-of) (framesize framesize-of) (nvertices nvertices-of)) header
        (let*
            ((result (make-instance 'md2 
                                    :fname (merge-pathnames filename)
                                    :frames (parse-md2-frames frames-offset nframes framesize nvertices stream)
                                    :sts (parse-md2-uvs (uv-offset-of header) (nuvs-of header) stream)
                                    :tris (parse-md2-triangles (tris-offset-of header) (ntris-of header) stream)
                                    :skins (parse-md2-skins (merge-pathnames (directory-namestring  (merge-pathnames filename)))))))
          result)))))


;; animation --
(defmethod pose ((model md2) (mesh md2-mesh) frame-name skin-name)
  "Set the pose of  mesh based on an md2 frame"
  (let ((frame (gethash frame-name (frames-of model))))
    (when frame
      (let ((header (car frame))
            (vertices (cdr frame))
            (skin (gethash skin-name (skins-of model))))
        ;; problem when we texture -- 1:1 mapping betewen index and vertex is lost..
        ;; maybe md2 mesh with it's own texture - or reallocate and renumber vertices?
        ;; just a new mesh type with extra attributes        
        (setf (vertices-of mesh) (make-vertex3d-array (length vertices))) 
        (pose-vertices (vertices-of mesh) (scale-of header) (translation-of header) vertices)
        (setf (faces-of mesh) (make-triangle-array (length (tris-of model))))
        (pose-faces (faces-of mesh) (tris-of model))
        (setf (uvs-of mesh) (make-vector2d-array (length (sts-of model)) :fill-pointer 0))
        (pose-skin (uvs-of mesh) (sts-of model) (gethash skin *textures*))
        (setf (uvs-tris-of mesh) (make-triangle-array (length (tris-of model)) :fill-pointer 0))
        (pose-skin-indices (uvs-tris-of mesh) (tris-of model))
        (setf (skin-of mesh) skin)))
    mesh))


(defmethod repose ((model md2) (mesh md2-mesh) frame-name skin-name)
  "Change the pose of an exising mesh already initialised with the md2"
  (let ((frame (gethash frame-name (frames-of model))))
    (when frame
      (let ((header (car frame))
            (vertices (cdr frame))
            (skin (gethash skin-name (skins-of model))))
        ;; problem when we texture -- 1:1 mapping betewen index and vertex is lost..
        ;; maybe md2 mesh with it's own texture - or reallocate and renumber vertices?
        ;; just a new mesh type with extra attributes
        (pose-vertices (vertices-of mesh) (scale-of header) (translation-of header) vertices)
        (pose-faces (faces-of mesh) (tris-of model))
        (setf (fill-pointer (uvs-of mesh)) 0)
        (pose-skin (uvs-of mesh) (sts-of model) (gethash skin *textures*))
        (setf (fill-pointer (uvs-tris-of mesh)) 0)
        (pose-skin-indices (uvs-tris-of mesh) (tris-of model))
        (setf (skin-of mesh) skin)))))



;;  (let ((
;;   (mesh :clear-vertices)
;;   (let ((pose-frame (get-frame-of mesh)))
;;     (iterate 
;;       (for vertex in (cdr frame)