;;; -*- Mode:LISP; Syntax:Common-Lisp; Package:IFF -*-

;;;
;;; This file contains code for reading Sculpt-Animate 3D SC3D scene files.
;;;


;;;  ChangeLog:
;;;
;;; 30 Dec 88  Jamie Zawinski  Created.


(in-package "IFF")

(pushnew :SC3D *all-forms-known*)
(pushnew :VERT *all-forms-known*)
(pushnew :EDGE *all-forms-known*)
(pushnew :FACE *all-forms-known*)
(pushnew :HIER *all-forms-known*)
(pushnew :VNAM *all-forms-known*)


(defstruct (SC3D-VERT (:print-function %print-vert))
  (x 0 :type long)
  (y 0 :type long)
  (z 0 :type long))

(defstruct (SC3D-EDGE (:print-function %print-edge))
  (a 0 :type ulong)
  (b 0 :type ulong))

(defstruct (SC3D-FACE (:print-function %print-face))
  (a 0 :type ulong) ;
  (b 0 :type ulong) ;  Indexes to the points.
  (c 0 :type ulong) ;
  (red   0 :type ubyte)  ;
  (green 0 :type ubyte)  ; The color of the face.
  (blue  0 :type ubyte)  ;
  (smooth-p nil :type (member T NIL))
  (texture  127 :type (or UBYTE (member :DULL :SHINY :MIRROR :LUMINOUS :GLASS :METAL)))
  )

(defstruct (SC3D-HIER (:print-function %print-hier))
  (parent-index   0   :type uword)
  (name           ""  :type string) ; 10 bytes
  (type           nil :type (member NIL :EMPTY :LAMP :PATH :TARGET :OBSERVER :VERTICES))
  (local-origin   nil :type (or null uword))
  (local-origin-x 0   :type long)
  (local-origin-y 0   :type long)
  (local-origin-z 0   :type long)
  ;;
  ;; These next three slots are not in the file - we calculate them because they are useful.
  ;;
  (parent   nil)            ; NIL or a HIER.
  (children nil :type list) ; a list of HIERs.
  (verts    nil :type list) ; a list of VERTs.
  )


(defstruct (SC3D-VNAM (:print-function %print-vnam))
  (vertex 0 :type uword)
  (name   0 :type uword))


(defun %print-vert (struct stream depth)
  (declare (ignore depth))
  (format stream "#<SC3D-VERT ~D ~D ~D>" (sc3d-vert-x struct) (sc3d-vert-y struct) (sc3d-vert-y struct)))

(defun %print-edge (struct stream depth)
  (declare (ignore depth))
  (format stream "#<SC3D-EDGE ~D ~D>" (sc3d-edge-a struct) (sc3d-edge-b struct)))

(defun %print-face (struct stream depth)
  (declare (ignore depth))
  (format stream "#<SC3D-FACE ~D ~D ~D, ~A~A>"
	  (sc3d-face-a struct) (sc3d-face-b struct) (sc3d-face-c struct)
	  (if (numberp (sc3d-face-texture struct))
	      (format nil "texture=~D" (sc3d-face-texture struct))
	      (string-capitalize (string (sc3d-face-texture struct))))
	  (if (sc3d-face-smooth-p struct) ", smooth" "")))

(defun %print-hier (struct stream depth)
  (declare (ignore depth))
  (format stream "#<SC3D-HIER ~S ~A>" (sc3d-hier-name struct) (sc3d-hier-type struct)))

(defun %print-vnam (struct stream depth)
  (declare (ignore depth))
  (format stream "#<SC3D-VNAM ~D ~D>" (sc3d-vnam-vertex struct) (sc3d-vnam-name struct)))


(defstruct SC3D-SCENE
  (verts nil :type (or null vector))
  (edges nil :type (or null vector))
  (faces nil :type (or null vector))
  (hiers nil :type (or null vector))
  (vnams nil :type (or null vector))
  )



(setf (get :SC3D 'FORM-READER) 'READ-SC3D)

(defun read-sc3d (stream maxlength)
  "Read a SCENE descriptor.  Returns two values: the ILBM and the number of bytes read."
  (declare (values 8svx nbytes))
  (reporting-form ("Reading an SC3D, length ~D bytes" maxlength)
    (let* ((length 0)
	   id idname verts edges faces hiers vnams ig)
      (catch 'IFF-EOF
	(do* ()
	     ((>= length maxlength))
	  (multiple-value-setq (id idname) (read-chunk-id stream))
	  (incf length 4)
	  (let* (thing-length)
	    (case id
	      (:VERT
	       (when verts (error "There are multiple VERT chunks in this SC3D."))
	       (multiple-value-setq (verts thing-length) (read-sc3d-verts stream)))
	      (:EDGE
	       (when edges (error "There are multiple EDGE chunks in this SC3D."))
	       (multiple-value-setq (edges thing-length) (read-sc3d-edges stream)))
	      (:FACE
	       (when faces (error "There are multiple FACE chunks in this SC3D."))
	       (multiple-value-setq (faces thing-length) (read-sc3d-faces stream)))
	      (:HIER
	       (when hiers (error "There are multiple HIER chunks in this SC3D."))
	       (multiple-value-setq (hiers thing-length) (read-sc3d-hiers stream)))
	      (:VNAM
	       (when vnams (error "There are multiple VNAM chunks in this SC3D."))
	       (multiple-value-setq (vnams thing-length) (read-sc3d-vnams stream)))
	      (t
	       (multiple-value-setq (ig thing-length) (read-and-ignore-chunk stream idname))))
	    
	    (incf length thing-length)))
	(when (oddp length) (read-ubyte stream) (incf length)))
      (add-hier-backpointers hiers vnams verts)
      
      (values (make-sc3d-scene :VERTS verts :FACES faces :EDGES edges :HIERS hiers :VNAMS vnams)
	      length))))


(defun read-sc3d-verts (stream)
  (declare (values vector nbytes))
  (let* ((length (read-ulong-word stream))
	 (vector (make-array (ceiling length 12))))
    (reporting-form ("Reading VERTs of length ~D bytes." length)
      (when (oddp length) (incf length))
      (do* ((bytes-read 0 (+ bytes-read 12))
	    (i 0 (1+ i)))
	   ((>= bytes-read length))
	(let* ((vert (make-sc3d-vert)))
	  (setf (sc3d-vert-x vert) (read-long-word stream)
		(sc3d-vert-y vert) (read-long-word stream)
		(sc3d-vert-z vert) (read-long-word stream))
	  (setf (aref vector i) vert)
	  )))
    (values vector length)))


(defun read-sc3d-edges (stream)
  (declare (values vector nbytes))
  (let* ((length (read-ulong-word stream))
	 (vector (make-array (ceiling length 8))))
    (reporting-form ("Reading EDGEs of length ~D bytes." length)
      (when (oddp length) (incf length))
      (do* ((bytes-read 0 (+ bytes-read 8))
	    (i 0 (1+ i)))
	   ((>= bytes-read length))
	(let* ((edge (make-sc3d-edge)))
	  (setf (sc3d-edge-a edge) (read-ulong-word stream)
		(sc3d-edge-b edge) (read-ulong-word stream))
	  (setf (aref vector i) edge))))
    (values vector length)))


(defun read-sc3d-faces (stream)
  (declare (values vector nbytes))
  (let* ((length (read-ulong-word stream))
	 (vector (make-array (ceiling length 16))))
    (reporting-form ("Reading FACEs of length ~D bytes." length)
      (when (oddp length) (incf length))
      (do* ((bytes-read 0 (+ bytes-read 16))
	    (i 0 (1+ i)))
	   ((>= bytes-read length))
	(let* ((face (make-sc3d-face)))
	  (setf (sc3d-face-a face) (read-ulong-word stream) ; 4
		(sc3d-face-b face) (read-ulong-word stream) ; 4
		(sc3d-face-c face) (read-ulong-word stream) ; 4
		(sc3d-face-red   face) (read-ubyte stream)  ; 1
		(sc3d-face-green face) (read-ubyte stream)  ; 1
		(sc3d-face-blue  face) (read-ubyte stream)) ; 1
	  (let* ((texture-byte (read-ubyte stream)))        ; 1
	    (setf (sc3d-face-smooth-p face) (logbitp 7 texture-byte))
	    (setq texture-byte (ldb (lisp:byte 7 0) texture-byte))
	    (setf (sc3d-face-texture face)
		  (or (nth texture-byte '(:DULL :SHINY :MIRROR :LUMINOUS :GLASS :METAL)) texture-byte)))
	  (setf (aref vector i) face))))
    (values vector length)))


(defun read-sc3d-hiers (stream)
  (declare (values vector nbytes))
  (let* ((length (read-ulong-word stream))
	 (vector (make-array (ceiling length 28))))
    (reporting-form ("Reading HIERs of length ~D bytes." length)
      (when (oddp length) (incf length))
      (do* ((bytes-read 0 (+ bytes-read 28))
	    (i 0 (1+ i)))
	   ((>= bytes-read length))
	(let* ((hier (make-sc3d-hier)))
	  (setf (sc3d-hier-parent-index hier) (read-short-word stream))                  ; 2
	  (let* ((string (make-string 10)))
	    (dotimes (i 10) (setf (schar string i) (int-char (read-ubyte stream))))      ; 10
	    (setf (sc3d-hier-name hier)
		  (subseq string 0 (or (position (int-char 0) string) 10))))
	  (let* ((type-byte (read-ushort-word stream))                                   ; 2
		 (local-origin-p (logbitp 10 type-byte))
		 (type (case (logand type-byte (lognot (ash 1 10)))
			 (0 :EMPTY)
			 (2 :LAMP)
			 (4 :PATH)
			 (8 :OBSERVER)
			 (10 :VERTICES)
			 (t type-byte)))
		 (local-origin (read-ushort-word stream)))                             ; 2
	    (setf (sc3d-hier-local-origin hier) (if local-origin-p local-origin nil))
	    (setf (sc3d-hier-type hier) type)
	    (setf (sc3d-hier-local-origin-x hier) (read-ulong-word stream)             ; 4
		  (sc3d-hier-local-origin-y hier) (read-ulong-word stream)             ; 4
		  (sc3d-hier-local-origin-z hier) (read-ulong-word stream))            ; 4
	    )
	  (setf (aref vector i) hier))))
    (values vector length)))


(defun read-sc3d-vnams (stream)
  (declare (values vector nbytes))
  (let* ((length (read-ulong-word stream))
	 (vector (make-array (ceiling length 4))))
    (reporting-form ("Reading VNAMs of length ~D bytes." length)
      (when (oddp length) (incf length))
      (do* ((bytes-read 0 (+ bytes-read 4))
	    (i 0 (1+ i)))
	   ((>= bytes-read length))
	(let* ((vnam (make-sc3d-vnam :vertex (read-short-word stream)
				     :name  (read-short-word stream))))
	  (setf (aref vector i) vnam))))
    (values vector length)))



(defun add-hier-backpointers (hier-vector vnam-vector vert-vector)
  "Fills in the parent and child slots on the HIERs in the HIER-VECTOR."
  ;;
  ;; take care of the PARENT and CHILDREN slots.
  ;;
  (dotimes (i (length hier-vector))
    (let* ((hier (aref hier-vector i))
	   (parent-index (sc3d-hier-parent-index hier))
	   (parent (if (= parent-index -1)
		       nil
		       (aref hier-vector parent-index))))
      (setf (sc3d-hier-parent hier) parent)
      (when parent
	(pushnew hier (sc3d-hier-children parent)))))
  ;;
  ;; take care of the VERTS slot.
  ;;
  (dotimes (i (length vnam-vector))
    (let* ((vnam (aref vnam-vector i))
	   (vert-index (sc3d-vnam-vertex vnam))
	   (hier-index (sc3d-vnam-name vnam))
	   (vert (aref vert-vector vert-index))
	   (hier (aref hier-vector hier-index)))
      (pushnew vert (sc3d-hier-verts hier))))
  nil)



;;; Display an orthogonal view of a scene on the explorer screen.
;;;
;;; For the font that comes with SA4D, view the letters with (ORTHO letter :XZ 0.004 400 650)
;;;

#+EXPLORER
(defun ortho (scene which &optional (scale 0.1) (x-off 20) (y-off 20))
  (setq which (case which (:yx :xy) (:zy :yz) (:zx :xz) (t which)))
  (let* ((verts (sc3d-scene-verts scene))
	 (edges (sc3d-scene-edges scene)))
    (send tv:selected-window :clear-screen)
    (dotimes (i (length edges))
      (let* ((edge (aref edges i))
	     (a (sc3d-edge-a edge))
	     (b (sc3d-edge-b edge))
	     (vert-a (aref verts a))
	     (vert-b (aref verts b))
	     x1 y1 x2 y2)
	(ecase which
	  (:XY (setq x1 (sc3d-vert-x vert-a) y1 (sc3d-vert-y vert-a)
		     x2 (sc3d-vert-x vert-b) y2 (sc3d-vert-y vert-b)))
	  (:YZ (setq x1 (sc3d-vert-z vert-a) y1 (sc3d-vert-y vert-a)
		     x2 (sc3d-vert-z vert-b) y2 (sc3d-vert-y vert-b)))
	  (:XZ (setq x1 (sc3d-vert-x vert-a) y1 (sc3d-vert-z vert-a)
		     x2 (sc3d-vert-x vert-b) y2 (sc3d-vert-z vert-b))))
	(setq x1 (round (* scale x1))
	      x2 (round (* scale x2)))
	(setq y1 (- (round (* scale y1)))
	      y2 (- (round (* scale y2))))
	(send tv:selected-window :draw-line (+ x-off x1) (+ y-off y1) (+ x-off x2) (+ y-off y2))
	))
    (dotimes (i (length verts))
      (let* ((vert (aref verts i))
	     (x (round (* scale (sc3d-vert-x vert))))
	     (y (round (* scale (sc3d-vert-y vert))))
	     (z (round (* scale (sc3d-vert-z vert))))
	     x1 y1)
	(ecase which
	  (:XY (setq x1 x y1 y))
	  (:YZ (setq x1 z y1 y))
	  (:XZ (setq x1 x y1 z)))
	(setq y1 (- y1))
	(send tv:selected-window :draw-point (+ x-off x1) (+ y-off y1) TV:ALU-SETA W:RED)))
    ))


;;; Describing these structures.


(def-describer (SC3D-VERT thing)
  (dump "~AVERT: a 3-point at ~6D, ~6D, ~6D."
	(if (numberp type) (format nil "~D~4t " type) "")
	(sc3d-vert-x thing) (sc3d-vert-y thing) (sc3d-vert-z thing)))

(def-describer (SC3D-EDGE thing)
  (dump "~AEDGE: points ~D and ~D."
	(if (numberp type) (format nil "~D~4t " type) "")
	(sc3d-edge-a thing) (sc3d-edge-b thing)))

(def-describer (SC3D-FACE thing)
  (dump "~AFACE: points ~D, ~D, and ~D. ~50tColor: ~2,'0X ~2,'0X 2~,'0X,  Smoothing ~A,  texture ~A"
	(if (numberp type) (format nil "~D~4t " type) "")
	(sc3d-face-a thing) (sc3d-face-b thing) (sc3d-face-c thing)
	(sc3d-face-red thing) (sc3d-face-green thing) (sc3d-face-blue thing)
	(if (sc3d-face-smooth-p thing) " on" "off")
	(sc3d-face-texture thing)))


(defvar *describe-points-and-lines* nil
  "Set this to T if you want IFF-DESCRIBE to show you the coordinates of the points and lines of a scene.")

(def-describer (SC3D-SCENE thing)
  (let* ((verts (sc3d-scene-verts thing))
	 (edges (sc3d-scene-edges thing))
	 (faces (sc3d-scene-faces thing))
	 (hiers (sc3d-scene-hiers thing))
	 (vnams (sc3d-scene-vnams thing)))
    (dump "SC3D: a three dimensional scene of ~D point~:P, ~D line~:P, and ~D face~:P."
	  (length verts) (length edges) (length faces))
    (when *describe-points-and-lines*
      (dump "    Points:")
      (dotimes (i (length verts))
	(iff-describe (aref verts i) i))
      (dump "    Edges:")
      (dotimes (i (length edges))
	(iff-describe (aref edges i) i))
      (dump "    Faces:")
      (dotimes (i (length faces))
	(iff-describe (aref faces i) i)))
    (when hiers
      (dump "    Hiers:")
      (dotimes (i (length hiers))
	(iff-describe (aref hiers i) i)))
    (when *describe-points-and-lines*
      (when vnams
	(dump "    Vnams:")
	(dotimes (i (length vnams))
	  (iff-describe (aref vnams i) i))))))


(def-describer (SC3D-HIER thing)
  (dump "~AHIER ~A: ~A, parent = ~A; ~45Tlocal origin: ~A~A"
	(if (numberp type) (format nil "~D~4t " type) "")
	(sc3d-hier-name thing)
	(sc3d-hier-type thing)
	(if (= -1 (sc3d-hier-parent-index thing)) "none" (sc3d-hier-parent-index thing))
	(or (sc3d-hier-local-origin thing) "none.")
	(if (sc3d-hier-local-origin thing)
	    (format nil "~D, ~D, ~D"
		    (sc3d-hier-local-origin-x thing) (sc3d-hier-local-origin-y thing) (sc3d-hier-local-origin-z thing))
	    "")))

(def-describer (SC3D-VNAM thing)
  (dump "~ALNAM: vertex ~D, hier ~D"
	(if (numberp type) (format nil "~D~4t " type) "")
	(sc3d-vnam-vertex thing) (sc3d-vnam-name thing)))


;;; Let the Explorer FS know that files ending in .scene are 8-bit binary.
;;;

#+LISPM (fs::define-canonical-type :SCENE "SCENE"
	  (:unix-ucb "scene") (:unix "scene") (:lispm "scene"))
#+LISPM (push :SCENE fs::*copy-file-known-short-binary-types*)