+;;; -*- mode: lisp; syntax: common-lisp; package: existenz-client; coding: utf-8-unix; -*-
+
+(in-package #:existenz-client)
+\f
+;;; 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
+\f
+;; 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)))
+\f
+(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*)
+\f
+;;; 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)))
+\f
+;;; 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)))
+\f
+;;; 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)))
+\f
+;;; 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)))
+\f
+;;; 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
+\f
+;;; reloading resources on change
+\f
+;;; 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)))
+\f
+;;; materials
+\f
+;;; 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)))
+\f
+(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.")))
+\f
+(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)))
+\f
+#+(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"))
+\f
+#+(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)))))
+\f
+;;; 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)))
+\f
+;;; 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))))
+\f
+;;; 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))
+\f
+;;; materials
+\f
+;;; scene management
+
+;;; three structures, logical (scene tree), spatial and render graph
+
+(defun add-scene-node (scene-node)
+ (push scene-node *scene-tree*))
+\f
+(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))
+\f
+;;; 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))
+\f
+;;; 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))
+\f
+;; (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.")))))))
+\f
+;; 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*))))))
projects / existenz.git / commitdiff