;;/* 
;;    maiden.c
;;    Nate Robins  1997
;;
;;    A killer "Iron Maiden rocks out with OpenGL" demo (according to
;;    Mark Kilgard).
;;
;; */
;;
(in-package :common-lisp-user)

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

(in-package :maiden)


(defvar *window* nil)

(defvar *fps* 0)


(defconstant Ri 4.0)			; /* inner radius of torus */
(defconstant Ro 8.0)                      ; /* outer radius of torus */
(defconstant Rid 4.0d0)			; /* inner radius of torus */
(defconstant Rod 8.0d0)                      ; /* outer radius of torus */

(defconstant N_COLORS 12)

(defparameter colors #(#(255  0  0 )
		       #(255  128  0)
		       #(255  255  0)
		       #(128  255  0)
		       #(0  255  0)
		       #(0  255  128)
		       #(0  255  255)
		       #(0  128  255)
		       #(0  0  255)
		       #(128  0  255)
		       #(255  0  255)
		       #(255  0  128)))
(dotimes (i (length colors))
  (setf (svref colors i) (convert-array-to-pointer 'unsigned-byte (svref colors i))))




(defstruct star x y vx vy)
(defparameter num_stars 500)
(defparameter stars (make-array num_stars :element-type 'star))


;;GLubyte* background

(defparameter lod 24)
(defparameter spin_y 0.0)
(defparameter spin_x 0.0)
(defparameter spin_z 0.0)

(defparameter num_spheres 12)
(defparameter num_textures 4)
(defparameter mode GL_MODULATE)
(defparameter filter GL_LINEAR)


(defparameter drawbackground t)
(defparameter drawstars t)
(defparameter texturing t)
(defparameter perftiming t)
(defparameter frozen nil)

(defparameter width 0)
(defparameter height 0)

(defparameter bgtexture 1)

(defparameter texnames #("ppm/deadone-256x256.ppm" 
			 "ppm/virus-256x256.ppm" 
			 "ppm/ace-256x256.ppm" 
			 "ppm/space-256x256.ppm"))

;;(defparameter texnames #("ppm/deadone-128x128.ppm" 
;;			 "ppm/virus-128x128.ppm" 
;;			 "ppm/ace-128x128.ppm" 
;;			 "ppm/space-128x128.ppm"))
;;
;;(defparameter texnames #("ppm/deadone-64x64.ppm" 
;;			 "ppm/virus-64x64.ppm" 
;;			 "ppm/ace-64x64.ppm" 
;;			 "ppm/space-64x64.ppm"))





(defun color (c)
  (glColor3ubv (svref colors (floor (* (/ N_COLORS num_spheres) c)))))



(defun string-to-list (str &key (split-char #\space))
  (do* ((start 0 (1+ index))
	(index (position split-char str :start start)
	       (position split-char str :start start))
	(accum nil))
      ((null index)
       (unless (string= (subseq str start) "")
	 (push (subseq str start) accum))
       (nreverse accum))
    (when (/= start index)
      (push (subseq str start index) accum))))


(defun my-parse-integer (str)
  (when str
    (parse-integer str)))


;;/* ppmRead: read a PPM raw (type P6) file.  The PPM file has a header
;;   that should look something like:
;;
;;     P6
;;     # comment
;;     width height max_value
;;     rgbrgbrgb...
;;
;;   where "P6" is the magic cookie which identifies the file type and
;;   should be the only characters on the first line followed by a
;;   carriage return.  Any line starting with a # mark will be treated
;;   as a comment and discarded.  After the magic cookie  three integer
;;   values are expected: width  height of the image and the maximum
;;   value for a pixel (max_value must be < 256 for PPM raw files).  The
;;   data section consists of width*height rgb triplets (one byte each)
;;   in binary format (i.e.  such as that written with fwrite() or
;;   equivalent).
;;
;;   The rgb data is returned as an array of unsigned chars (packed
;;   rgb).  The malloc()'d memory should be free()'d by the caller.  If
;;   an error occurs  an error message is sent to stderr and NULL is
;;   returned.
;;
;; */
(defun read-sequence-cs (array stream)
  "Read a binary sequence from a character stream"
  #+CLISP
  (progn
    (setf (stream-element-type stream) '(unsigned-byte 8))
    (read-sequence array stream)
    (setf (stream-element-type stream) 'character))
  #+CMU
  (let ((data (make-array (length array) :element-type 'character)))
    (read-sequence data stream)
    (dotimes (i (length array))
      (setf (aref array i) (char-code (svref data i))))))



(defun ppmRead (filename)
  (let (line w h d image)
    (format t "Opening ~A~%" filename)
    (with-open-file
     (stream filename :direction :input :element-type 'character)
     (unless (string= (read-line stream nil :eof) "P6")
       (format t "~A : Not a raw PPM file~%" filename))
     (read-line stream nil :eof)
     (setq line (string-to-list (read-line stream nil :eof)))
     (setq w (my-parse-integer (first line))
	   h (my-parse-integer (second line)))
     (setq line (string-to-list (read-line stream nil :eof)))
     (setq d (my-parse-integer (first line)))
     (setf image (make-array (* w h 3) :element-type '(unsigned-byte 8)))
     (read-sequence-cs image stream)
     (values image w h))))



(defun sphere (texture)
  (if texturing
      (progn
	(glBindTexture GL_TEXTURE_2D  texture)
	(glutSolidSphere Rid  lod  lod))
    (glutSolidSphere Rid  lod  lod)))



(defun textures ()
  (glPixelStorei GL_UNPACK_ALIGNMENT 1)
  ;;    /* XXX - RE bug - must enable texture before bind. */
  (glEnable GL_TEXTURE_2D)
  (dotimes (i 4)
    (glBindTexture GL_TEXTURE_2D  (1+ i))
    (multiple-value-bind (texture w h)
	(ppmRead (svref 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 ()
  (glEnable GL_DEPTH_TEST)
  (glEnable GL_CULL_FACE)
  (glEnable GL_LIGHTING)
  (glEnable GL_LIGHT0)
  (glEnable GL_COLOR_MATERIAL)
  (glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA)
  (glColorMaterial GL_FRONT GL_DIFFUSE)
  (glMaterialf GL_FRONT GL_SHININESS  64f0)
  (glMaterialfv GL_FRONT GL_SPECULAR (convert-array-to-pointer 'single-float #(0.2f0  0.2f0  0.2f0  1f0)))
  (glMaterialfv GL_FRONT GL_AMBIENT  (convert-array-to-pointer 'single-float #(1.0f0  1.0f0  1.0f0  1.0f0)))
  (glTexParameteri GL_TEXTURE_2D  GL_TEXTURE_MAG_FILTER  filter)
  (glTexParameteri GL_TEXTURE_2D  GL_TEXTURE_MIN_FILTER  filter))




(def-callback reshape (void (w int) (h int))
  (setq width w
	height h)
  (glViewport 0  0  width  height)
  (glMatrixMode GL_PROJECTION)
  (glLoadIdentity)
  (gluPerspective 120.0d0  (float (/ width height) 1d0)  0.1d0  1000.0d0)
  (glMatrixMode GL_MODELVIEW)
  (glLoadIdentity)
  (gluLookAt 0d0  0d0  20d0  0d0  0d0  0d0  0d0  1d0  0d0)
  (dotimes (i num_stars)
    (setf (svref stars i) (make-star :x (random width)
				     :y (random height)
				     :vx (+ (random 5) 2)
				     :vy 0))))


;;(uffi:def-function ("glutBitmapHelvetica18" ici-glutbitmaphelvetica18)
;;		   ()
;;		   :returning :pointer-void
;;		   :module "/usr/lib/libglut.so")
;(uffi:def-foreign-var ("glutBitmapHelvetica18" glutBitmapHelvetica18) (* t) "/usr/lib/libglut.so")
;(setf GLUT_BITMAP_HELVETICA_18 glutBitmapHelvetica18)

;;(setf (uffi:deref-pointer glutBitmapHelvetica18 :int) #x0008)

;;(defparameter glutBitmapHelvetica18 (uffi:allocate-foreign-object :int))
;;(setf (uffi:deref-pointer glutBitmapHelvetica18 :int) #x0008)

(let ((start 1)
      (last 1)
      (end 0)
      (step 0))
  (def-callback display (void)
    (setq start (glutGet GLUT_ELAPSED_TIME))
    
    (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
    (when (or drawbackground drawstars perftiming)
      (glMatrixMode GL_PROJECTION)
      (glPushMatrix)
      (glLoadIdentity)
      (glOrtho 0d0  (coerce width 'double-float)  0d0  (coerce height 'double-float)  -1d0  1d0)
      (glMatrixMode GL_MODELVIEW)
      (glPushMatrix)
      (glLoadIdentity)
      (glDepthMask GL_FALSE)
      (glDisable GL_DEPTH_TEST)
      (glDisable GL_LIGHTING)

      (when drawbackground
	(glEnable GL_TEXTURE_2D)
	(glBindTexture GL_TEXTURE_2D  bgtexture)
	(glColor3ub 255  255  255)
	(glBegin GL_QUADS)
	(glTexCoord2i 0  0)
	(glVertex2i 0  0)
	(glTexCoord2i 1  0)
	(glVertex2i width  0)
	(glTexCoord2i 1  1)
	(glVertex2i width  height)
	(glTexCoord2i 0  1)
	(glVertex2i 0  height)
	(glEnd)
	(glDisable GL_TEXTURE_2D))

      (when drawstars
	(glEnable GL_BLEND)
	(glBegin GL_LINES)
	(dotimes (i num_stars)
	  (incf (star-x (svref stars i)) (star-vx (svref stars i)))
	  (if (< (star-x (svref stars i)) width)
	      (progn
		(glColor4ub 0  0  0  0)
		(glVertex2i (- (star-x (svref stars i)) (* (star-vx (svref stars i)) 3))
			    (star-y (svref stars i)))
		(glColor4ub 255  255  255  255)
		(glVertex2i (star-x (svref stars i)) (star-y (svref stars i))))
	    (setf (star-x (svref stars i)) 0)))
	(glEnd)
	(glDisable GL_BLEND))


      (when perftiming
	(glColor3ub 255 255 255)
	(glRasterPos2i 5  5)
	(loop :for i :across (format nil "~A" (floor (* (/ 1.0 (- end last)) 1000)))
	      :do (glutBitmapCharacter GLUT_BITMAP_8BY13 (char-code i))))
      
      (setf *fps* (max *fps* (* (/ 1.0 (- end last)) 1000)))
      (setq last start)

      (glEnable GL_LIGHTING)
      (glEnable GL_DEPTH_TEST)
      (glDepthMask GL_TRUE)
      (glMatrixMode GL_PROJECTION)
      (glPopMatrix)
      (glMatrixMode GL_MODELVIEW)
      (glPopMatrix))

    (glPushMatrix)

    (when texturing
      (glTexGeni GL_S  GL_TEXTURE_GEN_MODE  GL_SPHERE_MAP)
      (glTexGeni GL_T  GL_TEXTURE_GEN_MODE  GL_SPHERE_MAP)
      (glEnable GL_TEXTURE_GEN_S)
      (glEnable GL_TEXTURE_GEN_T)
      (glEnable GL_TEXTURE_2D))
    

    (glRotatef spin_y  0.0  1.0  0.0)
    (glColor3ub 196  196  196)
    (glutSolidTorus Rid  Rod  lod  lod)

    (setq step (/ 360.0 num_spheres))
    (dotimes (i num_spheres)
      (glPushMatrix)
      (glRotatef (+ (* step i) spin_z)  0.0  0.0  1.0)
      (glTranslatef 0.0  Ro  0.0)
      (glRotatef (+ (* step i) spin_x)  1.0  0.0  0.0)
      (glTranslatef 0.0  (+ Ri Ri)  0.0)
      (color i)
      (sphere (1+ (mod i num_textures)))
      (glPopMatrix))

    (when texturing
      (glDisable GL_TEXTURE_GEN_S)
      (glDisable GL_TEXTURE_GEN_T)
      (glDisable GL_TEXTURE_2D))

    (glPopMatrix)

    (glutSwapBuffers)

    (setq end (glutGet GLUT_ELAPSED_TIME))))

(def-callback idle (void)
  (unless frozen
    (when (> (incf spin_y 0.5) 360) (decf spin_y 360))
    (when (> (incf spin_x 10) 360) (decf spin_x 360))
    (when (> (incf spin_z 1) 360) (decf spin_z 360)))
  (glutPostRedisplay))


(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 key x y))
  (case (code-char key)
    (#\Tab (swap-fullscreen))
    (#\Escape
     (glutDestroyWindow *window*)
     (throw :exit-maiden nil))
    (#\p (setq perftiming (not perftiming)))
    (#\t (setq texturing (not texturing)))
    (#\m (cond ((= mode GL_REPLACE) (setq mode GL_MODULATE))
	       ((= mode GL_MODULATE) (setq mode GL_REPLACE)))
     (glTexEnvi GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE mode)
     (format t "~A mode.~%"  (if (= mode GL_MODULATE) "GL_MODULATE" "GL_REPLACE")))
    (#\f (cond ((= filter GL_NEAREST) (setq filter GL_LINEAR))
	       (t (setq filter GL_NEAREST)))
     (dotimes (i num_textures)
       (glBindTexture GL_TEXTURE_2D  (1+ i))
       (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER  filter)
       (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER  filter))
     (format t "~A filtering.~%" (if (= filter GL_LINEAR) "GL_LINEAR" "GL_NEAREST")))
    (#\> (when (< num_textures 4) (incf num_textures)))
    (#\< (when (> num_textures 1) (decf num_textures)))
    (#\b (setq drawbackground (not drawbackground)))
    (#\* (setq drawstars (not drawstars)))
    (#\c (if (plusp (glIsEnabled GL_CULL_FACE))
	     (glDisable GL_CULL_FACE)
	   (glEnable GL_CULL_FACE))
     (format t "Culling ~A.~%" (if (plusp (glIsEnabled GL_CULL_FACE)) "enabled" "disabled")))
    (#\Space (setq  frozen (not frozen)))
    (#\1 (setq bgtexture 1))
    (#\2 (setq bgtexture 2))
    (#\3 (setq bgtexture 3))
    (#\4 (setq bgtexture 4))))



(def-callback special-key (void (value int) (x int) (y int))
  (declare (ignorable value x y))
  (cond ((= value GLUT_KEY_UP)
	 (format t "Key UP~%")
	 (when (< lod 32) (incf lod)))
	((= value GLUT_KEY_DOWN)
	 (format t "Key DOWN~%")
	 (when (> lod 3) (decf lod)))
	((= value GLUT_KEY_RIGHT)
	 (format t "Key RIGHT~%")
	 (when (< num_spheres N_COLORS) (incf num_spheres)))
	((= value GLUT_KEY_LEFT)
	 (format t "Key LEFT~%")
	 (when (> num_spheres 1) (decf num_spheres)))
	(t (format t "Key ? ~A~%" value))))


(def-callback menu (void (value int))
  (funcall-callback keyboard (function void int int int) value 0 0))



(defun start ()
  (glutInitDisplayMode (+ GLUT_DOUBLE GLUT_DEPTH GLUT_RGBA GLUT_MULTISAMPLE))
  (glutInitWindowPosition 200  50)
  (glutInitWindowSize 800  600)

  (setq *window* (glutCreateWindow "Maiden"))
  (glutDisplayFunc (callback display))
  (glutReshapeFunc (callback reshape))
  (glutSpecialFunc (callback special-key))
  (glutKeyboardFunc (callback keyboard))
  (glutCreateMenu (callback menu))
  (glutAddMenuEntry "Toggle texture mapping"  (char-code #\t))
  (glutAddMenuEntry "Toggle texture mode"  (char-code #\m))
  (glutAddMenuEntry "Toggle filter mode"  (char-code #\f))
  (glutAddMenuEntry "Toggle performance"  (char-code #\p))
  (glutAddMenuEntry "Toggle background"  (char-code #\b))
  (glutAddMenuEntry "Toggle animation"  (char-code #\Space))
  (glutAddMenuEntry "Toggle culling"  (char-code #\c))
  (glutAddMenuEntry "Toggle stars"  (char-code #\*))
  (glutAddMenuEntry "Toggle fullscreen"  (char-code #\Tab))
  (glutAddMenuEntry ""  0)
  (glutAddMenuEntry "> and < keys change # of textures"  0)
  (glutAddMenuEntry "Arrows up/down change level of detail"  0)
  (glutAddMenuEntry "Arrows right/left change # of spheres"  0)
  (glutAddMenuEntry "1-4 keys change background image"  0)
  (glutAddMenuEntry ""  0)
  (glutAddMenuEntry "Quit"  (char-code #\Escape))
  (glutAttachMenu GLUT_RIGHT_BUTTON)

  (textures)

  (init)
  (glutIdleFunc (callback idle))

  (catch :exit-maiden
    (glutMainLoop))
  (ignore-errors (glutMainLoopEvent))
  (format t "Done  => FPS = ~A~%" *fps*))