obj2.lisp

;;; Wavefront OBJ file loader

(in-package #:cl)

(defpackage #:obj2
  (:use #:cl)
  (:export
   #:count-info
   #:read-obj-file
   #:v ;; v vn vt f g はできればexternしたくない。
   #:vn
   #:vt
   #:f
   #:g))

(in-package #:obj2)

(defun line-head-symbol (line)
  (if (equal (char line 0) #\#)
      nil
      (let ((s (read-from-string line nil nil)))
	(if (or (eq 'v  s)
		(eq 'vn s)
		(eq 'vt s)
		(eq 'f  s)
		(eq 'g  s))
	    s
	    nil))))

(defun count-info-1 (in)
  (let ((v-count  0)
	(vn-count 0)
	(vt-count 0)
	(f-count  0)
	(g-count  0))
    (loop for line = (read-line in nil) while line do
	 (let ((s (line-head-symbol line)))
	   (cond ((eq s 'v)
		  (setf v-count (1+ v-count)))
		 ((eq s 'vn)
		  (setf vn-count (1+ vn-count)))
		 ((eq s 'vt)
		  (setf vt-count (1+ vt-count)))
		 ((eq s 'f)
		  (setf f-count (1+ f-count)))
		 ((eq s 'g)
		  (setf g-count (1+ g-count))))))
    (list :v v-count :vn vn-count :vt vt-count :f f-count :g g-count)))

(defun count-info(in-filename)
  (let ((in (open in-filename)))
    (when in
      (count-info-1 in))))

(defun rest-float-list ( line start )
; "「v 1 1 1」とあった場合の1 1 1をlistで返す関数"
  (multiple-value-bind (r0 r1)
      (read-from-string line nil nil :start start)
    (cond ((> (length line) r1) 
	   (cons r0 (rest-float-list line r1)))
	  ((not (null r0))
	     (cons r0 nil))
	  (nil))))

(defun vertex-indices-1 (line &optional (start 0))
;  "line文字列のstart開始位置にある、 1//1を(0 nil 0)、1/1/1を(0 0 0)で返す関数。"
  (multiple-value-bind (r0 r1)
      (parse-integer line :start start :junk-allowed t)
    (if (not (null r0))
	(setf r0 (1- r0)))
    (if (and (< r1 (length line))
	     (equal (char line r1) #\/))
	(multiple-value-bind
	      (result pos) (vertex-indices-1 line (1+ r1))
	  (values (cons r0 result) pos))
	(values (if (not (null r0))
		    (cons r0 nil)) r1))))

(defun vertex-indices (line &optional (start 0) )
;  "line文字列の開始位置以降にある、1//1 2//2 3//3を((0 nil 0) (1 nil 1) (2 nil 2))として返す関数"
  (multiple-value-bind (l pos)
      (vertex-indices-1 line start)
    (if (< pos (length line))
	(cons l (vertex-indices line (+ pos 1)))
      (if (not (null l))
	  (cons l nil)))))

(defun objdata-from-line (line)
  (if (equal (char line 0) #\#)
      nil
      (multiple-value-bind (s pos)
	  (read-from-string line nil nil)
	(if (or (eq 'v s)
		(eq 'vn s)
		(eq 'vt s))
	    (let ((l (rest-float-list line pos)))
	      (cons s l))
	    (if (eq 'f s)
		(cons s (vertex-indices line pos)))))))

(defmacro make-vertex(positions texcoords normals indices)
  `(cons
    (aref ,positions (nth 0 ,indices))
    (cons
     (if (null (nth 1 ,indices))
	 nil
	 (aref ,texcoords (nth 1 ,indices)))
     (cons
      (if (null (nth 2 ,indices))
	  nil
	 (aref ,normals (nth 2 ,indices)))
      nil))))

(defmacro make-face-1(positions texcoord normals face)
  (let ((v (gensym)))
    `(mapcar 
      #'(lambda (,v) (make-vertex ,positions ,texcoord ,normals ,v))
      ,face)))

(defmacro make-face (obj-data data)
  `(make-face-1 (getf ,obj-data :positions)
	      (getf ,obj-data :texcoords)
	      (getf ,obj-data :normals)
	      (cdr ,data)))

(defun attribute-setter! (obj-data symbol)
  (let ((dest obj-data)
	(property symbol)
	(index 0))
    (lambda (data)
      (setf (aref (getf dest property) index) (cdr data))
      (incf index 1))))

(defun face-setter! (obj-data)
  (let ((dest obj-data)
	(index 0))
    (lambda (face)
      (setf (aref
	     (getf dest :faces)
	     index)
	    face)
      (incf index))))

(defmacro make-obj-mesh (info)
  `(list :positions
	 (make-array (getf ,info :v))
	 :texcoords
	 (make-array (getf ,info :vt))
	 :normals
	 (make-array (getf ,info :vn))
	 :faces
	 (make-array (getf ,info :f))
	 ))

(defun read-obj-file-1 (in info)
  (let* ((obj-mesh (make-obj-mesh info))
	 (add-position! (attribute-setter! obj-mesh :positions))
	 (add-texcoord! (attribute-setter! obj-mesh :texcoords))
	 (add-normal!   (attribute-setter! obj-mesh :normals))
	 (add-face!     (face-setter! obj-mesh)))
    (loop for line = (read-line in nil) while line do
	 (let ((data (objdata-from-line line)))
	   (if data
	       (let ((s (car data)))
		 (cond ((eq s 'v)
			(funcall add-position! data))
		       ((eq s 'vt)
			(funcall add-texcoord! data))
		       ((eq s 'vn)
			(funcall add-normal! data))
		       ((eq 'f (car data))
			(let ((face (make-face obj-mesh data)))
			  (when face
			    (funcall add-face! face)
			      ))))))))
    (format t "load complete.~%")
    obj-mesh))

(defun read-obj-file(in-filename)
  (let ((info (count-info in-filename))
	(in (open in-filename)))
    (when in
      (read-obj-file-1 in info))))

(defun write-obj(in-filename out-filename)
  (with-open-file (out out-filename
		       :direction :output
		       :if-exists :supersede)
    (when out
      (let ((*print-circle* t))
	(print (read-obj-file in-filename) out)))))