;;;/* 
;;;    null.c
;;;    Nate Robins  1997
;;;
;;;    An example of using null bitmaps to place the rasterpos at
;;;    positions that may be clipped.
;;;
;;; */

(in-package :common-lisp-user)

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

(in-package :null)

(defvar *window* nil)

(defparameter image (make-array (* 256 256 3) :element-type 'unsigned-byte))

(defparameter bitmap (make-array 1 :element-type 'unsigned-byte :initial-element 1))

(defparameter raster_x 32.0)
(defparameter raster_y 32.0)
(defparameter old_raster_x 0.0)
(defparameter old_raster_y 0.0)


(def-callback reshape (void (width int) (height int))
  (glViewport 0  0  width  height)
  (glMatrixMode GL_PROJECTION)
  (glLoadIdentity)
  (glOrtho 0d0  (coerce width 'double-float)  0d0  (coerce height 'double-float)  -1d0  1d0)
  (glMatrixMode GL_MODELVIEW)
  (glLoadIdentity))



(def-callback display (void)
  (glClear GL_COLOR_BUFFER_BIT)

  (glRasterPos2i 0  0)
  (glBitmap 0  0  0.0  0.0  raster_x  raster_y bitmap)
  (glDrawPixels 256  256  GL_RGB  GL_UNSIGNED_BYTE image)

  (glutSwapBuffers))



(def-callback mouse (void (button int) (state int) (x int) (y int))
  (declare (ignorable button state x y))
  (let ((y (- (glutGet GLUT_WINDOW_HEIGHT) y)))
    (setq old_raster_x (- x raster_x)
	  old_raster_y (- y raster_y))))


(def-callback motion (void (x int) (y int))
  (let ((y (- (glutGet GLUT_WINDOW_HEIGHT) y)))
    (setq raster_x (- x old_raster_x)
	  raster_y (- y old_raster_y))
    (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-null nil))))



(defun start ()
  (glutInitDisplayMode (+ GLUT_DOUBLE GLUT_RGBA))
  (glutInitWindowPosition 50  50)
  (glutInitWindowSize 320  320)
  ;;(glutInit 0 "")

  (setq *window* (glutCreateWindow "null"))
  (glutKeyboardFunc (callback keyboard))
  (glutDisplayFunc (callback display))
  (glutReshapeFunc (callback reshape))
  (glutMotionFunc (callback motion))
  (glutMouseFunc (callback mouse))

  (dotimes (i 256)
    (dotimes (j 256)
      (setf (aref image (+ (* (+ (* 256 j) i) 3) 0)) (floor (- 255 (* i j 1/255))))
      (setf (aref image (+ (* (+ (* 256 j) i) 3) 1)) i)
      (setf (aref image (+ (* (+ (* 256 j) i) 3) 2)) j)))
  (setf image (convert-array-to-pointer 'unsigned-byte image))
  (setf bitmap (convert-array-to-pointer 'unsigned-byte bitmap))

  (catch :exit-null
    (glutMainLoop))

  (ignore-errors (glutMainLoopEvent))
  (format t "Done~%"))