Wavefront->Lisp->C converter

;; ====================================================================================================
;;
;; file        :wavefront.lisp
;; date        :2012-06-03
;; author      :walantis giosis (wg@xraw.de)
;;
;; description :Parse a wavefront OBJ file (exported from Blender) into a Lisp object.
;;
;; ====================================================================================================

(defclass material ()
  ((name               :accessor name-of               :initarg :name               :initform nil)
   (specular-exponent  :accessor specular-exponent-of  :initarg :specular-exponent  :initform 0.0)
   (optical-density    :accessor optical-density-of    :initarg :optical-density    :initform 0.0)
   (dissolve           :accessor dissolve-of           :initarg :dissolve           :initform 0.0)
   (illumination-model :accessor illumination-model-of :initarg :illumination-model :initform 0)
   (ambient-color      :accessor ambient-color-of      :initarg :ambient-color      :initform #(0.0 0.0 0.0))
   (diffuse-color      :accessor diffuse-color-of      :initarg :diffuse-color      :initform #(0.0 0.0 0.0))
   (specular-color     :accessor specular-color-of     :initarg :specular-color     :initform #(0.0 0.0 0.0))
   (diffuse-map        :accessor diffuse-map-of        :initarg :diffuse-map        :initform nil))
  (:documentation ""))


(defclass face-description ()
  ((vertex-indices  :accessor vertex-indices-of  :initarg :vertex-indices  :initform nil)
   (tvertex-indices :accessor tvertex-indices-of :initarg :tvertex-indices :initform nil)
   (nvertex-indices :accessor nvertex-indices-of :initarg :nvertex-indices :initform nil)
   (smooth-shaded     :accessor is-smooth-shaded     :initarg :smooth-shaded     :initform nil)
   (material-name     :accessor material-name-of     :initarg :material-name     :initform ""))
  (:documentation ""))


(defclass scene-description ()
  ((vertex-data       :accessor vertex-data-of       :initarg :vertex-data       :initform '())
   (tvertex-data      :accessor tvertex-data-of      :initarg :tvertex-data      :initform '())
   (nvertex-data      :accessor nvertex-data-of      :initarg :nvertex-data      :initform '())
   (face-descriptions :accessor face-descriptions-of :initarg :face-descriptions :initform '())
   (materials         :accessor materials-of         :initarg :materials         :initform '()))
  (:documentation ""))

;; ====================================================================================================

(defun parse-string-to-floats (string)
  ;; very helpful for this use case: http://stackoverflow.com/questions/1495475/parsing-numbers-from-strings-in-lisp
  (let ((*read-eval* nil))
    (with-input-from-string (stream string)
      (loop for number = (read stream nil nil)
            while number collect number))))


(defun replace-all (string part replacement &key (test #'char=))
  ;; got it from: http://cl-cookbook.sourceforge.net/strings.html
  "Returns a new string in which all the occurences of the part
is replaced with replacement."
  (with-output-to-string (out)
    (loop with part-length = (length part)
       for old-pos = 0 then (+ pos part-length)
       for pos = (search part string
                         :start2 old-pos
                         :test test)
       do (write-string string out
                        :start old-pos
                        :end (or pos (length string)))
       when pos do (write-string replacement out)
       while pos)))

(defun basepath (path)
  (subseq path 0 (search "/" path :from-end t)))
;; ====================================================================================================

(defun material-newmtl (name)
  (make-instance 'material :name name))


(defun material-Ns (material value)
  (setf (specular-exponent-of material) (parse-float value)))


(defun material-Ka (material rgb)
  (setf (ambient-color-of material) (parse-string-to-floats rgb)))


(defun material-Kd (material rgb)
  (setf (diffuse-color-of material) (parse-string-to-floats rgb)))


(defun material-Ks (material rgb)
  (setf (specular-color-of material) (parse-string-to-floats rgb)))


(defun material-Ni (material value)
  (setf (optical-density-of material) (parse-float value)))


(defun material-d (material value)
  (setf (dissolve-of material) (parse-float value)))


(defun material-illum (material value)
  (setf (illumination-model-of material) (parse-integer value)))


(defun material-map_Kd (material path)
  (setf (diffuse-map-of material) path))


(defun wavefront-consume-v (scene xyz)
  (push (parse-string-to-floats xyz) (vertex-data-of scene)))


(defun wavefront-consume-vt (scene uv)
  (push (parse-string-to-floats uv) (tvertex-data-of scene)))


(defun wavefront-consume-vn (scene xyz)
  (push (parse-string-to-floats xyz) (nvertex-data-of scene)))


(defun wavefront-consume-f (scene face shading material-name)
  (let* ((has-three-components (not (search "//" face)))
         (clean-string         (replace-all face "/" " "))
         (face                 (make-instance 'face-description :smooth-shaded shading :material-name material-name))
         (values               (parse-string-to-floats clean-string)))
    (if has-three-components
        (setf (vertex-indices-of  face) (list (nth 0 values) (nth 3 values) (nth 6 values))
              (tvertex-indices-of face) (list (nth 1 values) (nth 4 values) (nth 7 values))
              (nvertex-indices-of face) (list (nth 2 values) (nth 5 values) (nth 8 values)))
        (setf (tvertex-indices-of face) (list (nth 0 values) (nth 2 values) (nth 4 values))
              (nvertex-indices-of face) (list (nth 1 values) (nth 3 values) (nth 5 values))))
    (push face (face-descriptions-of scene))))


(defun wavefront-consume-s (scene value)
  (declare (ignore scene))
  (if (string-equal value "off")
      NIL
      T))


(defun wavefront-consume-usemtl (scene value)
  (declare (ignore scene))
  value)


(defun wavefront-consume-mtllib (scene value path)
  (with-open-file (in (concatenate 'string path "/" value)
                      :direction :input)
    (let (line
          current-material
          (material-library (make-hash-table))
          (valid-tokens     '("Ns" "Ka" "Kd" "Ks" "Ni" "d" "illum" "map_Kd")))
      (loop
         (setf line (read-line in nil nil nil))
         (when (null line)
           (return))
         (when (> (length line) 0)
           (let* ((pos   (search " " line))
                  (token (subseq line 0 pos)))
             (cond
               ((string-equal token "newmtl")
                (setf current-material (funcall (read-from-string (concatenate 'string "material-" token)) (subseq line (1+ pos)))
                      (gethash (name-of current-material) material-library) current-material))
               ((member token valid-tokens :test 'string-equal)
                (funcall (read-from-string (concatenate 'string "material-" token)) current-material (subseq line (1+ pos))))
               ((string-equal token "#") NIL)
               (:otherwise (error "wavefront mtllib converter: unhandled token ~A in path ~A.~%" token path))))))
      (push material-library (materials-of scene)))))


(defun wavefront (path)
  (with-open-file (in path
                      :direction :input)
    (let (line
          current-shading
          current-material
          (vertex-count  0)
          (face-count    0)
          (nvertex-count 0)
          (tvertex-count 0)
          (scene         (make-instance 'scene-description))
          (valid-tokens  '("v" "vt" "vn")))
      (loop
         (setf line (read-line in nil nil nil))
         (when (null line)
           (return))
         (when (> (length line) 0)
           (let* ((pos   (search " " line))
                  (token (subseq line 0 pos)))
             (cond
               ((string-equal token "#") NIL)

               ((string-equal token "s")
                (setf current-shading (funcall (read-from-string (concatenate 'string "wavefront-consume-" token)) scene (subseq line (1+ pos)))))

               ((string-equal token "usemtl")
                (setf current-material (funcall (read-from-string (concatenate 'string "wavefront-consume-" token)) scene (subseq line (1+ pos)))))

               ((string-equal token "f")
                (funcall (read-from-string (concatenate 'string "wavefront-consume-" token)) scene (subseq line (1+ pos)) current-shading current-material))

               ((string-equal token "mtllib")
                (funcall (read-from-string (concatenate 'string "wavefront-consume-" token)) scene (subseq line (1+ pos)) (basepath path)))

               ((member token valid-tokens :test 'string-equal)
                (funcall (read-from-string (concatenate 'string "wavefront-consume-" token)) scene (subseq line (1+ pos))))

               (:otherwise (error "wavefront converter: unhandled token ~A in path ~A.~%" token path))))))
      scene)))