;;; Rotating a cube
;;;
;;; Sky box demo, multiple camera view, lights and textures.
;;;
;;; Philippe Brochard <hocwp@free.fr>
;;;
;;; #date#: Wed Feb 16 14:40:30 2005
;;;
;;; The authors grant you the rights to distribute
;;; and use this software as governed by the terms
;;; of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html),
;;; known as the LLGPL.

(in-package :common-lisp-user)

(defpackage :rotate-cube
  (:use :common-lisp #-SBCL :ext #+SBCL :sb-ext :gl :ffi-glue :utils)
  (:export :start))
	

(in-package :rotate-cube)


(defvar *window* nil)

(defvar *width/2* 1)
(defvar *height/2* 1)

(defvar *camera* (make-place))
(defvar *camera-object* (make-place))
(defvar *camera-rel-object* (make-place))
(defvar *camera-front-object* (make-place))
(defvar *object* (make-place))
(defvar *distance* (make-place))
(defvar *distance-front* (make-place))

(defvar *object-to-move* *object*)
(defvar *object-to-look* *camera*)

(defvar *look-sensibility* 5)

(defparameter *rotX* 0.0)
(defparameter *rotY* 0.0)
(defparameter *rotZ* 0.0)



(defparameter mat_specular (convert-array-to-pointer 'single-float #(1.0 1.0 1.0 0.1)))
(defparameter mat_shininess 100.0)

(defparameter mat_specular_default (convert-array-to-pointer 'single-float #(0.0 0.0 0.0 1.0)))
(defparameter mat_shininess_default 0.0)


(defparameter ambience (convert-array-to-pointer 'single-float #(0.3 0.3 0.3 1.0)))
(defparameter diffuse (convert-array-to-pointer 'single-float  #(0.5 0.5 0.5 1.0)))



(defparameter sphereList nil)
(defparameter cubeList nil)

(defparameter mat_solid (convert-array-to-pointer 'single-float #(0.75 0.75 0.0 1.0)))
(defparameter mat_zero (convert-array-to-pointer 'single-float #(0.0 0.0 0.0 1.0)))
(defparameter mat_transparent (convert-array-to-pointer 'single-float #(0.0 0.8 0.8 0.6)))
(defparameter mat_emission (convert-array-to-pointer 'single-float #(0.0 0.3 0.3 0.6)))

(defparameter *light-pos* (convert-array-to-pointer 'single-float #(0.5f0  0.5f0  1.0f0  0f0)))


(defvar *key-table* (make-array 400 :initial-element nil))



(defvar *key-up* 301)
(defvar *key-down* 303)
(defvar *key-left* 300)
(defvar *key-right* 302)
(defvar *key-F1* 201)
(defvar *key-F2* 202)
(defvar *key-F3* 203)
(defvar *key-F4* 204)
(defvar *key-F5* 205)
(defvar *key-F6* 206)
(defvar *key-F7* 207)
(defvar *key-F8* 208)
(defvar *key-F9* 209)
(defvar *key-F10* 210)
(defvar *key-F11* 211)
(defvar *key-F12* 212)




(defvar *key-lookup* (char-code #\z))
(defvar *key-lookdown* (char-code #\w))
(defvar *key-lookleft* (char-code #\q))
(defvar *key-lookright* (char-code #\s))

(defvar *speed* 1)


(defvar *skybox* t)


(defparameter texnames #("ppm/deadone-256x256.ppm" 
			 "ppm/virus-256x256.ppm" 
			 "ppm/ace-256x256.ppm" 
			 "ppm/space-256x256.ppm"
			 "ppm/Back.ppm"
			 "ppm/Front.ppm"
			 "ppm/Top.ppm"
			 "ppm/Bottom.ppm"
			 "ppm/Right.ppm"
			 "ppm/Left.ppm"))



(defun textures ()
  (glPixelStorei GL_UNPACK_ALIGNMENT 1)
  ;;    /* XXX - RE bug - must enable texture before bind. */
  (glEnable GL_TEXTURE_2D)
  (dotimes (i (length texnames))
    (format t "~A: " i)
    (glBindTexture GL_TEXTURE_2D i)
    (multiple-value-bind (texture w h)
	(ppmRead (aref texnames i))
      (gluBuild2DMipmaps GL_TEXTURE_2D 3 w h GL_RGB
			 GL_UNSIGNED_BYTE (convert-array-to-pointer 'unsigned-byte texture))))
  ;;    /* XXX - RE bug - must enable texture before bind. */
  (glDisable GL_TEXTURE_2D))






(defun init (width height posx posy)
  (glutInitDisplayMode (+ GLUT_DOUBLE GLUT_DEPTH GLUT_RGB GLUT_MULTISAMPLE))
  (glutInitWindowPosition posx posy)
  (glutInitWindowSize width height)
  (glEnable GL_DEPTH_TEST)

  (setq *window* (glutCreateWindow "Rotate Cube"))

  (textures)

  (glLightfv GL_LIGHT0 GL_AMBIENT ambience)
  (glLightfv GL_LIGHT0 GL_DIFFUSE diffuse)
  (glLightfv GL_LIGHT0 GL_POSITION *light-pos*)

  (glEnable GL_LIGHTING)
  (glEnable GL_LIGHT0)
  (glEnable GL_DEPTH_TEST)

  (setq sphereList (glGenLists 1))
  (glNewList sphereList GL_COMPILE)
  (glutSolidSphere 0.4d0 16 16)
  (glEndList)

  (setq cubeList (glGenLists 1))
  (glNewList cubeList GL_COMPILE)
  (glutSolidCube 1d0)
  (glEndList)

  (setq *width/2* (/ width 2)
	*height/2* (/ height 2))
  (glutWarpPointer *width/2* *height/2*)
  (glutSetCursor GLUT_CURSOR_NONE)

  (set-position *camera* 0d0 0d0 10d0 -90d0 0d0)
  (set-position *object* 0.0d0 2.0d0 0.0d0 0d0 0d0)
  (set-position *camera-object* 0d0 10d0 0d0 0d0 0d0)
  (set-position *distance* -5d0 -5d0 -5d0 0d0 0d0)
  (set-position *distance-front* -3d0 0d0 0d0 0d0 0d0)
  (attach *camera-object* *object* *distance*)
  (attach-rel *camera-rel-object* *object* *distance*)
  (attach-rel-front *camera-front-object* *object* *distance-front*)

  (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR)    
  (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR_MIPMAP_NEAREST)
  (glTexEnvf GL_TEXTURE_ENV  GL_TEXTURE_ENV_MODE  (float GL_MODULATE))
  
  (glTexParameteri GL_TEXTURE_2D  GL_TEXTURE_WRAP_S  GL_CLAMP_TO_EDGE)
  (glTexParameteri GL_TEXTURE_2D  GL_TEXTURE_WRAP_T  GL_CLAMP_TO_EDGE))
  





(def-callback reshape (void (width int) (height int))
  (glViewport 0 0 width height)
  (glMatrixMode GL_PROJECTION)
  (glLoadIdentity)
  (gluPerspective 45.0d0  (float (/ width height) 1d0)  0.01d0  1000.0d0)
  (glMatrixMode GL_MODELVIEW)
  (setq *width/2* (/ width 2)
	*height/2* (/ height 2))
  (glutWarpPointer *width/2* *height/2*)
  (glLoadIdentity))




(defun create-skybox (x y z w h l)
  (let* ((w2 (/ w 2))
	 (h2 (/ h 2))
	 (l2 (/ l 2))
	 (mx (- x w2)) (px (+ x w2))
	 (my (- y h2)) (py (+ y h2))
	 (mz (- z l2)) (pz (+ z l2)))
    (glPushMatrix)
    (glEnable GL_TEXTURE_2D)
  
    ;;// Assign the texture coordinates and vertices for the BACK Side
    (glBindTexture GL_TEXTURE_2D 4)
    (glBegin GL_QUADS)
    (glTexCoord2f 0.0 1.0) (glVertex3f mx    my    mz)
    (glTexCoord2f 0.0 0.0) (glVertex3f mx    py    mz)
    (glTexCoord2f 1.0 0.0) (glVertex3f px    py    mz) 
    (glTexCoord2f 1.0 1.0) (glVertex3f px    my    mz)
    (glEnd)
  
    ;;// Assign the texture coordinates and vertices for the FRONT Side
    (glBindTexture GL_TEXTURE_2D 5)
    (glBegin GL_QUADS)
    (glTexCoord2f 1.0 1.0) (glVertex3f mx    my    pz)
    (glTexCoord2f 1.0 0.0) (glVertex3f mx    py    pz)
    (glTexCoord2f 0.0 0.0) (glVertex3f px    py    pz) 
    (glTexCoord2f 0.0 1.0) (glVertex3f px    my    pz)
    (glEnd)
  
  
    ;;// Assign the texture coordinates and vertices for the TOP Side
    (glBindTexture GL_TEXTURE_2D 6)
    (glBegin GL_QUADS)
    (glTexCoord2f 1.0 0.0) (glVertex3f mx    py    mz)
    (glTexCoord2f 1.0 1.0) (glVertex3f mx    py    pz)
    (glTexCoord2f 0.0 1.0) (glVertex3f px    py    pz) 
    (glTexCoord2f 0.0 0.0) (glVertex3f px    py    mz)
    (glEnd)
  
    ;;// Assign the texture coordinates and vertices for the BOTTOM Side
    (glBindTexture GL_TEXTURE_2D 7)
    (glBegin GL_QUADS)
    (glTexCoord2f 1.0 1.0) (glVertex3f mx    my   mz)
    (glTexCoord2f 1.0 0.0) (glVertex3f mx    my   pz)
    (glTexCoord2f 0.0 0.0) (glVertex3f px    my   pz) 
    (glTexCoord2f 0.0 1.0) (glVertex3f px    my   mz)
    (glEnd)
  
    ;;// Assign the texture coordinates and vertices for the LEFT Side
    (glBindTexture GL_TEXTURE_2D 9)
    (glBegin GL_QUADS)
    (glTexCoord2f 1.0 1.0) (glVertex3f mx    my    mz)
    (glTexCoord2f 0.0 1.0) (glVertex3f mx    my    pz)
    (glTexCoord2f 0.0 0.0) (glVertex3f mx    py    pz) 
    (glTexCoord2f 1.0 0.0) (glVertex3f mx    py    mz)
    (glEnd)
  
    ;;// Assign the texture coordinates and vertices for the RIGHT Side
    (glBindTexture GL_TEXTURE_2D 8)
    (glBegin GL_QUADS)
    (glTexCoord2f 0.0 1.0) (glVertex3f  px    my    mz)
    (glTexCoord2f 1.0 1.0) (glVertex3f  px    my    pz)
    (glTexCoord2f 1.0 0.0) (glVertex3f  px    py    pz) 
    (glTexCoord2f 0.0 0.0) (glVertex3f  px    py    mz)
    (glEnd)    
  
  
    (glDisable GL_TEXTURE_2D)
    (glPopMatrix)))


(defun draw-object ()
  (glPushMatrix)
  (glTranslatef (float (place-x *object*) 1f0)
		(float (place-y *object*) 1f0)
		(float (place-z *object*) 1f0))
  (glMaterialfv GL_FRONT GL_SPECULAR mat_specular)
  (glMaterialf GL_FRONT GL_SHININESS mat_shininess)
  (glMaterialfv GL_FRONT GL_EMISSION mat_zero)
  (glMaterialfv GL_FRONT GL_DIFFUSE mat_solid)
  (glCallList sphereList)
  (glPopMatrix)

  (glPushMatrix)  
  (glTranslatef (float (+ (place-x *object*) (* 0.4d0 (place-dx *object*))) 1f0)
		(float (+ (place-y *object*) (* 0.4d0 (place-dy *object*))) 1f0)
		(float (+ (place-z *object*) (* 0.4d0 (place-dz *object*))) 1f0))
  (glScalef 0.5 0.5 0.5)
  (glCallList sphereList)
  (glPopMatrix))



(let ((quad (gluNewQuadric)))
  (def-callback display (void)
    (set-fps)
  
    (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
    (glLoadIdentity)

    (look *object-to-look*)

    (when *skybox*
      (create-skybox 0.0 0.0 0.0 400.0 200.0 400.0))

    (glPushMatrix)
    (glTranslatef -0.15 -0.15 -0.01)
    (glMaterialfv GL_FRONT GL_SPECULAR mat_specular)
    (glMaterialf GL_FRONT GL_SHININESS mat_shininess)
    (glMaterialfv GL_FRONT GL_EMISSION mat_zero)
    (glMaterialfv GL_FRONT GL_DIFFUSE mat_solid)
    (glCallList sphereList)
    (glPopMatrix)

    (draw-object)

    (glPushMatrix)
    (glTranslatef 0.15 0.15 0.5)
    (glRotatef (+ 15.0 *rotX*) 1.0 0.0 0.0)
    (glRotatef (+ 30.0 *rotY*) 0.0 1.0 0.0)
    (glRotatef *rotZ* 0.0 0.0 1.0)
    (glScalef 1.0 3.0 1.0)
    (glMaterialfv GL_FRONT GL_EMISSION mat_emission)
    (glMaterialfv GL_FRONT GL_DIFFUSE mat_transparent)
    (glMaterialfv GL_FRONT GL_SPECULAR mat_specular_default)
    (glMaterialf GL_FRONT GL_SHININESS mat_shininess_default)
    (glEnable GL_BLEND)
    (glDepthMask GL_FALSE)
    (glBlendFunc GL_SRC_ALPHA GL_ONE)
    (glCallList cubeList)
    (glDepthMask GL_TRUE)
    (glDisable GL_BLEND)
    (glPopMatrix)

    (glPushMatrix)
    (glTranslatef 2.0 0.15 0.5)
    (glRotatef (+ 15.0 *rotX*) 0.0 1.0 0.0)
    (glRotatef (+ 30.0 *rotY*) 1.0 0.0 1.0)
    (glRotatef *rotZ* 0.0 0.0 1.0)

    (glEnable GL_TEXTURE_2D)
    (glBindTexture GL_TEXTURE_2D 1)
    (gluQuadricTexture quad 1)
    (gluQuadricDrawStyle quad GLU_FILL)
    (gluSphere quad 1.0d0 20 20)
    (glDisable GL_TEXTURE_2D)
    (glPopMatrix)

    (glutWarpPointer *width/2* *height/2*)
    (glutSwapBuffers)))





(def-callback idle (void)
  (incf *rotX* (* 0.03f0 *frame-interval*))
  (incf *rotY* (* 0.03f0 *frame-interval*))
  (incf *rotZ* (* 0.08f0 *frame-interval*))

  (when (svref *key-table* *key-F1*)
    (setf *object-to-move* *camera*)
    (setf *object-to-look* *camera*)
    (setf *look-sensibility* 5))
  (when (svref *key-table* *key-F2*)
    (setf *object-to-move* *object*)
    (setf *object-to-look* *camera*)
    (setf *look-sensibility* 50))
  (when (svref *key-table* *key-F3*)
    (setf *object-to-move* *object*)
    (setf *object-to-look* *camera-object*)
    (setf *look-sensibility* 50))
  (when (svref *key-table* *key-F4*)
    (setf *object-to-move* *distance*)
    (setf *object-to-look* *camera-object*)
    (setf *look-sensibility* 5))
  (when (svref *key-table* *key-F5*)
    (setf *object-to-move* *object*)
    (setf *object-to-look* *camera-rel-object*)
    (setf *look-sensibility* 50))
  (when (svref *key-table* *key-F6*)
    (setf *object-to-move* *distance*)
    (setf *object-to-look* *camera-rel-object*)
    (setf *look-sensibility* 5))
  (when (svref *key-table* *key-F7*)
    (setf *object-to-move* *object*)
    (setf *object-to-look* *camera-front-object*)
    (setf *look-sensibility* 50))
  (when (svref *key-table* *key-F8*)
    (setf *object-to-move* *distance-front*)
    (setf *object-to-look* *camera-front-object*)
    (setf *look-sensibility* 5))

  
  (when (svref *key-table* *key-up*)
    (walk *object-to-move* 0.01d0 0.01d0 0.01d0))
  (when (svref *key-table* *key-down*)
    (walk *object-to-move* -0.01d0 -0.01d0 -0.01d0))
  (when (svref *key-table* *key-right*)
    (walk-strafe *object-to-move* 0.01d0 0.01d0 0.01d0))
  (when (svref *key-table* *key-left*)
    (walk-strafe *object-to-move* -0.01d0 0.01d0 -0.01d0))

  (when (svref *key-table* *key-lookup*)
    (update-angle *object-to-move* 0 *look-sensibility* 1d0))
  (when (svref *key-table* *key-lookdown*)
    (update-angle *object-to-move* 0 (- *look-sensibility*) 1d0))
  (when (svref *key-table* *key-lookright*)
    (update-angle *object-to-move* *look-sensibility* 0 1d0))
  (when (svref *key-table* *key-lookleft*)
    (update-angle *object-to-move* (- *look-sensibility*) 0 1d0))

  (when (eql *object-to-look* *camera-object*)
    (attach *camera-object* *object* *distance*))
  (when (eql *object-to-look* *camera-rel-object*)
    (attach-rel *camera-rel-object* *object* *distance*))
  (when (eql *object-to-look* *camera-front-object*)
    (attach-rel-front *camera-front-object* *object* *distance-front*))
  
  (glutPostRedisplay))
;;(sleep 0.01))





(def-callback mouse (void (button int) (state int) (x int) (y int))
  (declare (ignorable button state x y)))
;;  (update-angle *camera* (- x *width/2*) (- *height/2* y) 5))
;;(format t "Mouse: button=~A  state=~A  x=~A  y=~A~%" button state x y)



(def-callback motion (void (x int) (y int))
  (update-angle *object-to-move* (- x *width/2*) (- *height/2* y) 5))



(def-callback passive-mouse (void (x int) (y int))
  (update-angle *object-to-move* (- x *width/2*) (- *height/2* y) 5))





(let ((old_x 50)
      (old_y 50)
      (old_width 320)
      (old_height 320))
  (defun swap-fullscreen ()
    (if (< (glutGet GLUT_WINDOW_WIDTH)  (glutGet GLUT_SCREEN_WIDTH))
	(progn
	  (setq old_x (glutGet GLUT_WINDOW_X)
		old_y (glutGet GLUT_WINDOW_Y)
		old_width (glutGet GLUT_WINDOW_WIDTH)
		old_height (glutGet GLUT_WINDOW_HEIGHT))
	  (glutFullScreen))
      (progn
	(glutPositionWindow old_x  old_y)
	(glutReshapeWindow old_width  old_height)))
    (glutPostRedisplay)))
  


(def-callback keyboard (void (key int) (x int) (y int))
  (declare (ignorable x y))
  ;;(format t "Key: ~C [~A]  x=~A  y=~A~%" (code-char key) key x y)
  (case (code-char key)
    (#\Tab (swap-fullscreen))
    (#\a (print-fps))
    (#\e (setq *skybox* (not *skybox*)))
    (#\Escape
     (glutDestroyWindow *window*)
     (throw :exit-null nil))
    (t (setf (svref *key-table* key) t))))


(def-callback special-key (void (key int) (x int) (y int))
  (declare (ignorable x y))
  ;;(format t "Special Key: ~A  x=~A  y=~A~%" key x y)
  (setf (svref *key-table* (+ key 200)) t))



(def-callback keyboard-up (void (key int) (x int) (y int))
  (declare (ignorable x y))
  ;;(format t "Key Up: ~C [~A]  x=~A  y=~A~%" (code-char key) key x y)
  (setf (svref *key-table* key) nil))



(def-callback special-key-up (void (key int) (x int) (y int))
  (declare (ignorable x y))
  ;;(format t "Special Key Up: ~A  x=~A  y=~A~%" key x y)
  (setf (svref *key-table* (+ key 200)) nil))

(defun show-help ()
  (format t "Rotating a cube
Key:
  Escape     :         Quit
  Tab        :         Swap fullscreen
  a          :         Print FPS
  e          :         Disable skybox
  Up/Down    :         Walk/Backpedal
  Left/Right :         Strafe Left/Right
  z/w        :         Look up/down
  q/s        :         Look left/rigth
  F1         :         Camera look / Camera move
  F2         :         Camera look / Object move
  F3         :         Object look / Object move
  F4         :         Object look / Camera move
  F5         :         Object relative look / Object move
  F6         :         Object relative look / Camera move
  F7         :         Object front look / Object move
  F8         :         Object front look / Camera move
"))
  



(defun start ()
  (show-help)
  
  ;;(init 800 600 50 50)
  ;;(init 320 320 400 50)
  (init 1016 744 0 0)
  ;;(swap-fullscreen)
  
  (glutKeyboardFunc (callback keyboard))
  (glutSpecialFunc (callback special-key))
  (glutKeyboardUpFunc (callback keyboard-up))
  (glutSpecialUpFunc (callback special-key-up))
  
  (glutDisplayFunc (callback display))
  (glutReshapeFunc (callback reshape))
  (glutMotionFunc (callback motion))
  (glutMouseFunc (callback mouse))
  (glutPassiveMotionFunc (callback passive-mouse))
  (glutIdleFunc (callback idle))

  (catch :exit-null
    (glutMainLoop))

  (ignore-errors (glutMainLoopEvent))
  (format t "Done:")
  (print-fps))