client/client.lisp

   1 ;;; -*- mode: lisp; syntax: common-lisp; package: existenz-client; coding: utf-8-unix; -*-
   2
   3 (in-package #:existenz-client)
   4 \f
   5 ;;; ideas
   6 ;;; - bridge between blender and engine, in addition to inotify-watching.
   7 ;;;   this will be best possible with some ready to run rpc framework,
   8 ;;    i.e. xmlrpc.server.SimpleXMLRPCServer
   9 ;;;   source files if no bridge is available
  10 ;;; - interaction with windows messaging, i.e. enable powermenu
  11 ;;; - config.lisp loading a la emacs
  12 ;;; - ensure conversion to CL-TUPLES::FAST-FLOAT on system boundaries,
  13 ;;;   also add normalization and test for divergence on low optimization
  14 ;;;   levels to *every* operation
  15 ;;; - be sure about the coordinate systems, i.e. 2d+gui/3d
  16 ;;; - how to do networking (iolib? or some other plain library?), sound
  17 ;;;   (openal)?
  18 ;;; - serialization? cl-store or something else?
  19 ;;; - FINALIZE as per its description, i.e. register closures to directly
  20 ;;;   deallocate the nested resources.  since this may occur in any thread,
  21 ;;;   unloading of textures needs to be pushed to the main/opengl thread -
  22 ;;;   the same goes for other values (openal?) similarly.  it may be
  23 ;;;   possible to still retain often used resources in a separate cache,
  24 ;;;   but that's just icing then.  better make a state-chart for all this
  25 ;;;   behaviour, i.e. when is a resource (successfully) loaded, what
  26 ;;;   happens at what stage
  27 ;;; - replace missing resources with placeholders, which may still be
  28 ;;;   corrected, i.e. by saving a file to the wanted name, or correcting
  29 ;;;   an invalid file
  30 ;;; - resource lookup by what?  filesystem like?  how are different
  31 ;;;   authors sufficiently discriminated against?
  32
  33 ;;; future future ideas
  34 ;;; - bytecode vm for scripting?  targeted to mathematics, i.e. full
  35 ;;;   regular tower + vectors + matrixes + quaternions, which then may be
  36 ;;;   optimized somehow
  37
  38 ;;; every object in the world is in the scene tree and in the spatial
  39 ;;; trees.  if an object is removed, it is removed from all trees.  if
  40 ;;; an object moves, it has to be reinserted in some of the spatial trees,
  41 ;;; also if it changes its scale, rotation and furthermore its actual
  42 ;;; geometry
  43 \f
  44 ;; nice, but doesn't work with eldoc, so it's kinda useless
  45 #+(or)
  46 (eval-when (:compile-toplevel :load-toplevel :execute)
  47   (defmacro package-calls (package &body body)
  48     (setf package (find-package package))
  49     `(progn
  50        ,.(mapcar (lambda (form)
  51                    (let (car found)
  52                      (if (and (listp form)
  53                               (setf car (car form))
  54                               (symbolp car)
  55                               (setf found (find-symbol
  56                                            (symbol-name car)
  57                                            package)))
  58                          `(,found ,.(cdr form))
  59                          form)))
  60                  body)))
  61
  62   (defmacro gl (&body body)
  63     `(package-calls #.(find-package '#:gl) ,@body)))
  64 \f
  65 (defvar *window-width*)
  66 (defvar *window-height*)
  67 (defvar *window-fullscreen*)
  68
  69 (push '(window-resolution . (640 480)) *options*)
  70 (push '(window-fullscreen . (NIL)) *options*)
  71
  72 (push '(window-resolution *window-width* *window-height*) *options-mappings*)
  73 (push '(window-fullscreen *window-fullscreen*) *options-mappings*)
  74 \f
  75 ;;; message passing to the client main thread
  76
  77 (defvar *client*)
  78 (defvar *messages*)
  79
  80 (defun send-to-client (object)
  81   (cond
  82     ((not (boundp '*client*))
  83      (warn "*CLIENT* is unbound"))
  84     ((not *client*)
  85      (warn "*CLIENT* has no value"))
  86     ((not (thread-alive-p *client*))
  87      (warn "*CLIENT* isn't running"))
  88     (T
  89      (prog1 T (enqueue *messages* object)))))
  90
  91 (defmacro run-in-client (&body body)
  92   `(send-to-client (lambda () ,@body)))
  93
  94 (defun handle-message (message)
  95   (etypecase message
  96     (function
  97      (handler-case (funcall message)
  98        (error (error)
  99          (warn "ERROR occured while executing ~A: ~A" message error))))))
 100
 101 (defun handle-messages (locked-deque)
 102   (let ((messages (dequeue-all locked-deque)))
 103     (mapc #'handle-message messages)))
 104 \f
 105 ;;; resources
 106
 107 (defvar *resources* (make-hash-table :test 'eq))
 108
 109 (defgeneric unload-resource (resource)
 110   (:documentation "Explicitely deallocate the RESOURCE and disable the
 111 finalizer (see MAKE-RESOURCE-FINALIZER)."))
 112 (defgeneric make-resource-finalizer (resource)
 113   (:documentation "Returns a FUNCTION, which takes care of cleaning up
 114 resources in the correct threads when the RESOURCE is gc'ed.  Note the
 115 rules for FINALIZE apply, i.e. the closure may not reference the RESOURCE
 116 object, or it won't ever be collected."))
 117 (defgeneric load-resource (resource))
 118 (defgeneric resource-loaded-p (resource)
 119   (:documentation "A resource may fail to load, but by using placeholder
 120 values, it can still be used.  Of course, this only works for some objects,
 121 e.g. textures."))
 122
 123 (defun map-resources (function)
 124   (maphash
 125    (lambda (name resource)
 126      (declare (ignore name))
 127      (funcall function resource))
 128    *resources*))
 129
 130 (defun load-all-resources (&optional force)
 131   (map-resources
 132    (lambda (resource)
 133      (when (or (not (resource-loaded-p resource)) force)
 134        (load-resource resource)))))
 135
 136 (defun unload-all-resources ()
 137   (map-resources #'unload-resource))
 138
 139 (defmacro with-all-resources (&body body)
 140   `(unwind-protect
 141         (progn
 142           ,@body)
 143      (unload-all-resources)))
 144
 145 (defun get-resource (name)
 146   (gethash name *resources*))
 147
 148 (defun %delete-resource (name)
 149   (awhen (get-resource name)
 150     (unload-resource it)
 151     (remhash name *resources*)))
 152
 153 (defun %add-resource (name new)
 154   (symbol-macrolet ((resource (gethash name *resources*)))
 155     (let ((old resource))
 156       (when old
 157         (unload-resource old)
 158         (load-resource new))
 159       (setf resource new))))
 160
 161 (defun add-resource (name new)
 162   "Adds the NEW resource.  For the moment all resources are loaded in the
 163 main thread."
 164   ;; TODO: wait for client to execute it, then return the object
 165   (unless (run-in-client (%add-resource name new))
 166     (setf (gethash name *resources*) new))
 167   new)
 168
 169 (defun delete-resource (name)
 170   (unless (run-in-client (%delete-resource name))
 171     (remhash name *resources*)))
 172
 173 (define-condition undefined-resource (error)
 174   ((resource-name :initarg :resource-name :reader resource-name))
 175   (:report
 176    (lambda (condition stream)
 177      (format stream "Undefined RESOURCE ~A requested."
 178              (resource-name condition)))))
 179
 180 (defun resource (name)
 181   (let ((resource (get-resource name)))
 182     (unless resource
 183       (error 'undefined-resource :resource-name name))
 184     resource))
 185
 186 (defclass resource ()
 187   ((name :type symbol :initarg :name)))
 188
 189 (defmethod unload-resource :around (resource)
 190   (when (resource-loaded-p resource)
 191     (call-next-method)))
 192
 193 (defmethod load-resource :before (resource)
 194   (when (resource-loaded-p resource)
 195     (unload-resource resource)))
 196
 197 (defmethod load-resource :after (resource)
 198   (format-log "loaded resource ~A" resource))
 199
 200 (defmethod unload-resource :after (resource)
 201   (format-log "unloaded resource ~A" resource))
 202
 203 (defun ensure-resource (resource)
 204   (unless (resource-loaded-p resource)
 205     (load-resource resource)))
 206
 207 (defmethod print-object ((resource resource) stream)
 208   (if *print-readably*
 209       (prin1 (make-load-form resource) stream)
 210       (print-unreadable-object (resource stream :type T :identity T)
 211         (with-slots (name) resource
 212           (format stream "~A ~A"
 213                   name (if (resource-loaded-p resource)
 214                            'loaded 'unloaded))))))
 215
 216 (defclass pathname-mixin ()
 217   ((pathname :initarg :pathname)))
 218 \f
 219 ;;; fonts
 220
 221 #+(or)
 222 (deftype font-mode ()
 223   `(member :textured :polygon))
 224
 225 #+(or)
 226 (defvar *default-font-mode* :textured)
 227
 228 #+(or)
 229 (defclass font (pathname-mixin resource)
 230   ((ftgl-object :initform NIL)
 231    (mode :initarg :mode)))
 232
 233 #+(or)
 234 (defun make-font (name pathname &key (mode *default-font-mode*))
 235   (check-type mode font-mode)
 236   (make-instance 'font :name name :pathname pathname :mode mode))
 237
 238 #+(or)
 239 (defmethod unload-resource ((font font))
 240   (with-slots (ftgl-object) font
 241     (let ((object ftgl-object))
 242       (setf ftgl-object NIL)
 243       (cancel-finalization object)
 244       (ftgl:destroy-font object))))
 245
 246 #+(or)
 247 (defmethod load-resource ((font font))
 248   (with-slots (pathname ftgl-object mode) font
 249     (let ((object (funcall (case mode
 250                              (:textured #'ftgl:create-texture-font)
 251                              (:polygon #'ftgl:create-polygon-font))
 252                            pathname)))
 253       (finalize object #'ftgl:destroy-font)
 254       (setf ftgl-object object)
 255       (ftgl:set-font-face-size object 36 90)
 256       (ftgl:set-font-char-map object :unicode))))
 257
 258 #+(or)
 259 (defmethod resource-loaded-p ((font font))
 260   (and (slot-value font 'ftgl-object) T))
 261
 262 #+(or)
 263 (defmacro add-font (name pathname &key (mode NIL modep))
 264   `(add-resource
 265     ',name
 266     (make-font ',name ,pathname ,@(when modep (list :mode mode)))))
 267
 268 #+(or)
 269 (defmethod make-load-form ((font font) &optional environment)
 270   (declare (ignore environment))
 271   (with-slots (name pathname mode) font
 272     `(add-font ,name ,pathname ,mode)))
 273 \f
 274 ;;; images
 275
 276 (defclass image (pathname-mixin resource)
 277   ((sdl-object :initform NIL)))
 278
 279 (defun make-image (name pathname)
 280   (make-instance 'image :name name :pathname pathname))
 281
 282 ;; TODO: um, is the free necessary?
 283 (defmethod unload-resource ((image image))
 284   (with-slots (sdl-object) image
 285     (sdl:free (shiftf sdl-object NIL))))
 286
 287 ;; TODO: and then, is this necessary?  specific thread?
 288 (defmethod make-resource-finalizer ((image image))
 289   (with-slots (sdl-object) image
 290     (lambda ()
 291       (sdl:free sdl-object))))
 292
 293 (defmethod load-resource ((image image))
 294   (with-slots (pathname sdl-object) image
 295     (setf sdl-object (sdl:load-image pathname))))
 296
 297 (defmethod resource-loaded-p ((image image))
 298   (and (slot-value image 'sdl-object) T))
 299
 300 (defmacro add-image (name pathname)
 301   `(add-resource ',name (make-image ',name ,pathname)))
 302
 303 (defmethod make-load-form ((image image) &optional environment)
 304   (declare (ignore environment))
 305   (with-slots (name pathname) image
 306     `(add-image ,name ,pathname)))
 307 \f
 308 ;;; shaders
 309
 310 ;;; multiple shaders are linked into a program, but they can already be
 311 ;;; compiled beforehand
 312
 313 ;; (defclass shader (pathname-mixin resource)
 314 ;;   ((shader-object :initform NIL)))
 315
 316 ;; (defun make-shader (name pathname)
 317 ;;   (make-instance 'shader :name name :pathname pathname))
 318
 319 ;; (defmethod unload-resource ((shader shader))
 320 ;;   (with-slots (shader-object
 321 \f
 322 ;;; reloading resources on change
 323 \f
 324 ;;; entities
 325
 326 ;;; distinction between stripped geometry (allocated in not gc'ed memory)
 327 ;;; and lisp-managed geometry
 328
 329 (defun make-static-geometry (geometry)
 330   geometry)
 331
 332 (defclass cube ()
 333   ((dimensions :initarg :dimensions)))
 334
 335 (defgeneric render-object (object))
 336
 337 (defvar *debug-matrix*)
 338
 339 (defmethod render-object ((cube cube))
 340   (let* ((dimensions (slot-value cube 'dimensions))
 341          (w (aref dimensions 0))
 342          (d (aref dimensions 1))
 343          (h (aref dimensions 2))
 344          ;; TODO: make static macros for this using some permutation
 345          ;; algorithm
 346          )
 347     (debug-display-matrix :modelview)
 348     (gl:scale w d h)
 349     (render-unit-cube)))
 350 \f
 351 ;;; materials
 352 \f
 353 ;;; video
 354
 355 (defun window-resolution ()
 356   (values *window-width* *window-height*))
 357
 358 (defun window-fullscreen ()
 359   *window-fullscreen*)
 360
 361 (defun set-window-resolution (width height)
 362   (setf *window-width* width
 363         *window-height* height))
 364
 365 (defun reset-opengl ()
 366   (multiple-value-bind (width height)
 367       (window-resolution)
 368     (gl:viewport 0 0 width height)
 369     (gl:matrix-mode :projection)
 370     (gl:load-identity)
 371     (gl:matrix-mode :modelview)
 372     (gl:load-identity)
 373     (gl:clear-color 0.2 0.2 0.2 0)))
 374
 375 (defvar *camera*)
 376
 377 (defun setup-3d ()
 378   (apply-camera-transformation *camera*))
 379
 380 (defun setup-2d ()
 381   (multiple-value-bind (width height)
 382       (window-resolution)
 383     (gl:matrix-mode :projection)
 384     (gl:load-identity)
 385     (gl:ortho 0 width 0 height -1 1)
 386     (gl:matrix-mode :modelview)))
 387
 388 (defun bbox-size (bbox)
 389   (values
 390    (+ (fourth bbox) (max 0 (first bbox)))
 391    (+ (fifth bbox) (max 0 (second bbox)))))
 392
 393 (defun rectangle (x1 y1 x2 y2)
 394   (vector x1 y1 x2 y2))
 395
 396 (defmacro with-rectangle ((rect &optional (x1 'x1) (y1 'y1) (x2 'x2) (y2 'y2)) &body body)
 397   "Destructures the rectangle RECT into the components named by the given
 398 symbols X1 to Y2 for the duration of BODY."
 399   (let ((rect-sym (gensym))
 400         (ref 'aref))
 401     `(let* ((,rect-sym ,rect)
 402             (,x1 (,ref ,rect-sym 0))
 403             (,y1 (,ref ,rect-sym 1))
 404             (,x2 (,ref ,rect-sym 2))
 405             (,y2 (,ref ,rect-sym 3)))
 406        ,@body)))
 407
 408 #+(or)
 409 (defun render-aligned-text (font string size rect &key (vertical :left) (horizontal :top) (resolution 75))
 410   (let ((ftgl (slot-value font 'ftgl-object)))
 411     (ftgl:set-font-face-size ftgl size resolution)
 412     (multiple-value-bind (text-width text-height)
 413         (bbox-size (ftgl:get-font-bbox ftgl string))
 414       (setf text-width (fceiling text-width)
 415             text-height (fceiling text-height))
 416       (gl:with-pushed-matrix
 417         (with-rectangle (rect)
 418           (multiple-value-bind (xtrans ytrans)
 419               (values (ecase vertical
 420                         (:left x1)
 421                         (:center (/ (- (- x2 x1) text-width) 2))
 422                         (:right (- x2 text-width)))
 423                       (ecase horizontal
 424                         (:top (- y2 text-height))
 425                         (:center (/ (- (- y2 y1) text-height) 2))
 426                         (:bottom y1)))
 427             (gl:translate xtrans ytrans 0)))
 428         (ftgl:render-font ftgl string :all))
 429       (values text-width text-height))))
 430
 431 #+(or)
 432 (defun render-aligned-matrix (font matrix size rect &key (vertical :left) (horizontal :top) (resolution 75))
 433   (flet ((format-line (matrix offset)
 434            (format NIL "~8,3F ~8,3F ~8,3F ~8,3F"
 435                    (aref matrix (+ offset 0))
 436                    (aref matrix (+ offset 1))
 437                    (aref matrix (+ offset 2))
 438                    (aref matrix (+ offset 3)))))
 439     (let* ((lines (iterate
 440                     (for i from 0 to 15 by 4)
 441                     (collect (format-line matrix i))))
 442            (ftgl (slot-value font 'ftgl-object)))
 443       (ftgl:set-font-face-size ftgl size resolution)
 444       (let* ((sizes (mapcar (lambda (line) (multiple-value-list (bbox-size (ftgl:get-font-bbox ftgl line)))) lines))
 445              (bbox (reduce (lambda (size1 size2) (list (max (first size1) (first size2))
 446                                                        (+ (second size1) (second size2))))
 447                            sizes)))
 448         (gl:with-pushed-matrix
 449           (with-rectangle (rect)
 450             (multiple-value-bind (xtrans ytrans)
 451                 (destructuring-bind (text-width text-height) bbox
 452                   (incf text-height (* 3 3)) ; three gaps, three pixels
 453                   (values (ecase vertical
 454                             (:left x1)
 455                             (:center (/ (- (- x2 x1) text-width) 2))
 456                             (:right (- x2 text-width)))
 457                           (ecase horizontal
 458                             (:top (- y2 text-height))
 459                             (:center (/ (- (- y2 y1) text-height) 2))
 460                             (:bottom y1))))
 461               (gl:translate xtrans ytrans 0)
 462               (iterate
 463                 (for line in lines)
 464                 (for size in sizes)
 465                 (ftgl:render-font ftgl line :all)
 466                 (gl:translate 0 (+ 3 (second size)) 0)))))))))
 467
 468 (defmacro with-all-pushed-matrixes (&body body)
 469   `(unwind-protect
 470         (progn
 471           (gl:matrix-mode :texture)
 472           (gl:push-matrix)
 473           (gl:matrix-mode :projection)
 474           (gl:push-matrix)
 475           (gl:matrix-mode :modelview)
 476           (gl:push-matrix)
 477           ,@body)
 478      (gl:matrix-mode :texture)
 479      (gl:pop-matrix)
 480      (gl:matrix-mode :projection)
 481      (gl:pop-matrix)
 482      (gl:matrix-mode :modelview)
 483      (gl:pop-matrix)))
 484 \f
 485 (define-condition abort-client () ())
 486 (define-condition restart-inner-client () ())
 487
 488 (defun client ()
 489   (restart-case
 490       (sdl:with-init (sdl:sdl-init-video sdl:sdl-init-joystick)
 491         (loop
 492           (restart-case (inner-client)
 493             (restart-inner-client ()
 494               :report "Restart the INNER-CLIENT while keeping the SDL context alive."
 495               (format-log "restarting inner client")))))
 496     (abort-client ()
 497       :report "Abort CLIENT thread.")))
 498 \f
 499 (defvar *scene-tree*)
 500
 501 (defun run-client (&optional (client #'client))
 502   (cond
 503     ((and (boundp '*client*) (thread-alive-p *client*))
 504      (warn "Client is already running."))
 505     (T
 506      (let* ((locked-deque (or (and (boundp '*messages*) *messages*)
 507                               (make-locked-deque "EXISTENZ-MESSAGES")))
 508             ;; TODO: maybe include *STANDARD-IO-BINDINGS*?
 509             (bindings `((*messages* . ,locked-deque)
 510                         (*package* . #.(find-package '#:existenz-client))
 511                         (*standard-output* . ,*standard-output*)
 512                         ;; TODO: include all the other private variables, i.e. *SCENE-TREE*
 513                         (*scene-tree*)
 514                         (*debug-matrix*))))
 515        (setf *messages* locked-deque
 516              *client* (make-thread client :name "EXISTENZ-CLIENT"
 517                                           :initial-bindings bindings))))))
 518
 519 (defun abort-client ()
 520   (run-in-client (invoke-restart 'abort-client))
 521   (join-thread *client*))
 522
 523 (defun restart-client (&optional (client #'client))
 524   (abort-client)
 525   (run-client client))
 526
 527 (defun restart-inner-client ()
 528   (run-in-client (invoke-restart 'restart-inner-client)))
 529
 530 (defun reset-identity ()
 531   (run-in-client
 532     (gl:matrix-mode :modelview)
 533     (gl:load-identity)))
 534 \f
 535 #+(or)
 536 (progn
 537   (add-font arial-polygon #P"/usr/share/fonts/corefonts/arial.ttf")
 538   (add-font proggy-polygon #P"/usr/share/fonts/ProggyTinySZ.ttf")
 539   (add-image silkscreen-texture #P"~/src/existenz/data/silkscreen.bmp"))
 540 \f
 541 #+(or)
 542 (defun run-client (&optional (host +ipv6-loopback+) (port 4000))
 543   (with-event-base (event-base)
 544     (let ((client (make-socket :ipv6 T
 545                                :type :datagram
 546                                :remote-host host
 547                                :remote-port port
 548                                :reuse-address T)))
 549       (unwind-protect
 550            (send-to client #(1 0 0 3))
 551         (iterate
 552          (when (wait-until-fd-ready (fd-of client) :input)
 553            (multiple-value-bind (buffer length host port)
 554                (receive-from client :size 100)
 555              (format T "received ~A bytes from ~A:~A~%"
 556                      length host port))))
 557         (close client)))))
 558 \f
 559 ;;; scene node / entity protocol
 560
 561 ;;; individual scene nodes build a logical tree of related objects
 562 ;;; one or more spatial trees are independent of them and build orthogonal
 563 ;;; hierarchies, which allows ...
 564 (defgeneric parent (object)
 565   (:documentation "Retrieves the PARENT node of the OBJECT.  This may be
 566 used to traverse the scene tree."))
 567 (defgeneric (setf parent) (new-value object)
 568   (:documentation "Sets the PARENT node of the OBJECT to NEW-VALUE."))
 569
 570 (defgeneric children (object)
 571   (:method ((object T)))
 572   (:documentation "Retrieves the LIST of CHILDREN of the OBJECT.  This may
 573 be used to traverse the scene tree."))
 574 (defgeneric (setf children) (new-value object)
 575   (:documentation "Sets the CHILDREN of the OBJECT to NEW-VALUE."))
 576
 577 (defgeneric transformation (object)
 578   (:method ((object T)))
 579   (:documentation "Retrieves the TRANSFORMATION for OBJECT.  If it has
 580 none, returns NIL instead (default)."))
 581
 582 (defgeneric bounding-box (object)
 583   (:documentation "Retrieves the axis aligned bounding box around around
 584 the OBJECT.  This one is relative to the object.  See
 585 ABSOLUTE-BOUNDING-BOX for the box transformed into absolute world
 586 coordinates."))
 587 (defgeneric absolute-bounding-box (object)
 588   (:documentation "Retrieves the axis aligned bounding box in world
 589 coordinates for OBJECT.  See BOUNDING-BOX to get the relative one
 590 instead."))
 591
 592 (defgeneric animators (object)
 593   (:method ((object T)))
 594   (:documentation "Retrieves the LIST of ANIMATORS of the OBJECT."))
 595 (defgeneric (setf animators) (new-value object)
 596   (:documentation "Sets the ANIMATORS of the OBJECT to NEW-VALUE."))
 597
 598 (defvar *delta-real-elapsed* 0
 599   "Measures real milliseconds since the last UPDATE call.")
 600
 601 (defgeneric update (object)
 602   (:method ((object T)))
 603   (:documentation "Updates an OBJECT when some real time has elapsed.
 604 Does nothing by default.  The elapsed real time is measured in
 605 milliseconds and stored in the global variable *DELTA-REAL-ELAPSED*."))
 606
 607 (defgeneric animate (animator object)
 608   (:method ((animator T) (object T))))
 609
 610 (defgeneric render (object)
 611   (:method ((object T)))
 612   (:documentation "Renders an OBJECT to the screen.  Since objects may be
 613 sorted by some external criteria, iteration over child nodes is done
 614 externally, thus by default child nodes aren't rendered and in fact
 615 nothing is done."))
 616
 617 (defclass scene-node-mixin ()
 618   ((parent
 619     :initarg :parent
 620     :accessor parent
 621     :initform NIL)
 622    (children
 623     :initarg :children
 624     :accessor children
 625     :initform NIL)
 626    (transformation
 627     :initarg :transformation
 628     :accessor transformation
 629     :initform (make-transformation))
 630    (animators
 631     :initarg :animators
 632     :accessor animators
 633     :initform NIL)))
 634 \f
 635 ;;; scene node animators
 636
 637 ;; TODO: this should be angle + velocity, or pure quaternion angle, when
 638 ;; we figure out how to scale it
 639 (defclass animator-rotation ()
 640   ((angle
 641     :initarg :rotation
 642     :accessor rotation
 643     :initform (new-angle-axis))))
 644
 645 ;; TODO: so how does one actually do quaternion scaling? i.e. scaling
 646 ;; below one rotation or applying multiple rotations in one step?
 647 (defmethod animate ((animator animator-rotation) object)
 648   (let ((transformation (transformation object)))
 649     (when transformation
 650       (let ((rotation (relative-rotation transformation)))
 651         (quaternion-setter*
 652          rotation
 653          (quaternion-normalize*
 654           (quaternion-product*
 655             (with-angle-axis (rotation animator)
 656                 (x y z a)
 657               (angle-axis-quaternion*
 658                (angle-axis-values* x y z (* a 0.001 *delta-real-elapsed*))))
 659             (quaternion*
 660              rotation)))))
 661       (setf (relative-dirty-p transformation) T))))
 662 \f
 663 ;;; scene nodes
 664
 665 ;;; distinction between stripped geometry (allocated in not gc'ed memory)
 666 ;;; and lisp-managed geometry
 667
 668 (defclass cube (scene-node-mixin)
 669   ())
 670
 671 (defun make-cube (&optional (width 1.0) (height 1.0) (depth 1.0))
 672   (let ((transformation (make-transformation)))
 673     (setf (relative-scale transformation)
 674           (make-vector3d width height depth))
 675     (make-instance 'cube :transformation transformation)))
 676
 677 (defun render-unit-cube ()
 678   (let ((points #(0 0 0                 ; 0
 679                   1 0 0                 ; 1
 680                   1 1 0                 ; 2
 681                   0 1 0                 ; 3
 682                   0 0 1                 ; 4
 683                   1 0 1                 ; 5
 684                   1 1 1                 ; 6
 685                   0 1 1))               ; 7
 686         (indexes #(0 1 2 3              ; front
 687                    1 5 6 2              ; right
 688                    5 4 7 6              ; back
 689                    4 7 3 0              ; left
 690                    3 2 6 7              ; top
 691                    0 4 5 1)))           ; bottom
 692     (gl:with-primitives :quads
 693       (map NIL (lambda (index)
 694                  (let ((x (aref points (+ (* index 3) 0)))
 695                        (y (aref points (+ (* index 3) 1)))
 696                        (z (aref points (+ (* index 3) 2))))
 697                    (gl:color x y z)
 698                    ;; align cube at 0,0,0
 699                    (gl:vertex (1- (* 2 x)) (1- (* 2 y)) (1- (* 2 z)))))
 700            indexes))))
 701
 702 (defvar *debug-matrix*)
 703
 704 (defun debug-display-matrix (mode)
 705   ;; FIXME: welp, if this is only for debugging okay, but otherwise write
 706   ;; a wrapper, which returns row-major matrixes instead
 707   (setf *debug-matrix*
 708         (make-matrix44*
 709          (transpose-matrix44*
 710           (matrix44*
 711            (gl:get-float
 712             (ecase mode
 713               (:modelview :modelview-matrix)
 714               (:projection :projection-matrix)
 715               (:texture :texture-matrix))))))))
 716
 717 (defmethod render ((cube cube))
 718   (render-unit-cube))
 719 \f
 720 ;;; materials
 721 \f
 722 ;;; scene management
 723
 724 ;;; three structures, logical (scene tree), spatial and render graph
 725
 726 (defun add-scene-node (scene-node)
 727   (push scene-node *scene-tree*))
 728 \f
 729 (defgeneric relative-transformation (object))
 730
 731 (defmethod relative-transformation (object)
 732   (relative-transformation (transformation object)))
 733
 734 (defun translate (object x y z)
 735   (let* ((transformation (transformation object))
 736          (relative (relative-position transformation)))
 737     (vector3d-setter*
 738      relative
 739      (vector3d-sum*
 740       (vector3d* relative)
 741       (vector3d-values* x y z)))
 742     (setf (relative-dirty-p transformation) T)))
 743
 744 ;; TODO: this in all possible permutations and as def-tuple-op
 745 (defun euler-xyz-to-quaternion (x y z)
 746   (let* ((sr (sin (/ x 2)))
 747          (cr (cos (/ x 2)))
 748          (sp (sin (/ y 2)))
 749          (cp (cos (/ y 2)))
 750          (sy (sin (/ z 2)))
 751          (cy (cos (/ z 2)))
 752          (cpcy (* cp cy))
 753          (spcy (* sp cy))
 754          (cpsy (* cp sy))
 755          (spsy (* sp sy)))
 756     (quaternion-normalize*
 757      (quaternion-values*
 758       (- (* sr cpcy) (* cr spsy))
 759       (+ (* cr spcy) (* sr cpsy))
 760       (- (* cr cpsy) (* sr spcy))
 761       (+ (* cr cpcy) (* sr spsy))))))
 762
 763 (defun rotate (object x y z)
 764   (let* ((transformation (transformation object))
 765          (relative (relative-rotation transformation)))
 766     (quaternion-setter*
 767      relative
 768      (quaternion-product*
 769       (quaternion* relative)
 770       (euler-xyz-to-quaternion x y z)))
 771     (setf (relative-dirty-p transformation) T)))
 772
 773 (defun scale (object x y z)
 774   (let* ((transformation (transformation object))
 775          (relative (relative-scale transformation)))
 776     (vector3d-setter*
 777      relative
 778      (vector3d-map* (*)
 779       (vector3d* relative)
 780       (vector3d-values* x y z)))
 781     (setf (relative-dirty-p transformation) T)))
 782
 783 (defgeneric absolute-transformation (object))
 784
 785 (defmethod absolute-transformation (object)
 786   (absolute-transformation (transformation object)))
 787
 788 (defun identity-matrix44 ()
 789   (make-matrix44* (identity-matrix44*)))
 790
 791 (defvar *identity-matrix44* (identity-matrix44))
 792
 793 (defun ones-vector3d ()
 794   (make-vector3d 1.0 1.0 1.0))
 795
 796 (def-tuple-op zero-quaternion*
 797     ()
 798   (:return quaternion
 799            (quaternion-values* 0.0 0.0 0.0 1.0)))
 800
 801 (defun zero-quaternion ()
 802   (make-quaternion*
 803    (zero-quaternion*)))
 804
 805 (def-tuple-op unit-quaternion-x*
 806     ((angle cl-tuples::fast-float))
 807   (:return quaternion
 808            (let ((angle/2 (/ angle 2)))
 809              (quaternion-normalize* (quaternion-values* (sin angle/2) 0.0 0.0 (cos angle/2))))))
 810
 811 (def-tuple-op unit-quaternion-y*
 812     ((angle cl-tuples::fast-float))
 813   (:return quaternion
 814            (let ((angle/2 (/ angle 2)))
 815              (quaternion-normalize* (quaternion-values* 0.0 (sin angle/2) 0.0 (cos angle/2))))))
 816
 817 (def-tuple-op unit-quaternion-z*
 818     ((angle cl-tuples::fast-float))
 819   (:return quaternion
 820            (let ((angle/2 (/ angle 2)))
 821              (quaternion-normalize* (quaternion-values* 0.0 0.0 (sin angle/2) (cos angle/2))))))
 822
 823 (defclass transformation ()
 824   ((relative-position
 825     :initarg :relative-position
 826     :accessor relative-position
 827     :initform (new-vector3d))
 828    (relative-rotation
 829     :initarg :relative-rotation
 830     :accessor relative-rotation
 831     :initform (zero-quaternion))
 832    (relative-scale
 833     :initarg :relative-scale
 834     :accessor relative-scale
 835     :initform (ones-vector3d))
 836    (relative-dirty-p
 837     :initarg :relative-dirty-p
 838     :accessor relative-dirty-p
 839     :initform T)
 840    (relative-transformation
 841     :initarg :relative-transformation
 842     :accessor relative-transformation
 843     :initform (new-matrix44))
 844    (absolute-transformation
 845     :initarg :absolute-transformation
 846     :accessor absolute-transformation
 847     :initform (new-matrix44)))
 848   (:documentation "Contains information about the position, rotation and
 849 scale relative to some other scene node (usually the parent) or the
 850 coordinate origin.  Also contains a scratch slot ABSOLUTE-TRANSFORMATION,
 851 which is used destructively to calculate it."))
 852
 853 (defmethod (setf relative-position) :after (new-value (transformation transformation))
 854   (setf (relative-dirty-p transformation) T))
 855
 856 (defmethod (setf relative-rotation) :after (new-value (transformation transformation))
 857   (setf (relative-dirty-p transformation) T))
 858
 859 (defmethod (setf relative-scale) :after (new-value (transformation transformation))
 860   (setf (relative-dirty-p transformation) T))
 861
 862 (defun calculate-relative-transformation (position rotation scale relative-transformation)
 863   (matrix44-setter*
 864    relative-transformation
 865    (matrix44-product*
 866     (with-vector3d scale (sx sy sz)
 867       (scaling-matrix44* sx sy sz))
 868     (matrix44-product*
 869      (matrix33-matrix44*
 870       (quaternion-matrix33*
 871        (quaternion* rotation)))
 872      (with-vector3d position (tx ty tz)
 873        (translation-matrix44* tx ty tz))))))
 874
 875 (defmethod relative-transformation :before ((transformation transformation))
 876   (when (relative-dirty-p transformation)
 877     (calculate-relative-transformation
 878      (relative-position transformation)
 879      (relative-rotation transformation)
 880      (relative-scale transformation)
 881      (slot-value transformation 'relative-transformation))
 882     (setf (relative-dirty-p transformation) NIL)))
 883
 884 (defun make-transformation ()
 885   (make-instance 'transformation))
 886 \f
 887 ;;; camera
 888
 889 (defclass camera (scene-node-mixin)
 890   ((inverse-absolute-matrix
 891     :initarg :inverse-absolute-matrix
 892     :accessor inverse-absolute-matrix
 893     :initform (new-matrix44)
 894     :documentation "Scratch slot to calculate the inverse transformation.")
 895    (fov
 896     :initarg :fov
 897     :accessor fov
 898     :initform 60)
 899    (clipping-planes
 900     :initarg :clipping-planes
 901     :accessor clipping-planes
 902     :initform (cons 1 1024))))
 903
 904 (defclass fps-camera (camera)
 905   ((relative-rotation
 906     :initarg :relative-rotation
 907     :accessor relative-rotation
 908     :initform (new-vector3d))))
 909
 910 (defgeneric apply-camera-rotation (camera x y z))
 911
 912 (defmethod apply-camera-rotation ((camera camera) rotate-x rotate-y rotate-z)
 913   (symbol-macrolet ((r (relative-rotation (transformation *camera*)))
 914                     (r* (quaternion* r)))
 915     (setf r
 916           (make-quaternion*
 917            (quaternion-product*
 918             (quaternion-product*
 919              (with-vector3d*
 920                  (quaternion-transform-vector3d* (vector3d-values* 0.0 0.0 -1.0) r*)
 921                  (x y z)
 922                (angle-axis-quaternion*
 923                 (angle-axis-values* x y z rotate-z)))
 924              (quaternion-product*
 925               (with-vector3d*
 926                   (quaternion-transform-vector3d* (vector3d-values* 0.0 1.0 0.0) r*)
 927                   (x y z)
 928                 (angle-axis-quaternion*
 929                  (angle-axis-values* x y z rotate-y)))
 930               (with-vector3d*
 931                   (quaternion-transform-vector3d* (vector3d-values* 1.0 0.0 0.0) r*)
 932                   (x y z)
 933                 (angle-axis-quaternion*
 934                  (angle-axis-values* x y z rotate-x)))))
 935             r*)))))
 936
 937 (defconstant +2-pi-fast+
 938   (coerce (* pi 2) 'cl-tuples::fast-float))
 939
 940 (defconstant +-2-pi-fast+
 941   (coerce (- (* pi 2)) 'cl-tuples::fast-float))
 942
 943 (defconstant +pi/2-fast+
 944   (coerce (/ pi 2) 'cl-tuples::fast-float))
 945
 946 (defconstant +-pi/2-fast+
 947   (coerce (- (/ pi 2)) 'cl-tuples::fast-float))
 948
 949 (defmethod apply-camera-rotation ((camera fps-camera) rotate-x rotate-y rotate-z)
 950   (symbol-macrolet ((r (relative-rotation (transformation *camera*)))
 951                     (r* (quaternion* r)))
 952     (with-vector3d
 953         (relative-rotation *camera*)
 954         (old-x old-y old-z)
 955       (with-vector3d*
 956           (vector3d-setter*
 957            (relative-rotation *camera*)
 958            (vector3d-values*
 959             (max +-pi/2-fast+
 960                  (min +pi/2-fast+
 961                       (+ old-x rotate-x)))
 962             (let ((y (+ old-y rotate-y)))
 963               y
 964               #+ (or)
 965               (cond
 966                 ((< y 0) (+ +2-pi-fast+ y))
 967                 ((> y +2-pi-fast+) (+ +-2-pi-fast+ y))
 968                 (T y)))
 969             (let ((z (+ old-z rotate-z)))
 970               z
 971               #+ (or)
 972               (cond
 973                 ((< z 0) (+ +2-pi-fast+ z))
 974                 ((> z +2-pi-fast+) (+ +-2-pi-fast+ z))
 975                 (T z)))
 976             (+ old-z rotate-z)))
 977           (new-x new-y new-z)
 978         ;; (format-log "~F ~F ~F" new-x new-y new-z)
 979         (setf r
 980               #+(or)
 981               (make-quaternion*
 982                (euler-xzy-to-quaternion new-x new-y new-z))
 983               (make-quaternion*
 984                (quaternion-product*
 985                 (unit-quaternion-y* new-y)
 986                 (quaternion-product*
 987                  (unit-quaternion-z* new-z)
 988                  (unit-quaternion-x* new-x)))))))))
 989
 990 (defmethod render ((camera camera))
 991   "Render a placeholder for the invisible CAMERA when debugging.")
 992
 993 (defun make-camera ()
 994   (make-instance 'camera))
 995
 996 (defun make-fps-camera ()
 997   (make-instance 'fps-camera))
 998
 999 ;; http://nehe.gamedev.net/article/replacement_for_gluperspective/21002/
1000 (defun perspective (fov aspect near far)
1001   (let* ((fh (* (tan (* (/ fov 360) pi)) near))
1002          (fw (* fh aspect)))
1003     (gl:frustum (- fw) fw (- fh) fh near far)))
1004
1005 (defun setup-camera (camera)
1006   "Initial setup which affects the OpenGL PROJECTION matrix."
1007   (multiple-value-bind (width height)
1008       (window-resolution)
1009     (let ((planes (clipping-planes camera)))
1010       (gl:matrix-mode :projection)
1011       (gl:load-identity)
1012       (perspective (fov camera) (/ width height)
1013                    (car planes) (cdr planes))
1014       (gl:matrix-mode :modelview))))
1015
1016 (defun calculate-inverse-absolute-matrix (absolute-transformation
1017                                           inverse-absolute-matrix)
1018   ;; (format-log "det ~F" (matrix44-determinant* (matrix44* absolute-transformation)))
1019   (matrix44-setter*
1020    inverse-absolute-matrix
1021    (inverted-matrix44*
1022     (matrix44* absolute-transformation))))
1023
1024 (defun apply-camera-transformation (camera)
1025   ;; same as GLU:LOOK-AT
1026   (let ((inverse-absolute-matrix (inverse-absolute-matrix camera)))
1027     (calculate-inverse-absolute-matrix
1028      (absolute-transformation camera)
1029      inverse-absolute-matrix)
1030     ;; (cl-tuples::print-matrix44* (matrix44* (absolute-transformation camera)))
1031     ;; i.e. column-major mode
1032     (gl:load-transpose-matrix inverse-absolute-matrix)))
1033
1034 (defun calculate-absolute-transformation (absolute relative parent)
1035   (matrix44-setter*
1036    absolute
1037    (matrix44-product*
1038     (matrix44* relative)
1039     (matrix44* parent))))
1040
1041 (defun update-absolute-transformation (object parent-transformation)
1042   (let ((absolute (absolute-transformation object)))
1043     (calculate-absolute-transformation
1044      absolute
1045      (relative-transformation object)
1046      parent-transformation)
1047     absolute))
1048 \f
1049 ;;; video
1050
1051 (defun reset-window ()
1052   ;; FIXME: check these options ...
1053   (multiple-value-call #'sdl:window
1054     (window-resolution)
1055     :position (list 0 0)
1056     :fullscreen (window-fullscreen)
1057     :any-format T
1058     :double-buffer T
1059     :no-frame T
1060     :resizable NIL
1061     :opengl T
1062     :opengl-attributes '((:sdl-gl-doublebuffer 1))
1063     :title-caption "Lisp Game"
1064     :icon-caption "Lisp Game")
1065   (sdl:initialise-default-font)
1066   (sdl:show-cursor NIL))
1067
1068 #+(or)
1069 (break "~A ~A ~A, ~A ~A, ~A ~A ~A, ~A ~A"
1070        (sdl-base:surf-w (sdl:fp sdl-object))
1071        (sdl-base:surf-h (sdl:fp sdl-object))
1072        (sdl-base:pixel-format (sdl:fp sdl-object))
1073        (cffi:foreign-slot-value (sdl-base:pixel-format (sdl:fp sdl-object))
1074                                 'sdl-cffi::sdl-pixel-format 'sdl-cffi::bytesperpixel)
1075        (cffi:foreign-slot-value (sdl-base:pixel-format (sdl:fp sdl-object))
1076                                 'sdl-cffi::sdl-pixel-format 'sdl-cffi::bitsperpixel)
1077        (cffi:foreign-slot-value (sdl-base:pixel-format (sdl:fp sdl-object))
1078                                 'sdl-cffi::sdl-pixel-format 'sdl-cffi::Rmask)
1079        (cffi:foreign-slot-value (sdl-base:pixel-format (sdl:fp sdl-object))
1080                                 'sdl-cffi::sdl-pixel-format 'sdl-cffi::Gmask)
1081        (cffi:foreign-slot-value (sdl-base:pixel-format (sdl:fp sdl-object))
1082                                 'sdl-cffi::sdl-pixel-format 'sdl-cffi::Bmask)
1083        (sdl:with-pixel (pixels (sdl:fp sdl-object))
1084          (multiple-value-list (sdl:read-pixel pixels 0 0)))
1085        (sdl:with-pixel (pixels (sdl:fp sdl-object))
1086          (multiple-value-list (sdl:read-pixel pixels 2 130))))
1087
1088 ;; (defvar *joystick*)
1089
1090 #+(or)
1091 (defun render-debug-joystick ()
1092   (gl:with-primitive :points
1093     (flet ((color (state)
1094              (if (eql 0 state)
1095                  (gl:color 0.0 0.0 0.0)
1096                  (gl:color 1.0 1.0 1.0))))
1097       ;; FIXME: idiotic functions here, it's constant anyway
1098       (color (sdl-cffi::sdl-joystick-get-button *joystick* 0))
1099       (gl:vertex 0 0)
1100
1101       (color (sdl-cffi::sdl-joystick-get-button *joystick* 1))
1102       (gl:vertex 2 0)
1103
1104       (color (sdl-cffi::sdl-joystick-get-button *joystick* 2))
1105       (gl:vertex 4.5 0)
1106
1107       (color (sdl-cffi::sdl-joystick-get-button *joystick* 3))
1108       (gl:vertex 6 0)
1109
1110       (color (sdl-cffi::sdl-joystick-get-button *joystick* 4))
1111       (gl:vertex 0 2)
1112
1113       (color (sdl-cffi::sdl-joystick-get-button *joystick* 5))
1114       (gl:vertex 2 2)
1115
1116       (color (sdl-cffi::sdl-joystick-get-button *joystick* 6))
1117       (gl:vertex 4.5 2)
1118
1119       (color (sdl-cffi::sdl-joystick-get-button *joystick* 7))
1120       (gl:vertex 6 2)
1121
1122       (color (sdl-cffi::sdl-joystick-get-button *joystick* 8))
1123       (gl:vertex 0 4)
1124
1125       (color (sdl-cffi::sdl-joystick-get-button *joystick* 9))
1126       (gl:vertex 2 4)
1127
1128
1129       (color (logand 8 (sdl-cffi::sdl-joystick-get-hat *joystick* 0)))
1130       (gl:vertex 0 8)
1131
1132       (color (logand 1 (sdl-cffi::sdl-joystick-get-hat *joystick* 0)))
1133       (gl:vertex 2 10)
1134
1135       (color (logand 2 (sdl-cffi::sdl-joystick-get-hat *joystick* 0)))
1136       (gl:vertex 4.5 8)
1137
1138       (color (logand 4 (sdl-cffi::sdl-joystick-get-hat *joystick* 0)))
1139       (gl:vertex 2 6)
1140
1141       )))
1142
1143 ;; TODO: show edges, double clicks
1144 (defun render-debug-mouse (&optional (button (sdl::get-mouse-button)))
1145   (gl:with-primitive :points
1146     (flet ((color (mask)
1147              (if (eql 0 (logand button mask))
1148                  (gl:color 0.0 0.0 0.0)
1149                  (gl:color 1.0 1.0 1.0))))
1150       ;; FIXME: idiotic functions here, it's constant anyway
1151       (color #.(sdl-cffi::sdl-button-lmask))
1152       (gl:vertex 0 -2)
1153       (color #.(sdl-cffi::sdl-button-rmask))
1154       (gl:vertex 6 -2)
1155
1156       (color #.(sdl-cffi::sdl-button-mmask))
1157       (gl:vertex 4 0)
1158       (color #.(sdl-cffi::sdl-button-wumask))
1159       (gl:vertex 4 -3)
1160       (color #.(sdl-cffi::sdl-button-wdmask))
1161       (gl:vertex 4 -5)
1162
1163       (color #.(sdl-cffi::sdl-button-x1mask))
1164       (gl:vertex 0 -5)
1165       (color #.(sdl-cffi::sdl-button-x2mask))
1166       (gl:vertex 0 -7))))
1167
1168 (defvar *fix-texture* T)
1169
1170 #+(or)
1171 (defun render-debug-overlay ()
1172   (gl:polygon-mode :front-and-back :fill)
1173   (gl:hint :line-smooth-hint :fastest)
1174   (multiple-value-bind (width height)
1175       (window-resolution)
1176     (gl:color 1 0.5 0.5)
1177     (let ((proggy (resource 'proggy-polygon))
1178           (size 20)
1179           (rect (rectangle 0 0 width height)))
1180       (multiple-value-bind (render-width render-height)
1181           (render-aligned-text
1182            proggy (format NIL "FPS ~3D" (sdl:frame-rate)) size
1183            rect
1184            :vertical :right)
1185         (declare (ignore render-width))
1186         (decf (aref rect 3) (+ render-height 3)))
1187       (when *debug-matrix*
1188         (render-aligned-matrix
1189          proggy *debug-matrix* size
1190          rect
1191          :vertical :right)))))
1192
1193 (defun render-debug-overlay ()
1194   (multiple-value-bind (width height)
1195       (window-resolution)
1196     (gl:with-pushed-matrix
1197       (gl:translate (- width 100) (- height 100) 0)
1198       (render-debug-mouse)
1199       ;; (gl:translate 0 50 0)
1200       ;; (render-debug-joystick)
1201       )
1202     (let ((silkscreen-texture (resource 'silkscreen-texture))
1203           (texture (first (gl:gen-textures 1))))
1204       (ensure-resource silkscreen-texture)
1205       (gl:enable :blend :texture-2d)
1206       (let ((sdl-object (slot-value silkscreen-texture 'sdl-object)))
1207         ;; FIXME: effing hell, scaling to 255 is necessary
1208         (when *fix-texture*
1209           (sdl:with-pixel (pixels (sdl:fp sdl-object))
1210             (iterate
1211               (for x from 0 below (sdl:width sdl-object))
1212               (iterate
1213                 (for y from 0 below (sdl:height sdl-object))
1214                 (when (eql (sdl:read-pixel pixels x y) 0)
1215                   (sdl:write-pixel pixels x y 255))
1216                 (when (eql (sdl:read-pixel pixels x y) 1)
1217                   (sdl:write-pixel pixels x y 0)))))
1218           (setf *fix-texture* NIL))
1219
1220         (gl:bind-texture :texture-2d texture)
1221         (gl:tex-parameter :texture-2d :texture-min-filter :nearest)
1222         (gl:tex-parameter :texture-2d :texture-mag-filter :nearest)
1223         ;; rgba rgba
1224         (gl:tex-image-2d :texture-2d 0 :intensity
1225                          (sdl:width sdl-object)
1226                          (sdl:height sdl-object)
1227                          0 :red
1228                          :unsigned-byte
1229                          (sdl:with-pixel (pixels (sdl:fp sdl-object))
1230                            (sdl:pixel-data pixels)))
1231         (gl:generate-mipmap-ext :texture-2d))
1232       (gl:blend-func :one :one-minus-src-alpha)
1233       (gl:color 1.0 1.0 1.0 1.0)
1234       (let ((fps (format NIL "~D FPS" (floor (sdl:average-fps)))))
1235         (gl:translate (- width (* (length fps) 8)) (- height 8) 0)
1236         (gl:matrix-mode :texture)
1237         (gl:load-identity)
1238         ;; this fixes the inverted loading from bmp format
1239         (gl:scale 1.0 -1.0 1.0)
1240         (gl:matrix-mode :modelview)
1241         (gl:with-primitive :quads
1242           (iterate
1243             (for i from 0)
1244             (for character in-string fps)
1245             (for index = (- (char-code character) 32))
1246             (for (values y x) = (floor index 16))
1247             (setf x (/ x 16) y (- 1 (/ y 16)))
1248             (gl:tex-coord x (- y 1/16))
1249             (gl:vertex (* i 8) 0.0)
1250
1251             (gl:tex-coord (+ x 1/16) (- y 1/16))
1252             (gl:vertex (* (1+ i) 8) 0.0)
1253
1254             (gl:tex-coord (+ x 1/16) y)
1255             (gl:vertex (* (1+ i) 8) 8)
1256
1257             (gl:tex-coord x y)
1258             (gl:vertex (* i 8) 8))))
1259       (gl:bind-texture :texture-2d 0)
1260       (gl:delete-textures (list texture))
1261       (gl:blend-func :one :zero)
1262       (gl:disable :blend :texture-2d))))
1263
1264 (defun render-coordinate-arrows ()
1265   (gl:with-primitive :lines
1266     (gl:color 1 0 0)
1267     (gl:vertex 0 0 0)
1268     (gl:vertex 1 0 0)
1269     (gl:color 0 1 0)
1270     (gl:vertex 0 0 0)
1271     (gl:vertex 0 1 0)
1272     (gl:color 0 0 1)
1273     (gl:vertex 0 0 0)
1274     (gl:vertex 0 0 1)))
1275
1276 #+(or)
1277 (defun render-camera-arrows ()
1278   (gl:with-pushed-matrix
1279     (with-vector3d*
1280         (quaternion-transform-vector3d*
1281          (vector3d-values* 1.0 0.0 0.0)
1282          (quaternion* (relative-rotation (transformation *camera*))))
1283         (x y z)
1284       (gl:with-primitive :lines
1285         (gl:color 1 1 0)
1286         (gl:vertex 0 0 0)
1287         (gl:vertex x y z)))
1288     (with-vector3d*
1289         (quaternion-transform-vector3d*
1290          (vector3d-values* 0.0 1.0 0.0)
1291          (quaternion* (relative-rotation (transformation *camera*))))
1292         (x y z)
1293       (gl:with-primitive :lines
1294         (gl:color 0 1 1)
1295         (gl:vertex 0 0 0)
1296         (gl:vertex x y z)))
1297     (with-vector3d*
1298         (quaternion-transform-vector3d*
1299          (vector3d-values* 0.0 0.0 -1.0)
1300          (quaternion* (relative-rotation (transformation *camera*))))
1301         (x y z)
1302       (gl:with-primitive :lines
1303         (gl:color 1 0 1)
1304         (gl:vertex 0 0 0)
1305         (gl:vertex x y z)))))
1306
1307 (defun update-scene-tree (scene-tree)
1308   (setf *delta-real-elapsed* (sdl::delta-ticks sdl:*default-fpsmanager*))
1309   (labels ((aux (list parent-transformation)
1310              (dolist (object list)
1311                (update object)
1312                (dolist (animator (animators object))
1313                  (animate animator object))
1314                (aux (children object)
1315                     (update-absolute-transformation
1316                      object
1317                      parent-transformation)))))
1318     (aux scene-tree *identity-matrix44*)))
1319
1320 (defvar *once* T)
1321
1322 (defun render-scene-tree (scene-tree)
1323   (labels ((aux (list)
1324              (dolist (object list)
1325                (let ((transformation (transformation object)))
1326                  (when transformation
1327                    (gl:push-matrix)
1328                    ;; transpose, because opengl uses column-major mode for
1329                    ;; matrixes
1330                    ;; TODO: also, have some c-level buffer here instead of
1331                    ;; allocating all other the place
1332                    (gl:mult-transpose-matrix
1333                     (make-matrix44*
1334                       (matrix44*
1335                        (relative-transformation transformation)))))
1336                  ;; TODO: maybe this UNWIND-PROTECT can be omitted, i.e.
1337                  ;; "there'll be no errors", or if there are, a trashed
1338                  ;; OpenGL state is the least of our problems?
1339                  (unwind-protect
1340                       (progn
1341                         (render object)
1342                         (aux (children object)))
1343                    (when transformation
1344                      (gl:pop-matrix)))))))
1345     (aux scene-tree)))
1346
1347 (defun render-frame ()
1348   ;; TODO: assert the correct matrix mode here and reset if necessary
1349   (gl:clear :color-buffer :depth-buffer)
1350   ;; TODO: protect us from clobbering the setup?  look at the matrix
1351   ;; stack and reset if necessary
1352   (with-all-pushed-matrixes
1353     (setup-3d)
1354     (gl:enable :depth-test)
1355     (gl:with-pushed-matrix
1356       (gl:scale 10 10 10)
1357       ;; TODO: render on "inside" the gui layer, i.e. in front of the
1358       ;; scene and rotate it to match the view orientation, like in
1359       ;; blender
1360       (render-coordinate-arrows))
1361     ;; (render-camera-arrows)
1362     (render-scene-tree *scene-tree*))
1363   (with-all-pushed-matrixes
1364     (setup-2d)
1365     (gl:with-pushed-matrix
1366       (render-debug-overlay)))
1367   (sdl:update-display))
1368 \f
1369 ;; (gl:shader-source fragment-shader-object (list fragment-shader))
1370 ;; (gl:compile-shader fragment-shader-object)
1371 ;; (format T "~A~%" (gl:get-shader-info-log fragment-shader-object))
1372 ;; (gl:attach-shader program-object fragment-shader-object)
1373
1374 ;; (gl:shader-source vertex-shader-object (list vertex-shader))
1375 ;; (gl:compile-shader vertex-shader-object)
1376 ;; (format T "~A~%" (gl:get-shader-info-log vertex-shader-object))
1377 ;; (gl:attach-shader program-object vertex-shader-object)
1378
1379 ;; (gl:link-program program-object)
1380 ;; (format T "~A~%" (gl:get-program-info-log program-object))
1381 ;; (gl:use-program program-object)
1382
1383 ;; (fragment-shader (read-file-into-string "../data/shaders/green.glsl"))
1384 ;; (fragment-shader-object (gl:create-shader :fragment-shader))
1385 ;; (vertex-shader (read-file-into-string "../data/shaders/scale.glsl"))
1386 ;; (vertex-shader-object (gl:create-shader :vertex-shader))
1387 ;; (program-object (gl:create-program))
1388
1389            ;; rotate around global z
1390            ;; which is more fps like
1391            #+(or)
1392            (unit-quaternion-y* rotate-y)
1393
1394 #+ (or)
1395 (defun apply-camera-rotation (rotate-x rotate-y rotate-z)
1396   (with-vector3d
1397       (relative-rotation *camera*)
1398       (old-x old-y old-z)
1399     (with-vector3d*
1400         (vector3d-sum*
1401          (vector3d-values* old-x old-y old-z)
1402          (vector3d-values* rotate-x rotate-y (- rotate-z)))
1403         (new-x new-y new-z)
1404       (vector3d-setter*
1405        (relative-rotation *camera*)
1406        (vector3d-values* new-x new-y new-z)))))
1407
1408 (defun inner-client ()
1409   (load-options)
1410   (reset-window)
1411   (reset-opengl)
1412   (setup-camera (setf *camera* (make-fps-camera)))
1413   (add-scene-node *camera*)
1414   (setf (relative-position (transformation *camera*)) (make-vector3d 10.0 0.0 0.0))
1415   (setf (sdl:frame-rate) 30)
1416   (with-all-resources
1417     (load-all-resources)
1418     (sdl:enable-unicode)
1419     (let ((rotate-x 0.0)
1420           (rotate-y 0.0)
1421           (rotate-z 0.0)
1422           (translate-x 0.0)
1423           (translate-y 0.0)
1424           (translate-z 0.0)
1425           (capture-mouse-p T))
1426       (sdl:with-events ()
1427         (:active-event (:gain gain)
1428                        ;; FIXME: this needs better handling of the actual state, not just gain
1429                        (if (eql gain 0)
1430                            (progn
1431                              (sdl:show-cursor T)
1432                              (setf capture-mouse-p NIL))
1433                            (progn
1434                              (sdl:show-cursor NIL)
1435                              (setf capture-mouse-p T))))
1436         (:quit-event () T)
1437         (:video-expose-event () (render-frame))
1438         (:key-down-event (:key key :unicode unicode)
1439                          (declare (ignore unicode))
1440                          (case key
1441                            (:sdl-key-a (setf translate-x -10.0))
1442                            (:sdl-key-d (setf translate-x 10.0))
1443                            (:sdl-key-w (setf translate-z -10.0))
1444                            (:sdl-key-s (setf translate-z 10.0))
1445                            (:sdl-key-space (setf translate-y 10.0))
1446                            (:sdl-key-lctrl (setf translate-y -10.0))
1447                            (:sdl-key-q (setf rotate-z (to-radian -0.5)))
1448                            (:sdl-key-e (setf rotate-z (to-radian 0.5)))
1449                            (:sdl-key-f
1450                             (setf *window-fullscreen* (not *window-fullscreen*))
1451                             (reset-window)
1452                             (reset-opengl)
1453                             (setup-camera *camera*))
1454                            (:sdl-key-escape
1455                             (invoke-restart 'abort-client))))
1456         (:key-up-event (:key key :unicode unicode)
1457                        (declare (ignore unicode))
1458                        (case key
1459                          (:sdl-key-a (setf translate-x 0.0))
1460                          (:sdl-key-d (setf translate-x 0.0))
1461                          (:sdl-key-w (setf translate-z 0.0))
1462                          (:sdl-key-s (setf translate-z 0.0))
1463                          (:sdl-key-q (setf rotate-z 0.0))
1464                          (:sdl-key-e (setf rotate-z 0.0))
1465                          (:sdl-key-space (setf translate-y 0.0))
1466                          (:sdl-key-lctrl (setf translate-y 0.0))))
1467         (:mouse-button-down-event ())
1468         (:mouse-button-up-event ())
1469         (:joy-button-down-event ())
1470         (:mouse-motion-event (:state state :x x :y y :x-rel xrel :y-rel yrel)
1471                              (declare (ignore state x y))
1472                              (setf rotate-y (* xrel (to-radian 0.5)))
1473                              (setf rotate-x (* yrel (to-radian 0.5)))
1474                              (when capture-mouse-p
1475                                (multiple-value-bind (width height)
1476                                    (window-resolution)
1477                                  (sdl-cffi::sdl-warp-mouse (floor width 2) (floor height 2)))))
1478         (:idle ()
1479                (handle-messages *messages*)
1480                (update-scene-tree *scene-tree*)
1481                (restart-case
1482                    (progn
1483                      ;; TODO: limit rotation around x
1484                      (apply-fps-camera-rotation rotate-x rotate-y rotate-z)
1485                      ;; FIXME: vector3d-x expands into wrong code
1486                      (setf (relative-position (transformation *camera*))
1487                            (make-vector3d*
1488                             (vector3d-sum*
1489                              (vector3d* (relative-position (transformation *camera*)))
1490                              (quaternion-transform-vector3d*
1491                               (vector3d-scale*
1492                                (vector3d-values* translate-x translate-y translate-z)
1493                                (* 0.001 *delta-real-elapsed*))
1494                               (quaternion* (relative-rotation (transformation *camera*)))))))
1495                      ;; rotate-z left out, because it's controlled by keyboard
1496                      (setf rotate-x 0.0 rotate-y 0.0 ;; rotate-z 0.0
1497                            )
1498                      (render-frame))
1499                  (continue ()
1500                    :report "Continue with the next frame.")))))))
1501 \f
1502 ;; seems like the direct calculation has some signs inverted
1503 #+(or)
1504 (defun test (x y z)
1505   (setf x (coerce x 'cl-tuples::fast-float)
1506         y (coerce y 'cl-tuples::fast-float)
1507         z (coerce z 'cl-tuples::fast-float))
1508   (let* ((sr (sin (/ x 2)))
1509          (cr (cos (/ x 2)))
1510          (sp (sin (/ y 2)))
1511          (cp (cos (/ y 2)))
1512          (sy (sin (/ z 2)))
1513          (cy (cos (/ z 2)))
1514          (cpcy (* cp cy))
1515          (spcy (* sp cy))
1516          (cpsy (* cp sy))
1517          (spsy (* sp sy)))
1518     (values
1519      #-(or)
1520      (make-quaternion*
1521       (quaternion-normalize*
1522        (quaternion-values*
1523         (- (* sr cpcy) (* cr spsy))
1524         (+ (* cr spcy) (* sr cpsy))
1525         (- (* cr cpsy) (* sr spcy))
1526         (+ (* cr cpcy) (* sr spsy)))))
1527      #-(or)
1528      (make-quaternion*
1529       (quaternion-normalize*
1530        (quaternion-product*
1531         (quaternion-product*
1532          (unit-quaternion-x* z)
1533          (unit-quaternion-y* x))
1534         (unit-quaternion-z* y)))))))
1535
1536 ;; no, this doesn't work at all
1537 #+(or)
1538 (make-quaternion*
1539  (quaternion-normalize*
1540   (quaternion-product*
1541    (quaternion* (euler-xyz-to-quaternion rotate-x rotate-y rotate-z))
1542    (quaternion* (relative-rotation (transformation *camera*))))))