Created
April 7, 2010 16:01
-
-
Save narumij/359055 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
;;; 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))))) | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment