Writing files is compiling.

[lodematron.git] / file-3ds.lisp

(in-package :lodematron)

(defconstant  +MAIN3DS+  #X4D4D)
(defconstant  +EDIT3DS+  #X3D3D)
(defconstant  +EDIT_MATERIAL+ #XAFFF)
(defconstant  +MAT_NAME01+ #XA000) 
(defconstant  +MAT_AMBIENT+ #XA010) ;;S        ambient color   [RGB1 and RGB2]
(defconstant  +MAT_DIFFUSE+ #XA020) ;;S  ;; diffuse color       idem
(defconstant  +MAT_SPECULAR+ #xA030)  ;;S        specular color      idem
(defconstant  +MAT_SHININESS+ #XA040)  ;;S        shininess       [amount of]
(defconstant  +MAT_STRENGTH+ #XA041)  ;;S      ;;shin. strength     "
(defconstant  +MAT_TRANSPARENCY+ #XA050) ;;S      ;;  transparency       "
(defconstant  +MAT_FALLOFF+ #XA052)          ;;  trans. falloff     "
;;  A053   S        reflect blur       "
;;  A100   intsh    material type   [1=flat 2=gour. 3=phong 4=metal]
;;  A084   S        self illum      [amount of]
(defconstant  +EDIT_CONFIG1+  #X0100)
(defconstant  +EDIT_CONFIG2+  #X3E3D)
(defconstant  +EDIT_VIEW_P1+  #X7012)
(defconstant  +TOP+            #X0001)
(defconstant  +BOTTOM+         #X0002)
(defconstant  +LEFT+           #X0003)
(defconstant  +RIGHT+          #X0004)
(defconstant  +FRONT+          #X0005)
(defconstant  +BACK+           #X0006)
(defconstant  +USER+           #X0007)
(defconstant  +CAMERA+         #XFFFF)
(defconstant  +LIGHT+          #X0009)
(defconstant  +DISABLED+       #X0010)
(defconstant  +BOGUS+          #X0011)
(defconstant  +EDIT_VIEW_P2+  #X7011)
(defconstant  +EDIT_VIEW_P3+  #X7020)
(defconstant  +EDIT_VIEW1+    #X7001)
(defconstant  +EDIT_BACKGR+   #X1200)
(defconstant  +EDIT_AMBIENT+  #X2100)
(defconstant  +EDIT_OBJECT+   #X4000)
(defconstant  +OBJ_TRIMESH+   #X4100)
(defconstant  +TRI_VERTEXL+          #X4110)
(defconstant  +TRI_VERTEXOPTIONS+    #X4111)
(defconstant  +TRI_MAPPINGCOORS+     #X4140)
(defconstant  +TRI_MAPPINGSTANDARD+  #X4170)
(defconstant  +TRI_FACEL1+           #X4120)
(defconstant  +TRI_SMOOTH+            #X4150)
(defconstant  +TRI_MATERIAL+          #X4130)
(defconstant  +TRI_LOCAL+            #X4160)
(defconstant  +TRI_VISIBLE+          #X4165)
(defconstant  +OBJ_LIGHT+    #X4600)
(defconstant  +LIT_OFF+              #X4620)
(defconstant  +LIT_SPOT+             #X4610)
(defconstant  +LIT_UNKNWN01+         #X465A)
(defconstant  +OBJ_CAMERA+   #X4700)
(defconstant  +CAM_UNKNWN01+         #X4710)
(defconstant  +CAM_UNKNWN02+         #X4720)
(defconstant  +OBJ_UNKNWN01+ #X4710)
(defconstant  +OBJ_UNKNWN02+ #X4720)
(defconstant  +EDIT_UNKNW01+  #X1100)
(defconstant  +EDIT_UNKNW02+  #X1201)
(defconstant  +EDIT_UNKNW03+  #X1300)
(defconstant  +EDIT_UNKNW04+  #X1400)
(defconstant  +EDIT_UNKNW05+  #X1420)
(defconstant  +EDIT_UNKNW06+  #X1450)
(defconstant  +EDIT_UNKNW07+  #X1500)
(defconstant  +EDIT_UNKNW08+  #X2200)
(defconstant  +EDIT_UNKNW09+  #X2201)
(defconstant  +EDIT_UNKNW10+  #X2210)
(defconstant  +EDIT_UNKNW11+  #X2300)
(defconstant  +EDIT_UNKNW12+  #X2302)
(defconstant  +EDIT_UNKNW13+  #X2000)
(defconstant  +EDIT_UNKNW14+  #XAFFF)
(defconstant  +KEYF3DS+              #XB000)
(defconstant  +KEYF_UNKNWN01+ #XB00A)
;; +............. #X7001) ( viewport, same as editor )
(defconstant  +KEYF_FRAMES+       #XB008)
(defconstant  +KEYF_UNKNWN02+     #XB009)
(defconstant  +KEYF_OBJDES+       #XB002)
(defconstant  +KEYF_OBJHIERARCH+  #XB010)
(defconstant  +KEYF_OBJDUMMYNAME+ #XB011)
(defconstant  +KEYF_OBJUNKNWN01+  #XB013)
(defconstant  +KEYF_OBJUNKNWN02+  #XB014)
(defconstant  +KEYF_OBJUNKNWN03+  #XB015)
(defconstant  +KEYF_OBJPIVOT+     #XB020)
(defconstant  +KEYF_OBJUNKNWN04+  #XB021)
(defconstant  +KEYF_OBJUNKNWN05+  #XB022)

;;  >>------  these define the different color chunk types

(defconstant  +COL_RGB+  #X0010)
(defconstant  +COL_TRU+  #X0011)
(defconstant  +COL_UNK+  #X0013)
(defconstant  +AMOUNT+   #X0030)


;; -- definition of 3ds chunk -----------------------------------------

(defclass 3ds-chunk ()
  ((chunk-id :accessor chunk-id-of)
   (chunk-size :accessor chunk-size-of)))

(defmethod initialize-instance :after ((self 3ds-chunk) &key stream)
  "Create a 3ds chunk and read it in."
  (setf (chunk-id-of self) (read-value 'u16 stream))
  (setf (chunk-size-of self) (read-value 'u32 stream)))

(defmethod chunk-size ((chunk 3ds-chunk)) (- (chunk-size-of chunk) 6))

;; -- chunk parser table and macros ------------------------------------
(defparameter *3ds-chunk-parsers* (make-hash-table))


(defun advance-file-position (stream  by)
  (file-position stream
                 (+ (file-position stream) by)))

(defun unknown-3ds-chunk-parser (chunk parent-chunk in-stream out-stream)
  (declare (ignore parent-chunk out-stream))
  (formatting *debug-io* "~&Skipping unknown chunk " 
              (:hex :width 4 :fillchar #\0 :form (chunk-id-of chunk))
              :tab "Size "
              (:hex :width 4 :fillchar #\0 :form (chunk-size-of chunk))
              :freshline)
  (advance-file-position in-stream (chunk-size chunk)))

(defmethod parse-chunk ((chunk 3ds-chunk) parent-chunk in-stream out)
  (funcall  (gethash (chunk-id-of chunk) *3ds-chunk-parsers* #'unknown-3ds-chunk-parser) 
            chunk parent-chunk in-stream out))

(defmacro make-3ds-chunk-parser ((chunk chunk-sym parent-chunk-sym stream-sym out-sym) 
                                 &key before after)
  (with-gensyms (chunk-end)
  `(setf (gethash ,chunk *3ds-chunk-parsers*)
                  (lambda (,chunk-sym ,parent-chunk-sym ,stream-sym ,out-sym)
                    (declare (ignorable ,stream-sym ,parent-chunk-sym ,out-sym))
                    (formatting *debug-io* "~&Reading 3ds chunk " 
                                (:hex :width 4 :fillchar #\0 :form (chunk-id-of  ,chunk-sym))
                                :tab "Size "
                                (:hex :width 4 :fillchar #\0 :form (chunk-size-of  ,chunk-sym))
                                :tab "At "
                                (:hex :width 4 :fillchar #\0 :form (-  (file-position ,stream-sym) 6))
                                :freshline)
                    ,before
                    (let ((,chunk-end (+ (file-position ,stream-sym) (chunk-size ,chunk-sym))))
                      (ignore-errors
                        (iterate 
                         (while (not (>= (file-position ,stream-sym) ,chunk-end)))
                         (parse-chunk (make-instance '3ds-chunk :stream ,stream-sym) ,parent-chunk-sym ,stream-sym ,out-sym))))
                    ,after))))

;; -- actual chunk parsers ------------------------------------


(make-3ds-chunk-parser 
 (+MAIN3DS+ main-chunk parent-chunk stream out)
 :before (formatting *debug-io* "Reading main chunk " :freshline))

(make-3ds-chunk-parser 
 (+EDIT3DS+ edit-chunk main-chunk stream out)
 :before (formatting *debug-io* "Reading editor chunk " :freshline))

(defparameter *object-name* "")

(make-3ds-chunk-parser 
 (+EDIT_OBJECT+ object-chunk edit-chunk stream out)
 :before (progn (formatting *debug-io* "Reading object chunk " :freshline)
                (let ((object-name (read-value 'asciiz stream)))
                  (format *debug-io* "Object Name ~A~%"  object-name)
                  (setf *object-name* object-name))))

(make-3ds-chunk-parser
 (+OBJ_TRIMESH+ mesh-chunk object-chunk stream out)
 :before (progn
           (formatting *debug-io* "Reading trimesh chunk " :freshline)
         (format *debug-io* "~%(make-mesh ~A " (symbol-name (gensym *object-name*))))
 :after   (format *debug-io* ")~%")
)

(make-3ds-chunk-parser 
 (+OBJ_CAMERA+ camera-chunk edit-chunk stream out)
 :before (formatting *debug-io* "Reading camera chunk "  :freshline))

(make-3ds-chunk-parser 
 (+OBJ_LIGHT+ light-chunk edit-chunk stream out)
 :before (formatting *debug-io* "Reading light chunk " :freshline)) 


(make-3ds-chunk-parser 
 (+TRI_VERTEXL+ vertex-chunk trimesh-chunk stream out)
 :before (progn (formatting *debug-io* "Reading vertex list chunk " :freshline)
                  (let ((vertex-count (read-value 'u16 stream)))
                    (formatting *debug-io* "Total vertices " :decimal vertex-count)
                    (format *debug-io* "~&~T:vertices '( ")
                    (iterate 
                     (for index from 0 below vertex-count)
                     (format *debug-io* "~%~T~T(~F ~F ~F)" 
                             (read-value 'float32 stream)
                             (read-value 'float32 stream)
                             (read-value 'float32 stream)))
                    (format *debug-io* ")"))))

(make-3ds-chunk-parser  
 (+TRI_FACEL1+ face-chunk trimesh-chunk stream out)
 :before (progn                       
           (formatting *debug-io* "Reading face list chunk " :freshline)
           (let ((face-count (read-value 'u16 stream)))
             (formatting *debug-io* "Total Faces " :decimal face-count)
             (format *debug-io* "~&~T:faces '( ")
             (iterate
              (for index from 0 below face-count)      
              (format *debug-io* "~&~T~T(~4D ~4D ~4D)"
                      (read-value 'u16 stream)
                      (read-value 'u16 stream)
                      (read-value 'u16 stream))              
              (read-value 'u16 stream))
             (format *debug-io* ")"))))

(make-3ds-chunk-parser 
 (+TRI_MAPPINGCOORS+ uv-chunk trimesh-chunk stream out)
 :before (progn                      
           (formatting *debug-io* "Reading Mapping list chunk " :freshline)
           (let ((uv-count (read-value 'u16 stream)))
             (formatting *debug-io* "Total uvs " :decimal uv-count)
             (format *debug-io* "~&:texcoords '( ")
             (iterate
              (for index from 0 below uv-count)
              (format *debug-io* "~T~&(~4D ~4D)"
                      (read-value 'float32 stream)
                      (read-value 'float32 stream)))
             (format *debug-io* ")"))))

(make-3ds-chunk-parser 
 (+TRI_LOCAL+ local-coord-chunk trimesh-chunk stream out)            
 :before (progn                      
           (formatting *debug-io* "Reading Local coord sys " :freshline)
           (format *debug-io* "X : ~4D ~4D ~4D ~%" 
                   (read-value 'float32 stream)
                   (read-value 'float32 stream)
                   (read-value 'float32 stream))
           (format *debug-io* "Y : ~4D ~4D ~4D ~%" 
                   (read-value 'float32 stream)
                   (read-value 'float32 stream)
                   (read-value 'float32 stream))
           (format *debug-io* "Z : ~4D ~4D ~4D ~%" 
                   (read-value 'float32 stream)
                   (read-value 'float32 stream)
                   (read-value 'float32 stream))
           (format *debug-io* "O : ~4D ~4D ~4D ~%" 
                   (read-value 'float32 stream)
                   (read-value 'float32 stream)
                   (read-value 'float32 stream))))
 
(make-3ds-chunk-parser 
 (+TRI_MATERIAL+ face-material-chunk face-chunk stream out)
 :before (progn
           (formatting *debug-io* "Reading face material " :freshline)
           (let* ((material-name (read-value 'asciiz stream))
                  (face-count (read-value 'u16 stream))
                  (faces  (iterate 
                           (for i from 0 below face-count)
                           (collect (read-value 'u16 stream)))))
             (format *debug-io* "Name ~A ~%" material-name)
             (format *debug-io* "Applied to ~A faces." faces))))

(make-3ds-chunk-parser 
 (+EDIT_MATERIAL+ material-chunk edit-chunk stream out)
 :before (progn
           (formatting *debug-io* "Reading material Chunk " :freshline)))

(make-3ds-chunk-parser 
 (+MAT_NAME01+ material-name-chunk material-chunk stream out)
 :before (progn
           (let* ((material-name (read-value 'asciiz stream)))
             (format *debug-io* "Name ~A %" material-name))))

(make-3ds-chunk-parser 
 (+MAT_AMBIENT+ ambient-chunk material-chunk stream out)
 :before (progn
           (formatting *debug-io* "Reading ambient color hunk " :freshline)))


(make-3ds-chunk-parser
 (+MAT_DIFFUSE+ diffuse-chunk material-chunk stream out)
 :before (progn
           (formatting *debug-io* "Reading diffuse color hunk " :freshline)))

(make-3ds-chunk-parser
 (+MAT_SPECULAR+ specular-chunk material-chunk stream out)
 :before (progn
          (formatting *debug-io* "Reading specular color hunk " :freshline)))

(make-3ds-chunk-parser ( +MAT_SHININESS+ shiny-chunk material-chunk stream out) 
 :before (progn
          (formatting *debug-io* "Reading shininess hunk " :freshline)))

(make-3ds-chunk-parser ( +MAT_STRENGTH+ strength-chunk material-chunk stream out) 
 :before (progn
          (formatting *debug-io* "Reading shininess strength chunk " :freshline)))

(make-3ds-chunk-parser 
 ( +MAT_FALLOFF+ falloff-chunk material-chunk stream out )
 :before (progn
           (formatting *debug-io* "Reading falloff hunk " :freshline)))

(make-3ds-chunk-parser 
 ( +AMOUNT+ amount-chunk parent-chunk stream out )
 :before (let ((amount (read-value 'u16 stream)))
           (format *debug-io* "Amount ~D" amount)))

(make-3ds-chunk-parser 
 (+COL_RGB+ color-chunk parent-chunk stream out)
 :before (let
             ((red (read-value 'float32 stream))
              (green (read-value 'float32 stream))
              (blue (read-value 'float32 stream)))
           (format *debug-io* "Red ~F Green ~F Blue ~F" red green blue)))

(make-3ds-chunk-parser
 (+COL_TRU+ color-chunk parent-chunk stream out)
 :before  
 (let
     ((red (read-value 'u8 stream))
      (green (read-value 'u8 stream))
      (blue (read-value 'u8 stream)))
   (format *debug-io* "Red ~F Green ~F Blue ~F" red green blue)))

;; to do -- assume output fn is a funcallable mesh
(defun parse-3ds-file (input-file output-fn)
  "Parse the named file as a 3ds file, making meshbuilding calls to the supplied function."
  (with-open-file 
      (in-stream input-file :element-type '(unsigned-byte 8))  
    (parse-chunk (make-instance '3ds-chunk :stream in-stream) nil in-stream output-fn)))