勉強中

http://blog.goo.ne.jp/torisu_tetosuki/e/209ad341d3ece2b1b4df24abf619d6e4
を参考に、PMDをsbclで表示してみました。
画像はとりあえずありません。

最初の速度がでない状態と、今の多少よくなった状態とのギャップが激しすぎてびっくり。
今回はじめて構造体を使ったのですが、アクセッサがものすごい長くなってしまって最初大変でした。

反省としては、関数や変数の名前の付け方が下手過ぎること。語彙増やさないと。
あとループの書方が定ってないこと。再帰でループがまだ書けないこと。
うまくコンパイルできないことの解決。キリないな。

pmdtest.asd

(require 'asdf)

(asdf:defsystem #:pmdtest
    :depends-on (#:ieee-floats #:cl-opengl #:cl-glu #:cl-glut)
    :components
    ((:file "pmd")
     (:file "gl-pmd" :depends-on ("pmd"))))

pmd.lisp

(defpackage jp.narumij.pmd
  (:use :cl :ieee-floats))

(in-package jp.narumij.pmd)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun read-uint(in bytes)
  (let ((u 0))
    (loop for i from 0 to (1- bytes) do
	  (setf (ldb (byte 8 (* 8 i)) u) (read-byte in)))
    u))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun read-uint8 (in)
  (read-uint in 1))
(defun read-uint16 (in)
  (read-uint in 2))
(defun read-uint32 (in)
  (read-uint in 4))
(defun read-uint64 (in)
  (read-uint in 8))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun read-float (in)
  (decode-float32 (read-uint32 in)))
(defun read-double (in)
  (decode-float64 (read-uint64 in)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun read-floats (in size)
  (loop for i from 1 to size collect
	(read-float in)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defstruct header
  "(+ 3 4 20 256) 283 byte"
  magic;char[3]
  version;float
  model-name;char[20]
  comment;char[256]
  )
(defstruct vertices
  "(+ 4 ?) 4 byte"
  count;dword
  list; list of vertex
  )
(defstruct vertex
  "(+ (* 4 3) (* 4 3) (* 4 2) (* 2 2) 1 1) 38 byte"
  pos;float[3]
  normal;float[3]
  uv;float[2]
  bone-num;word[2]
  bone-weight;byte
  edge-flag;byte
  )
(defstruct faces
  "(+ 4 ?) 4 byte"
  count;dword
  indices;word[3][?]
  )
(defstruct materials
  count;dward
  list
  )
(defstruct material
  "(+ 12 4 4 12 12 1 1 4 20) 46 byte"
  diffuse-color
  alpha
  specularity
  specular-color
  mirror-color
  toon-index
  edge-flag
  vertex-count
  texture-file-name
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun read-header (in)
  (loop for i from 1 to 283 do
	(read-uint8 in))
  (make-header))
(defun read-vertices (in)
  (let ((count (read-uint32 in)))
    (make-vertices :count count
		   :list
      (loop for i from 1 to count collect
	    (progn
	      (make-vertex :pos (read-floats in 3)
			   :normal (read-floats in 3)
			   :uv (read-floats in 2)
			   :bone-num (list (read-uint16 in) (read-uint16 in))
			   :bone-weight (read-uint8 in)
			   :edge-flag (read-uint8 in)))))))
(defun read-faces (in)
  (let ((count (read-uint32 in)))
    (make-faces :count count
		   :indices
      (loop for i from 1 to count collect (read-uint16 in)))))

(defun read-materials (in)
  (let ((count (read-uint32 in)))
    (make-materials :count count
		    :list
     (loop for i from 1 to count collect
	   (make-material :diffuse-color
			  (loop for i from 1 to 4 collect (if (< i 4 ) (read-float in) 1.0))
			  :alpha (read-float in)
			  :specularity (read-float in)
			  :specular-color
			  (loop for i from 1 to 4 collect (if (< i 4 ) (read-float in) 1.0))
			  :mirror-color
			  (loop for i from 1 to 4 collect (if (< i 4 ) (read-float in) 1.0))
			  :toon-index (read-uint8 in)
			  :edge-flag (read-uint8 in)
			  :vertex-count (read-uint32 in)
			  :texture-file-name (loop for i from 1 to 20 collect (read-uint8 in)))))))

(defun read-pmd (in)
  (let ((header (read-header in))
	(vertices (read-vertices in))
	(faces (read-faces in))
	(materials (read-materials in)))
    (list :header header
	  :vertices vertices
	  :faces faces
	  :materials materials
	  )))

(defun open-byte-stream (filename)
  (open filename :element-type '(unsigned-byte 8)))

(defun issue-vertex-lambda(vertex)
  (let ((position (vertex-pos vertex))
	(normal (vertex-normal vertex)))
    (lambda()(progn
	       (apply #'gl:normal normal)
	       (apply #'gl:vertex position)))))

(defun draw-triangles-of-faces-lambda (pmd start end)
  (let ((vertices (getf pmd :vertices))
	(faces (getf pmd :faces)))
    (let ((v-lambda (mapcar #'(lambda (v) (issue-vertex-lambda v))
			  (mapcar #'(lambda(i)(nth (nth i (faces-indices faces))
						   (vertices-list vertices)))
				  (loop for i from start to end collect i)))))
      (lambda()
	(gl:with-primitive :triangles
	  (mapcar #'funcall v-lambda))))))

(defun draw-material-lambda(pmd material current-index)
  (let ((m material)
	(triangles (draw-triangles-of-faces-lambda
		    pmd
		    current-index
		    (1- (+ current-index (material-vertex-count material))))))
    (lambda ()
      (progn
       (gl:material :front-and-back :emission (material-mirror-color m))
       (gl:material :front-and-back :ambient (material-mirror-color m))
       (gl:material :front-and-back :diffuse (material-diffuse-color m))
       (gl:material :front-and-back :specular (material-specular-color m))
       (gl:material :front-and-back :shininess (material-specularity m))
       (funcall triangles)))))

(defun draw-pmd-test-lambda(pmd)
  (let ((current-index 0)
	(materials (getf pmd :materials)))
    (loop for material in (materials-list materials) collect
	  (let ((start current-index))
	    (setf current-index (+ current-index (material-vertex-count material)))
	    (draw-material-lambda pmd material start)))))

gl-pmd.lisp

(in-package jp.narumij.pmd)

(let ((in (open-byte-stream "miku.pmd")))
  (defparameter *miku-draw* (draw-pmd-test-lambda (read-pmd in))))
(defparameter *use-light* nil)
(defclass my-glut-window (glut:window)
  ()
  (:default-initargs :pos-x 100 :pos-y 100 :width 400 :height 400
                     :mode '(:single :rgb :depth) :title "my-glut-window"))

(defmethod glut:display-window :before ((w my-glut-window))
  (gl:clear-color 0.1 0.1 0.1 0.1)
  (gl:clear-depth 1)
  (gl:shade-model :smooth)
  (if (not (null *use-light*))
      (progn
	(gl:enable :lighting)
	(gl:enable :light0)))
  (gl:enable :depth-test)
  (gl:enable :normalize)
  )

(defmethod glut:reshape ((w my-glut-window) width height)
  (gl:viewport 0 0 width height)
  (cond (nil
	 (progn
	   (gl:matrix-mode :projection)
	   (gl:load-identity)
	   (glu:perspective 45 (/ width height) 3000 12000)
	   (gl:matrix-mode :modelview)
	   (gl:load-identity)
	   (gl:translate 0 -1500 -7000)))
	 (
	  (progn
	    (gl:matrix-mode :projection)
	    (gl:load-identity)
	    (glu:perspective 45 (/ width height) 1 100)
	    (gl:matrix-mode :modelview)
	    (gl:load-identity)
	    (gl:translate 0 -10 -30)
	    (gl:rotate 180 0 1 0)
	    ))))

(defmethod glut:idle ((w my-glut-window))
    (glut:post-redisplay))

(defmethod glut:display ((w my-glut-window))
  (gl:clear :color-buffer :depth-buffer)
  (gl:color 1 1 1)
  (gl:rotate 1 0 1 0)
  (mapcar #'funcall *miku-draw*)
  (gl:flush)
  )

(defun my-glut-test ()
  (glut:display-window (make-instance 'my-glut-window))
  )

(setq *use-light* t)
(my-glut-test)

PMDファイルは5.22に付属してたものをmiku.pmdに名称変更して使っています。
asdファイル足したら、(require 'pmdtest)で動くようになりました。

(require 'asdf)も必要かも。.sbclに足してあったの忘れてた。