;;; Example openmcl FFI by hamlink
;;;
;;; 2d Gasket example taken from
;;;  "Interactive Computer Graphics:
;;;   A Top-Down Approach with OpenGL" by Ed Angel

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ccl:use-interface-dir :GL))

(defpackage "DRAWPIXEL")
(defpackage "OPENGL"
    (:nicknames :opengl :gl)
    (:export "INITIALIZE-GLUT"
	     "WITH-MATRIX-MODE"))

;;; Opening "libglut.so" should also open "libGL.so", "libGLU.so",
;;; and other libraries that they depend on.
;;; It seems that it does on some platforms and not on others;
;;; explicitly open what we require here.
(eval-when (:compile-toplevel :load-toplevel :execute)
  #+linuxppc-target
  (dolist (lib '("libGL.so" "libGLU.so" "libglut.so"))
    (open-shared-library lib))
  #+darwinppc-target
  (open-shared-library "GLUT.framework/GLUT")
  )

(in-package :opengl)



;; glut complains if it's initialized redundantly
(let ((glut-initialized-p nil))
  (defun initialize-glut ()
    (let ((command-line-strings (list "openmcl")))
      (when (not glut-initialized-p)
        (ccl::with-string-vector (argv command-line-strings)
          (rlet ((argvp (* t))    ; glutinit takes (* (:signed 32)) and (* (* (:unsigned 8)))
		 (argcp :signed)) ; so why are these declared as (* t) and :signed?
	    (setf (%get-long argcp) (length command-line-strings)
		  (%get-ptr argvp) argv)
	    (#_glutInit argcp argvp)))
	(setf glut-initialized-p t))))
  ;; When a saved image is restarted, it needs to know that glut
  ;; hasn't been initialized yet.
  (defun uninitialize-glut ()
    (setf glut-initialized-p nil))
  )

(pushnew #'uninitialize-glut ccl::*save-exit-functions*
	 :key #'ccl::function-name)

(defparameter *matrix-mode* #$GL_MODELVIEW)
(defmacro with-matrix-mode (mode &body body)
  `(unwind-protect
       (let ((*matrix-mode* ,mode))
	 (#_glMatrixMode *matrix-mode*)
	 ,@body)
     (#_glMatrixMode *matrix-mode*)))

(in-package :drawpixel)


(defmacro for ((var start stop) &body body)
  (let ((gstop (gensym)))
    `(do ((,var ,start (1+ ,var))
	  (,gstop ,stop))
	 ((> ,var ,gstop))
	 ,@body)))

(defconstant *check-image-width* 10)
(defconstant *check-image-height* 10)
(defparameter *check-image*
   (make-array (list *check-image-height* *check-image-width* 3)
              :element-type '(unsigned-byte 8)))


(defun copy-unsigned-byte-array-to-foreign-memory (array pointer)
  (dotimes (i (array-total-size array))
    (setf (%get-unsigned-byte pointer i)
          (row-major-aref array i))))


(defun make-check-image ()
  (for (i 0 (- *check-image-width* 1))
       (for (j 0 (- *check-image-height* 1))
	    (for (k 0 2)
		 (setf (aref *check-image* i j k) 255)))))
 

(defun setup-rc ()
  (#_glClearColor 0.0 0.0 0.0 0.0)
  (make-check-image)
  (#_glPixelStorei #$GL_UNPACK_ALIGNMENT 1)
  (#_glClear #$GL_COLOR_BUFFER_BIT))


(ccl::defcallback render-scene (:void)
		  (%stack-block ((ap (array-total-size *check-image*)))
				    (copy-unsigned-byte-array-to-foreign-memory *check-image* ap)
				    (for (i 1 100)
					 (#_glRasterPos2i i (* i i))
					 (#_glDrawPixels *check-image-width* 
							 *check-image-height* 
							 #$GL_RGB 
							 #$GL_UNSIGNED_BYTE 
							 ap)))  
				    (#_glFlush))



(defun main () ; no int argc or char **argv
  (opengl:initialize-glut)
  (#_glutInitDisplayMode (logior #$GLUT_RGB
				 #$GLUT_SINGLE
				 #+ignore #$GLUT_DEPTH))
  (#_glutInitWindowSize 800 600)
  (#_glutInitWindowPosition 100 100)
  (ccl::with-cstrs ((title "Bounce"))
		   (#_glutCreateWindow title))
  (setup-rc)
  (#_glutDisplayFunc render-scene)
  
; It appears that glut provides no mechanism for doing the event loop
; yourself -- if you want to do that, you should use some other set of
; libraries and make your own GUI toolkit.
  
  (#_glutMainLoop) ; this never returns and interferes w/scheduling
 
 )


;;; With native threads, #_glutMainLoop doesn't necessarily interfere
;;; with scheduling: we can just run all of the OpenGL code in a separate
;;; thread (which'll probably spend most of its time blocked in GLUT's
;;; event loop.)  On OSX, we need to use an undocumented API or two
;;; to ensure that the thread we're creating is seen as the "main"
;;; event handling thread (that's what the code that sets the current
;;; thread's CFRunLoop to the main CFRunLoop does.)
#+OpenMCL-native-threads
(ccl:process-run-function
 "OpenGL main thread"
 #'(lambda ()
     #+darwinppc-target
     (progn
       ;;; In OSX, a "run loop" is a data structure that
       ;;; describes how event-handling code should block
       ;;; for events, timers, and other event sources.
       ;;; Ensure that this thread has a "current run loop".
       ;;; (Under some circumstances, there may not yet be
       ;;; a "main" run loop; setting the "current" run loop
       ;;; ensures that a main run loop exists.)
       (ccl::external-call "_CFRunLoopGetCurrent" :address)
       ;;; Make the current thread's run loop be the "main" one;
       ;;; only the main run loop can interact with the window
       ;;; server.
       (ccl::external-call
        "__CFRunLoopSetCurrent"
        :address (ccl::external-call "_CFRunLoopGetMain" :address))
       ;;; Set the OSX Window Server's notion of the name of the
       ;;; current process.
       (%stack-block ((psn 8))
         (ccl::external-call "_GetCurrentProcess" :address psn)
         (with-cstrs ((name "simple OpenGL example"))
           (ccl::external-call "_CPSSetProcessName" :address psn :address name))))
     (main)))

; (main)