;;; -*- mode: lisp; syntax: common-lisp; package: existenz-client; coding: utf-8-unix; -*-

(in-package #:existenz-client)

;;; ideas
;;; - bridge between blender and engine, in addition to inotify-watching.
;;;   this will be best possible with some ready to run rpc framework,
;;    i.e. xmlrpc.server.SimpleXMLRPCServer
;;;   source files if no bridge is available
;;; - interaction with windows messaging, i.e. enable powermenu
;;; - config.lisp loading a la emacs
;;; - ensure conversion to CL-TUPLES::FAST-FLOAT on system boundaries,
;;;   also add normalization and test for divergence on low optimization
;;;   levels to *every* operation
;;; - be sure about the coordinate systems, i.e. 2d+gui/3d
;;; - how to do networking (iolib? or some other plain library?), sound
;;;   (openal)?
;;; - serialization? cl-store or something else?
;;; - FINALIZE as per its description, i.e. register closures to directly
;;;   deallocate the nested resources.  since this may occur in any thread,
;;;   unloading of textures needs to be pushed to the main/opengl thread -
;;;   the same goes for other values (openal?) similarly.  it may be
;;;   possible to still retain often used resources in a separate cache,
;;;   but that's just icing then.  better make a state-chart for all this
;;;   behaviour, i.e. when is a resource (successfully) loaded, what
;;;   happens at what stage
;;; - replace missing resources with placeholders, which may still be
;;;   corrected, i.e. by saving a file to the wanted name, or correcting
;;;   an invalid file
;;; - resource lookup by what?  filesystem like?  how are different
;;;   authors sufficiently discriminated against?

;;; future future ideas
;;; - bytecode vm for scripting?  targeted to mathematics, i.e. full
;;;   regular tower + vectors + matrixes + quaternions, which then may be
;;;   optimized somehow

;;; every object in the world is in the scene tree and in the spatial
;;; trees.  if an object is removed, it is removed from all trees.  if
;;; an object moves, it has to be reinserted in some of the spatial trees,
;;; also if it changes its scale, rotation and furthermore its actual
;;; geometry

;; nice, but doesn't work with eldoc, so it's kinda useless
#+(or)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defmacro package-calls (package &body body)
    (setf package (find-package package))
    `(progn
       ,.(mapcar (lambda (form)
                   (let (car found)
                     (if (and (listp form)
                              (setf car (car form))
                              (symbolp car)
                              (setf found (find-symbol
                                           (symbol-name car)
                                           package)))
                         `(,found ,.(cdr form))
                         form)))
                 body)))

  (defmacro gl (&body body)
    `(package-calls #.(find-package '#:gl) ,@body)))

(defvar *window-width*)
(defvar *window-height*)
(defvar *window-fullscreen*)

(push '(window-resolution . (640 480)) *options*)
(push '(window-fullscreen . (NIL)) *options*)

(push '(window-resolution *window-width* *window-height*) *options-mappings*)
(push '(window-fullscreen *window-fullscreen*) *options-mappings*)

;;; message passing to the client main thread

(defvar *client*)
(defvar *messages*)

(defun send-to-client (object)
  (cond
    ((not (boundp '*client*))
     (warn "*CLIENT* is unbound"))
    ((not *client*)
     (warn "*CLIENT* has no value"))
    ((not (thread-alive-p *client*))
     (warn "*CLIENT* isn't running"))
    (T
     (prog1 T (enqueue *messages* object)))))

(defmacro run-in-client (&body body)
  `(send-to-client (lambda () ,@body)))

(defun handle-message (message)
  (etypecase message
    (function
     (handler-case (funcall message)
       (error (error)
         (warn "ERROR occured while executing ~A: ~A" message error))))))

(defun handle-messages (locked-deque)
  (let ((messages (dequeue-all locked-deque)))
    (mapc #'handle-message messages)))

;;; resources

(defvar *resources* (make-hash-table :test 'eq))

(defgeneric unload-resource (resource)
  (:documentation "Explicitely deallocate the RESOURCE and disable the
finalizer (see MAKE-RESOURCE-FINALIZER)."))
(defgeneric make-resource-finalizer (resource)
  (:documentation "Returns a FUNCTION, which takes care of cleaning up
resources in the correct threads when the RESOURCE is gc'ed.  Note the
rules for FINALIZE apply, i.e. the closure may not reference the RESOURCE
object, or it won't ever be collected."))
(defgeneric load-resource (resource))
(defgeneric resource-loaded-p (resource)
  (:documentation "A resource may fail to load, but by using placeholder
values, it can still be used.  Of course, this only works for some objects,
e.g. textures."))

(defun map-resources (function)
  (maphash
   (lambda (name resource)
     (declare (ignore name))
     (funcall function resource))
   *resources*))

(defun load-all-resources (&optional force)
  (map-resources
   (lambda (resource)
     (when (or (not (resource-loaded-p resource)) force)
       (load-resource resource)))))

(defun unload-all-resources ()
  (map-resources #'unload-resource))

(defmacro with-all-resources (&body body)
  `(unwind-protect
        (progn
          ,@body)
     (unload-all-resources)))

(defun get-resource (name)
  (gethash name *resources*))

(defun %delete-resource (name)
  (awhen (get-resource name)
    (unload-resource it)
    (remhash name *resources*)))

(defun %add-resource (name new)
  (symbol-macrolet ((resource (gethash name *resources*)))
    (let ((old resource))
      (when old
        (unload-resource old)
        (load-resource new))
      (setf resource new))))

(defun add-resource (name new)
  "Adds the NEW resource.  For the moment all resources are loaded in the
main thread."
  ;; TODO: wait for client to execute it, then return the object
  (unless (run-in-client (%add-resource name new))
    (setf (gethash name *resources*) new))
  new)

(defun delete-resource (name)
  (unless (run-in-client (%delete-resource name))
    (remhash name *resources*)))

(define-condition undefined-resource (error)
  ((resource-name :initarg :resource-name :reader resource-name))
  (:report
   (lambda (condition stream)
     (format stream "Undefined RESOURCE ~A requested."
             (resource-name condition)))))

(defun resource (name)
  (let ((resource (get-resource name)))
    (unless resource
      (error 'undefined-resource :resource-name name))
    resource))

(defclass resource ()
  ((name :type symbol :initarg :name)))

(defmethod unload-resource :around (resource)
  (when (resource-loaded-p resource)
    (call-next-method)))

(defmethod load-resource :before (resource)
  (when (resource-loaded-p resource)
    (unload-resource resource)))

(defmethod load-resource :after (resource)
  (format-log "loaded resource ~A" resource))

(defmethod unload-resource :after (resource)
  (format-log "unloaded resource ~A" resource))

(defun ensure-resource (resource)
  (unless (resource-loaded-p resource)
    (load-resource resource)))

(defmethod print-object ((resource resource) stream)
  (if *print-readably*
      (prin1 (make-load-form resource) stream)
      (print-unreadable-object (resource stream :type T :identity T)
        (with-slots (name) resource
          (format stream "~A ~A"
                  name (if (resource-loaded-p resource)
                           'loaded 'unloaded))))))

(defclass pathname-mixin ()
  ((pathname :initarg :pathname)))

;;; fonts

#+(or)
(deftype font-mode ()
  `(member :textured :polygon))

#+(or)
(defvar *default-font-mode* :textured)

#+(or)
(defclass font (pathname-mixin resource)
  ((ftgl-object :initform NIL)
   (mode :initarg :mode)))

#+(or)
(defun make-font (name pathname &key (mode *default-font-mode*))
  (check-type mode font-mode)
  (make-instance 'font :name name :pathname pathname :mode mode))

#+(or)
(defmethod unload-resource ((font font))
  (with-slots (ftgl-object) font
    (let ((object ftgl-object))
      (setf ftgl-object NIL)
      (cancel-finalization object)
      (ftgl:destroy-font object))))

#+(or)
(defmethod load-resource ((font font))
  (with-slots (pathname ftgl-object mode) font
    (let ((object (funcall (case mode
                             (:textured #'ftgl:create-texture-font)
                             (:polygon #'ftgl:create-polygon-font))
                           pathname)))
      (finalize object #'ftgl:destroy-font)
      (setf ftgl-object object)
      (ftgl:set-font-face-size object 36 90)
      (ftgl:set-font-char-map object :unicode))))

#+(or)
(defmethod resource-loaded-p ((font font))
  (and (slot-value font 'ftgl-object) T))

#+(or)
(defmacro add-font (name pathname &key (mode NIL modep))
  `(add-resource
    ',name
    (make-font ',name ,pathname ,@(when modep (list :mode mode)))))

#+(or)
(defmethod make-load-form ((font font) &optional environment)
  (declare (ignore environment))
  (with-slots (name pathname mode) font
    `(add-font ,name ,pathname ,mode)))

;;; images

(defclass image (pathname-mixin resource)
  ((sdl-object :initform NIL)))

(defun make-image (name pathname)
  (make-instance 'image :name name :pathname pathname))

;; TODO: um, is the free necessary?
(defmethod unload-resource ((image image))
  (with-slots (sdl-object) image
    (sdl:free (shiftf sdl-object NIL))))

;; TODO: and then, is this necessary?  specific thread?
(defmethod make-resource-finalizer ((image image))
  (with-slots (sdl-object) image
    (lambda ()
      (sdl:free sdl-object))))

(defmethod load-resource ((image image))
  (with-slots (pathname sdl-object) image
    (setf sdl-object (sdl:load-image pathname))))

(defmethod resource-loaded-p ((image image))
  (and (slot-value image 'sdl-object) T))

(defmacro add-image (name pathname)
  `(add-resource ',name (make-image ',name ,pathname)))

(defmethod make-load-form ((image image) &optional environment)
  (declare (ignore environment))
  (with-slots (name pathname) image
    `(add-image ,name ,pathname)))

;;; shaders

;;; multiple shaders are linked into a program, but they can already be
;;; compiled beforehand

;; (defclass shader (pathname-mixin resource)
;;   ((shader-object :initform NIL)))

;; (defun make-shader (name pathname)
;;   (make-instance 'shader :name name :pathname pathname))

;; (defmethod unload-resource ((shader shader))
;;   (with-slots (shader-object

;;; reloading resources on change

;;; entities

;;; distinction between stripped geometry (allocated in not gc'ed memory)
;;; and lisp-managed geometry

(defun make-static-geometry (geometry)
  geometry)

(defclass cube ()
  ((dimensions :initarg :dimensions)))

(defgeneric render-object (object))

(defvar *debug-matrix*)

(defmethod render-object ((cube cube))
  (let* ((dimensions (slot-value cube 'dimensions))
         (w (aref dimensions 0))
         (d (aref dimensions 1))
         (h (aref dimensions 2))
         ;; TODO: make static macros for this using some permutation
         ;; algorithm
         )
    (debug-display-matrix :modelview)
    (gl:scale w d h)
    (render-unit-cube)))

;;; materials

;;; video

(defun window-resolution ()
  (values *window-width* *window-height*))

(defun window-fullscreen ()
  *window-fullscreen*)

(defun set-window-resolution (width height)
  (setf *window-width* width
        *window-height* height))

(defun reset-opengl ()
  (multiple-value-bind (width height)
      (window-resolution)
    (gl:viewport 0 0 width height)
    (gl:matrix-mode :projection)
    (gl:load-identity)
    (gl:matrix-mode :modelview)
    (gl:load-identity)
    (gl:clear-color 0.2 0.2 0.2 0)))

(defvar *camera*)

(defun setup-3d ()
  (apply-camera-transformation *camera*))

(defun setup-2d ()
  (multiple-value-bind (width height)
      (window-resolution)
    (gl:matrix-mode :projection)
    (gl:load-identity)
    (gl:ortho 0 width 0 height -1 1)
    (gl:matrix-mode :modelview)))

(defun bbox-size (bbox)
  (values
   (+ (fourth bbox) (max 0 (first bbox)))
   (+ (fifth bbox) (max 0 (second bbox)))))

(defun rectangle (x1 y1 x2 y2)
  (vector x1 y1 x2 y2))

(defmacro with-rectangle ((rect &optional (x1 'x1) (y1 'y1) (x2 'x2) (y2 'y2)) &body body)
  "Destructures the rectangle RECT into the components named by the given
symbols X1 to Y2 for the duration of BODY."
  (let ((rect-sym (gensym))
        (ref 'aref))
    `(let* ((,rect-sym ,rect)
            (,x1 (,ref ,rect-sym 0))
            (,y1 (,ref ,rect-sym 1))
            (,x2 (,ref ,rect-sym 2))
            (,y2 (,ref ,rect-sym 3)))
       ,@body)))

#+(or)
(defun render-aligned-text (font string size rect &key (vertical :left) (horizontal :top) (resolution 75))
  (let ((ftgl (slot-value font 'ftgl-object)))
    (ftgl:set-font-face-size ftgl size resolution)
    (multiple-value-bind (text-width text-height)
        (bbox-size (ftgl:get-font-bbox ftgl string))
      (setf text-width (fceiling text-width)
            text-height (fceiling text-height))
      (gl:with-pushed-matrix
        (with-rectangle (rect)
          (multiple-value-bind (xtrans ytrans)
              (values (ecase vertical
                        (:left x1)
                        (:center (/ (- (- x2 x1) text-width) 2))
                        (:right (- x2 text-width)))
                      (ecase horizontal
                        (:top (- y2 text-height))
                        (:center (/ (- (- y2 y1) text-height) 2))
                        (:bottom y1)))
            (gl:translate xtrans ytrans 0)))
        (ftgl:render-font ftgl string :all))
      (values text-width text-height))))

#+(or)
(defun render-aligned-matrix (font matrix size rect &key (vertical :left) (horizontal :top) (resolution 75))
  (flet ((format-line (matrix offset)
           (format NIL "~8,3F ~8,3F ~8,3F ~8,3F"
                   (aref matrix (+ offset 0))
                   (aref matrix (+ offset 1))
                   (aref matrix (+ offset 2))
                   (aref matrix (+ offset 3)))))
    (let* ((lines (iterate
                    (for i from 0 to 15 by 4)
                    (collect (format-line matrix i))))
           (ftgl (slot-value font 'ftgl-object)))
      (ftgl:set-font-face-size ftgl size resolution)
      (let* ((sizes (mapcar (lambda (line) (multiple-value-list (bbox-size (ftgl:get-font-bbox ftgl line)))) lines))
             (bbox (reduce (lambda (size1 size2) (list (max (first size1) (first size2))
                                                       (+ (second size1) (second size2))))
                           sizes)))
        (gl:with-pushed-matrix
          (with-rectangle (rect)
            (multiple-value-bind (xtrans ytrans)
                (destructuring-bind (text-width text-height) bbox
                  (incf text-height (* 3 3)) ; three gaps, three pixels
                  (values (ecase vertical
                            (:left x1)
                            (:center (/ (- (- x2 x1) text-width) 2))
                            (:right (- x2 text-width)))
                          (ecase horizontal
                            (:top (- y2 text-height))
                            (:center (/ (- (- y2 y1) text-height) 2))
                            (:bottom y1))))
              (gl:translate xtrans ytrans 0)
              (iterate
                (for line in lines)
                (for size in sizes)
                (ftgl:render-font ftgl line :all)
                (gl:translate 0 (+ 3 (second size)) 0)))))))))

(defmacro with-all-pushed-matrixes (&body body)
  `(unwind-protect
        (progn
          (gl:matrix-mode :texture)
          (gl:push-matrix)
          (gl:matrix-mode :projection)
          (gl:push-matrix)
          (gl:matrix-mode :modelview)
          (gl:push-matrix)
          ,@body)
     (gl:matrix-mode :texture)
     (gl:pop-matrix)
     (gl:matrix-mode :projection)
     (gl:pop-matrix)
     (gl:matrix-mode :modelview)
     (gl:pop-matrix)))

(define-condition abort-client () ())
(define-condition restart-inner-client () ())

(defun client ()
  (restart-case
      (sdl:with-init (sdl:sdl-init-video sdl:sdl-init-joystick)
        (loop
          (restart-case (inner-client)
            (restart-inner-client ()
              :report "Restart the INNER-CLIENT while keeping the SDL context alive."
              (format-log "restarting inner client")))))
    (abort-client ()
      :report "Abort CLIENT thread.")))

(defvar *scene-tree*)

(defun run-client (&optional (client #'client))
  (cond
    ((and (boundp '*client*) (thread-alive-p *client*))
     (warn "Client is already running."))
    (T
     (let* ((locked-deque (or (and (boundp '*messages*) *messages*)
                              (make-locked-deque "EXISTENZ-MESSAGES")))
            ;; TODO: maybe include *STANDARD-IO-BINDINGS*?
            (bindings `((*messages* . ,locked-deque)
                        (*package* . #.(find-package '#:existenz-client))
                        (*standard-output* . ,*standard-output*)
                        ;; TODO: include all the other private variables, i.e. *SCENE-TREE*
                        (*scene-tree*)
                        (*debug-matrix*))))
       (setf *messages* locked-deque
             *client* (make-thread client :name "EXISTENZ-CLIENT"
                                          :initial-bindings bindings))))))

(defun abort-client ()
  (run-in-client (invoke-restart 'abort-client))
  (join-thread *client*))

(defun restart-client (&optional (client #'client))
  (abort-client)
  (run-client client))

(defun restart-inner-client ()
  (run-in-client (invoke-restart 'restart-inner-client)))

(defun reset-identity ()
  (run-in-client
    (gl:matrix-mode :modelview)
    (gl:load-identity)))

#+(or)
(progn
  (add-font arial-polygon #P"/usr/share/fonts/corefonts/arial.ttf")
  (add-font proggy-polygon #P"/usr/share/fonts/ProggyTinySZ.ttf")
  (add-image silkscreen-texture #P"~/src/existenz/data/silkscreen.bmp"))

#+(or)
(defun run-client (&optional (host +ipv6-loopback+) (port 4000))
  (with-event-base (event-base)
    (let ((client (make-socket :ipv6 T
                               :type :datagram
                               :remote-host host
                               :remote-port port
                               :reuse-address T)))
      (unwind-protect
           (send-to client #(1 0 0 3))
        (iterate
         (when (wait-until-fd-ready (fd-of client) :input)
           (multiple-value-bind (buffer length host port)
               (receive-from client :size 100)
             (format T "received ~A bytes from ~A:~A~%"
                     length host port))))
        (close client)))))

;;; scene node / entity protocol

;;; individual scene nodes build a logical tree of related objects
;;; one or more spatial trees are independent of them and build orthogonal
;;; hierarchies, which allows ...
(defgeneric parent (object)
  (:documentation "Retrieves the PARENT node of the OBJECT.  This may be
used to traverse the scene tree."))
(defgeneric (setf parent) (new-value object)
  (:documentation "Sets the PARENT node of the OBJECT to NEW-VALUE."))

(defgeneric children (object)
  (:method ((object T)))
  (:documentation "Retrieves the LIST of CHILDREN of the OBJECT.  This may
be used to traverse the scene tree."))
(defgeneric (setf children) (new-value object)
  (:documentation "Sets the CHILDREN of the OBJECT to NEW-VALUE."))

(defgeneric transformation (object)
  (:method ((object T)))
  (:documentation "Retrieves the TRANSFORMATION for OBJECT.  If it has
none, returns NIL instead (default)."))

(defgeneric bounding-box (object)
  (:documentation "Retrieves the axis aligned bounding box around around
the OBJECT.  This one is relative to the object.  See
ABSOLUTE-BOUNDING-BOX for the box transformed into absolute world
coordinates."))
(defgeneric absolute-bounding-box (object)
  (:documentation "Retrieves the axis aligned bounding box in world
coordinates for OBJECT.  See BOUNDING-BOX to get the relative one
instead."))

(defgeneric animators (object)
  (:method ((object T)))
  (:documentation "Retrieves the LIST of ANIMATORS of the OBJECT."))
(defgeneric (setf animators) (new-value object)
  (:documentation "Sets the ANIMATORS of the OBJECT to NEW-VALUE."))

(defvar *delta-real-elapsed* 0
  "Measures real milliseconds since the last UPDATE call.")

(defgeneric update (object)
  (:method ((object T)))
  (:documentation "Updates an OBJECT when some real time has elapsed.
Does nothing by default.  The elapsed real time is measured in
milliseconds and stored in the global variable *DELTA-REAL-ELAPSED*."))

(defgeneric animate (animator object)
  (:method ((animator T) (object T))))

(defgeneric render (object)
  (:method ((object T)))
  (:documentation "Renders an OBJECT to the screen.  Since objects may be
sorted by some external criteria, iteration over child nodes is done
externally, thus by default child nodes aren't rendered and in fact
nothing is done."))

(defclass scene-node-mixin ()
  ((parent
    :initarg :parent
    :accessor parent
    :initform NIL)
   (children
    :initarg :children
    :accessor children
    :initform NIL)
   (transformation
    :initarg :transformation
    :accessor transformation
    :initform (make-transformation))
   (animators
    :initarg :animators
    :accessor animators
    :initform NIL)))

;;; scene node animators

;; TODO: this should be angle + velocity, or pure quaternion angle, when
;; we figure out how to scale it
(defclass animator-rotation ()
  ((angle
    :initarg :rotation
    :accessor rotation
    :initform (new-angle-axis))))

;; TODO: so how does one actually do quaternion scaling? i.e. scaling
;; below one rotation or applying multiple rotations in one step?
(defmethod animate ((animator animator-rotation) object)
  (let ((transformation (transformation object)))
    (when transformation
      (let ((rotation (relative-rotation transformation)))
        (quaternion-setter*
         rotation
         (quaternion-normalize*
          (quaternion-product*
            (with-angle-axis (rotation animator)
                (x y z a)
              (angle-axis-quaternion*
               (angle-axis-values* x y z (* a 0.001 *delta-real-elapsed*))))
            (quaternion*
             rotation)))))
      (setf (relative-dirty-p transformation) T))))

;;; scene nodes

;;; distinction between stripped geometry (allocated in not gc'ed memory)
;;; and lisp-managed geometry

(defclass cube (scene-node-mixin)
  ())

(defun make-cube (&optional (width 1.0) (height 1.0) (depth 1.0))
  (let ((transformation (make-transformation)))
    (setf (relative-scale transformation)
          (make-vector3d width height depth))
    (make-instance 'cube :transformation transformation)))

(defun render-unit-cube ()
  (let ((points #(0 0 0                 ; 0
                  1 0 0                 ; 1
                  1 1 0                 ; 2
                  0 1 0                 ; 3
                  0 0 1                 ; 4
                  1 0 1                 ; 5
                  1 1 1                 ; 6
                  0 1 1))               ; 7
        (indexes #(0 1 2 3              ; front
                   1 5 6 2              ; right
                   5 4 7 6              ; back
                   4 7 3 0              ; left
                   3 2 6 7              ; top
                   0 4 5 1)))           ; bottom
    (gl:with-primitives :quads
      (map NIL (lambda (index)
                 (let ((x (aref points (+ (* index 3) 0)))
                       (y (aref points (+ (* index 3) 1)))
                       (z (aref points (+ (* index 3) 2))))
                   (gl:color x y z)
                   ;; align cube at 0,0,0
                   (gl:vertex (1- (* 2 x)) (1- (* 2 y)) (1- (* 2 z)))))
           indexes))))

(defvar *debug-matrix*)

(defun debug-display-matrix (mode)
  ;; FIXME: welp, if this is only for debugging okay, but otherwise write
  ;; a wrapper, which returns row-major matrixes instead
  (setf *debug-matrix*
        (make-matrix44*
         (transpose-matrix44*
          (matrix44*
           (gl:get-float
            (ecase mode
              (:modelview :modelview-matrix)
              (:projection :projection-matrix)
              (:texture :texture-matrix))))))))

(defmethod render ((cube cube))
  (render-unit-cube))

;;; materials

;;; scene management

;;; three structures, logical (scene tree), spatial and render graph

(defun add-scene-node (scene-node)
  (push scene-node *scene-tree*))

(defgeneric relative-transformation (object))

(defmethod relative-transformation (object)
  (relative-transformation (transformation object)))

(defun translate (object x y z)
  (let* ((transformation (transformation object))
         (relative (relative-position transformation)))
    (vector3d-setter*
     relative
     (vector3d-sum*
      (vector3d* relative)
      (vector3d-values* x y z)))
    (setf (relative-dirty-p transformation) T)))

;; TODO: this in all possible permutations and as def-tuple-op
(defun euler-xyz-to-quaternion (x y z)
  (let* ((sr (sin (/ x 2)))
         (cr (cos (/ x 2)))
         (sp (sin (/ y 2)))
         (cp (cos (/ y 2)))
         (sy (sin (/ z 2)))
         (cy (cos (/ z 2)))
         (cpcy (* cp cy))
         (spcy (* sp cy))
         (cpsy (* cp sy))
         (spsy (* sp sy)))
    (quaternion-normalize*
     (quaternion-values*
      (- (* sr cpcy) (* cr spsy))
      (+ (* cr spcy) (* sr cpsy))
      (- (* cr cpsy) (* sr spcy))
      (+ (* cr cpcy) (* sr spsy))))))

(defun rotate (object x y z)
  (let* ((transformation (transformation object))
         (relative (relative-rotation transformation)))
    (quaternion-setter*
     relative
     (quaternion-product*
      (quaternion* relative)
      (euler-xyz-to-quaternion x y z)))
    (setf (relative-dirty-p transformation) T)))

(defun scale (object x y z)
  (let* ((transformation (transformation object))
         (relative (relative-scale transformation)))
    (vector3d-setter*
     relative
     (vector3d-map* (*)
      (vector3d* relative)
      (vector3d-values* x y z)))
    (setf (relative-dirty-p transformation) T)))

(defgeneric absolute-transformation (object))

(defmethod absolute-transformation (object)
  (absolute-transformation (transformation object)))

(defun identity-matrix44 ()
  (make-matrix44* (identity-matrix44*)))

(defvar *identity-matrix44* (identity-matrix44))

(defun ones-vector3d ()
  (make-vector3d 1.0 1.0 1.0))

(def-tuple-op zero-quaternion*
    ()
  (:return quaternion
           (quaternion-values* 0.0 0.0 0.0 1.0)))

(defun zero-quaternion ()
  (make-quaternion*
   (zero-quaternion*)))

(def-tuple-op unit-quaternion-x*
    ((angle cl-tuples::fast-float))
  (:return quaternion
           (let ((angle/2 (/ angle 2)))
             (quaternion-normalize* (quaternion-values* (sin angle/2) 0.0 0.0 (cos angle/2))))))

(def-tuple-op unit-quaternion-y*
    ((angle cl-tuples::fast-float))
  (:return quaternion
           (let ((angle/2 (/ angle 2)))
             (quaternion-normalize* (quaternion-values* 0.0 (sin angle/2) 0.0 (cos angle/2))))))

(def-tuple-op unit-quaternion-z*
    ((angle cl-tuples::fast-float))
  (:return quaternion
           (let ((angle/2 (/ angle 2)))
             (quaternion-normalize* (quaternion-values* 0.0 0.0 (sin angle/2) (cos angle/2))))))

(defclass transformation ()
  ((relative-position
    :initarg :relative-position
    :accessor relative-position
    :initform (new-vector3d))
   (relative-rotation
    :initarg :relative-rotation
    :accessor relative-rotation
    :initform (zero-quaternion))
   (relative-scale
    :initarg :relative-scale
    :accessor relative-scale
    :initform (ones-vector3d))
   (relative-dirty-p
    :initarg :relative-dirty-p
    :accessor relative-dirty-p
    :initform T)
   (relative-transformation
    :initarg :relative-transformation
    :accessor relative-transformation
    :initform (new-matrix44))
   (absolute-transformation
    :initarg :absolute-transformation
    :accessor absolute-transformation
    :initform (new-matrix44)))
  (:documentation "Contains information about the position, rotation and
scale relative to some other scene node (usually the parent) or the
coordinate origin.  Also contains a scratch slot ABSOLUTE-TRANSFORMATION,
which is used destructively to calculate it."))

(defmethod (setf relative-position) :after (new-value (transformation transformation))
  (setf (relative-dirty-p transformation) T))

(defmethod (setf relative-rotation) :after (new-value (transformation transformation))
  (setf (relative-dirty-p transformation) T))

(defmethod (setf relative-scale) :after (new-value (transformation transformation))
  (setf (relative-dirty-p transformation) T))

(defun calculate-relative-transformation (position rotation scale relative-transformation)
  (matrix44-setter*
   relative-transformation
   (matrix44-product*
    (with-vector3d scale (sx sy sz)
      (scaling-matrix44* sx sy sz))
    (matrix44-product*
     (matrix33-matrix44*
      (quaternion-matrix33*
       (quaternion* rotation)))
     (with-vector3d position (tx ty tz)
       (translation-matrix44* tx ty tz))))))

(defmethod relative-transformation :before ((transformation transformation))
  (when (relative-dirty-p transformation)
    (calculate-relative-transformation
     (relative-position transformation)
     (relative-rotation transformation)
     (relative-scale transformation)
     (slot-value transformation 'relative-transformation))
    (setf (relative-dirty-p transformation) NIL)))

(defun make-transformation ()
  (make-instance 'transformation))

;;; camera

(defclass camera (scene-node-mixin)
  ((inverse-absolute-matrix
    :initarg :inverse-absolute-matrix
    :accessor inverse-absolute-matrix
    :initform (new-matrix44)
    :documentation "Scratch slot to calculate the inverse transformation.")
   (fov
    :initarg :fov
    :accessor fov
    :initform 60)
   (clipping-planes
    :initarg :clipping-planes
    :accessor clipping-planes
    :initform (cons 1 1024))))

(defclass fps-camera (camera)
  ((relative-rotation
    :initarg :relative-rotation
    :accessor relative-rotation
    :initform (new-vector3d))))

(defgeneric apply-camera-rotation (camera x y z))

(defmethod apply-camera-rotation ((camera camera) rotate-x rotate-y rotate-z)
  (symbol-macrolet ((r (relative-rotation (transformation *camera*)))
                    (r* (quaternion* r)))
    (setf r
          (make-quaternion*
           (quaternion-product*
            (quaternion-product*
             (with-vector3d*
                 (quaternion-transform-vector3d* (vector3d-values* 0.0 0.0 -1.0) r*)
                 (x y z)
               (angle-axis-quaternion*
                (angle-axis-values* x y z rotate-z)))
             (quaternion-product*
              (with-vector3d*
                  (quaternion-transform-vector3d* (vector3d-values* 0.0 1.0 0.0) r*)
                  (x y z)
                (angle-axis-quaternion*
                 (angle-axis-values* x y z rotate-y)))
              (with-vector3d*
                  (quaternion-transform-vector3d* (vector3d-values* 1.0 0.0 0.0) r*)
                  (x y z)
                (angle-axis-quaternion*
                 (angle-axis-values* x y z rotate-x)))))
            r*)))))

(defconstant +2-pi-fast+
  (coerce (* pi 2) 'cl-tuples::fast-float))

(defconstant +-2-pi-fast+
  (coerce (- (* pi 2)) 'cl-tuples::fast-float))

(defconstant +pi/2-fast+
  (coerce (/ pi 2) 'cl-tuples::fast-float))

(defconstant +-pi/2-fast+
  (coerce (- (/ pi 2)) 'cl-tuples::fast-float))

(defmethod apply-camera-rotation ((camera fps-camera) rotate-x rotate-y rotate-z)
  (symbol-macrolet ((r (relative-rotation (transformation *camera*)))
                    (r* (quaternion* r)))
    (with-vector3d
        (relative-rotation *camera*)
        (old-x old-y old-z)
      (with-vector3d*
          (vector3d-setter*
           (relative-rotation *camera*)
           (vector3d-values*
            (max +-pi/2-fast+
                 (min +pi/2-fast+
                      (+ old-x rotate-x)))
            (let ((y (+ old-y rotate-y)))
              y
              #+ (or)
              (cond
                ((< y 0) (+ +2-pi-fast+ y))
                ((> y +2-pi-fast+) (+ +-2-pi-fast+ y))
                (T y)))
            (let ((z (+ old-z rotate-z)))
              z
              #+ (or)
              (cond
                ((< z 0) (+ +2-pi-fast+ z))
                ((> z +2-pi-fast+) (+ +-2-pi-fast+ z))
                (T z)))
            (+ old-z rotate-z)))
          (new-x new-y new-z)
        ;; (format-log "~F ~F ~F" new-x new-y new-z)
        (setf r
              #+(or)
              (make-quaternion*
               (euler-xzy-to-quaternion new-x new-y new-z))
              (make-quaternion*
               (quaternion-product*
                (unit-quaternion-y* new-y)
                (quaternion-product*
                 (unit-quaternion-z* new-z)
                 (unit-quaternion-x* new-x)))))))))

(defmethod render ((camera camera))
  "Render a placeholder for the invisible CAMERA when debugging.")

(defun make-camera ()
  (make-instance 'camera))

(defun make-fps-camera ()
  (make-instance 'fps-camera))

;; http://nehe.gamedev.net/article/replacement_for_gluperspective/21002/
(defun perspective (fov aspect near far)
  (let* ((fh (* (tan (* (/ fov 360) pi)) near))
         (fw (* fh aspect)))
    (gl:frustum (- fw) fw (- fh) fh near far)))

(defun setup-camera (camera)
  "Initial setup which affects the OpenGL PROJECTION matrix."
  (multiple-value-bind (width height)
      (window-resolution)
    (let ((planes (clipping-planes camera)))
      (gl:matrix-mode :projection)
      (gl:load-identity)
      (perspective (fov camera) (/ width height)
                   (car planes) (cdr planes))
      (gl:matrix-mode :modelview))))

(defun calculate-inverse-absolute-matrix (absolute-transformation
                                          inverse-absolute-matrix)
  ;; (format-log "det ~F" (matrix44-determinant* (matrix44* absolute-transformation)))
  (matrix44-setter*
   inverse-absolute-matrix
   (inverted-matrix44*
    (matrix44* absolute-transformation))))

(defun apply-camera-transformation (camera)
  ;; same as GLU:LOOK-AT
  (let ((inverse-absolute-matrix (inverse-absolute-matrix camera)))
    (calculate-inverse-absolute-matrix
     (absolute-transformation camera)
     inverse-absolute-matrix)
    ;; (cl-tuples::print-matrix44* (matrix44* (absolute-transformation camera)))
    ;; i.e. column-major mode
    (gl:load-transpose-matrix inverse-absolute-matrix)))

(defun calculate-absolute-transformation (absolute relative parent)
  (matrix44-setter*
   absolute
   (matrix44-product*
    (matrix44* relative)
    (matrix44* parent))))

(defun update-absolute-transformation (object parent-transformation)
  (let ((absolute (absolute-transformation object)))
    (calculate-absolute-transformation
     absolute
     (relative-transformation object)
     parent-transformation)
    absolute))

;;; video

(defun reset-window ()
  ;; FIXME: check these options ...
  (multiple-value-call #'sdl:window
    (window-resolution)
    :position (list 0 0)
    :fullscreen (window-fullscreen)
    :any-format T
    :double-buffer T
    :no-frame T
    :resizable NIL
    :opengl T
    :opengl-attributes '((:sdl-gl-doublebuffer 1))
    :title-caption "Lisp Game"
    :icon-caption "Lisp Game")
  (sdl:initialise-default-font)
  (sdl:show-cursor NIL))

#+(or)
(break "~A ~A ~A, ~A ~A, ~A ~A ~A, ~A ~A"
       (sdl-base:surf-w (sdl:fp sdl-object))
       (sdl-base:surf-h (sdl:fp sdl-object))
       (sdl-base:pixel-format (sdl:fp sdl-object))
       (cffi:foreign-slot-value (sdl-base:pixel-format (sdl:fp sdl-object))
                                'sdl-cffi::sdl-pixel-format 'sdl-cffi::bytesperpixel)
       (cffi:foreign-slot-value (sdl-base:pixel-format (sdl:fp sdl-object))
                                'sdl-cffi::sdl-pixel-format 'sdl-cffi::bitsperpixel)
       (cffi:foreign-slot-value (sdl-base:pixel-format (sdl:fp sdl-object))
                                'sdl-cffi::sdl-pixel-format 'sdl-cffi::Rmask)
       (cffi:foreign-slot-value (sdl-base:pixel-format (sdl:fp sdl-object))
                                'sdl-cffi::sdl-pixel-format 'sdl-cffi::Gmask)
       (cffi:foreign-slot-value (sdl-base:pixel-format (sdl:fp sdl-object))
                                'sdl-cffi::sdl-pixel-format 'sdl-cffi::Bmask)
       (sdl:with-pixel (pixels (sdl:fp sdl-object))
         (multiple-value-list (sdl:read-pixel pixels 0 0)))
       (sdl:with-pixel (pixels (sdl:fp sdl-object))
         (multiple-value-list (sdl:read-pixel pixels 2 130))))

;; (defvar *joystick*)

#+(or)
(defun render-debug-joystick ()
  (gl:with-primitive :points
    (flet ((color (state)
             (if (eql 0 state)
                 (gl:color 0.0 0.0 0.0)
                 (gl:color 1.0 1.0 1.0))))
      ;; FIXME: idiotic functions here, it's constant anyway
      (color (sdl-cffi::sdl-joystick-get-button *joystick* 0))
      (gl:vertex 0 0)

      (color (sdl-cffi::sdl-joystick-get-button *joystick* 1))
      (gl:vertex 2 0)

      (color (sdl-cffi::sdl-joystick-get-button *joystick* 2))
      (gl:vertex 4.5 0)

      (color (sdl-cffi::sdl-joystick-get-button *joystick* 3))
      (gl:vertex 6 0)

      (color (sdl-cffi::sdl-joystick-get-button *joystick* 4))
      (gl:vertex 0 2)

      (color (sdl-cffi::sdl-joystick-get-button *joystick* 5))
      (gl:vertex 2 2)

      (color (sdl-cffi::sdl-joystick-get-button *joystick* 6))
      (gl:vertex 4.5 2)

      (color (sdl-cffi::sdl-joystick-get-button *joystick* 7))
      (gl:vertex 6 2)

      (color (sdl-cffi::sdl-joystick-get-button *joystick* 8))
      (gl:vertex 0 4)

      (color (sdl-cffi::sdl-joystick-get-button *joystick* 9))
      (gl:vertex 2 4)


      (color (logand 8 (sdl-cffi::sdl-joystick-get-hat *joystick* 0)))
      (gl:vertex 0 8)

      (color (logand 1 (sdl-cffi::sdl-joystick-get-hat *joystick* 0)))
      (gl:vertex 2 10)

      (color (logand 2 (sdl-cffi::sdl-joystick-get-hat *joystick* 0)))
      (gl:vertex 4.5 8)

      (color (logand 4 (sdl-cffi::sdl-joystick-get-hat *joystick* 0)))
      (gl:vertex 2 6)

      )))

;; TODO: show edges, double clicks
(defun render-debug-mouse (&optional (button (sdl::get-mouse-button)))
  (gl:with-primitive :points
    (flet ((color (mask)
             (if (eql 0 (logand button mask))
                 (gl:color 0.0 0.0 0.0)
                 (gl:color 1.0 1.0 1.0))))
      ;; FIXME: idiotic functions here, it's constant anyway
      (color #.(sdl-cffi::sdl-button-lmask))
      (gl:vertex 0 -2)
      (color #.(sdl-cffi::sdl-button-rmask))
      (gl:vertex 6 -2)

      (color #.(sdl-cffi::sdl-button-mmask))
      (gl:vertex 4 0)
      (color #.(sdl-cffi::sdl-button-wumask))
      (gl:vertex 4 -3)
      (color #.(sdl-cffi::sdl-button-wdmask))
      (gl:vertex 4 -5)

      (color #.(sdl-cffi::sdl-button-x1mask))
      (gl:vertex 0 -5)
      (color #.(sdl-cffi::sdl-button-x2mask))
      (gl:vertex 0 -7))))

(defvar *fix-texture* T)

#+(or)
(defun render-debug-overlay ()
  (gl:polygon-mode :front-and-back :fill)
  (gl:hint :line-smooth-hint :fastest)
  (multiple-value-bind (width height)
      (window-resolution)
    (gl:color 1 0.5 0.5)
    (let ((proggy (resource 'proggy-polygon))
          (size 20)
          (rect (rectangle 0 0 width height)))
      (multiple-value-bind (render-width render-height)
          (render-aligned-text
           proggy (format NIL "FPS ~3D" (sdl:frame-rate)) size
           rect
           :vertical :right)
        (declare (ignore render-width))
        (decf (aref rect 3) (+ render-height 3)))
      (when *debug-matrix*
        (render-aligned-matrix
         proggy *debug-matrix* size
         rect
         :vertical :right)))))

(defun render-debug-overlay ()
  (multiple-value-bind (width height)
      (window-resolution)
    (gl:with-pushed-matrix
      (gl:translate (- width 100) (- height 100) 0)
      (render-debug-mouse)
      ;; (gl:translate 0 50 0)
      ;; (render-debug-joystick)
      )
    (let ((silkscreen-texture (resource 'silkscreen-texture))
          (texture (first (gl:gen-textures 1))))
      (ensure-resource silkscreen-texture)
      (gl:enable :blend :texture-2d)
      (let ((sdl-object (slot-value silkscreen-texture 'sdl-object)))
        ;; FIXME: effing hell, scaling to 255 is necessary
        (when *fix-texture*
          (sdl:with-pixel (pixels (sdl:fp sdl-object))
            (iterate
              (for x from 0 below (sdl:width sdl-object))
              (iterate
                (for y from 0 below (sdl:height sdl-object))
                (when (eql (sdl:read-pixel pixels x y) 0)
                  (sdl:write-pixel pixels x y 255))
                (when (eql (sdl:read-pixel pixels x y) 1)
                  (sdl:write-pixel pixels x y 0)))))
          (setf *fix-texture* NIL))

        (gl:bind-texture :texture-2d texture)
        (gl:tex-parameter :texture-2d :texture-min-filter :nearest)
        (gl:tex-parameter :texture-2d :texture-mag-filter :nearest)
        ;; rgba rgba
        (gl:tex-image-2d :texture-2d 0 :intensity
                         (sdl:width sdl-object)
                         (sdl:height sdl-object)
                         0 :red
                         :unsigned-byte
                         (sdl:with-pixel (pixels (sdl:fp sdl-object))
                           (sdl:pixel-data pixels)))
        (gl:generate-mipmap-ext :texture-2d))
      (gl:blend-func :one :one-minus-src-alpha)
      (gl:color 1.0 1.0 1.0 1.0)
      (let ((fps (format NIL "~D FPS" (floor (sdl:average-fps)))))
        (gl:translate (- width (* (length fps) 8)) (- height 8) 0)
        (gl:matrix-mode :texture)
        (gl:load-identity)
        ;; this fixes the inverted loading from bmp format
        (gl:scale 1.0 -1.0 1.0)
        (gl:matrix-mode :modelview)
        (gl:with-primitive :quads
          (iterate
            (for i from 0)
            (for character in-string fps)
            (for index = (- (char-code character) 32))
            (for (values y x) = (floor index 16))
            (setf x (/ x 16) y (- 1 (/ y 16)))
            (gl:tex-coord x (- y 1/16))
            (gl:vertex (* i 8) 0.0)

            (gl:tex-coord (+ x 1/16) (- y 1/16))
            (gl:vertex (* (1+ i) 8) 0.0)

            (gl:tex-coord (+ x 1/16) y)
            (gl:vertex (* (1+ i) 8) 8)

            (gl:tex-coord x y)
            (gl:vertex (* i 8) 8))))
      (gl:bind-texture :texture-2d 0)
      (gl:delete-textures (list texture))
      (gl:blend-func :one :zero)
      (gl:disable :blend :texture-2d))))

(defun render-coordinate-arrows ()
  (gl:with-primitive :lines
    (gl:color 1 0 0)
    (gl:vertex 0 0 0)
    (gl:vertex 1 0 0)
    (gl:color 0 1 0)
    (gl:vertex 0 0 0)
    (gl:vertex 0 1 0)
    (gl:color 0 0 1)
    (gl:vertex 0 0 0)
    (gl:vertex 0 0 1)))

#+(or)
(defun render-camera-arrows ()
  (gl:with-pushed-matrix
    (with-vector3d*
        (quaternion-transform-vector3d*
         (vector3d-values* 1.0 0.0 0.0)
         (quaternion* (relative-rotation (transformation *camera*))))
        (x y z)
      (gl:with-primitive :lines
        (gl:color 1 1 0)
        (gl:vertex 0 0 0)
        (gl:vertex x y z)))
    (with-vector3d*
        (quaternion-transform-vector3d*
         (vector3d-values* 0.0 1.0 0.0)
         (quaternion* (relative-rotation (transformation *camera*))))
        (x y z)
      (gl:with-primitive :lines
        (gl:color 0 1 1)
        (gl:vertex 0 0 0)
        (gl:vertex x y z)))
    (with-vector3d*
        (quaternion-transform-vector3d*
         (vector3d-values* 0.0 0.0 -1.0)
         (quaternion* (relative-rotation (transformation *camera*))))
        (x y z)
      (gl:with-primitive :lines
        (gl:color 1 0 1)
        (gl:vertex 0 0 0)
        (gl:vertex x y z)))))

(defun update-scene-tree (scene-tree)
  (setf *delta-real-elapsed* (sdl::delta-ticks sdl:*default-fpsmanager*))
  (labels ((aux (list parent-transformation)
             (dolist (object list)
               (update object)
               (dolist (animator (animators object))
                 (animate animator object))
               (aux (children object)
                    (update-absolute-transformation
                     object
                     parent-transformation)))))
    (aux scene-tree *identity-matrix44*)))

(defvar *once* T)

(defun render-scene-tree (scene-tree)
  (labels ((aux (list)
             (dolist (object list)
               (let ((transformation (transformation object)))
                 (when transformation
                   (gl:push-matrix)
                   ;; transpose, because opengl uses column-major mode for
                   ;; matrixes
                   ;; TODO: also, have some c-level buffer here instead of
                   ;; allocating all other the place
                   (gl:mult-transpose-matrix
                    (make-matrix44*
                      (matrix44*
                       (relative-transformation transformation)))))
                 ;; TODO: maybe this UNWIND-PROTECT can be omitted, i.e.
                 ;; "there'll be no errors", or if there are, a trashed
                 ;; OpenGL state is the least of our problems?
                 (unwind-protect
                      (progn
                        (render object)
                        (aux (children object)))
                   (when transformation
                     (gl:pop-matrix)))))))
    (aux scene-tree)))

(defun render-frame ()
  ;; TODO: assert the correct matrix mode here and reset if necessary
  (gl:clear :color-buffer :depth-buffer)
  ;; TODO: protect us from clobbering the setup?  look at the matrix
  ;; stack and reset if necessary
  (with-all-pushed-matrixes
    (setup-3d)
    (gl:enable :depth-test)
    (gl:with-pushed-matrix
      (gl:scale 10 10 10)
      ;; TODO: render on "inside" the gui layer, i.e. in front of the
      ;; scene and rotate it to match the view orientation, like in
      ;; blender
      (render-coordinate-arrows))
    ;; (render-camera-arrows)
    (render-scene-tree *scene-tree*))
  (with-all-pushed-matrixes
    (setup-2d)
    (gl:with-pushed-matrix
      (render-debug-overlay)))
  (sdl:update-display))

;; (gl:shader-source fragment-shader-object (list fragment-shader))
;; (gl:compile-shader fragment-shader-object)
;; (format T "~A~%" (gl:get-shader-info-log fragment-shader-object))
;; (gl:attach-shader program-object fragment-shader-object)

;; (gl:shader-source vertex-shader-object (list vertex-shader))
;; (gl:compile-shader vertex-shader-object)
;; (format T "~A~%" (gl:get-shader-info-log vertex-shader-object))
;; (gl:attach-shader program-object vertex-shader-object)

;; (gl:link-program program-object)
;; (format T "~A~%" (gl:get-program-info-log program-object))
;; (gl:use-program program-object)

;; (fragment-shader (read-file-into-string "../data/shaders/green.glsl"))
;; (fragment-shader-object (gl:create-shader :fragment-shader))
;; (vertex-shader (read-file-into-string "../data/shaders/scale.glsl"))
;; (vertex-shader-object (gl:create-shader :vertex-shader))
;; (program-object (gl:create-program))

           ;; rotate around global z
           ;; which is more fps like
           #+(or)
           (unit-quaternion-y* rotate-y)

#+ (or)
(defun apply-camera-rotation (rotate-x rotate-y rotate-z)
  (with-vector3d
      (relative-rotation *camera*)
      (old-x old-y old-z)
    (with-vector3d*
        (vector3d-sum*
         (vector3d-values* old-x old-y old-z)
         (vector3d-values* rotate-x rotate-y (- rotate-z)))
        (new-x new-y new-z)
      (vector3d-setter*
       (relative-rotation *camera*)
       (vector3d-values* new-x new-y new-z)))))

(defun inner-client ()
  (load-options)
  (reset-window)
  (reset-opengl)
  (setup-camera (setf *camera* (make-fps-camera)))
  (add-scene-node *camera*)
  (setf (relative-position (transformation *camera*)) (make-vector3d 10.0 0.0 0.0))
  (setf (sdl:frame-rate) 30)
  (with-all-resources
    (load-all-resources)
    (sdl:enable-unicode)
    (let ((rotate-x 0.0)
          (rotate-y 0.0)
          (rotate-z 0.0)
          (translate-x 0.0)
          (translate-y 0.0)
          (translate-z 0.0)
          (capture-mouse-p T))
      (sdl:with-events ()
        (:active-event (:gain gain)
                       ;; FIXME: this needs better handling of the actual state, not just gain
                       (if (eql gain 0)
                           (progn
                             (sdl:show-cursor T)
                             (setf capture-mouse-p NIL))
                           (progn
                             (sdl:show-cursor NIL)
                             (setf capture-mouse-p T))))
        (:quit-event () T)
        (:video-expose-event () (render-frame))
        (:key-down-event (:key key :unicode unicode)
                         (declare (ignore unicode))
                         (case key
                           (:sdl-key-a (setf translate-x -10.0))
                           (:sdl-key-d (setf translate-x 10.0))
                           (:sdl-key-w (setf translate-z -10.0))
                           (:sdl-key-s (setf translate-z 10.0))
                           (:sdl-key-space (setf translate-y 10.0))
                           (:sdl-key-lctrl (setf translate-y -10.0))
                           (:sdl-key-q (setf rotate-z (to-radian -0.5)))
                           (:sdl-key-e (setf rotate-z (to-radian 0.5)))
                           (:sdl-key-f
                            (setf *window-fullscreen* (not *window-fullscreen*))
                            (reset-window)
                            (reset-opengl)
                            (setup-camera *camera*))
                           (:sdl-key-escape
                            (invoke-restart 'abort-client))))
        (:key-up-event (:key key :unicode unicode)
                       (declare (ignore unicode))
                       (case key
                         (:sdl-key-a (setf translate-x 0.0))
                         (:sdl-key-d (setf translate-x 0.0))
                         (:sdl-key-w (setf translate-z 0.0))
                         (:sdl-key-s (setf translate-z 0.0))
                         (:sdl-key-q (setf rotate-z 0.0))
                         (:sdl-key-e (setf rotate-z 0.0))
                         (:sdl-key-space (setf translate-y 0.0))
                         (:sdl-key-lctrl (setf translate-y 0.0))))
        (:mouse-button-down-event ())
        (:mouse-button-up-event ())
        (:joy-button-down-event ())
        (:mouse-motion-event (:state state :x x :y y :x-rel xrel :y-rel yrel)
                             (declare (ignore state x y))
                             (setf rotate-y (* xrel (to-radian 0.5)))
                             (setf rotate-x (* yrel (to-radian 0.5)))
                             (when capture-mouse-p
                               (multiple-value-bind (width height)
                                   (window-resolution)
                                 (sdl-cffi::sdl-warp-mouse (floor width 2) (floor height 2)))))
        (:idle ()
               (handle-messages *messages*)
               (update-scene-tree *scene-tree*)
               (restart-case
                   (progn
                     ;; TODO: limit rotation around x
                     (apply-fps-camera-rotation rotate-x rotate-y rotate-z)
                     ;; FIXME: vector3d-x expands into wrong code
                     (setf (relative-position (transformation *camera*))
                           (make-vector3d*
                            (vector3d-sum*
                             (vector3d* (relative-position (transformation *camera*)))
                             (quaternion-transform-vector3d*
                              (vector3d-scale*
                               (vector3d-values* translate-x translate-y translate-z)
                               (* 0.001 *delta-real-elapsed*))
                              (quaternion* (relative-rotation (transformation *camera*)))))))
                     ;; rotate-z left out, because it's controlled by keyboard
                     (setf rotate-x 0.0 rotate-y 0.0 ;; rotate-z 0.0
                           )
                     (render-frame))
                 (continue ()
                   :report "Continue with the next frame.")))))))

;; seems like the direct calculation has some signs inverted
#+(or)
(defun test (x y z)
  (setf x (coerce x 'cl-tuples::fast-float)
        y (coerce y 'cl-tuples::fast-float)
        z (coerce z 'cl-tuples::fast-float))
  (let* ((sr (sin (/ x 2)))
         (cr (cos (/ x 2)))
         (sp (sin (/ y 2)))
         (cp (cos (/ y 2)))
         (sy (sin (/ z 2)))
         (cy (cos (/ z 2)))
         (cpcy (* cp cy))
         (spcy (* sp cy))
         (cpsy (* cp sy))
         (spsy (* sp sy)))
    (values
     #-(or)
     (make-quaternion*
      (quaternion-normalize*
       (quaternion-values*
        (- (* sr cpcy) (* cr spsy))
        (+ (* cr spcy) (* sr cpsy))
        (- (* cr cpsy) (* sr spcy))
        (+ (* cr cpcy) (* sr spsy)))))
     #-(or)
     (make-quaternion*
      (quaternion-normalize*
       (quaternion-product*
        (quaternion-product*
         (unit-quaternion-x* z)
         (unit-quaternion-y* x))
        (unit-quaternion-z* y)))))))

;; no, this doesn't work at all
#+(or)
(make-quaternion*
 (quaternion-normalize*
  (quaternion-product*
   (quaternion* (euler-xyz-to-quaternion rotate-x rotate-y rotate-z))
   (quaternion* (relative-rotation (transformation *camera*))))))