From 49826d4d8725473aa76784f2f940021adf44a37d Mon Sep 17 00:00:00 2001 From: Olof-Joachim Frahm Date: Thu, 6 Mar 2014 23:44:01 +0100 Subject: [PATCH 1/1] Initial commit. --- DESIGN.md | 66 ++ IDEAS.md | 38 ++ client/client.lisp | 1542 ++++++++++++++++++++++++++++++++++++++++++++ client/config.lisp | 7 + client/joystick.lisp | 99 +++ client/package.lisp | 19 + common/entity.lisp | 9 + common/options.lisp | 44 ++ common/package.lisp | 23 + common/syntax.lisp | 38 ++ common/transformation.lisp | 92 +++ common/wavefront.lisp | 185 ++++++ existenz-client.asd | 25 + existenz-common.asd | 25 + existenz-server.asd | 21 + hacks.lisp | 20 + server/package.lisp | 19 + server/server.lisp | 105 +++ 18 files changed, 2377 insertions(+) create mode 100644 DESIGN.md create mode 100644 IDEAS.md create mode 100644 client/client.lisp create mode 100644 client/config.lisp create mode 100644 client/joystick.lisp create mode 100644 client/package.lisp create mode 100644 common/entity.lisp create mode 100644 common/options.lisp create mode 100644 common/package.lisp create mode 100644 common/syntax.lisp create mode 100644 common/transformation.lisp create mode 100644 common/wavefront.lisp create mode 100644 existenz-client.asd create mode 100644 existenz-common.asd create mode 100644 existenz-server.asd create mode 100644 hacks.lisp create mode 100644 server/package.lisp create mode 100644 server/server.lisp diff --git a/DESIGN.md b/DESIGN.md new file mode 100644 index 0000000..7284d9b --- /dev/null +++ b/DESIGN.md @@ -0,0 +1,66 @@ +# Virtual 3D address space + +Each *plane* is a separate space where objects exist and actors can +move around. Each *plane* is a torus, i.e. at the end of the address +space the coordinates wrap around. *Cells* are the smallest unit which +can be mapped to servers, which simulate them. The association between +cells and servers is done via DNS(?). The same risks apply. + +Clients receive and send sensations and actions from and to *virtual +addresses*, which are then routed to the underlying servers. +*Subscriptions* define which messages a client is interested in. +Servers may serve less events in case permissions or the simulation +itself don't allow for them to be served to a particular client (think +visibility or fog of war). + +*Federation* between servers in the grid is necessary to handle overlap +and transition between cells as well as event relay to adjacent cells. + +All *objects* in the world are instances of *blueprints* from the server +database. Blueprints are cryptographically signed packages of assets, +code and other metadata, which can be taken with you from server to +server. A server might not run your objects, but could give you a +temporary replacement. Ownership and trust is managed analogous to +Bitcoin and the GPG web of trust. Your identity is linked to an account +on another server, which manages your assets, however only concensus +opinion is ultimately valid as a proof of ownership etc. + +Special rules depend on the server settings. + +The common protocol allows for integration of various quality levels, +assets and other web infrastructure. + +# Limits + +- Coordinates: -2^62+1 to 2^62-1 signed integers used as fixed point + floats where the basic unit is 1000, i.e. down to millimeter scale. + This presumably allows faster/smaller implementation on languages with + GC and tagged representation of fixnums. +- Cells: Depends on hardware limits and base scale, e.g. in the area of + 1km to 10km cubes. However given the current state and in the + foreseeable future cells of this size should be good enough. Future + iterations may co-locate cells on the same server and/or raise the + cell sizes. + +# Protocol + +- Events: Binary frames in custom protocol. +- World information, objects, etc: Might be shared as structured text + form data, i.e. SEXP/JSON/XML. +- Content exchange: Via direct connection, server download, or + distributed, i.e. Bittorrent. + +A single server instance can run one or more cells. From the point of +view of a client a proxy can distribute load and provide a single +address to access a network of simulated cells. + ++---------------------------------------------+ +-------.. +| +--------+ +--------+ +--------+ +--------+ | | +--------+ +| |CELL ...| |CELL 23 | |CELL 24 | |CELL ...| +--+ |CELL ...| +| +--------+ +--------+ +--------+ +--------+ +--+ +--------+ +| SERVER 1 | | SERVER ... ++------+------------+------------+------------+ +----+--.. + | | | | + +----+-----+ +----+-----+ +----+-----+ | + |CLIENT ...| |CLIENT 42 | |CLIENT ...+--------------/ + +----------+ +----------+ +----------+ diff --git a/IDEAS.md b/IDEAS.md new file mode 100644 index 0000000..d734bf4 --- /dev/null +++ b/IDEAS.md @@ -0,0 +1,38 @@ +;;; 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 diff --git a/client/client.lisp b/client/client.lisp new file mode 100644 index 0000000..fcfd8a6 --- /dev/null +++ b/client/client.lisp @@ -0,0 +1,1542 @@ +;;; -*- mode: lisp; syntax: common-lisp; package: existenz-client; coding: utf-8-unix; -*- + +(in-package #:existenz-client) + +;;; ideas +;;; - bridge between blender and engine, in addition to inotify-watching. +;;; this will be best possible with some ready to run rpc framework, +;; i.e. xmlrpc.server.SimpleXMLRPCServer +;;; source files if no bridge is available +;;; - interaction with windows messaging, i.e. enable powermenu +;;; - config.lisp loading a la emacs +;;; - ensure conversion to CL-TUPLES::FAST-FLOAT on system boundaries, +;;; also add normalization and test for divergence on low optimization +;;; levels to *every* operation +;;; - be sure about the coordinate systems, i.e. 2d+gui/3d +;;; - how to do networking (iolib? or some other plain library?), sound +;;; (openal)? +;;; - serialization? cl-store or something else? +;;; - FINALIZE as per its description, i.e. register closures to directly +;;; deallocate the nested resources. since this may occur in any thread, +;;; unloading of textures needs to be pushed to the main/opengl thread - +;;; the same goes for other values (openal?) similarly. it may be +;;; possible to still retain often used resources in a separate cache, +;;; but that's just icing then. better make a state-chart for all this +;;; behaviour, i.e. when is a resource (successfully) loaded, what +;;; happens at what stage +;;; - replace missing resources with placeholders, which may still be +;;; corrected, i.e. by saving a file to the wanted name, or correcting +;;; an invalid file +;;; - resource lookup by what? filesystem like? how are different +;;; authors sufficiently discriminated against? + +;;; future future ideas +;;; - bytecode vm for scripting? targeted to mathematics, i.e. full +;;; regular tower + vectors + matrixes + quaternions, which then may be +;;; optimized somehow + +;;; every object in the world is in the scene tree and in the spatial +;;; trees. if an object is removed, it is removed from all trees. if +;;; an object moves, it has to be reinserted in some of the spatial trees, +;;; also if it changes its scale, rotation and furthermore its actual +;;; geometry + +;; nice, but doesn't work with eldoc, so it's kinda useless +#+(or) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro package-calls (package &body body) + (setf package (find-package package)) + `(progn + ,.(mapcar (lambda (form) + (let (car found) + (if (and (listp form) + (setf car (car form)) + (symbolp car) + (setf found (find-symbol + (symbol-name car) + package))) + `(,found ,.(cdr form)) + form))) + body))) + + (defmacro gl (&body body) + `(package-calls #.(find-package '#:gl) ,@body))) + +(defvar *window-width*) +(defvar *window-height*) +(defvar *window-fullscreen*) + +(push '(window-resolution . (640 480)) *options*) +(push '(window-fullscreen . (NIL)) *options*) + +(push '(window-resolution *window-width* *window-height*) *options-mappings*) +(push '(window-fullscreen *window-fullscreen*) *options-mappings*) + +;;; message passing to the client main thread + +(defvar *client*) +(defvar *messages*) + +(defun send-to-client (object) + (cond + ((not (boundp '*client*)) + (warn "*CLIENT* is unbound")) + ((not *client*) + (warn "*CLIENT* has no value")) + ((not (thread-alive-p *client*)) + (warn "*CLIENT* isn't running")) + (T + (prog1 T (enqueue *messages* object))))) + +(defmacro run-in-client (&body body) + `(send-to-client (lambda () ,@body))) + +(defun handle-message (message) + (etypecase message + (function + (handler-case (funcall message) + (error (error) + (warn "ERROR occured while executing ~A: ~A" message error)))))) + +(defun handle-messages (locked-deque) + (let ((messages (dequeue-all locked-deque))) + (mapc #'handle-message messages))) + +;;; resources + +(defvar *resources* (make-hash-table :test 'eq)) + +(defgeneric unload-resource (resource) + (:documentation "Explicitely deallocate the RESOURCE and disable the +finalizer (see MAKE-RESOURCE-FINALIZER).")) +(defgeneric make-resource-finalizer (resource) + (:documentation "Returns a FUNCTION, which takes care of cleaning up +resources in the correct threads when the RESOURCE is gc'ed. Note the +rules for FINALIZE apply, i.e. the closure may not reference the RESOURCE +object, or it won't ever be collected.")) +(defgeneric load-resource (resource)) +(defgeneric resource-loaded-p (resource) + (:documentation "A resource may fail to load, but by using placeholder +values, it can still be used. Of course, this only works for some objects, +e.g. textures.")) + +(defun map-resources (function) + (maphash + (lambda (name resource) + (declare (ignore name)) + (funcall function resource)) + *resources*)) + +(defun load-all-resources (&optional force) + (map-resources + (lambda (resource) + (when (or (not (resource-loaded-p resource)) force) + (load-resource resource))))) + +(defun unload-all-resources () + (map-resources #'unload-resource)) + +(defmacro with-all-resources (&body body) + `(unwind-protect + (progn + ,@body) + (unload-all-resources))) + +(defun get-resource (name) + (gethash name *resources*)) + +(defun %delete-resource (name) + (awhen (get-resource name) + (unload-resource it) + (remhash name *resources*))) + +(defun %add-resource (name new) + (symbol-macrolet ((resource (gethash name *resources*))) + (let ((old resource)) + (when old + (unload-resource old) + (load-resource new)) + (setf resource new)))) + +(defun add-resource (name new) + "Adds the NEW resource. For the moment all resources are loaded in the +main thread." + ;; TODO: wait for client to execute it, then return the object + (unless (run-in-client (%add-resource name new)) + (setf (gethash name *resources*) new)) + new) + +(defun delete-resource (name) + (unless (run-in-client (%delete-resource name)) + (remhash name *resources*))) + +(define-condition undefined-resource (error) + ((resource-name :initarg :resource-name :reader resource-name)) + (:report + (lambda (condition stream) + (format stream "Undefined RESOURCE ~A requested." + (resource-name condition))))) + +(defun resource (name) + (let ((resource (get-resource name))) + (unless resource + (error 'undefined-resource :resource-name name)) + resource)) + +(defclass resource () + ((name :type symbol :initarg :name))) + +(defmethod unload-resource :around (resource) + (when (resource-loaded-p resource) + (call-next-method))) + +(defmethod load-resource :before (resource) + (when (resource-loaded-p resource) + (unload-resource resource))) + +(defmethod load-resource :after (resource) + (format-log "loaded resource ~A" resource)) + +(defmethod unload-resource :after (resource) + (format-log "unloaded resource ~A" resource)) + +(defun ensure-resource (resource) + (unless (resource-loaded-p resource) + (load-resource resource))) + +(defmethod print-object ((resource resource) stream) + (if *print-readably* + (prin1 (make-load-form resource) stream) + (print-unreadable-object (resource stream :type T :identity T) + (with-slots (name) resource + (format stream "~A ~A" + name (if (resource-loaded-p resource) + 'loaded 'unloaded)))))) + +(defclass pathname-mixin () + ((pathname :initarg :pathname))) + +;;; fonts + +#+(or) +(deftype font-mode () + `(member :textured :polygon)) + +#+(or) +(defvar *default-font-mode* :textured) + +#+(or) +(defclass font (pathname-mixin resource) + ((ftgl-object :initform NIL) + (mode :initarg :mode))) + +#+(or) +(defun make-font (name pathname &key (mode *default-font-mode*)) + (check-type mode font-mode) + (make-instance 'font :name name :pathname pathname :mode mode)) + +#+(or) +(defmethod unload-resource ((font font)) + (with-slots (ftgl-object) font + (let ((object ftgl-object)) + (setf ftgl-object NIL) + (cancel-finalization object) + (ftgl:destroy-font object)))) + +#+(or) +(defmethod load-resource ((font font)) + (with-slots (pathname ftgl-object mode) font + (let ((object (funcall (case mode + (:textured #'ftgl:create-texture-font) + (:polygon #'ftgl:create-polygon-font)) + pathname))) + (finalize object #'ftgl:destroy-font) + (setf ftgl-object object) + (ftgl:set-font-face-size object 36 90) + (ftgl:set-font-char-map object :unicode)))) + +#+(or) +(defmethod resource-loaded-p ((font font)) + (and (slot-value font 'ftgl-object) T)) + +#+(or) +(defmacro add-font (name pathname &key (mode NIL modep)) + `(add-resource + ',name + (make-font ',name ,pathname ,@(when modep (list :mode mode))))) + +#+(or) +(defmethod make-load-form ((font font) &optional environment) + (declare (ignore environment)) + (with-slots (name pathname mode) font + `(add-font ,name ,pathname ,mode))) + +;;; images + +(defclass image (pathname-mixin resource) + ((sdl-object :initform NIL))) + +(defun make-image (name pathname) + (make-instance 'image :name name :pathname pathname)) + +;; TODO: um, is the free necessary? +(defmethod unload-resource ((image image)) + (with-slots (sdl-object) image + (sdl:free (shiftf sdl-object NIL)))) + +;; TODO: and then, is this necessary? specific thread? +(defmethod make-resource-finalizer ((image image)) + (with-slots (sdl-object) image + (lambda () + (sdl:free sdl-object)))) + +(defmethod load-resource ((image image)) + (with-slots (pathname sdl-object) image + (setf sdl-object (sdl:load-image pathname)))) + +(defmethod resource-loaded-p ((image image)) + (and (slot-value image 'sdl-object) T)) + +(defmacro add-image (name pathname) + `(add-resource ',name (make-image ',name ,pathname))) + +(defmethod make-load-form ((image image) &optional environment) + (declare (ignore environment)) + (with-slots (name pathname) image + `(add-image ,name ,pathname))) + +;;; shaders + +;;; multiple shaders are linked into a program, but they can already be +;;; compiled beforehand + +;; (defclass shader (pathname-mixin resource) +;; ((shader-object :initform NIL))) + +;; (defun make-shader (name pathname) +;; (make-instance 'shader :name name :pathname pathname)) + +;; (defmethod unload-resource ((shader shader)) +;; (with-slots (shader-object + +;;; reloading resources on change + +;;; entities + +;;; distinction between stripped geometry (allocated in not gc'ed memory) +;;; and lisp-managed geometry + +(defun make-static-geometry (geometry) + geometry) + +(defclass cube () + ((dimensions :initarg :dimensions))) + +(defgeneric render-object (object)) + +(defvar *debug-matrix*) + +(defmethod render-object ((cube cube)) + (let* ((dimensions (slot-value cube 'dimensions)) + (w (aref dimensions 0)) + (d (aref dimensions 1)) + (h (aref dimensions 2)) + ;; TODO: make static macros for this using some permutation + ;; algorithm + ) + (debug-display-matrix :modelview) + (gl:scale w d h) + (render-unit-cube))) + +;;; materials + +;;; video + +(defun window-resolution () + (values *window-width* *window-height*)) + +(defun window-fullscreen () + *window-fullscreen*) + +(defun set-window-resolution (width height) + (setf *window-width* width + *window-height* height)) + +(defun reset-opengl () + (multiple-value-bind (width height) + (window-resolution) + (gl:viewport 0 0 width height) + (gl:matrix-mode :projection) + (gl:load-identity) + (gl:matrix-mode :modelview) + (gl:load-identity) + (gl:clear-color 0.2 0.2 0.2 0))) + +(defvar *camera*) + +(defun setup-3d () + (apply-camera-transformation *camera*)) + +(defun setup-2d () + (multiple-value-bind (width height) + (window-resolution) + (gl:matrix-mode :projection) + (gl:load-identity) + (gl:ortho 0 width 0 height -1 1) + (gl:matrix-mode :modelview))) + +(defun bbox-size (bbox) + (values + (+ (fourth bbox) (max 0 (first bbox))) + (+ (fifth bbox) (max 0 (second bbox))))) + +(defun rectangle (x1 y1 x2 y2) + (vector x1 y1 x2 y2)) + +(defmacro with-rectangle ((rect &optional (x1 'x1) (y1 'y1) (x2 'x2) (y2 'y2)) &body body) + "Destructures the rectangle RECT into the components named by the given +symbols X1 to Y2 for the duration of BODY." + (let ((rect-sym (gensym)) + (ref 'aref)) + `(let* ((,rect-sym ,rect) + (,x1 (,ref ,rect-sym 0)) + (,y1 (,ref ,rect-sym 1)) + (,x2 (,ref ,rect-sym 2)) + (,y2 (,ref ,rect-sym 3))) + ,@body))) + +#+(or) +(defun render-aligned-text (font string size rect &key (vertical :left) (horizontal :top) (resolution 75)) + (let ((ftgl (slot-value font 'ftgl-object))) + (ftgl:set-font-face-size ftgl size resolution) + (multiple-value-bind (text-width text-height) + (bbox-size (ftgl:get-font-bbox ftgl string)) + (setf text-width (fceiling text-width) + text-height (fceiling text-height)) + (gl:with-pushed-matrix + (with-rectangle (rect) + (multiple-value-bind (xtrans ytrans) + (values (ecase vertical + (:left x1) + (:center (/ (- (- x2 x1) text-width) 2)) + (:right (- x2 text-width))) + (ecase horizontal + (:top (- y2 text-height)) + (:center (/ (- (- y2 y1) text-height) 2)) + (:bottom y1))) + (gl:translate xtrans ytrans 0))) + (ftgl:render-font ftgl string :all)) + (values text-width text-height)))) + +#+(or) +(defun render-aligned-matrix (font matrix size rect &key (vertical :left) (horizontal :top) (resolution 75)) + (flet ((format-line (matrix offset) + (format NIL "~8,3F ~8,3F ~8,3F ~8,3F" + (aref matrix (+ offset 0)) + (aref matrix (+ offset 1)) + (aref matrix (+ offset 2)) + (aref matrix (+ offset 3))))) + (let* ((lines (iterate + (for i from 0 to 15 by 4) + (collect (format-line matrix i)))) + (ftgl (slot-value font 'ftgl-object))) + (ftgl:set-font-face-size ftgl size resolution) + (let* ((sizes (mapcar (lambda (line) (multiple-value-list (bbox-size (ftgl:get-font-bbox ftgl line)))) lines)) + (bbox (reduce (lambda (size1 size2) (list (max (first size1) (first size2)) + (+ (second size1) (second size2)))) + sizes))) + (gl:with-pushed-matrix + (with-rectangle (rect) + (multiple-value-bind (xtrans ytrans) + (destructuring-bind (text-width text-height) bbox + (incf text-height (* 3 3)) ; three gaps, three pixels + (values (ecase vertical + (:left x1) + (:center (/ (- (- x2 x1) text-width) 2)) + (:right (- x2 text-width))) + (ecase horizontal + (:top (- y2 text-height)) + (:center (/ (- (- y2 y1) text-height) 2)) + (:bottom y1)))) + (gl:translate xtrans ytrans 0) + (iterate + (for line in lines) + (for size in sizes) + (ftgl:render-font ftgl line :all) + (gl:translate 0 (+ 3 (second size)) 0))))))))) + +(defmacro with-all-pushed-matrixes (&body body) + `(unwind-protect + (progn + (gl:matrix-mode :texture) + (gl:push-matrix) + (gl:matrix-mode :projection) + (gl:push-matrix) + (gl:matrix-mode :modelview) + (gl:push-matrix) + ,@body) + (gl:matrix-mode :texture) + (gl:pop-matrix) + (gl:matrix-mode :projection) + (gl:pop-matrix) + (gl:matrix-mode :modelview) + (gl:pop-matrix))) + +(define-condition abort-client () ()) +(define-condition restart-inner-client () ()) + +(defun client () + (restart-case + (sdl:with-init (sdl:sdl-init-video sdl:sdl-init-joystick) + (loop + (restart-case (inner-client) + (restart-inner-client () + :report "Restart the INNER-CLIENT while keeping the SDL context alive." + (format-log "restarting inner client"))))) + (abort-client () + :report "Abort CLIENT thread."))) + +(defvar *scene-tree*) + +(defun run-client (&optional (client #'client)) + (cond + ((and (boundp '*client*) (thread-alive-p *client*)) + (warn "Client is already running.")) + (T + (let* ((locked-deque (or (and (boundp '*messages*) *messages*) + (make-locked-deque "EXISTENZ-MESSAGES"))) + ;; TODO: maybe include *STANDARD-IO-BINDINGS*? + (bindings `((*messages* . ,locked-deque) + (*package* . #.(find-package '#:existenz-client)) + (*standard-output* . ,*standard-output*) + ;; TODO: include all the other private variables, i.e. *SCENE-TREE* + (*scene-tree*) + (*debug-matrix*)))) + (setf *messages* locked-deque + *client* (make-thread client :name "EXISTENZ-CLIENT" + :initial-bindings bindings)))))) + +(defun abort-client () + (run-in-client (invoke-restart 'abort-client)) + (join-thread *client*)) + +(defun restart-client (&optional (client #'client)) + (abort-client) + (run-client client)) + +(defun restart-inner-client () + (run-in-client (invoke-restart 'restart-inner-client))) + +(defun reset-identity () + (run-in-client + (gl:matrix-mode :modelview) + (gl:load-identity))) + +#+(or) +(progn + (add-font arial-polygon #P"/usr/share/fonts/corefonts/arial.ttf") + (add-font proggy-polygon #P"/usr/share/fonts/ProggyTinySZ.ttf") + (add-image silkscreen-texture #P"~/src/existenz/data/silkscreen.bmp")) + +#+(or) +(defun run-client (&optional (host +ipv6-loopback+) (port 4000)) + (with-event-base (event-base) + (let ((client (make-socket :ipv6 T + :type :datagram + :remote-host host + :remote-port port + :reuse-address T))) + (unwind-protect + (send-to client #(1 0 0 3)) + (iterate + (when (wait-until-fd-ready (fd-of client) :input) + (multiple-value-bind (buffer length host port) + (receive-from client :size 100) + (format T "received ~A bytes from ~A:~A~%" + length host port)))) + (close client))))) + +;;; scene node / entity protocol + +;;; individual scene nodes build a logical tree of related objects +;;; one or more spatial trees are independent of them and build orthogonal +;;; hierarchies, which allows ... +(defgeneric parent (object) + (:documentation "Retrieves the PARENT node of the OBJECT. This may be +used to traverse the scene tree.")) +(defgeneric (setf parent) (new-value object) + (:documentation "Sets the PARENT node of the OBJECT to NEW-VALUE.")) + +(defgeneric children (object) + (:method ((object T))) + (:documentation "Retrieves the LIST of CHILDREN of the OBJECT. This may +be used to traverse the scene tree.")) +(defgeneric (setf children) (new-value object) + (:documentation "Sets the CHILDREN of the OBJECT to NEW-VALUE.")) + +(defgeneric transformation (object) + (:method ((object T))) + (:documentation "Retrieves the TRANSFORMATION for OBJECT. If it has +none, returns NIL instead (default).")) + +(defgeneric bounding-box (object) + (:documentation "Retrieves the axis aligned bounding box around around +the OBJECT. This one is relative to the object. See +ABSOLUTE-BOUNDING-BOX for the box transformed into absolute world +coordinates.")) +(defgeneric absolute-bounding-box (object) + (:documentation "Retrieves the axis aligned bounding box in world +coordinates for OBJECT. See BOUNDING-BOX to get the relative one +instead.")) + +(defgeneric animators (object) + (:method ((object T))) + (:documentation "Retrieves the LIST of ANIMATORS of the OBJECT.")) +(defgeneric (setf animators) (new-value object) + (:documentation "Sets the ANIMATORS of the OBJECT to NEW-VALUE.")) + +(defvar *delta-real-elapsed* 0 + "Measures real milliseconds since the last UPDATE call.") + +(defgeneric update (object) + (:method ((object T))) + (:documentation "Updates an OBJECT when some real time has elapsed. +Does nothing by default. The elapsed real time is measured in +milliseconds and stored in the global variable *DELTA-REAL-ELAPSED*.")) + +(defgeneric animate (animator object) + (:method ((animator T) (object T)))) + +(defgeneric render (object) + (:method ((object T))) + (:documentation "Renders an OBJECT to the screen. Since objects may be +sorted by some external criteria, iteration over child nodes is done +externally, thus by default child nodes aren't rendered and in fact +nothing is done.")) + +(defclass scene-node-mixin () + ((parent + :initarg :parent + :accessor parent + :initform NIL) + (children + :initarg :children + :accessor children + :initform NIL) + (transformation + :initarg :transformation + :accessor transformation + :initform (make-transformation)) + (animators + :initarg :animators + :accessor animators + :initform NIL))) + +;;; scene node animators + +;; TODO: this should be angle + velocity, or pure quaternion angle, when +;; we figure out how to scale it +(defclass animator-rotation () + ((angle + :initarg :rotation + :accessor rotation + :initform (new-angle-axis)))) + +;; TODO: so how does one actually do quaternion scaling? i.e. scaling +;; below one rotation or applying multiple rotations in one step? +(defmethod animate ((animator animator-rotation) object) + (let ((transformation (transformation object))) + (when transformation + (let ((rotation (relative-rotation transformation))) + (quaternion-setter* + rotation + (quaternion-normalize* + (quaternion-product* + (with-angle-axis (rotation animator) + (x y z a) + (angle-axis-quaternion* + (angle-axis-values* x y z (* a 0.001 *delta-real-elapsed*)))) + (quaternion* + rotation))))) + (setf (relative-dirty-p transformation) T)))) + +;;; scene nodes + +;;; distinction between stripped geometry (allocated in not gc'ed memory) +;;; and lisp-managed geometry + +(defclass cube (scene-node-mixin) + ()) + +(defun make-cube (&optional (width 1.0) (height 1.0) (depth 1.0)) + (let ((transformation (make-transformation))) + (setf (relative-scale transformation) + (make-vector3d width height depth)) + (make-instance 'cube :transformation transformation))) + +(defun render-unit-cube () + (let ((points #(0 0 0 ; 0 + 1 0 0 ; 1 + 1 1 0 ; 2 + 0 1 0 ; 3 + 0 0 1 ; 4 + 1 0 1 ; 5 + 1 1 1 ; 6 + 0 1 1)) ; 7 + (indexes #(0 1 2 3 ; front + 1 5 6 2 ; right + 5 4 7 6 ; back + 4 7 3 0 ; left + 3 2 6 7 ; top + 0 4 5 1))) ; bottom + (gl:with-primitives :quads + (map NIL (lambda (index) + (let ((x (aref points (+ (* index 3) 0))) + (y (aref points (+ (* index 3) 1))) + (z (aref points (+ (* index 3) 2)))) + (gl:color x y z) + ;; align cube at 0,0,0 + (gl:vertex (1- (* 2 x)) (1- (* 2 y)) (1- (* 2 z))))) + indexes)))) + +(defvar *debug-matrix*) + +(defun debug-display-matrix (mode) + ;; FIXME: welp, if this is only for debugging okay, but otherwise write + ;; a wrapper, which returns row-major matrixes instead + (setf *debug-matrix* + (make-matrix44* + (transpose-matrix44* + (matrix44* + (gl:get-float + (ecase mode + (:modelview :modelview-matrix) + (:projection :projection-matrix) + (:texture :texture-matrix)))))))) + +(defmethod render ((cube cube)) + (render-unit-cube)) + +;;; materials + +;;; scene management + +;;; three structures, logical (scene tree), spatial and render graph + +(defun add-scene-node (scene-node) + (push scene-node *scene-tree*)) + +(defgeneric relative-transformation (object)) + +(defmethod relative-transformation (object) + (relative-transformation (transformation object))) + +(defun translate (object x y z) + (let* ((transformation (transformation object)) + (relative (relative-position transformation))) + (vector3d-setter* + relative + (vector3d-sum* + (vector3d* relative) + (vector3d-values* x y z))) + (setf (relative-dirty-p transformation) T))) + +;; TODO: this in all possible permutations and as def-tuple-op +(defun euler-xyz-to-quaternion (x y z) + (let* ((sr (sin (/ x 2))) + (cr (cos (/ x 2))) + (sp (sin (/ y 2))) + (cp (cos (/ y 2))) + (sy (sin (/ z 2))) + (cy (cos (/ z 2))) + (cpcy (* cp cy)) + (spcy (* sp cy)) + (cpsy (* cp sy)) + (spsy (* sp sy))) + (quaternion-normalize* + (quaternion-values* + (- (* sr cpcy) (* cr spsy)) + (+ (* cr spcy) (* sr cpsy)) + (- (* cr cpsy) (* sr spcy)) + (+ (* cr cpcy) (* sr spsy)))))) + +(defun rotate (object x y z) + (let* ((transformation (transformation object)) + (relative (relative-rotation transformation))) + (quaternion-setter* + relative + (quaternion-product* + (quaternion* relative) + (euler-xyz-to-quaternion x y z))) + (setf (relative-dirty-p transformation) T))) + +(defun scale (object x y z) + (let* ((transformation (transformation object)) + (relative (relative-scale transformation))) + (vector3d-setter* + relative + (vector3d-map* (*) + (vector3d* relative) + (vector3d-values* x y z))) + (setf (relative-dirty-p transformation) T))) + +(defgeneric absolute-transformation (object)) + +(defmethod absolute-transformation (object) + (absolute-transformation (transformation object))) + +(defun identity-matrix44 () + (make-matrix44* (identity-matrix44*))) + +(defvar *identity-matrix44* (identity-matrix44)) + +(defun ones-vector3d () + (make-vector3d 1.0 1.0 1.0)) + +(def-tuple-op zero-quaternion* + () + (:return quaternion + (quaternion-values* 0.0 0.0 0.0 1.0))) + +(defun zero-quaternion () + (make-quaternion* + (zero-quaternion*))) + +(def-tuple-op unit-quaternion-x* + ((angle cl-tuples::fast-float)) + (:return quaternion + (let ((angle/2 (/ angle 2))) + (quaternion-normalize* (quaternion-values* (sin angle/2) 0.0 0.0 (cos angle/2)))))) + +(def-tuple-op unit-quaternion-y* + ((angle cl-tuples::fast-float)) + (:return quaternion + (let ((angle/2 (/ angle 2))) + (quaternion-normalize* (quaternion-values* 0.0 (sin angle/2) 0.0 (cos angle/2)))))) + +(def-tuple-op unit-quaternion-z* + ((angle cl-tuples::fast-float)) + (:return quaternion + (let ((angle/2 (/ angle 2))) + (quaternion-normalize* (quaternion-values* 0.0 0.0 (sin angle/2) (cos angle/2)))))) + +(defclass transformation () + ((relative-position + :initarg :relative-position + :accessor relative-position + :initform (new-vector3d)) + (relative-rotation + :initarg :relative-rotation + :accessor relative-rotation + :initform (zero-quaternion)) + (relative-scale + :initarg :relative-scale + :accessor relative-scale + :initform (ones-vector3d)) + (relative-dirty-p + :initarg :relative-dirty-p + :accessor relative-dirty-p + :initform T) + (relative-transformation + :initarg :relative-transformation + :accessor relative-transformation + :initform (new-matrix44)) + (absolute-transformation + :initarg :absolute-transformation + :accessor absolute-transformation + :initform (new-matrix44))) + (:documentation "Contains information about the position, rotation and +scale relative to some other scene node (usually the parent) or the +coordinate origin. Also contains a scratch slot ABSOLUTE-TRANSFORMATION, +which is used destructively to calculate it.")) + +(defmethod (setf relative-position) :after (new-value (transformation transformation)) + (setf (relative-dirty-p transformation) T)) + +(defmethod (setf relative-rotation) :after (new-value (transformation transformation)) + (setf (relative-dirty-p transformation) T)) + +(defmethod (setf relative-scale) :after (new-value (transformation transformation)) + (setf (relative-dirty-p transformation) T)) + +(defun calculate-relative-transformation (position rotation scale relative-transformation) + (matrix44-setter* + relative-transformation + (matrix44-product* + (with-vector3d scale (sx sy sz) + (scaling-matrix44* sx sy sz)) + (matrix44-product* + (matrix33-matrix44* + (quaternion-matrix33* + (quaternion* rotation))) + (with-vector3d position (tx ty tz) + (translation-matrix44* tx ty tz)))))) + +(defmethod relative-transformation :before ((transformation transformation)) + (when (relative-dirty-p transformation) + (calculate-relative-transformation + (relative-position transformation) + (relative-rotation transformation) + (relative-scale transformation) + (slot-value transformation 'relative-transformation)) + (setf (relative-dirty-p transformation) NIL))) + +(defun make-transformation () + (make-instance 'transformation)) + +;;; camera + +(defclass camera (scene-node-mixin) + ((inverse-absolute-matrix + :initarg :inverse-absolute-matrix + :accessor inverse-absolute-matrix + :initform (new-matrix44) + :documentation "Scratch slot to calculate the inverse transformation.") + (fov + :initarg :fov + :accessor fov + :initform 60) + (clipping-planes + :initarg :clipping-planes + :accessor clipping-planes + :initform (cons 1 1024)))) + +(defclass fps-camera (camera) + ((relative-rotation + :initarg :relative-rotation + :accessor relative-rotation + :initform (new-vector3d)))) + +(defgeneric apply-camera-rotation (camera x y z)) + +(defmethod apply-camera-rotation ((camera camera) rotate-x rotate-y rotate-z) + (symbol-macrolet ((r (relative-rotation (transformation *camera*))) + (r* (quaternion* r))) + (setf r + (make-quaternion* + (quaternion-product* + (quaternion-product* + (with-vector3d* + (quaternion-transform-vector3d* (vector3d-values* 0.0 0.0 -1.0) r*) + (x y z) + (angle-axis-quaternion* + (angle-axis-values* x y z rotate-z))) + (quaternion-product* + (with-vector3d* + (quaternion-transform-vector3d* (vector3d-values* 0.0 1.0 0.0) r*) + (x y z) + (angle-axis-quaternion* + (angle-axis-values* x y z rotate-y))) + (with-vector3d* + (quaternion-transform-vector3d* (vector3d-values* 1.0 0.0 0.0) r*) + (x y z) + (angle-axis-quaternion* + (angle-axis-values* x y z rotate-x))))) + r*))))) + +(defconstant +2-pi-fast+ + (coerce (* pi 2) 'cl-tuples::fast-float)) + +(defconstant +-2-pi-fast+ + (coerce (- (* pi 2)) 'cl-tuples::fast-float)) + +(defconstant +pi/2-fast+ + (coerce (/ pi 2) 'cl-tuples::fast-float)) + +(defconstant +-pi/2-fast+ + (coerce (- (/ pi 2)) 'cl-tuples::fast-float)) + +(defmethod apply-camera-rotation ((camera fps-camera) rotate-x rotate-y rotate-z) + (symbol-macrolet ((r (relative-rotation (transformation *camera*))) + (r* (quaternion* r))) + (with-vector3d + (relative-rotation *camera*) + (old-x old-y old-z) + (with-vector3d* + (vector3d-setter* + (relative-rotation *camera*) + (vector3d-values* + (max +-pi/2-fast+ + (min +pi/2-fast+ + (+ old-x rotate-x))) + (let ((y (+ old-y rotate-y))) + y + #+ (or) + (cond + ((< y 0) (+ +2-pi-fast+ y)) + ((> y +2-pi-fast+) (+ +-2-pi-fast+ y)) + (T y))) + (let ((z (+ old-z rotate-z))) + z + #+ (or) + (cond + ((< z 0) (+ +2-pi-fast+ z)) + ((> z +2-pi-fast+) (+ +-2-pi-fast+ z)) + (T z))) + (+ old-z rotate-z))) + (new-x new-y new-z) + ;; (format-log "~F ~F ~F" new-x new-y new-z) + (setf r + #+(or) + (make-quaternion* + (euler-xzy-to-quaternion new-x new-y new-z)) + (make-quaternion* + (quaternion-product* + (unit-quaternion-y* new-y) + (quaternion-product* + (unit-quaternion-z* new-z) + (unit-quaternion-x* new-x))))))))) + +(defmethod render ((camera camera)) + "Render a placeholder for the invisible CAMERA when debugging.") + +(defun make-camera () + (make-instance 'camera)) + +(defun make-fps-camera () + (make-instance 'fps-camera)) + +;; http://nehe.gamedev.net/article/replacement_for_gluperspective/21002/ +(defun perspective (fov aspect near far) + (let* ((fh (* (tan (* (/ fov 360) pi)) near)) + (fw (* fh aspect))) + (gl:frustum (- fw) fw (- fh) fh near far))) + +(defun setup-camera (camera) + "Initial setup which affects the OpenGL PROJECTION matrix." + (multiple-value-bind (width height) + (window-resolution) + (let ((planes (clipping-planes camera))) + (gl:matrix-mode :projection) + (gl:load-identity) + (perspective (fov camera) (/ width height) + (car planes) (cdr planes)) + (gl:matrix-mode :modelview)))) + +(defun calculate-inverse-absolute-matrix (absolute-transformation + inverse-absolute-matrix) + ;; (format-log "det ~F" (matrix44-determinant* (matrix44* absolute-transformation))) + (matrix44-setter* + inverse-absolute-matrix + (inverted-matrix44* + (matrix44* absolute-transformation)))) + +(defun apply-camera-transformation (camera) + ;; same as GLU:LOOK-AT + (let ((inverse-absolute-matrix (inverse-absolute-matrix camera))) + (calculate-inverse-absolute-matrix + (absolute-transformation camera) + inverse-absolute-matrix) + ;; (cl-tuples::print-matrix44* (matrix44* (absolute-transformation camera))) + ;; i.e. column-major mode + (gl:load-transpose-matrix inverse-absolute-matrix))) + +(defun calculate-absolute-transformation (absolute relative parent) + (matrix44-setter* + absolute + (matrix44-product* + (matrix44* relative) + (matrix44* parent)))) + +(defun update-absolute-transformation (object parent-transformation) + (let ((absolute (absolute-transformation object))) + (calculate-absolute-transformation + absolute + (relative-transformation object) + parent-transformation) + absolute)) + +;;; video + +(defun reset-window () + ;; FIXME: check these options ... + (multiple-value-call #'sdl:window + (window-resolution) + :position (list 0 0) + :fullscreen (window-fullscreen) + :any-format T + :double-buffer T + :no-frame T + :resizable NIL + :opengl T + :opengl-attributes '((:sdl-gl-doublebuffer 1)) + :title-caption "Lisp Game" + :icon-caption "Lisp Game") + (sdl:initialise-default-font) + (sdl:show-cursor NIL)) + +#+(or) +(break "~A ~A ~A, ~A ~A, ~A ~A ~A, ~A ~A" + (sdl-base:surf-w (sdl:fp sdl-object)) + (sdl-base:surf-h (sdl:fp sdl-object)) + (sdl-base:pixel-format (sdl:fp sdl-object)) + (cffi:foreign-slot-value (sdl-base:pixel-format (sdl:fp sdl-object)) + 'sdl-cffi::sdl-pixel-format 'sdl-cffi::bytesperpixel) + (cffi:foreign-slot-value (sdl-base:pixel-format (sdl:fp sdl-object)) + 'sdl-cffi::sdl-pixel-format 'sdl-cffi::bitsperpixel) + (cffi:foreign-slot-value (sdl-base:pixel-format (sdl:fp sdl-object)) + 'sdl-cffi::sdl-pixel-format 'sdl-cffi::Rmask) + (cffi:foreign-slot-value (sdl-base:pixel-format (sdl:fp sdl-object)) + 'sdl-cffi::sdl-pixel-format 'sdl-cffi::Gmask) + (cffi:foreign-slot-value (sdl-base:pixel-format (sdl:fp sdl-object)) + 'sdl-cffi::sdl-pixel-format 'sdl-cffi::Bmask) + (sdl:with-pixel (pixels (sdl:fp sdl-object)) + (multiple-value-list (sdl:read-pixel pixels 0 0))) + (sdl:with-pixel (pixels (sdl:fp sdl-object)) + (multiple-value-list (sdl:read-pixel pixels 2 130)))) + +;; (defvar *joystick*) + +#+(or) +(defun render-debug-joystick () + (gl:with-primitive :points + (flet ((color (state) + (if (eql 0 state) + (gl:color 0.0 0.0 0.0) + (gl:color 1.0 1.0 1.0)))) + ;; FIXME: idiotic functions here, it's constant anyway + (color (sdl-cffi::sdl-joystick-get-button *joystick* 0)) + (gl:vertex 0 0) + + (color (sdl-cffi::sdl-joystick-get-button *joystick* 1)) + (gl:vertex 2 0) + + (color (sdl-cffi::sdl-joystick-get-button *joystick* 2)) + (gl:vertex 4.5 0) + + (color (sdl-cffi::sdl-joystick-get-button *joystick* 3)) + (gl:vertex 6 0) + + (color (sdl-cffi::sdl-joystick-get-button *joystick* 4)) + (gl:vertex 0 2) + + (color (sdl-cffi::sdl-joystick-get-button *joystick* 5)) + (gl:vertex 2 2) + + (color (sdl-cffi::sdl-joystick-get-button *joystick* 6)) + (gl:vertex 4.5 2) + + (color (sdl-cffi::sdl-joystick-get-button *joystick* 7)) + (gl:vertex 6 2) + + (color (sdl-cffi::sdl-joystick-get-button *joystick* 8)) + (gl:vertex 0 4) + + (color (sdl-cffi::sdl-joystick-get-button *joystick* 9)) + (gl:vertex 2 4) + + + (color (logand 8 (sdl-cffi::sdl-joystick-get-hat *joystick* 0))) + (gl:vertex 0 8) + + (color (logand 1 (sdl-cffi::sdl-joystick-get-hat *joystick* 0))) + (gl:vertex 2 10) + + (color (logand 2 (sdl-cffi::sdl-joystick-get-hat *joystick* 0))) + (gl:vertex 4.5 8) + + (color (logand 4 (sdl-cffi::sdl-joystick-get-hat *joystick* 0))) + (gl:vertex 2 6) + + ))) + +;; TODO: show edges, double clicks +(defun render-debug-mouse (&optional (button (sdl::get-mouse-button))) + (gl:with-primitive :points + (flet ((color (mask) + (if (eql 0 (logand button mask)) + (gl:color 0.0 0.0 0.0) + (gl:color 1.0 1.0 1.0)))) + ;; FIXME: idiotic functions here, it's constant anyway + (color #.(sdl-cffi::sdl-button-lmask)) + (gl:vertex 0 -2) + (color #.(sdl-cffi::sdl-button-rmask)) + (gl:vertex 6 -2) + + (color #.(sdl-cffi::sdl-button-mmask)) + (gl:vertex 4 0) + (color #.(sdl-cffi::sdl-button-wumask)) + (gl:vertex 4 -3) + (color #.(sdl-cffi::sdl-button-wdmask)) + (gl:vertex 4 -5) + + (color #.(sdl-cffi::sdl-button-x1mask)) + (gl:vertex 0 -5) + (color #.(sdl-cffi::sdl-button-x2mask)) + (gl:vertex 0 -7)))) + +(defvar *fix-texture* T) + +#+(or) +(defun render-debug-overlay () + (gl:polygon-mode :front-and-back :fill) + (gl:hint :line-smooth-hint :fastest) + (multiple-value-bind (width height) + (window-resolution) + (gl:color 1 0.5 0.5) + (let ((proggy (resource 'proggy-polygon)) + (size 20) + (rect (rectangle 0 0 width height))) + (multiple-value-bind (render-width render-height) + (render-aligned-text + proggy (format NIL "FPS ~3D" (sdl:frame-rate)) size + rect + :vertical :right) + (declare (ignore render-width)) + (decf (aref rect 3) (+ render-height 3))) + (when *debug-matrix* + (render-aligned-matrix + proggy *debug-matrix* size + rect + :vertical :right))))) + +(defun render-debug-overlay () + (multiple-value-bind (width height) + (window-resolution) + (gl:with-pushed-matrix + (gl:translate (- width 100) (- height 100) 0) + (render-debug-mouse) + ;; (gl:translate 0 50 0) + ;; (render-debug-joystick) + ) + (let ((silkscreen-texture (resource 'silkscreen-texture)) + (texture (first (gl:gen-textures 1)))) + (ensure-resource silkscreen-texture) + (gl:enable :blend :texture-2d) + (let ((sdl-object (slot-value silkscreen-texture 'sdl-object))) + ;; FIXME: effing hell, scaling to 255 is necessary + (when *fix-texture* + (sdl:with-pixel (pixels (sdl:fp sdl-object)) + (iterate + (for x from 0 below (sdl:width sdl-object)) + (iterate + (for y from 0 below (sdl:height sdl-object)) + (when (eql (sdl:read-pixel pixels x y) 0) + (sdl:write-pixel pixels x y 255)) + (when (eql (sdl:read-pixel pixels x y) 1) + (sdl:write-pixel pixels x y 0))))) + (setf *fix-texture* NIL)) + + (gl:bind-texture :texture-2d texture) + (gl:tex-parameter :texture-2d :texture-min-filter :nearest) + (gl:tex-parameter :texture-2d :texture-mag-filter :nearest) + ;; rgba rgba + (gl:tex-image-2d :texture-2d 0 :intensity + (sdl:width sdl-object) + (sdl:height sdl-object) + 0 :red + :unsigned-byte + (sdl:with-pixel (pixels (sdl:fp sdl-object)) + (sdl:pixel-data pixels))) + (gl:generate-mipmap-ext :texture-2d)) + (gl:blend-func :one :one-minus-src-alpha) + (gl:color 1.0 1.0 1.0 1.0) + (let ((fps (format NIL "~D FPS" (floor (sdl:average-fps))))) + (gl:translate (- width (* (length fps) 8)) (- height 8) 0) + (gl:matrix-mode :texture) + (gl:load-identity) + ;; this fixes the inverted loading from bmp format + (gl:scale 1.0 -1.0 1.0) + (gl:matrix-mode :modelview) + (gl:with-primitive :quads + (iterate + (for i from 0) + (for character in-string fps) + (for index = (- (char-code character) 32)) + (for (values y x) = (floor index 16)) + (setf x (/ x 16) y (- 1 (/ y 16))) + (gl:tex-coord x (- y 1/16)) + (gl:vertex (* i 8) 0.0) + + (gl:tex-coord (+ x 1/16) (- y 1/16)) + (gl:vertex (* (1+ i) 8) 0.0) + + (gl:tex-coord (+ x 1/16) y) + (gl:vertex (* (1+ i) 8) 8) + + (gl:tex-coord x y) + (gl:vertex (* i 8) 8)))) + (gl:bind-texture :texture-2d 0) + (gl:delete-textures (list texture)) + (gl:blend-func :one :zero) + (gl:disable :blend :texture-2d)))) + +(defun render-coordinate-arrows () + (gl:with-primitive :lines + (gl:color 1 0 0) + (gl:vertex 0 0 0) + (gl:vertex 1 0 0) + (gl:color 0 1 0) + (gl:vertex 0 0 0) + (gl:vertex 0 1 0) + (gl:color 0 0 1) + (gl:vertex 0 0 0) + (gl:vertex 0 0 1))) + +#+(or) +(defun render-camera-arrows () + (gl:with-pushed-matrix + (with-vector3d* + (quaternion-transform-vector3d* + (vector3d-values* 1.0 0.0 0.0) + (quaternion* (relative-rotation (transformation *camera*)))) + (x y z) + (gl:with-primitive :lines + (gl:color 1 1 0) + (gl:vertex 0 0 0) + (gl:vertex x y z))) + (with-vector3d* + (quaternion-transform-vector3d* + (vector3d-values* 0.0 1.0 0.0) + (quaternion* (relative-rotation (transformation *camera*)))) + (x y z) + (gl:with-primitive :lines + (gl:color 0 1 1) + (gl:vertex 0 0 0) + (gl:vertex x y z))) + (with-vector3d* + (quaternion-transform-vector3d* + (vector3d-values* 0.0 0.0 -1.0) + (quaternion* (relative-rotation (transformation *camera*)))) + (x y z) + (gl:with-primitive :lines + (gl:color 1 0 1) + (gl:vertex 0 0 0) + (gl:vertex x y z))))) + +(defun update-scene-tree (scene-tree) + (setf *delta-real-elapsed* (sdl::delta-ticks sdl:*default-fpsmanager*)) + (labels ((aux (list parent-transformation) + (dolist (object list) + (update object) + (dolist (animator (animators object)) + (animate animator object)) + (aux (children object) + (update-absolute-transformation + object + parent-transformation))))) + (aux scene-tree *identity-matrix44*))) + +(defvar *once* T) + +(defun render-scene-tree (scene-tree) + (labels ((aux (list) + (dolist (object list) + (let ((transformation (transformation object))) + (when transformation + (gl:push-matrix) + ;; transpose, because opengl uses column-major mode for + ;; matrixes + ;; TODO: also, have some c-level buffer here instead of + ;; allocating all other the place + (gl:mult-transpose-matrix + (make-matrix44* + (matrix44* + (relative-transformation transformation))))) + ;; TODO: maybe this UNWIND-PROTECT can be omitted, i.e. + ;; "there'll be no errors", or if there are, a trashed + ;; OpenGL state is the least of our problems? + (unwind-protect + (progn + (render object) + (aux (children object))) + (when transformation + (gl:pop-matrix))))))) + (aux scene-tree))) + +(defun render-frame () + ;; TODO: assert the correct matrix mode here and reset if necessary + (gl:clear :color-buffer :depth-buffer) + ;; TODO: protect us from clobbering the setup? look at the matrix + ;; stack and reset if necessary + (with-all-pushed-matrixes + (setup-3d) + (gl:enable :depth-test) + (gl:with-pushed-matrix + (gl:scale 10 10 10) + ;; TODO: render on "inside" the gui layer, i.e. in front of the + ;; scene and rotate it to match the view orientation, like in + ;; blender + (render-coordinate-arrows)) + ;; (render-camera-arrows) + (render-scene-tree *scene-tree*)) + (with-all-pushed-matrixes + (setup-2d) + (gl:with-pushed-matrix + (render-debug-overlay))) + (sdl:update-display)) + +;; (gl:shader-source fragment-shader-object (list fragment-shader)) +;; (gl:compile-shader fragment-shader-object) +;; (format T "~A~%" (gl:get-shader-info-log fragment-shader-object)) +;; (gl:attach-shader program-object fragment-shader-object) + +;; (gl:shader-source vertex-shader-object (list vertex-shader)) +;; (gl:compile-shader vertex-shader-object) +;; (format T "~A~%" (gl:get-shader-info-log vertex-shader-object)) +;; (gl:attach-shader program-object vertex-shader-object) + +;; (gl:link-program program-object) +;; (format T "~A~%" (gl:get-program-info-log program-object)) +;; (gl:use-program program-object) + +;; (fragment-shader (read-file-into-string "../data/shaders/green.glsl")) +;; (fragment-shader-object (gl:create-shader :fragment-shader)) +;; (vertex-shader (read-file-into-string "../data/shaders/scale.glsl")) +;; (vertex-shader-object (gl:create-shader :vertex-shader)) +;; (program-object (gl:create-program)) + + ;; rotate around global z + ;; which is more fps like + #+(or) + (unit-quaternion-y* rotate-y) + +#+ (or) +(defun apply-camera-rotation (rotate-x rotate-y rotate-z) + (with-vector3d + (relative-rotation *camera*) + (old-x old-y old-z) + (with-vector3d* + (vector3d-sum* + (vector3d-values* old-x old-y old-z) + (vector3d-values* rotate-x rotate-y (- rotate-z))) + (new-x new-y new-z) + (vector3d-setter* + (relative-rotation *camera*) + (vector3d-values* new-x new-y new-z))))) + +(defun inner-client () + (load-options) + (reset-window) + (reset-opengl) + (setup-camera (setf *camera* (make-fps-camera))) + (add-scene-node *camera*) + (setf (relative-position (transformation *camera*)) (make-vector3d 10.0 0.0 0.0)) + (setf (sdl:frame-rate) 30) + (with-all-resources + (load-all-resources) + (sdl:enable-unicode) + (let ((rotate-x 0.0) + (rotate-y 0.0) + (rotate-z 0.0) + (translate-x 0.0) + (translate-y 0.0) + (translate-z 0.0) + (capture-mouse-p T)) + (sdl:with-events () + (:active-event (:gain gain) + ;; FIXME: this needs better handling of the actual state, not just gain + (if (eql gain 0) + (progn + (sdl:show-cursor T) + (setf capture-mouse-p NIL)) + (progn + (sdl:show-cursor NIL) + (setf capture-mouse-p T)))) + (:quit-event () T) + (:video-expose-event () (render-frame)) + (:key-down-event (:key key :unicode unicode) + (declare (ignore unicode)) + (case key + (:sdl-key-a (setf translate-x -10.0)) + (:sdl-key-d (setf translate-x 10.0)) + (:sdl-key-w (setf translate-z -10.0)) + (:sdl-key-s (setf translate-z 10.0)) + (:sdl-key-space (setf translate-y 10.0)) + (:sdl-key-lctrl (setf translate-y -10.0)) + (:sdl-key-q (setf rotate-z (to-radian -0.5))) + (:sdl-key-e (setf rotate-z (to-radian 0.5))) + (:sdl-key-f + (setf *window-fullscreen* (not *window-fullscreen*)) + (reset-window) + (reset-opengl) + (setup-camera *camera*)) + (:sdl-key-escape + (invoke-restart 'abort-client)))) + (:key-up-event (:key key :unicode unicode) + (declare (ignore unicode)) + (case key + (:sdl-key-a (setf translate-x 0.0)) + (:sdl-key-d (setf translate-x 0.0)) + (:sdl-key-w (setf translate-z 0.0)) + (:sdl-key-s (setf translate-z 0.0)) + (:sdl-key-q (setf rotate-z 0.0)) + (:sdl-key-e (setf rotate-z 0.0)) + (:sdl-key-space (setf translate-y 0.0)) + (:sdl-key-lctrl (setf translate-y 0.0)))) + (:mouse-button-down-event ()) + (:mouse-button-up-event ()) + (:joy-button-down-event ()) + (:mouse-motion-event (:state state :x x :y y :x-rel xrel :y-rel yrel) + (declare (ignore state x y)) + (setf rotate-y (* xrel (to-radian 0.5))) + (setf rotate-x (* yrel (to-radian 0.5))) + (when capture-mouse-p + (multiple-value-bind (width height) + (window-resolution) + (sdl-cffi::sdl-warp-mouse (floor width 2) (floor height 2))))) + (:idle () + (handle-messages *messages*) + (update-scene-tree *scene-tree*) + (restart-case + (progn + ;; TODO: limit rotation around x + (apply-fps-camera-rotation rotate-x rotate-y rotate-z) + ;; FIXME: vector3d-x expands into wrong code + (setf (relative-position (transformation *camera*)) + (make-vector3d* + (vector3d-sum* + (vector3d* (relative-position (transformation *camera*))) + (quaternion-transform-vector3d* + (vector3d-scale* + (vector3d-values* translate-x translate-y translate-z) + (* 0.001 *delta-real-elapsed*)) + (quaternion* (relative-rotation (transformation *camera*))))))) + ;; rotate-z left out, because it's controlled by keyboard + (setf rotate-x 0.0 rotate-y 0.0 ;; rotate-z 0.0 + ) + (render-frame)) + (continue () + :report "Continue with the next frame."))))))) + +;; seems like the direct calculation has some signs inverted +#+(or) +(defun test (x y z) + (setf x (coerce x 'cl-tuples::fast-float) + y (coerce y 'cl-tuples::fast-float) + z (coerce z 'cl-tuples::fast-float)) + (let* ((sr (sin (/ x 2))) + (cr (cos (/ x 2))) + (sp (sin (/ y 2))) + (cp (cos (/ y 2))) + (sy (sin (/ z 2))) + (cy (cos (/ z 2))) + (cpcy (* cp cy)) + (spcy (* sp cy)) + (cpsy (* cp sy)) + (spsy (* sp sy))) + (values + #-(or) + (make-quaternion* + (quaternion-normalize* + (quaternion-values* + (- (* sr cpcy) (* cr spsy)) + (+ (* cr spcy) (* sr cpsy)) + (- (* cr cpsy) (* sr spcy)) + (+ (* cr cpcy) (* sr spsy))))) + #-(or) + (make-quaternion* + (quaternion-normalize* + (quaternion-product* + (quaternion-product* + (unit-quaternion-x* z) + (unit-quaternion-y* x)) + (unit-quaternion-z* y))))))) + +;; no, this doesn't work at all +#+(or) +(make-quaternion* + (quaternion-normalize* + (quaternion-product* + (quaternion* (euler-xyz-to-quaternion rotate-x rotate-y rotate-z)) + (quaternion* (relative-rotation (transformation *camera*)))))) diff --git a/client/config.lisp b/client/config.lisp new file mode 100644 index 0000000..26e4dcc --- /dev/null +++ b/client/config.lisp @@ -0,0 +1,7 @@ +;;; -*- mode: lisp; syntax: common-lisp; package: existenz-client; coding: utf-8-unix; -*- + +(in-package #:existenz-client) + +(custom-set-variables + '(window-resolution (640 480)) + '(window-fullscreen NIL)) diff --git a/client/joystick.lisp b/client/joystick.lisp new file mode 100644 index 0000000..447cef9 --- /dev/null +++ b/client/joystick.lisp @@ -0,0 +1,99 @@ +;;; -*- mode: lisp; syntax: common-lisp; package: existenz-client; coding: utf-8-unix; -*- + +(in-package #:existenz-client) + +;; cat /dev/input/event6 |hexdump + +(define-enum linux-input-event-type (u16) + ev-syn #x00 + ev-key #x01 + ev-rel #x02 + ev-abs #x03 + ev-msc #x04 + ev-sw #x05 + ev-led #x11 + ev-snd #x12 + ev-rep #x14 + ev-ff #x15 + ev-pwr #x16 + ev-ff-status #x17 + ev-max #x1f) + +(define-enum linux-input-event-syn (u16) + syn-report 0 + syn-config 1 + syn-mt-report 2) + +(define-enum linux-input-event-button (u16) + btn-mouse #x110 + btn-left #x110 + btn-right #x111 + btn-middle #x112 + + btn-joystick #x120 + btn-trigger #x120 + btn-thumb #x121 + btn-thumb2 #x122 + btn-top #x123 + btn-top2 #x124 + btn-pinkie #x125 + + btn-gamepad #x130 + btn-a #x130 + btn-b #x131 + btn-c #x132 + btn-x #x133 + btn-y #x134 + btn-z #x135) + +(define-enum linux-input-event-rel (u16) + rel-x #x00 + rel-y #x01 + rel-z #x02 + rel-rx #x03 + rel-ry #x04 + rel-rz #x05 + rel-hwheel #x06 + rel-dial #x07 + rel-wheel #x08 + rel-misc #x09) + +(define-binary-struct linux-input-event () + (tv-sec 0 :binary-type s64) + (tv-usec 0 :binary-type s64) + (type 0 :binary-type linux-input-event-type) + (code 0 :binary-type u16) + (value 0 :binary-type s32)) + +(defun read-input-event (pathname) + (with-open-file (stream pathname :element-type '(unsigned-byte 8)) + (loop + (when (listen stream) + (let ((event (read-binary 'linux-input-event stream))) + (when (eq (linux-input-event-type event) 'ev-key) + (setf (linux-input-event-code event) + (enum-symbolic-value 'linux-input-event-button + (linux-input-event-code event))) + (logv event))))))) + +(logv 'idle) +(let ((mouse-rel-x 0) + (mouse-rel-y 0)) + (iolib:set-io-handler event-base (sb-sys:fd-stream-fd mouse) :read + (lambda (fd event exception) + (let ((event (read-binary 'linux-input-event mouse))) + (when (eq (linux-input-event-type event) 'ev-key) + (setf (linux-input-event-code event) + (enum-symbolic-value 'linux-input-event-button + (linux-input-event-code event)))) + (when (eq (linux-input-event-type event) 'ev-rel) + (setf (linux-input-event-code event) + (enum-symbolic-value 'linux-input-event-rel + (linux-input-event-code event))) + (case (linux-input-event-code event) + (rel-x (incf mouse-rel-x (linux-input-event-value event))) + (rel-y (incf mouse-rel-y (linux-input-event-value event)))))))) + (iolib:event-dispatch event-base :timeout 0.01) + (iolib:remove-fd-handlers event-base (sb-sys:fd-stream-fd mouse)) + (setf rotate-y (* (- mouse-rel-x) (to-radian 0.5))) + (setf rotate-x (* (- mouse-rel-y) (to-radian 0.5)))) diff --git a/client/package.lisp b/client/package.lisp new file mode 100644 index 0000000..67267ca --- /dev/null +++ b/client/package.lisp @@ -0,0 +1,19 @@ +;;; -*- mode: lisp; syntax: common-lisp; package: cl-user; coding: utf-8-unix; -*- + +(in-package #:cl-user) + +(defpackage #:existenz-client + (:use #:cl + #:metabang-bind + #:anaphora + #:logv + #:iterate + #:bordeaux-threads + #:utils-frahm + #:trivial-garbage + #:alexandria + #:cl-tuples + #:existenz-common + #:distlisp + #:binary-types) + (:shadow #:position #:rotate)) diff --git a/common/entity.lisp b/common/entity.lisp new file mode 100644 index 0000000..1256b42 --- /dev/null +++ b/common/entity.lisp @@ -0,0 +1,9 @@ +(in-package #:existenz-common) + +(defclass entity () + ((transformation + :initarg :transformation + :accessor transformation + :initform (make-transformation))) + (:documentation "Mixin for common ENTITY attributes, such as +TRANSFORMATION.")) \ No newline at end of file diff --git a/common/options.lisp b/common/options.lisp new file mode 100644 index 0000000..2939015 --- /dev/null +++ b/common/options.lisp @@ -0,0 +1,44 @@ +;;; -*- mode: lisp; syntax: common-lisp; package: existenz-client; coding: utf-8-unix; -*- + +(in-package #:existenz-common) + +(defvar *options* NIL) + +(defun option (name) + (cdr (assoc name *options*))) + +(defun set-option (name new-value) + (setf *options* + `((,name . ,new-value) + ,@(remove name *options* :test #'eq :key #'car))) + new-value) + +(defsetf option set-option) + +(defvar *options-mappings* NIL) + +(defun load-options () + (iterate + (for (name . variables) in *options-mappings*) + (iterate + (for value in (option name)) + (for variable in variables) + (set variable value)))) + +;; TODO: make emacs macros for this + +#| +(defmacro defcustom (name value documentation &key (type T))) + +(defcustom window-resolution + (list 640 480) + "Width and height of window. Two-element LIST of INTEGERS. Is mapped +to the global variables *WINDOW-WIDTH* and *WINDOW-HEIGHT*." + :type list) + +(defcustom window-fullscreen + NIL + "Whether the application runs in fullscreen or windowed mode. Is mapped +to the global variable *WINDOW-FULLSCREEN*." + :type boolean) +|# diff --git a/common/package.lisp b/common/package.lisp new file mode 100644 index 0000000..d1d106e --- /dev/null +++ b/common/package.lisp @@ -0,0 +1,23 @@ +;;; -*- mode: lisp; syntax: common-lisp; package: cl-user; coding: utf-8-unix; -*- + +(in-package #:cl-user) + +(defpackage #:existenz-common + (:use #:cl + #:metabang-bind + #:anaphora + #:logv + #:iterate + #:bordeaux-threads + #:utils-frahm + #:trivial-garbage + #:alexandria + #:cl-tuples) + (:shadow #:position) + (:export #:load-options + #:make-transformation + #:absolute-transformation + #:*options* + #:*options-mappings* + #:transformation + #:to-radian)) diff --git a/common/syntax.lisp b/common/syntax.lisp new file mode 100644 index 0000000..55b0664 --- /dev/null +++ b/common/syntax.lisp @@ -0,0 +1,38 @@ +;;; -*- mode: lisp; syntax: common-lisp; package: existenz-client; coding: utf-8-unix; -*- + +(in-package #:existenz-common) + +;;; shorthand for interactive degree values, also coerces to +;;; CL-TUPLES::FAST-FLOAT + +(defun to-radian (degree) + (* degree #.(coerce (/ pi 180) 'cl-tuples::fast-float))) + +;; FIXME: this fails omniusly while reading NIL +#+(or) +(defun |#°-reader| (stream sub-char arg) + (declare (ignore sub-char arg)) + (let ((read (read stream T NIL T))) + (and read (to-radian read)))) + +;; (set-dispatch-macro-character #\# #\° #'|#°-reader|) + +(defun matrix-elements (dimensions &optional (prefix '#:e)) + (labels ((aux (dimensions) + (let ((car (car dimensions)) + (cdr (cdr dimensions))) + (if cdr + (iterate outer + (for i from 0 below car) + (iterate + (for x in (aux cdr)) + (in outer (collect (list* i x))))) + (iterate + (for i from 0 below car) + (collect (list i))))))) + (map 'list (lambda (list) + (find-symbol (format NIL "~A~{~A~}" prefix list))) + (aux dimensions)))) + +(defun matrix2-elements (dimension &optional (prefix '#:e)) + (matrix-elements (list dimension dimension) prefix)) diff --git a/common/transformation.lisp b/common/transformation.lisp new file mode 100644 index 0000000..21c0fb4 --- /dev/null +++ b/common/transformation.lisp @@ -0,0 +1,92 @@ +(in-package #:existenz-common) + +(defun ones-vector3d () + (make-vector3d 1.0 1.0 1.0)) + +(defun identity-matrix44 () + (make-matrix44* (identity-matrix44*))) + +(defclass transformation () + ((relative-position + :initarg :relative-position + :accessor relative-position + :initform (new-vector3d)) + (relative-rotation + :initarg :relative-rotation + :accessor relative-rotation + :initform (new-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 entity (usually the parent), or the +coordinate origin. Also contains a scratch slot +ABSOLUTE-TRANSFORMATION, which is used destructively to calculate the +absolute transformation, i.e. relative to the coordinate origin.")) + +(defgeneric relative-transformation (object) + (:documentation "Returns the transformation of the OBJECT relative +to its parent as a MATRIX44.")) + +(defmethod relative-transformation (object) + (relative-transformation (transformation object))) + +(defgeneric absolute-transformation (object) + (:documentation "Returns the transformation of the OBJECT relative to +the coordinate origin.")) + +(defmethod absolute-transformation (object) + (absolute-transformation (transformation object))) + +(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* + (matrix44-product* + (matrix33-matrix44* (quaternion-matrix33* (quaternion* rotation))) + (with-vector3d position (tx ty tz) (translation-matrix44* tx ty tz))) + (with-vector3d scale (sx sy sz) (scaling-matrix44* sx sy sz))))) + +(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))) + +(defmethod update-absolute-transformation (object parent-transformation) + "Calculates the absolute transformation, returns and stores it in the +slot ABSOLUTE-TRANSFORMATION of OBJECT." + (let ((transformation (absolute-transformation object))) + (matrix44-setter* + transformation + (matrix44-product* + (matrix44* (relative-transformation object)) + (matrix44* parent-transformation))))) + +(defun make-transformation () + (make-instance 'transformation)) \ No newline at end of file diff --git a/common/wavefront.lisp b/common/wavefront.lisp new file mode 100644 index 0000000..0f9d744 --- /dev/null +++ b/common/wavefront.lisp @@ -0,0 +1,185 @@ +;;; -*- mode: lisp; syntax: common-lisp; package: existenz; -*- + +(in-package #:existenz) + +#+(or) +(defun parse-wavefront-object-file (pathname function) + (with-open-file (stream pathname) + (let (name vertexes faces) + (iterate + (for line = (read-line stream NIL)) + (while line) + (when (or (emptyp line) (char= #\# (char line 0))) + (next-iteration)) + (multiple-value-bind (token end) + (read-from-string line) + (ecase token + (mtllib) + (o + (when name + (funcall function name vertexes faces) + (setf vertexes NIL + faces NIL)) + (setf name (subseq line end))) + (v (let (x values) + (iterate + (multiple-value-setq (x end) + (read-from-string line NIL NIL :start end)) + (while x) + (push x values)) + (push (nreverse values) vertexes))) + (usemtl) + (s) + (f + (let (x values) + (iterate + (multiple-value-setq (x end) + (read-from-string line NIL NIL :start end)) + (while x) + (push x values)) + (push (nreverse values) faces))))) + (finally + (when name + (funcall function name vertexes faces))))))) + +#+(or) +(defun parse-wavefront-object-file (pathname object vertex face) + (with-open-file (stream pathname) + (iterate + (for line = (read-line stream NIL)) + (while line) + (when (or (emptyp line) (char= #\# (char line 0))) + (next-iteration)) + (multiple-value-bind (token end) + (read-from-string line) + (ecase token + (mtllib) + (o (funcall object (subseq line end))) + (v (let (x values) + (iterate + (multiple-value-setq (x end) + (read-from-string line NIL NIL :start end)) + (while x) + (push x values)) + (funcall vertex (nreverse values)))) + (usemtl) + (s) + (f (let (x values) + (iterate + (multiple-value-setq (x end) + (read-from-string line NIL NIL :start end)) + (while x) + (push x values)) + (funcall face (nreverse values))))))))) + +;; TODO: could be made more type static by using 0 instead of NIL for +;; missing values +;; TODO: use read-integer/read-number, split-sequence?, whitespacep +;; TODO: use stream or stream-designator +;; TODO: parse directly from stream, accept multiple directives per line, i.e. parse tokens +;; TODO: accept more, i.e. more coordinates/vertexes and less +;; TODO: also, type annotations? +;; TODO: use conditions and restarts to skip over bad data? e.g. allow +;; to selectively skip a single line, or try to resync on the next known +;; token +;; TODO: what about encoding? +(defun parse-wavefront-object-file (pathname object vertex face option) + ;; FIXME: option is unused, but should handle usemtl, s, mtllib + (with-open-file (stream pathname) + (iterate + (for count from 1) + (for line = (read-line stream NIL)) + (while line) + (let ((length (length line))) + (when (eql 0 length) + (next-iteration)) + (let ((char0 (char line 0))) + (when (char= #\# char0) + (next-iteration)) + (when (<= length 2) + (warn "too short input on line ~D" count) + (next-iteration)) + (if (eql length 1) + (ecase char0 + (#\o + (warn "missing object name on line ~D" count) + (funcall object "")) + (#\v + (warn "missing vertex data on line ~D" count) + (funcall vertex 0 0 0)) + (#\f + (warn "missing face data on line ~D" count) + (funcall face 0 0 0 0))) + ;; TODO: should be "any whitespace" + (let ((char1 (char line 1))) + (if (char= char1 #\Space) + (ecase char0 + (#\o + ;; TODO: discard other whitespace + (funcall object (subseq line 2))) + (#\v + (let ((x 0) (y 0) (z 0) end) + (multiple-value-setq (x end) + (read-from-string line NIL 0 :start 2)) + (multiple-value-setq (y end) + (read-from-string line NIL 0 :start end)) + (multiple-value-setq (z end) + (read-from-string line NIL 0 :start end)) + (funcall vertex x y z))) + (#\f + (let ((a 0) (b 0) (c 0) (d 0) end) + (multiple-value-setq (a end) + (read-from-string line NIL 0 :start 2)) + (multiple-value-setq (b end) + (read-from-string line NIL 0 :start end)) + (multiple-value-setq (c end) + (read-from-string line NIL 0 :start end)) + (multiple-value-setq (d end) + (read-from-string line NIL 0 :start end)) + (funcall face a b c d))) + (#\s + (warn "ignoring directive ~A on line ~D" char0 count))) + ;; TODO: use optimized string-case + (if (starts-with-subseq "usemtl" line :test #'char-equal) + (funcall option 'usemtl (subseq line #.(length "usemtl "))) + (if (starts-with-subseq "mtllib" line :test #'char-equal) + (funcall option 'mtllib (subseq line #.(length "mtllib "))) + (warn "ignoring unknown data on line ~D" count))))))))))) + +#| +(defun parse-wavefront-material-file (pathname material option) + (with-open-file (stream pathname) + (iterate + (for count from 1) + (for line = (read-line stream NIL)) + (while line) + (let ((length (length line))) + (when (eql 0 length) + (next-iteration)) + (let ((char0 (char line 0))) + (when (char= #\# char0) + (next-iteration)) + (when (<= length 2) + (warn "too short input on line ~D" count) + (next-iteration)) + (if (eql length 1) + (ecase char0 + (#\d + (warn "missing data on line ~D" count) + (funcall option 0))) + ;; TODO: should be "any whitespace" + (let ((char1 (char line 1))) + (if (char= char1 #\Space) + (ecase char0 + (#\d + ;; TODO: discard other whitespace + (funcall option 'd (read-from-string line NIL 0 :start 2)))) + (char= char1 + ;; TODO: use optimized string-case + (if (starts-with-subseq "newmtl" line :test #'char-equal) + (funcall material (subseq line #.(length "newmtl "))) + (if (starts-with-subseq "illum" line :test #'char-equal) + (funcall option 'illum (read-from-string line NIL 0 + :start #.(length "illum "))) + (warn "ignoring unknown data on line ~D" count))))))))))) +|# diff --git a/existenz-client.asd b/existenz-client.asd new file mode 100644 index 0000000..181503d --- /dev/null +++ b/existenz-client.asd @@ -0,0 +1,25 @@ +;;; -*- mode: lisp; syntax: common-lisp; package: cl-user; coding: utf-8-unix; -*- + +(in-package #:cl-user) + +(asdf:defsystem #:existenz-client + #+asdf-unicode :encoding #+asdf-unicode :utf-8 + :depends-on (#:cl-opengl + #:lispbuilder-sdl + #:logv + #:iterate + #:bordeaux-threads + #:anaphora + #:metabang-bind + ;; #:cl-ftgl + #:utils-frahm-threaded + #:cl-tuples + #:classimp + ;; #:iolib + #:existenz-common + #:binary-types) + :serial T + :components + ((:module client + :components ((:file "package") + (:file "client"))))) diff --git a/existenz-common.asd b/existenz-common.asd new file mode 100644 index 0000000..7f66370 --- /dev/null +++ b/existenz-common.asd @@ -0,0 +1,25 @@ +;;; -*- mode: lisp; syntax: common-lisp; package: cl-user; coding: utf-8-unix; -*- + +(in-package #:cl-user) + +(asdf:defsystem #:existenz-common + #+asdf-unicode :encoding #+asdf-unicode :utf-8 + :depends-on (#:logv + #:iterate + #:bordeaux-threads + #:anaphora + #:metabang-bind + #:utils-frahm-threaded + #:cl-tuples + ;; #:iolib + #:png-read + #:trivial-garbage + #:distlisp) + :serial T + :components + ((:module common + :components ((:file "package") + (:file "options") + (:file "syntax") + (:file "entity") + (:file "transformation"))))) diff --git a/existenz-server.asd b/existenz-server.asd new file mode 100644 index 0000000..38ceeb9 --- /dev/null +++ b/existenz-server.asd @@ -0,0 +1,21 @@ +;;; -*- mode: lisp; syntax: common-lisp; package: cl-user; coding: utf-8-unix; -*- + +(in-package #:cl-user) + +(asdf:defsystem #:existenz-server + #+asdf-unicode :encoding #+asdf-unicode :utf-8 + :depends-on (#:logv + #:iterate + #:bordeaux-threads + #:anaphora + #:metabang-bind + #:utils-frahm-threaded + #:cl-tuples + #:classimp + #:iolib + #:trivial-garbage + #:existenz-common) + :serial T + :components ((:module server + :components ((:file "package") + (:file "server"))))) diff --git a/hacks.lisp b/hacks.lisp new file mode 100644 index 0000000..6523616 --- /dev/null +++ b/hacks.lisp @@ -0,0 +1,20 @@ +;; 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))) \ No newline at end of file diff --git a/server/package.lisp b/server/package.lisp new file mode 100644 index 0000000..886be37 --- /dev/null +++ b/server/package.lisp @@ -0,0 +1,19 @@ +;;; -*- mode: lisp; syntax: common-lisp; package: cl-user; coding: utf-8-unix; -*- + +(in-package #:cl-user) + +(defpackage #:existenz-server + (:use #:cl + #:metabang-bind + #:anaphora + #:logv + #:iterate + #:bordeaux-threads + #:utils-frahm + #:trivial-garbage + #:alexandria + #:cl-tuples + #:existenz-common + #:iolib + #:distlisp) + (:shadow #:position)) diff --git a/server/server.lisp b/server/server.lisp new file mode 100644 index 0000000..9f828ba --- /dev/null +++ b/server/server.lisp @@ -0,0 +1,105 @@ +;;; -*- mode: lisp; syntax: common-lisp; package: existenz-server; coding: utf-8-unix; -*- + +(in-package #:existenz-server) + +#-(or) +(progn + (defun start-server (&optional (host +ipv6-unspecified+) (port 4000)) + (spawn-thread (lambda () + (run-server host port)) + :name "Existenz Server IO")) + + (defun run-server (host port) + (with-event-base (event-base) + (let ((server (make-socket :ipv6 T + :type :datagram + :local-host host + :local-port port + :reuse-address T))) + (unwind-protect (dispatch-server event-base server) + (close server))))) + + (defun dispatch-server (event-base server) + (flet ((read-event (fd event-type errorp) + (read-server-event server fd event-type errorp))) + (set-io-handler event-base (fd-of server) :read #'read-event) + (iterate + (iterate + (for (values message from) = (recv-nowait distlisp::*current-process*)) + (while from) + (case message + (:exit (abort-thread)))) + (event-dispatch event-base :timeout 0.001))))) + +#+(or) +(progn + (defun start-server (&optional (host +ipv6-unspecified+) (port 4000)) + (multiple-value-bind (left right) + (iolib.syscalls:pipe) + (make-thread (lambda () + (unwind-protect + (run-server host port right) + (iolib.syscalls:close left) + (iolib.syscalls:close right))) + :name "EXISTENZ-SERVER-IO") + left)) + + (defun run-server (host port pipe) + (with-event-base (event-base) + (let ((server (make-socket :ipv6 T + :type :datagram + :local-host host + :local-port port + :reuse-address T))) + (unwind-protect (dispatch-server event-base server pipe) + (close server))))) + + (defun dispatch-server (event-base server pipe) + (flet ((read-event (fd event-type errorp) + (read-server-event fd event-type errorp server)) + (read-pipe (fd event-type errorp) + (declare (ignore fd event-type errorp)) + (format T "received signal on pipe~%") + (exit-event-loop event-base))) + (set-io-handler event-base (fd-of server) :read #'read-event) + (set-io-handler event-base pipe :read #'read-pipe) + (event-dispatch event-base)))) + +(defvar *clients* (make-hash-table :test 'eql)) + +(defun read-server-event (server fd event-type errorp) + (declare (ignore fd event-type errorp)) + (multiple-value-bind (buffer length host port) + (receive-from server :size 500) + (format T "received ~A bytes from ~A:~A~%" + length host port) + (unless (>= length 4) + (format T "malformed message, length ~D of 4~%" length) + (send-to server #(1 0 0 1) :remote-host host :remote-port port) + (return-from read-server-event)) + (let ((version (aref buffer 0))) + (format T "version ~D~%" version) + (let ((sequence-number (+ (ash (aref buffer 1) 8) (aref buffer 2)))) + (format T "sequence number ~D~%" sequence-number) + (let ((event-type (aref buffer 3))) + (format T "event type ~D~%" event-type)))))) + +#+(or) +(defenum event-type + :error ; transport error + :ping ; hello there + :pong ; yes, i heard you + :login ; now assign me an identifier + :logged-in) ; and this is your session id + +;; movement, actions, updates? +;; data via http or bittorrent + +;; :ping -> :pong +;; :login -> :error, :logged-in + +#+(or) +(defun handle-event/default-state (buffer) + (case event-type + (:ping (send-event client :pong)) + (T (send-event client :error)))) -- 1.7.10.4