;;; ogl_bench v1.0 - Copyright 2007 - Graphcomp
;;; Bob Free bfree@graphcomp.com
;;; http://graphcomp.com/opengl
;;;
;;; This Common Lisp translation by Charles McMackin
;;; 
;;; This program is freely distributable without licensing fees 
;;; and is provided without guarantee or warrantee expressed or 
;;; implied. This program is -not- in the public domain.
;;; 


(defpackage #:ogl-bench
  (:use #:cl)
  (:export #:ogl-bench))

(in-package #:ogl-bench)

;; (declaim (optimize (speed 3)(space 0)(safety 0)))

(defparameter *program* "OpenGL Benchmark - Lisp Binding")
(defparameter *frames* 0)
(defparameter *app-bench* (cons 0 0))
(defparameter *frame-bench* (cons 0 0))
(defparameter *texture-bench* (cons 0 0))
(defparameter *teapot-bench*  (cons 0 0))
(defparameter *rot-y* 0.0)
(defparameter *inc-y* 0.5)
(defparameter *rot-tpot-x* 0.0)
(defparameter *rot-tpot-y* 0.0)

;; Start benchmark
(defun start-bench (var)
  (setf (cdr var) (get-internal-real-time)))

;; Accumulate benchmark
(defun end-bench (var)
  (incf (car var) (- (get-internal-real-time)
		     (cdr var))))

;; Print benchmark
(defun print-bench (frames frame-timer texture-timer teapot-timer app-timer)
  ;; Calculate FPS of the benchmark timers
  (flet ((time-for (xframes xtimer)
	   (/ xframes (/ (car xtimer)
			 internal-time-units-per-second))))
    (let ((app-time (time-for frames app-timer))
	  (texture-time (time-for frames texture-timer))
	  (teapot-time (time-for frames teapot-timer))
	  (frame-time (time-for frames frame-timer)))
          
      (format t "FBO Texture Rendering FPS: ~s~%" (float texture-time))
      (format t "Teapot Shader FPS: ~s~%"  (float teapot-time))
      (format t "Frame overhead secs/frame: ~s~%" (float (/ (- frame-time (+ texture-time teapot-time))
							    frames)))
      (format t "OS/GLUT overhead secs/frame: ~s~%"  (float (/ (- app-time frame-time) frames)))
      (format t "Overall FPS: ~s~%~%" (float (/ frames app-time))))))

;; Check OpenGL Version
(defun check-version ()
  ;;; Should work when get-string is supported by cl-opengl. -CM
  (let ((version (gl:get-string :version))
	(vendor (gl:get-string :vendor))
	(renderer (gl:get-string :renderer))
	; (exts (gl:get-string :extensions))
	)
    (format t "~A~%~%" *program*)
    (format t "OpenGL: ~A~%" version)
    (format t "Vendor: ~A~%" vendor)
    (format t "Renderer: ~A~%~%" renderer)))


(defun init-progs ()
  (let ;; NOP vertex program
      ((vertex-prog 
	  "!!ARBvp1.0
	   TEMP vertexClip;
	   DP4 vertexClip.x, state.matrix.mvp.row[0], vertex.position;
	   DP4 vertexClip.y, state.matrix.mvp.row[1], vertex.position;
	   DP4 vertexClip.z, state.matrix.mvp.row[2], vertex.position;
	   DP4 vertexClip.w, state.matrix.mvp.row[3], vertex.position;
	   MOV result.position, vertexClip;
	   MOV result.color, vertex.color;
	   MOV result.texcoord[0], vertex.texcoord;
	   MOV result.texcoord[1], vertex.normal;
	   END" )

	 ;; Black Light Fragment shader 
	 (fragment-prog
	  "!!ARBfp1.0
	   TEMP decal,color;
	   TEX decal, fragment.texcoord[0], texture[0], 2D;
	   MUL result.color, decal, fragment.texcoord[1];
	   END")
	 
	 (vertex-prog-id (first (gl:gen-programs-arb 1)))
	 (frag-prog-id (first (gl:gen-programs-arb 1))))
    
    (gl:bind-program-arb :vertex-program-arb vertex-prog-id)
    (gl:program-string-arb :vertex-program-arb :program-format-ascii-arb
			   vertex-prog)
    
    (gl:bind-program-arb :fragment-program-arb frag-prog-id)
    (gl:program-string-arb :fragment-program-arb :program-format-ascii-arb
			    fragment-prog)))


(defclass ogl-bench-window (glut:window)
  ((texture :accessor texture)
   (framebuffer :accessor framebuffer))
  (:default-initargs :width 512 :height 512 :title *program*
		     :mode '(:double :rgba :depth :alpha)))

(defmethod glut:display-window :before ((w ogl-bench-window))
  (let ((framebuffer (first (gl:gen-framebuffers-ext 1)))
	(depthbuffer (first (gl:gen-renderbuffers-ext 1)))
	(texture (first (gl:gen-textures 1)))
	(tex-width 128)
	(tex-height 128))
    
    ;;Resize Window
    (gl:viewport 0 0 512 512)
    (gl:matrix-mode :projection)
    (gl:load-identity)
    (glu:perspective 45 1 0.1 100)
    (gl:matrix-mode :modelview)
    
    ;;Initialize Framebuffers
    (gl:bind-framebuffer-ext :framebuffer-ext framebuffer)
    (gl:bind-texture :texture-2d texture)

    (gl:tex-image-2d :texture-2d 0 :rgba tex-width tex-height 0 :rgba :unsigned-byte (cffi:null-pointer))
    (gl:tex-parameter :texture-2d :texture-mag-filter :linear)
    (gl:tex-parameter :texture-2d :texture-min-filter :linear)
    
    (gl:framebuffer-texture-2d-ext :framebuffer-ext
				   :color-attachment0-ext
				   :texture-2d
				   texture
				   0)
    (gl:bind-renderbuffer-ext :renderbuffer-ext depthbuffer)
    (gl:renderbuffer-storage-ext :renderbuffer-ext :depth-component24 tex-width tex-height)
    (gl:framebuffer-renderbuffer-ext :framebuffer-ext 
				     :depth-attachment-ext 
				     :renderbuffer-ext 
				     depthbuffer)
    ;; FBO status check
    (let ((framebuffer-status (gl:check-framebuffer-status-ext :framebuffer-ext)))
      (unless (eql framebuffer-status :framebuffer-complete-ext)
	(error "FBO status: ~A." framebuffer-status)))
    
    (setf (texture w) texture
	  (framebuffer w) framebuffer))
  
  (init-progs))


(defun render-fbo ()
  (gl:load-identity)
  (gl:translate -0.75 -0.85 -2.5)

  (gl:rotate *rot-tpot-x* 1.0 0.0 0.0)
  (incf *rot-tpot-x* 0.5)

  (gl:rotate *rot-tpot-y* 0.0 1.0 0.0)
  (incf *rot-tpot-y* 1.0)
  
  (gl:clear-color 0 0 0 0)
  (gl:clear :color-buffer-bit :depth-buffer-bit)
  (gl:color 1.0 1.0 1.0)
  
  (glut:wire-teapot 0.125))

;; Terminate OpenGL Environment
(defun term ()
  ;; Note: many of the clean-up functions from the C version not translated...yet.
  ;; Display benchmark
  (end-bench *app-bench*)
  (print-bench *frames* *frame-bench* *texture-bench* *teapot-bench* *app-bench*)
  
  ;; Reset frames global variable in case of successive runs
  (setf *frames* 0
	(car *app-bench*) 0
	(car *frame-bench*) 0
	(car *texture-bench*) 0
	(car *teapot-bench*) 0))


(defmethod glut:display ((w ogl-bench-window))
      
  ;; Run benchmark 1000 times
  (if (> (incf *frames*) 1000) 
      (term))
  
  (start-bench *frame-bench*)
    
  ;; Render animated texture
  (start-bench *texture-bench*)
  (gl:bind-framebuffer-ext :framebuffer-ext (framebuffer w))
  (render-fbo)
  (gl:bind-framebuffer-ext :framebuffer-ext 0)
  (end-bench *texture-bench*)

  ;; Set up Modelview
  (gl:matrix-mode :modelview)
  (gl:load-identity)
  (gl:translate 0 0 -5)
  (gl:rotate 0 1 0 0)
  (gl:rotate *rot-y* 0 1 0)
  (incf *rot-y* *inc-y*)

  ;;Set attributes
  (gl:enable :texture-2d)
  (gl:enable :depth-test)
  (gl:tex-env :texture-env :texture-env-mode :decal)
    
  ;; Clear render buffer and set teapot color
  (gl:clear-color 0.2 0.2 0.2 1.0)
  (gl:clear :color-buffer-bit :depth-buffer-bit)
  (gl:color 0.9 0.45 0.0)
    
  ;; Render the teapot using our shader
  (start-bench *teapot-bench*)
  (gl:enable :vertex-program-arb)
  (gl:enable :fragment-program-arb)
    
  (glut:solid-teapot 1.0)
    
  (gl:disable :vertex-program-arb)
  (gl:disable :fragment-program-arb)
  (end-bench *teapot-bench*)

  ;; Double-buffer and done
  (glut:swap-buffers)
  (end-bench *frame-bench*))

(defmethod glut:idle ((w ogl-bench-window))
  (glut:post-redisplay))

(defmethod glut:keyboard ((w ogl-bench-window) key x y)
  (declare (ignore x y))
  (when (eql (code-char key) #\Esc)
    (glut:destroy-current-window)))


(defun ogl-bench ()
  (check-version)
  (start-bench *app-bench*)
  (glut:display-window (make-instance 'ogl-bench-window)))