(in-package :cube-modeller)

;;; (defparameter *perspective-specification* '(45d0 1d0 0.5d0 10d0))
(defparameter *perspective-specification* '(35d0 1d0 0.5d0 10d0))
(defparameter *unrotated-eye-coordinates* '(0d0 0d0 2.5488036409264643d0))

(defparameter *spin* 0d0)
(defparameter *move-x* 0d0)
(defparameter *move-z* 0d0)
(defparameter *x-old* 0f0)
(defparameter *y-old* 0f0)
(defparameter *alpha-default* -8f0)
(defparameter *beta-default* 15.691265)
(defparameter *alpha* *alpha-default*)
(defparameter *beta* *beta-default*)
(defparameter *rotate-mode* nil)

(defparameter *width* nil)
(defparameter *height* nil)

(defparameter *dark-mode* t)

;;; LEDs
(defparameter *LED-diameter* .04d0)
(defparameter *LED-distance* .20f0)

(defvar *modeller-window-shown* nil)

(defun init-gl ()
  (gl:clear-color 0f0 0f0 0f0 0f0)
  (gl:matrix-mode gl:+projection+)
  (gl:load-identity)
  ;; (gl:ortho -1d0 1d0 -1d0 1d0 0d0 10d0)
  (apply #'glu:perspective *perspective-specification*)
  
  (gl:enable gl:+depth-test+)
  (gl:enable gl:+lighting+)
  (gl:enable gl:+light0+)
  (gl:disable gl:+light1+)

  (gl:Enable GL:+BLEND+)
  (gl:blend-func gl:+src-alpha+ gl:+one-minus-src-alpha+)

  ;; smooth-lines for the coordinate system
  ;; (For a strange reason it does not work. -> disabled)
;;  (gl:enable gl:+line-smooth+)
;;  (gl:hint gl:+line-smooth-hint+ GL:+dont-care+)
;;  (gl:line-width 1.0)


  (gl:enable GL:+cull-face+) ;; only draw front sides of spheres (and everything else)
  )

(defun draw-sphere (size)
  (glu:with-quadric (sphere)
    (glu:quadric-draw-style sphere glu:+fill+)
    (glu:quadric-normals sphere glu:+smooth+)
    (glu:sphere sphere size 16 8)))

(defun draw-coordinate-system ()
  (gl:push-matrix)
  ;; (gl:translate-f .5f0 -.5f0 -2f0)
  (gl:translate-f .5f0 -.5f0 -2f0)
  (gl:rotate-f *beta* 1f0 0f0 0f0)
  (gl:rotate-f *alpha* 0f0 1f0 0f0)

  ;; define light source
  (sgum:with-single-float-values (ambient 0.3f0 0.3f0 0.3f0 1f0)
    (gl:light-fv gl:+light1+ gl:+ambient+ ambient))
  (sgum:with-single-float-values (diffuse 0.9f0 0.9f0 0.9f0 0f0)
    (gl:light-fv gl:+light1+ gl:+diffuse+ diffuse))
  (sgum:with-single-float-values (specular 1f0 1f0 1f0 1f0)
    (gl:light-fv gl:+light1+ gl:+specular+ specular))
  (sgum:with-single-float-values (position 0f0 10f0 0f0 1f0)
    (gl:light-fv gl:+light1+ gl:+position+ position))
  
  (gl:normal-3f 0f0 1f0 0f0)
  
  (gl:enable gl:+light1+)
  (gl:disable gl:+light0+)

  ;; (gl:scale-d .1d0 .1d0 .1d0)
  ;; (gl:disable gl:+depth-test+)

  (sgum:with-single-float-values (diffuse .9f0 0f0 0f0 1f0)
    (gl:material-fv gl:+front+ gl:+diffuse+ diffuse))

  (gl:begin gl:+lines+)
  (gl:vertex-3f 0f0 0f0 0f0)
  (gl:vertex-3f -.1f0 0f0 0f0)
  (gl:vertex-3f -.1f0 0f0 0f0)
  (gl:vertex-3f -.08f0 .01f0 -0.01f0)
  (gl:vertex-3f -.1f0 0f0 0f0)
  (gl:vertex-3f -.08f0 -.01f0 .01f0)
  (gl:vertex-3f -.1f0 0f0 0f0)
  (gl:end)

  ;; (sgum:with-single-float-values (diffuse 0f0 .9f0 0f0 1f0)
  ;;   (gl:material-fv gl:+front+ gl:+diffuse+ diffuse))
  (gl:color-material gl:+front+ gl:+diffuse+)
  (gl:enable gl:+color-material+)

  (gl:color-4f 0f0 .9f0 0f0 1f0)
  (gl:begin gl:+lines+)
  (gl:vertex-3f 0f0 0f0 0f0)
  (gl:vertex-3f 0f0 .1f0 0f0)
  (gl:vertex-3f 0f0 .1f0 0f0)
  (gl:vertex-3f -.01f0 .08f0 -.01f0)
  (gl:vertex-3f 0f0 .1f0 0f0)
  (gl:vertex-3f .01f0 .08f0 .01f0)
  (gl:end)
  
  ;; (sgum:with-single-float-values (diffuse 0f0 0f0 .9f0 1f0)
  ;;   (gl:material-fv gl:+front+ gl:+diffuse+ diffuse))
  (gl:color-4f 0f0 .0f0 9f0 1f0)
  (gl:begin gl:+lines+)  
  (gl:vertex-3f 0f0 0f0 0f0)
  (gl:vertex-3f 0f0 0f0 -.1f0)
  (gl:vertex-3f 0f0 0f0 -.1f0)
  (gl:vertex-3f -.01f0 -.01f0 -.08f0)
  (gl:vertex-3f 0f0 0f0 -.1f0)
  (gl:vertex-3f .01f0 .01f0 -.08f0)
  (gl:end)
  (gl:disable gl:+color-material+)
  
  ;; (gl:enable gl:+depth-test+)
  
  (gl:disable gl:+light1+)
  (gl:enable gl:+light0+)

  (gl:pop-matrix))

(defun degree-to-radian (degree)
  (/ (* degree pi)
     180))

(defun rotate-coordinates (x y z)
  "rotates given coordinates with two rotation matrices:
    - first in x directoin with angle beta,
    - then in y direction with angle alpha"
  (let ((alpha (- (degree-to-radian *alpha*)))
        (beta (- (degree-to-radian *beta*))))

    (list  (+ (* (cos alpha) x)
              (* (sin alpha)
                 (+ (* (sin beta) y)
                    (* (cos beta) z))))
           (- (* (cos beta) y)
              (* (sin beta) z))
           (+ (* (- (sin alpha)) x)
              (* (cos alpha)
                 (+ (* (sin beta) y)
                    (* (cos beta) z)))))))


(defun display-scene ()
  (gl:clear (logior gl:+color-buffer-bit+
		    gl:+depth-buffer-bit+))

  (if *dark-mode*
      (gl:clear-color 0f0 0f0 0f0 0f0)
      (gl:clear-color 1f0 1f0 1f0 0f0))
  (gl:matrix-mode gl:+modelview+)
  (gl:load-identity)

  ;; define light source
  (sgum:with-single-float-values (ambient 0.3f0 0.3f0 0.3f0 1f0)
    (gl:light-fv gl:+light0+ gl:+ambient+ ambient))
  (sgum:with-single-float-values (diffuse 0.9f0 0.9f0 0.9f0 0f0)
    (gl:light-fv gl:+light0+ gl:+diffuse+ diffuse))
  (sgum:with-single-float-values (specular 1f0 1f0 1f0 1f0)
    (gl:light-fv gl:+light0+ gl:+specular+ specular))
  (sgum:with-single-float-values (position 1f0 1f0 1f0 1f0)
    (gl:light-fv gl:+light0+ gl:+position+ position))

  ;; define LED material
  (sgum:with-single-float-values (emission 0f0 0f0 0f0 0f0)
    (gl:material-fv gl:+front+ gl:+emission+ emission))
  (if *dark-mode*
      (progn
        (sgum:with-single-float-values (ambient 0.5f0 0f0 0f0 1f0)
          (gl:material-fv gl:+front+ gl:+ambient+ ambient))
          (sgum:with-single-float-values (specular 0.15f0 0f0 0f0 1f0)
            (gl:material-fv gl:+front+ gl:+specular+ specular)))
      (progn
        (sgum:with-single-float-values (ambient 0.2f0 0.2f0 0.2f0 1f0)
          (gl:material-fv gl:+front+ gl:+ambient+ ambient))
        (sgum:with-single-float-values (specular 0.15f0 0.15f0 0.15f0 1f0)
          (gl:material-fv gl:+front+ gl:+specular+ specular))))
  (sgum:with-single-float-values (shininess 15f0)
    (gl:material-fv gl:+front+ gl:+shininess+ shininess))
  
  (draw-coordinate-system)

  ;; alternative code to the manual matrix rotation..
;;     (glu:look-at 0d0 0d0 2.5488036409264643d0 0d0 0d0 0d0 0d0 1d0 0d0)
;;     (gl:rotate-f *beta* 1f0 0f0 0f0)
;;     (gl:rotate-f *alpha* 0f0 1f0 0f0)
;;     (gl:normal-3f 0f0 1f0 0f0)

  (destructuring-bind ((eye-x eye-y eye-z)
                       (up-x  up-y  up-z))
      (list (apply #'rotate-coordinates *unrotated-eye-coordinates*)
            (rotate-coordinates 0d0 1d0 0d0))

    (glu:look-at eye-x eye-y eye-z
                 0d0 0d0 0d0
                 up-x up-y up-z)
    (gl:normal-3d up-x up-y up-z)


    ;; Oben-Kugel
;;;     (gl:push-matrix)
;;;       (sgum:with-single-float-values (diffuse 0f0 0.5f0 0f0 1f0)
;;;         (gl:material-fv gl:+front+ gl:+diffuse+ diffuse))
;;;       (gl:translate-f 0f0 (* 3 *LED-distance*) 0f0)
;;;       (draw-sphere (/ *LED-DIAMETER* 2))
;;;     (gl:pop-matrix)
  
    ;; LEDs
    
    (gl:push-matrix)
    (let ((origin (* -2 *LED-distance*)))
      (gl:translate-f (- origin) origin (- origin)))
    
    (draw-leds (make-fakecube :origin '(0 0 0) :size '(5 5 5))
               (mapcar #'- (OpenGL->cube eye-x eye-y eye-z))
               :draw-led #'draw-led)
    (gl:pop-matrix))

  (sdl:gl-swap-buffers))

(defun get-number-of-picked-LED (mouse-x mouse-y)
  ;; see http://wiki.delphigl.com/index.php/gluUnProject
  (display-scene)
  (gl:flush)
  
  (let ((modelview (sgum:allocate-foreign-object 'gl:double 16))
        (projection (sgum:allocate-foreign-object 'gl:double 16))
        (viewport (sgum:allocate-foreign-object 'gl:int 4))
        
        (viewport-x mouse-x)
        (viewport-y (- *height* mouse-y))
        (viewport-z* (sgum:allocate-foreign-object 'gl:float))
        
        (x* (sgum:allocate-foreign-object 'gl:double))
        (y* (sgum:allocate-foreign-object 'gl:double))
        (z* (sgum:allocate-foreign-object 'gl:double))
        viewport-z x y z)

    (gl:get-doublev gl:+modelview-matrix+ modelview)
    (gl:get-doublev gl:+projection-matrix+ projection)
    (gl:get-integerv gl:+viewport+ viewport)

    ;; print modelview matrix
;;     (dotimes (i 16)
;;       (format *trace-output* "~a " (sgum:deref-array modelview '(:array gl:double) i)))
;;     (terpri *trace-output*)
    
    (gl:read-pixels viewport-x viewport-y 1 1 gl:+depth-component+ gl:+float+ viewport-z*)
    (setf viewport-z (coerce (sgum:deref-pointer viewport-z* 'float) 'double-float))

    (glu:un-project (coerce viewport-x 'double-float) (coerce viewport-y 'double-float) viewport-z
                     modelview projection viewport
                     x* y* z*)
     (setf x (sgum:deref-pointer x* 'double-float)
           y (sgum:deref-pointer y* 'double-float)
           z (sgum:deref-pointer z* 'double-float))

     (if (= viewport-z 1d0) ;; clicked on background?
         nil ;; (format *trace-output* "no led~%")
         (progn
           (flet ((normalize-coordinate (value)
                    (round (/ value *led-distance*)))
                  (2+ (number)
                    (declare (type fixnum number))
                    (+ number 2)))
             (setf x (normalize-coordinate x)
                   y (normalize-coordinate y)
                   z (normalize-coordinate z))
           (destructuring-bind (led-x led-y led-z)
               (mapcar #'2+ ;; In pick-coordinates the middle LED is (0 0 0), therefore we have to add 2.
                       (opengl->cube x y z))
             ;; (format *trace-output* "viewport-z: ~a, pos: ~a ~a ~a, OpenGL pos: ~a ~a ~a~%" viewport-z led-x led-y led-z x y z)
             (values led-x led-y led-z)))))))

(defun process-mouse-motion (x y)
  (when *rotate-mode*
    (incf *beta* (* 0.2f0
		    (- y *y-old*)))
    (incf *alpha* (* 0.2f0
		     (- x *x-old*)))
    (setf *x-old* x
	  *y-old* y)))
  
(defun process-mouse-button-event (button state x y)
  (setf *x-old* x
	*y-old* y
	*rotate-mode* (and (eq state :down)
			   (eq button :right)))
  (when (and (eq state :down)
	     (eq button :left))
    (multiple-value-bind (x y z)
        (get-number-of-picked-LED x y)
      (when x
        (set-LED x y z)
        (write-cube-to-device)))))

(defun handle-keypress (key)
  #+(or) ;; The new animation-lock should prevent lock-ups between animation playing
         ;; and animation/frame deletion. The rest is not necessary, and I don't like
         ;; this behaviour anymore. (mgr, 20061010)
  (if (member key ;; Why stop at all? (mgr, 20060102)
              (list 273 274 275 276 (char-code #\s) (char-code #\x)
                    (char-code #\a) (char-code #\b)
                    (char-code #\e) (char-code #\f) (char-code #\d) (char-code #\n)))
        (stop-animation))

  (cond
    ;; move the states of the LEDs within the current cube
    ((eql 273 key) ; up arrow
     (move-forward))
    ((eql 274 key) ; down arrow
     (move-backward))
    ((eql 276 key) ; left arrow
     (move-left))
    ((eql 275 key) ; right arrow
     (move-right))
    ((eql (char-code #\s) key) ; s
     (move-up))
    ((eql (char-code #\x) key) ; x
     (move-down))
    
    ;; change *current-intensity*
    ((and (<= key (char-code #\5))
          (>= key (char-code #\0)))
     (set-current-intensity (code-char key)))
    
    ;; switch to previous/next cube
    ((eql 280 key) ;; page-up
     (goto-cube :next))
    ((eql 281 key) ;; page-down
     (goto-cube :previous))
    ((eql 278 key) ;; home
     (goto-cube :first))
    ((eql 279 key) ;; end
     (goto-cube :last))
    
    ;; insert a copy of the current-cube after or before it
    ((eql (char-code #\a) key)
     (insert-cube-copy))
    ((eql (char-code #\b) key)
     (insert-cube-copy :position :before))
    
    ;; fill the current-cube
    ((eql (char-code #\f) key)
     (fill-cube))

    ;; empty the current-cube
    ((eql (char-code #\e) key)
     (empty-cube))
    
    ;; delete the current-cube
    ((eql (char-code #\d) key)
     (delete-cube))
          
    ;; delete the whole animation -> make a _n_ew one
    ((eql (char-code #\n) key)
     (delete-animation))
          
    ;; reset perspective
    ((eql (char-code #\r) key)
     (reset-perspective))

    ;; start/stop animation (toggle status)
    ((eql (char-code #\p) key)
     (toggle-animation-running-state))

    ((eql (char-code #\u) key)
     (undo))

;;     ((eql (char-code #\k) key)
;;      (incf *number-of-displayed-leds*)
;;      (when (> *number-of-leds* 125)
;;        (setf *number-of-leds* 0)))

;;; old animation code	    
;;;      (let ((old-current-cube-number *current-cube-number*))
;;; ;	(do () (nil)
;;; ;       (dotimes (n 100)
;;; 	  (dotimes (i (length *animation*))
;;; 	    (setf *current-cube-number* i)
;;; 	    (display-scene)
;;; 	    (write-cube-to-device)
;;; 	    (sleep-for-delay)))
;;; 	(setf *current-cube-number* old-current-cube-number)
;;; 	(write-cube-to-device)))

    (t
     (format t "~&Unbound key code: ~a (~a)~%" key (sdl:get-key-name key)))))


;; calculate and display frames per second rate

(defvar *print-frames-per-second-p* nil
  "boolean variable that says whether the fps rate should be calculated and printed, or not")

(let ((fps-calculation-start-time 0) ;; variable for the fps calculation
      (interval-frame-counter 0))    ;; counter for the frames of the current interval

  (defun calculate-and-print-frames-per-second ()
    (let* ((now (sdl:get-ticks))
           (time-delta (- now fps-calculation-start-time)))
      (when (< 1000 time-delta);; count frames in intervals of 1 sec (= 1000 ms)
        (unless(< 1500 time-delta) ;; screwed-up  (restart of the viewer, probably)
          (let ((frames-per-second (/ interval-frame-counter
                                      (/ time-delta 1000))))
            (format *trace-output* "~5,1f frames per second~%" frames-per-second)))
          
        (setf fps-calculation-start-time now
              interval-frame-counter 0))
      (incf interval-frame-counter))))


(let ((first-start-up t))
  (defun run-sdl-event-loop ()
  (sdl:event-loop
      (:key-down (key)
	      (if (= key (char-code #\q))
		  (return)
		  (handle-keypress key)))
    (:mouse-button-up (button x y)
                      ;; (format t "Mouse button up: ~A (~A, ~A)~%" button x y)
                      (process-mouse-button-event button :up x y))
    (:mouse-button-down (button x y)
                        ;; (format t "Mouse button dn: ~A (~A, ~A)~%" button x y)
                        (process-mouse-button-event button :down x y))
    (:mouse-motion  (x y xrel yrel state)
                    (declare (ignore xrel yrel state))
                    (process-mouse-motion x y))
    (:quit ()
           (return))
    (:resize (width height)
	    (format t "Resized width = ~A height = ~A~%" width height)
	    (init-sdl-with-gl :width width :height height
                              :show-info nil))
    (:idle ()
           (when *print-frames-per-second-p*
             (calculate-and-print-frames-per-second))
           (unless (find-process-with-name "cube-modeller toolbox")
             (return))
           (animation-step)
           (sleep-for-delay)
           (display-scene)
           (when first-start-up ;; sleep on first run for a faster toolbox start
             (sleep 1)
             (setf first-start-up nil))))))

(defun start-viewer (&key new-process
                     (process-name "cube-modeller viewer"))
  (flet ((viewer ()
  (if *modeller-window-shown*
      (format t "start-viewer: The cube modeller OpenGL window is already been displayed.~%              Just returning without doing anything more.~%")
      (unwind-protect
	   (progn
	     (setf *modeller-window-shown* t)
	     
	     (init-sdl-with-gl :show-info nil)

	     ;; ??  (gl:depth-func gl:+lequal+)
	     (init-gl)
             ;; (goto-cube :first)
	     ;; (write-cube-to-device)
             (create-led-display-lists)
             (run-sdl-event-loop))
	(progn
          (destroy-led-display-lists)
	  (sdl:quit)
          (close-cube-device)
	  (setf *modeller-window-shown* nil))))))
    (if new-process
        (make-process #'viewer :name process-name)
        (viewer))))

(defun init-sdl-with-gl (&key (width 700) (height 700) (bpp 16) (show-info t)
			 (video-flags (logior sdl:+opengl+ sdl:+resizable+ sdl:+gl-doublebuffer+));; sdl:+hwpalette+))
			 )
  (setf *width* width
	*height* height)
  (sdl:init sdl:+init-video+)
  (sdl:set-gl-attributes :red-size 4 :blue-size 4 :green-size 4
			 :doublebuffer 1 :depth-size 16)
  (sdl:gl-set-attribute sdl:+gl-doublebuffer+ 1)

  (let ((surface (sdl:set-video-mode width height bpp video-flags)))

    (when show-info

      (format t "OpenGL Information~%------------------~%Vendor:     ~A~%Version:    ~A~%Renderer:   ~A~%Extensions: ~A~%"
	      (gl:get-string gl:+vendor+)
	      (gl:get-string gl:+renderer+)
	      (gl:get-string gl:+version+)
	      (gl:get-string gl:+extensions+))
      (format t "~%")

      (format t "GL Rendering Context Bit Depths Obtained:~%")
      (multiple-value-bind (s r) (sdl:gl-get-attribute sdl:+gl-red-size+)
	(format t "- RED:   ~A ~A~%" s r))
      (multiple-value-bind (s g) (sdl:gl-get-attribute sdl:+gl-green-size+)
	(format t "- GREEN: ~A ~A~%" s g))
      (multiple-value-bind (s b) (sdl:gl-get-attribute sdl:+gl-blue-size+)
	(format t "- BLUE:  ~A ~A~%" s b))
      (multiple-value-bind (s d) (sdl:gl-get-attribute sdl:+gl-doublebuffer+)
	(format t "- DOUBLEBUFFER: ~A ~A~%" s (if d 'yes 'no)))
      (force-output))

    (sdl:wm-set-caption "LED cube modeller" nil)
    (gl:viewport 0 0 width height)
    ;; (gl:frustum (/ -640.0d0 480.0d0) (/ 640.0d0 480.0d0)
    ;;             1.0d0 -1.0d0 0.0d0 20.0d0)
    surface))