wip

Remove tree functionality from utils.lisp and generalize it as graph

VERSION

@@ -0,0 +1 @@
+"0.1"

core/all.lisp

@@ -0,0 +1,18 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/core/all
+    (:nicknames :core)
+  (:use-reexport
+   :stoe/core/utils
+   :stoe/core/graph
+   :stoe/core/time
+   :stoe/core/thread
+   :stoe/core/containers
+   :stoe/core/modules
+   :stoe/core/jobs
+   :stoe/core/file
+   :stoe/core/resources
+   :stoe/core/entity))

core/containers.lisp

@@ -3,17 +3,13 @@
   Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
 |#
 
-(in-package :cl-user)
-(defpackage stoe.containers
-  (:nicknames :containers)
-  (:use :cl
-        :thread)
-  (:export :queue :stack :make-queue :make-stack
-           :enqueue :dequeue :push-stack :pop-stack :peek
-           :safe-queue :safe-stack
-           :make-safe-queue :make-safe-stack))
-
-(in-package :stoe.containers)
+(uiop:define-package :stoe/core/containers
+    (:use :cl :stoe/core/utils :stoe/core/thread)
+  (:export #:queue #:stack #:make-queue #:make-stack
+           #:enqueue #:dequeue #:push-stack #:pop-stack #:peek #:size
+           #:safe-queue #:safe-stack
+           #:make-safe-queue #:make-safe-stack))
+(in-package :stoe/core/containers)
 
 (defclass container ()
   ((data :initform nil))
@@ -70,8 +66,12 @@
   (with-slots (data) container
     (first data)))
 
+(defmethod size ((container container))
+  (with-slots (data) container
+    (length data)))
+
 (defclass safe-container-mixin ()
-  ((mutex :initform (thread:make-mutex))
+  ((lock :initform (make-lock))
    (waitp :initarg :waitp :accessor safe-container-wait-p))
   (:documentation "A mixin for thread-safe containers."))
 
@@ -94,26 +94,26 @@ if `waitp', don't return until the mutex is released."
   (make-instance 'safe-stack :waitp waitp))
 
 (defmethod enqueue :around ((queue safe-queue) elt)
-  (with-slots (mutex waitp) queue
-    (with-mutex (mutex :waitp waitp)
+  (with-slots (lock waitp) queue
+    (with-lock-held (lock waitp)
       (call-next-method))))
 
 (defmethod dequeue :around ((queue safe-queue))
-  (with-slots (mutex waitp) queue
-    (with-mutex (mutex :waitp waitp)
+  (with-slots (lock waitp) queue
+    (with-lock-held (lock waitp)
       (call-next-method))))
 
 (defmethod push-stack :around ((stack safe-stack) elt)
-  (with-slots (mutex waitp) stack
-    (with-mutex (mutex :waitp waitp)
+  (with-slots (lock waitp) stack
+    (with-lock-held (lock waitp)
       (call-next-method))))
 
 (defmethod pop-stack :around ((stack safe-stack))
-  (with-slots (mutex waitp) stack
-    (with-mutex (mutex :waitp waitp)
+  (with-slots (lock waitp) stack
+    (with-lock-held (lock waitp)
       (call-next-method))))
 
 (defmethod peek :around ((container safe-container-mixin))
-  (with-slots (mutex waitp) container
-    (with-mutex (mutex :waitp waitp)
+  (with-slots (lock waitp) container
+    (with-lock-held (lock waitp)
       (call-next-method))))

core/entity.lisp

@@ -0,0 +1,265 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2017 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/core/entity
+    (:use :cl :alexandria :blackbird
+          :stoe/core/utils
+          :stoe/core/graph
+          :stoe/core/jobs)
+  (:import-from :stoe/core/modules
+                #:defmodule)
+  (:export #:entity #:object-id #:make-entity
+           #:component #:owner #:activep
+           #:defcomponent #:initialize-component-class
+           #:components #:all-components #:with-components
+           #:add-component #:remove-component
+           #:create-entity #:destroy-entity
+           #:entity-system #:make-entity-system
+           #:defesystem #:run-esystem))
+(in-package :stoe/core/entity)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar *entity-array* (make-array 10 :adjustable t :fill-pointer 0))
+  (defvar *components-table-table* (make-hash-table))
+  (defvar *system-dependency-graph* (make-graph-node)))
+
+(defclass entity ()
+  ((name :initarg :name :reader name)
+   (object-id :initform 0 :reader object-id))
+  (:documentation "Class for an entity comprised of a unique identifier and a name."))
+
+(let (available-ids)
+  (defun get-available-ids ()
+    available-ids)
+
+  (defun register-entity (entity)
+    (let ((available-id (pop available-ids)))
+      (unless available-id
+        (setf available-id (extend-array *entity-array*)))
+      (setf (aref *entity-array* available-id) entity)
+      (setf available-ids (delete available-id available-ids))
+      available-id))
+
+  (defun unregister-entity (entity)
+    (let ((id (object-id entity)))
+      (push id available-ids)
+      (if (= id (1- (fill-pointer *entity-array*)))
+          (let ((new-fill-pointer (loop for index = (1- id) then (decf index)
+                                        while (member index available-ids)
+                                        finally (return (1+ index)))))
+            (shrink-array *entity-array* new-fill-pointer)
+            (setf available-ids (delete-if (lambda (x) (>= x new-fill-pointer)) available-ids)))
+          (setf (aref *entity-array* id) nil))
+      (values))))
+
+(defmethod initialize-instance :after ((entity entity) &key)
+  (with-slots (object-id) entity
+    (setf object-id (register-entity entity))))
+
+(defun make-entity (name)
+  (make-instance 'entity :name name))
+
+(defun entity (id)
+  (aref *entity-array* id))
+
+(defclass component ()
+  ((owner :initarg :owner :reader owner)
+   (activep :initarg :activep :initform t :accessor activep))
+  (:documentation "Base class for a component linked to an entity, its owner."))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun components-table (classname)
+    (gethash classname *components-table-table*))
+
+  (defun push-components-table (classname)
+    (assert (null (gethash classname *components-table-table*)))
+    (setf (gethash classname *components-table-table*) (make-hash-table)))
+
+  (defun ensure-components-table (classname)
+    (let ((components-table (components-table classname)))
+      (if components-table
+          components-table
+          (push-components-table classname))))
+
+  (ensure-components-table 'component))
+
+(defun initialize-component-class (name)
+  (closer-mop:finalize-inheritance (find-class name))
+  (ensure-components-table name))
+
+(defmacro defcomponent (name superclasses slots &rest options)
+  "Define a new component NAME with its SUPERCLASSES and SLOTS like in defclass.
+class OPTIONS are supported together with the option :NEEDS used to define the dependencies of the component."
+  (unless (every (lambda (superclass) (components-table superclass)) superclasses)
+    (error (format nil "not every superclasses of ~a is a component~%with superclasses = ~a~%" name superclasses)))
+  (unless superclasses
+    (setf superclasses '(component)))
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (defclass ,name ,superclasses
+      ,slots
+       ,@options)
+     (initialize-component-class ',name)))
+
+(defun component (entity classname)
+  "Return the first component of entity from classname."
+  (let ((components-table (components-table classname)))
+    (unless (null components-table)
+      (safe-first (gethash (object-id entity) components-table)))))
+
+(defun components (entity classname)
+  "Return a list of entity's components from classname."
+  (let ((components-table (components-table classname)))
+    (unless (null components-table)
+      (safe-list (gethash (object-id entity) components-table)))))
+
+(defun all-components (entity)
+  (components entity 'component))
+
+(defmacro with-components (components entity &body body)
+  (once-only (entity)
+    `(let (,@(loop for comp in components
+                   collect (let ((var (safe-first comp))
+                                 (comp-symb (or (second (safe-list comp))
+                                                (safe-first comp)))
+                                 (listp (eq (third (safe-list comp)) :all)))
+                             (if listp
+                                 `(,var (components ,entity ',comp-symb))
+                                 `(,var (component ,entity ',comp-symb))))))
+       ,@body)))
+
+(defun add-component (entity component)
+  "Add a component to entity."
+  (let ((classlist (mapcar (lambda (class) (class-name class))
+                           (closer-mop:class-precedence-list (class-of component))))
+        (id (object-id entity)))
+    (rplacd (member 'component classlist) nil)
+    (mapc (lambda (classname)
+            (let ((components-table (components-table classname)))
+              (when components-table
+                (push component (gethash id components-table)))))
+          classlist))
+  component)
+
+(defun remove-component (entity component)
+  "Remove a component from entity."
+  (let ((classlist (mapcar (lambda (class) (class-name class))
+                           (closer-mop:class-precedence-list (class-of component))))
+        (id (object-id entity)))
+    (rplacd (member 'component classlist) nil)
+    (mapc (lambda (class)
+            (let ((components-table (components-table class)))
+              (when components-table
+                (let ((place (gethash id components-table)))
+                  (setf place (delete component place))
+                  (unless place
+                    (remhash place components-table))))))
+          classlist))
+  (values))
+
+(defmethod initialize-instance :after ((comp component) &key owner)
+  (add-component owner comp))
+
+(defmacro create-entity (name &body component-specs)
+  (with-gensyms (entity)
+    `(ret ,entity (make-entity ,name)
+       ,@(mapcar (lambda (spec)
+                   (let* ((spec-list (safe-list spec))
+                          (comp-symb (first spec-list))
+                          (comp-options (rest spec-list)))
+                     `(make-instance ',comp-symb
+                                     ,@(append `(:owner ,entity) comp-options))))
+                 component-specs))))
+
+(defun destroy-entity (entity)
+  (mapc (lambda (component) (remove-component entity component)) (all-components entity))
+  (unregister-entity entity))
+
+(defmethod print-object ((entity entity) stream)
+  (print-unreadable-object (entity stream :identity t)
+    (format stream "~a: ~@<~{~:_~a~^ ~}~:>" (name entity) (all-components entity))))
+
+(defclass entity-system (graph-node)
+  ((name :initarg :name :reader name)
+   (components :initarg :components)
+   (body :initarg :body)
+   (promise :initform nil :accessor promise))
+  (:documentation "Class for an entity system."))
+
+(defun system-precedence-list (system)
+  (labels ((rec (node)
+             (cons node (mapcar #'rec (prior-nodes node)))))
+    (remove-duplicates (flatten (mapcar #'rec (prior-nodes system))))))
+
+(defun make-entity-system (name before after components body)
+  (ret instance (make-instance 'entity-system :name name :components components :body body)
+    (attach-node instance :prior (or after *system-dependency-graph*) :next before)
+    (when before
+      (let ((precedence-list (system-precedence-list instance)))
+        (mapc (lambda (system)
+                (with-slots (prior-nodes) system
+                  (setf prior-nodes (remove-if (lambda (node)
+                                                 (member node precedence-list))
+                                               prior-nodes))))
+              (safe-list before))))
+    (assert (not (cyclic-graph-p instance)))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun parse-defesystem (args)
+    (setf args (copy-sequence 'list args))
+    (let (before after)
+      (loop for i from 0 below 2
+            do (when (member (first args) '(:before :after))
+                 (ecase (first args)
+                   (:before (assert (null before)) (setf before (second args)))
+                   (:after (assert (null after)) (setf after (second args))))
+                 (setf args (cddr args))))
+      (assert (= (length args) 2))
+      (assert (> (length (first args)) 1))
+      (values before after (caar args) (cdar args) (cdr args)))))
+
+(defmacro defesystem (name &body args)
+  (multiple-value-bind (before after entity components body) (parse-defesystem args)
+    (let ((fun `(lambda (,entity ,@(mapcar (lambda (component)
+                                             (first (safe-list component))) components))
+                 ,@body)))
+      `(defparameter ,name
+         (make-entity-system ',name ,before ,after
+                             ',(mapcar (lambda (component)
+                                         (or (and (listp component) (second component))
+                                             component)) components) ,fun)))))
+
+(defun run-esystem (system)
+  (with-slots (components body promise) system
+    (setf promise (all (flatten
+                        (loop for object-id being the hash-key of (components-table (first components))
+                              collect (let* ((entity (entity object-id))
+                                             (entity-components (mapcar (lambda (classname)
+                                                                          (components entity classname))
+                                                                        components)))
+                                        (unless (some #'null entity-components)
+                                          (async-job (system entity entity-components)
+                                            (apply body system entity entity-components))))))))))
+
+(defun initialize (&optional argv)
+  "Initialize the entity system module."
+  (declare (ignore argv))
+  (format t "Initialize Entity System module~%"))
+
+(defun finalize ()
+  "Finalize the entity system module."
+  (format t "Finalize Entity System module~%"))
+
+(defun update (delta-time)
+  (declare (ignore delta-time))
+  (let ((systems (next-nodes *system-dependency-graph*)))
+    (mapc #'run-esystem systems)
+    (loop while systems
+          do (setf systems (mapc (lambda (system)
+                                   (wait (all (mapcar #'promise (prior-nodes system)))
+                                     (run-esystem system)))
+                                 (delete-duplicates
+                                  (flatten (mapcar #'next-nodes systems))))))))
+
+(defmodule stoe/core/entity :game)

core/file.lisp

@@ -0,0 +1,45 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/core/file
+    (:use :cl :blackbird :stoe/core/utils :stoe/core/jobs)
+  (:export #:safe-read #:safe-read-from-string #:load-file))
+(in-package :stoe/core/file)
+
+(let ((safe-readtable (copy-readtable nil)))
+  (dolist (c '(#\# #\=))
+    (set-macro-character c nil nil safe-readtable))
+
+  (defun safe-read (&optional (stream *standard-input*) (eof-error-p t) eof-value recursive-p)
+    (let ((*readtable* safe-readtable))
+      (restartable
+       (read stream eof-error-p eof-value recursive-p))))
+
+  (locally
+      #+sbcl
+      (declare sb-ext::(muffle-conditions style-warning))
+    (defun safe-read-from-string (s &optional (eof-error-p t) eof-value
+                                  &key (start 0) end preserve-whitespace)
+      (let ((*readtable* safe-readtable)
+            (*read-eval* nil))
+        (restartable
+          (read-from-string s eof-error-p eof-value :start start :end end
+                            :preserve-whitespace preserve-whitespace))))))
+
+(defun do-load-file (filepath type)
+  "Load the file specified by `filepath' and store it in the object returned."
+  (with-open-file (stream filepath :direction :input :element-type type)
+    (when stream
+      (let ((buffer (make-array (file-length stream) :element-type type)))
+        (read-sequence buffer stream)
+        buffer))))
+
+(defun load-file (filepath &key sync (type '(unsigned-byte 8)))
+  "Load the file specified by `filepath' asynchronally unless `sync' is true."
+  (if sync
+      (with-promise (resolve reject)
+        (resolve (do-load-file filepath type)))
+      (async-job (filepath type)
+        (do-load-file filepath type))))

core/graph.lisp

@@ -0,0 +1,68 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/core/graph
+    (:use :cl :stoe/core/utils)
+  (:export #:graph-node #:prior-nodes #:next-nodes
+           #:attach-node #:detach-node #:insert-node
+           #:cyclic-graph-p #:make-graph-node))
+(in-package :stoe/core/graph)
+
+(defclass graph-node ()
+  ((prior-nodes :initform nil :accessor prior-nodes)
+   (next-nodes :initform nil :accessor next-nodes)))
+
+(defgeneric attach-node (node &key prior next))
+(defmethod attach-node ((node graph-node) &key prior next)
+  (let ((prior-list (safe-list prior))
+        (next-list (safe-list next)))
+    (with-slots (prior-nodes next-nodes) node
+      (setf prior-nodes (append prior-nodes prior-list))
+      (setf next-nodes (append next-nodes next-list)))
+    (mapc (lambda (pnode)
+            (with-slots (next-nodes) pnode
+              (setf next-nodes (append next-nodes (list node)))))
+          prior-list)
+    (mapc (lambda (nnode)
+            (with-slots (prior-nodes) nnode
+              (setf prior-nodes (append prior-nodes (list node)))))
+          next-list))
+  node)
+
+(defgeneric detach-node (node &key prior next))
+(defmethod detach-node ((node graph-node) &key prior next)
+  (let ((prior-list (if (eq prior t) (prior-nodes node) (safe-list prior)))
+        (next-list (if (eq next t) (next-nodes node) (safe-list next))))
+    (mapc (lambda (pnode)
+            (with-slots (next-nodes) pnode
+              (setf next-nodes (remove node next-nodes))))
+          prior-list)
+    (mapc (lambda (nnode)
+            (with-slots (prior-nodes) nnode
+              (setf prior-nodes (remove node prior-nodes))))
+          next-list))
+  (values))
+
+(defgeneric insert-node (node prior next))
+(defmethod insert-node ((node graph-node) prior next)
+  (detach-node prior :next next)
+  (attach-node node :prior prior :next next))
+
+(defun cyclic-graph-p (node)
+  (let ((visited-nodes (list node))
+        (visit-stack (next-nodes node)))
+    (loop for node = (pop visit-stack)
+          do (cond
+               ((null node) (return nil))
+               ((member node visited-nodes) (return t))
+               (t
+                (push node visited-nodes)
+                (setf visit-stack (append (next-nodes node) visit-stack)))))))
+
+(defun make-graph-node (&key prior next)
+  (let ((node (make-instance 'graph-node)))
+    (when (or prior next)
+      (attach-node node :prior prior :next next))
+    node))

core/jobs.lisp

@@ -0,0 +1,220 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/core/jobs
+    (:use :cl :blackbird
+          :stoe/core/utils
+          :stoe/core/thread
+          :stoe/core/containers)
+  (:export #:job #:job-fun #:job-args #:job-callback
+           #:job-thread #:thread-terminate-p
+           #:specialized-thread #:job-queue
+           #:async-job #:eval-on-thread #:push-new-thread
+           #:push-new-job-thread #:push-new-specialized-thread
+           #:get-next-job #:job-run
+           #:terminate-thread
+           #:thread-initialize #:thread-finalize #:thread-process)
+  (:import-from :stoe/core/modules
+                #:defmodule))
+(in-package :stoe/core/jobs)
+
+#+stoe-debug
+(setf blackbird-base:*debug-on-error* t)
+
+(defclass job ()
+  ((id :initarg :id :reader id)
+   (fun :initarg :fun :reader job-fun
+        :documentation "The entry point of the job.")
+   (args :initarg :args :reader job-args
+         :documentation "The arguments given to the entry point function.")
+   (callback :initarg :callback :reader job-callback
+             :documentation "The function called upon completion of the job.")
+   (errback :initarg :errback :reader job-errback
+            :documentation "The function called when an error has occured regarding the job.")))
+
+(defclass base-thread ()
+  ((name :initarg :name :reader name)
+   (id :initarg :id :reader id)
+   (thread)
+   (terminatep :initform nil :accessor thread-terminate-p))
+  (:documentation "Base class for threads."))
+
+(defclass job-thread (base-thread)
+  ()
+  (:documentation "Threads sharing a job queue."))
+
+(defclass specialized-thread (base-thread)
+  ((job-queue :initform (make-safe-queue nil) :accessor job-queue))
+  (:documentation "Threads with an individual job queue."))
+
+(defvar *thread-list* nil)
+(defvar *job-thread-count* 0)
+(defvar *job-queue* (make-queue))
+(defvar *job-waitqueue* (make-condition-variable :name "job-waitqueue"))
+(defvar *job-lock* (make-lock "job-lock"))
+(defvar *current-thread-object* nil)
+
+(let ((job-id 0)
+      (thread-id 0))
+  (defun make-job-id ()
+    (incf job-id))
+  (defun reset-job-ids ()
+    (setf job-id 0))
+  (defun make-thread-id ()
+    (incf thread-id))
+  (defun reset-thread-ids ()
+    (setf thread-id 0)))
+
+(defun job-thread-available-p ()
+  (> (reduce #'+ (mapcar (lambda (x) (if (typep x 'job-thread) 1 0)) *thread-list*)) 0))
+
+(defun make-job (id fun args callback errback)
+  (make-instance 'job :id id :fun fun :args args :callback callback :errback errback))
+
+(defun push-new-job (fun &optional args)
+  (with-promise (resolve reject :resolve-fn resolver :reject-fn rejecter)
+    (let ((job (make-job (make-job-id) fun args resolver rejecter)))
+      (if (job-thread-available-p)
+          (with-lock-held (*job-lock*)
+            (enqueue *job-queue* job)
+            (condition-notify *job-waitqueue*))
+          (job-run job *current-thread-object*)))))
+
+(defmacro async-job (args &body body)
+  (if args
+      `(push-new-job (lambda ,args ,@body) (list ,@args))
+      `(push-new-job (lambda () ,@body))))
+
+(defun push-job-to-thread (thread fun &optional args)
+  (with-promise (resolve reject :resolve-fn resolver :reject-fn rejecter)
+    (let ((job (make-job (make-job-id) fun args resolver rejecter)))
+      (if thread
+          (enqueue (job-queue thread) job)
+          (error "Thread ~a is not available~%" thread)))))
+
+(defmacro eval-on-thread (args thread &body body)
+  (if args
+      `(push-job-to-thread ,thread (lambda ,args ,@body) (list ,@args))
+      `(push-job-to-thread ,thread (lambda () ,@body))))
+
+(defun make-base-thread (type name fun)
+  "Create a new thread."
+  (let* ((id (make-thread-id))
+         (thread-object (make-instance type :name name :id id)))
+    (with-slots (thread) thread-object
+      (setf thread (make-thread fun :name name
+                                :initial-bindings
+                                (cons (cons '*current-thread-object* thread-object)
+                                      *default-special-bindings*))))
+    thread-object))
+
+(defun make-job-thread (name fun)
+  "Create a new job thread."
+  (make-base-thread 'job-thread name fun))
+
+(defun make-specialized-thread (name fun)
+  "Create a new specialized thread."
+  (make-base-thread 'specialized-thread name fun))
+
+(defun push-new-thread (type name)
+  (let ((thread (make-base-thread type name #'start-thread)))
+    (push thread *thread-list*)
+    thread))
+
+(defun push-new-job-thread (&optional name)
+  (push-new-thread 'job-thread name)
+  (incf *job-thread-count*))
+
+(defun push-new-specialized-thread (&optional name)
+  (push-new-thread 'specialized-thread name))
+
+(defun terminate-thread (thread)
+  "Terminate THREAD."
+  (setf (thread-terminate-p thread) t)
+  (condition-notify *job-waitqueue*))
+
+(defun initialize (&optional argv)
+  "Initialize the jobs module."
+  (format t "Initialize Job system~%")
+  (let ((main-thread (make-instance 'base-thread :name "Main Thread"
+                                    :id (make-thread-id))))
+    (with-slots (thread) main-thread
+      (setf thread (current-thread)))
+    (setq *current-thread-object* main-thread))
+  (let ((thread-count (get-command-line-option-number argv "-j" 0)))
+    (loop for i below thread-count
+         do (push-new-job-thread))))
+
+(defun finalize ()
+  "Finalize the jobs module."
+  (loop-with-progress "Finalize Job system"
+     while (> (length *thread-list*) 0)
+     do (progn
+          (update 0.0)
+          (sleep 0.1)
+          progress-step))
+  (assert (eq (length *thread-list*) 0))
+  (loop as job = (dequeue *job-queue*)
+     while job
+       do (funcall (job-errback job) 'job-canceled))
+  (reset-job-ids)
+  (reset-thread-ids))
+
+(defun update (delta-time)
+  "Check finished threads and join them."
+  (declare (ignore delta-time))
+  (setf *thread-list*
+        (remove-if (lambda (th)
+                     (with-slots (thread) th
+                       (when (and thread (not (thread-alive-p thread)))
+                         (restartable
+                           (join-thread thread))
+                         t)))
+                   *thread-list*)))
+
+(defmodule stoe/core/jobs :jobs)
+
+(defgeneric get-next-job (thread))
+(defmethod get-next-job ((thread base-thread)))
+(defmethod get-next-job ((thread job-thread))
+  (with-lock-held (*job-lock*)
+    (unless (peek *job-queue*)
+      (condition-wait *job-waitqueue* *job-lock*))
+    (when (peek *job-queue*)
+      (dequeue *job-queue*))))
+
+(defmethod get-next-job ((thread specialized-thread))
+  (dequeue (job-queue thread)))
+
+(defgeneric job-run (job thread))
+(defmethod job-run ((job job) thread)
+  (with-accessors ((callback job-callback) (fun job-fun) (args job-args)) job
+    (let ((result (apply fun args)))
+      (when callback
+        (funcall callback result)))))
+
+(defgeneric thread-initialize (thread))
+(defmethod thread-initialize ((thread base-thread))
+  "Initialize a thread."
+  (format t "Initialize thread ~a~%" (name thread)))
+
+(defgeneric thread-finalize (thread))
+(defmethod thread-finalize ((thread base-thread))
+  (format t "Finalize thread ~a~%" (name thread)))
+
+(defgeneric thread-process (thread))
+(defmethod thread-process ((thread base-thread))
+  (loop until (thread-terminate-p thread)
+     do (let ((job (get-next-job thread)))
+          (when job
+            (format t "Thread ~a: Running job ~a~%" (name thread) (id job))
+            (restartable
+              (job-run job thread))))))
+
+(defun start-thread ()
+  (let ((thread *current-thread-object*))
+    (thread-initialize thread)
+    (thread-process thread)
+    (thread-finalize thread)))

core/modules.lisp

@@ -0,0 +1,53 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/core/modules
+  (:use :cl)
+  (:export #:initialize-modules #:finalize-modules #:update-modules #:defmodule))
+(in-package :stoe/core/modules)
+
+(defparameter *modules-list* nil)
+
+(defun initialize-modules (&optional argv)
+  "Perform the engine and subsystems initialization process."
+  (format t "Initialize...~%")
+  (loop for module in *modules-list*
+     do (funcall (intern "INITIALIZE" (cdr module)) argv)))
+
+(defun finalize-modules ()
+  "Perform the engine and subsystems initialization process."
+  (format t "Initialize...~%")
+  (loop for module in (reverse *modules-list*)
+     do (funcall (intern "FINALIZE" (cdr module)))))
+
+(defun update-modules (delta-time)
+  "Update-the modules each loop."
+  (loop for module in *modules-list*
+     do (funcall (intern "UPDATE" (cdr module)) delta-time)))
+
+(defun register-module (module priority)
+  (pushnew (cons priority module) *modules-list*)
+  (sort *modules-list* (lambda (prio1 prio2)
+                         (< prio1 prio2)) :key #'car))
+
+(defmacro defmodule (module priority)
+  "Register a new module.
+The module is expected to have at least `initialize', `update', and `finalize' functions.
+`initialize' accepts an optional `argv' argument,
+`update' accepts a delta-time argument."
+  `(register-module ',module
+                     ,(ecase priority
+                        (:first (if (null *modules-list*)
+                                    0.0
+                                    (1- (caar *modules-list*))))
+                        (:last (if (null *modules-list*)
+                                   10.0
+                                   (1+ (caar (reverse *modules-list*)))))
+                        (:jobs 1.0)
+                        (:resources 2.0)
+                        (:input 3.0)
+                        (:game 4.0)
+                        (:render 9.0)
+                        (t priority))))

core/resources.lisp

@@ -0,0 +1,195 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/core/resources
+    (:use :cl :blackbird
+          :stoe/core/utils
+          :stoe/core/file
+          :stoe/core/modules
+          :stoe/core/jobs)
+  (:export #:resource #:res-path #:res-loaded-p
+           #:resource-initialize
+           #:shared-resource
+           #:defrestype
+           #:binary-resource #:stream-resource #:lisp-resource
+           #:resource-proxy
+           #:load-stream-resource
+           #:load-resource #:with-resource #:unload-resource))
+(in-package :stoe/core/resources)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar *resource-handlers* (make-hash-table :test #'equal)))
+
+(defvar *resources-db* (make-hash-table :test #'equal))
+
+(defclass resource ()
+  ((path :initarg :path :reader res-path)
+   (loaded :initarg :loaded :initform nil :reader res-loaded-p))
+  (:documentation "Base class for a resource."))
+
+(defgeneric resource-initialize (res))
+
+(defclass shared-resource (resource shared-object)
+  ()
+  (:documentation "Base class for a shared resource."))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun make-load-fun (extension classname fun-decl)
+    (let ((fun-name (intern (concatenate 'string "LOAD-"
+                                         (string-upcase extension) "-"
+                                         (symbol-name classname))))
+          (path (first (first fun-decl)))
+          (retrieved-value (first (second (first fun-decl))))
+          (retriever (second (second (first fun-decl))))
+          (res (third (first fun-decl)))
+          (proxy (gensym "PROXY"))
+          (new-res-p (gensym "NEWRES")))
+      `(progn
+         (defun ,fun-name (,path)
+           (multiple-value-bind (,proxy ,res ,new-res-p)
+               (make-resource ,path ',classname)
+             (values ,proxy (if ,new-res-p
+                                (bb:chain ,retriever
+                                  (:attach (,retrieved-value)
+                                     ,@(cdr fun-decl)
+                                     (resource-initialize ,res))
+                                  (:attach ()
+                                     (setf (slot-value ,res 'loaded) t))
+                                  (:catch (e)
+                                     (unload-resource ,proxy)
+                                     (signal e))
+                                  (:finally ()
+                                    ,res))
+                                (promisify ,res)))))
+         (setf (getf (gethash ,extension *resource-handlers*) :load) #',fun-name)))))
+
+(defmacro defrestype (extension classname &body body)
+  "Associate a file extension with a resource class and load/write mechanisms.
+The syntax of defrestype is as follows:
+
+(defrestype \"extension\" resource-class
+  ((:load (path-var data-loading-form resource-var)
+      forms)))"
+  `(progn
+     ,@(loop for fun in (car body)
+          collect (ecase (first fun)
+                    (:load (make-load-fun extension classname (cdr fun)))))))
+
+(defclass binary-resource (shared-resource)
+  ((buffer :initarg :buffer :type (array (unsigned-byte 8) (*)) :reader raw-data))
+  (:documentation "Resource containing binary data."))
+
+(defmethod resource-initialize ((res binary-resource)))
+
+(defclass stream-resource (resource)
+  ((stream :initarg :stream :reader raw-data))
+  (:documentation "Streaming resource."))
+
+(defclass lisp-resource (shared-resource)
+  ((data :initarg :data :reader raw-data))
+  (:documentation "Resource defined in lisp."))
+
+(defmethod resource-initialize ((res lisp-resource)))
+
+(defclass resource-proxy ()
+  ((resource :initarg :resource))
+  (:documentation "Proxy class of a resource."))
+
+(defmethod raw-data ((res resource-proxy))
+  (with-slots (resource) res
+    (when (and resource (tg:weak-pointer-value resource))
+      (raw-data (tg:weak-pointer-value resource)))))
+
+(defmethod res-path ((res resource-proxy))
+  (with-slots (resource) res
+    (when (and resource (tg:weak-pointer-value resource))
+      (res-path (tg:weak-pointer-value resource)))))
+
+(defmethod res-loaded-p ((res resource-proxy))
+  (with-slots (resource) res
+    (when (and resource (tg:weak-pointer-value resource))
+      (res-loaded-p (tg:weak-pointer-value resource)))))
+
+(defun initialize (&optional argv)
+  "Initialize resources module."
+  (declare (ignore argv)))
+
+(defun finalize ()
+  "Finalize resources module."
+  (when (> (hash-table-count *resources-db*) 0)
+    (format t "There are still ~d resources in the database~%" (hash-table-count *resources-db*))
+    (loop for res being the hash-values in *resources-db*
+       do (format t "  file ~a is still referenced by ~d proxies~%" (pathname-path (res-path res))
+                  (slot-value res 'refcount)))
+    (clrhash *resources-db*)))
+
+(defun update (delta-time)
+  (declare (ignore delta-time)))
+
+(defmodule stoe/core/resources :resources)
+
+(defun register-resource (res)
+  (assert (null (gethash (res-path res) *resources-db*)))
+  (setf (gethash (res-path res) *resources-db*) res))
+
+(defun unregister-resource (res)
+  (assert (gethash (res-path res) *resources-db*))
+  (remhash (res-path res) *resources-db*))
+
+(defun make-resource (path type)
+  (let ((res (gethash path *resources-db*))
+        (new-res-p nil))
+    (unless res
+      (setf res (make-instance type :path path))
+      (register-resource res)
+      (setf new-res-p t))
+    (values (make-resource-proxy res) res new-res-p)))
+
+(defmethod dec-ref :after ((res shared-resource))
+  (with-slots (refcount) res
+    (when (= refcount 0)
+      (unregister-resource res))))
+
+(defun make-resource-proxy (res)
+  (let ((proxy (make-instance 'resource-proxy :resource (tg:make-weak-pointer res))))
+    (tg:finalize proxy (lambda () (dec-ref res)))
+    (inc-ref res)
+    proxy))
+
+(defrestype "bin" binary-resource
+  ((:load (path (data (load-file path)) res)
+          (with-slots (buffer) res
+            (setf buffer data)))))
+
+(defrestype "lisp" lisp-resource
+  ((:load (path (str (load-file path :type 'character)) res)
+          (with-slots (data) res
+            (setf data (safe-read-from-string str))))))
+
+(defun load-stream-resource (path)
+  (declare (ignore path)))
+
+(defun load-resource (path)
+  (let* ((extension (pathname-type path))
+        (fun (getf (gethash extension *resource-handlers*) :load)))
+    (if fun
+        (funcall fun path)
+        (error "File format not supported."))))
+
+(defun unload-resource (proxy)
+  (tg:cancel-finalization proxy)
+  (with-slots (resource) proxy
+    (dec-ref (tg:weak-pointer-value resource))
+    (setf resource nil)))
+
+(defmacro with-resource ((path proxy &optional (promise (gensym "PROMISE") promise-p)) &body body)
+  `(multiple-value-bind (,proxy ,promise) (load-resource ,path)
+     ,(if promise-p
+          `(bb:chain ,promise
+                     ,@body)
+          `(progn
+             (bb:wait ,promise
+                      ,@body)
+             ,proxy))))

core/thread.lisp

@@ -0,0 +1,42 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/core/thread
+    (:use :cl :alexandria)
+  (:recycle :bordeaux-threads)
+  (:export #:thread #:make-thread #:current-thread #:threadp #:thread-name
+           #:*default-special-bindings*
+           #:make-lock #:acquire-lock #:release-lock #:with-lock-held
+           #:make-recursive-lock #:acquire-recursive-lock
+           #:release-recursive-lock #:with-recursive-lock-held
+           #:make-condition-variable #:condition-wait #:condition-notify
+           #:with-timeout #:timeout
+           #:all-threads #:interrupt-thread #:destroy-thread #:thread-alive-p
+           #:join-thread #:thread-yield))
+(in-package :stoe/core/thread)
+
+(defmacro with-lock-held ((place &optional (waitp t)) &body body)
+  (once-only (place)
+    `(when (acquire-lock ,place ,waitp)
+       (unwind-protect
+            (progn
+              ,@body)
+         (release-lock ,place)))))
+
+;;; Functions not implemented by bordeaux-threads
+
+;; (defun condition-broadcast (queue)
+;;   "Notify all threads waiting on `queue'."
+;;   #+(and sbcl sb-thread) (sb-thread:condition-broadcast queue)
+;;   #-(and sbcl sb-thread) (error-implementation-unsupported))
+
+;; (defmacro atomic-set-flag (place flag)
+;;   "Set the variable pointed to by `place' to the value `flag' atomically."
+;;   #+ (and sbcl sb-thread)
+;;   `(flet ((set-flag (flag place)
+;;             (declare (ignore place))
+;;             flag))
+;;      (sb-ext:atomic-update ,place #'set-flag ,flag))
+;;   #- (and sbcl sb-thread) (error-implemntation-unsupported))

core/time.lisp

@@ -0,0 +1,46 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/core/time
+    (:use :cl)
+  (:export #:clock #:make-clock #:update-clock #:clock-delta))
+(in-package :stoe/core/time)
+
+(defun get-current-time ()
+  "Return the current time in seconds and microseconds."
+  #+sbcl
+  (multiple-value-bind (sec usec) (sb-ext:get-time-of-day)
+    (+ (* sec 1000000) usec))
+  #-sbcl
+  (let* ((time (get-internal-real-time))
+         (sec (/ time internal-time-units-per-second))
+         (usec (* time (/ 1000000 internal-time-units-per-second))))
+    (+ (* sec 1000000) usec)))
+
+(defclass clock ()
+  ((current-time :initarg :time)
+   (last-time :initarg :last-time)
+   (delta-time :initform nil)
+   (scale :initarg :scale)
+   (pausep :initarg :pause)))
+
+(defun make-clock (&optional (time 0 timep) (scale 1.0) pause)
+  (unless timep
+    (setf time (get-current-time)))
+  (make-instance 'clock :time time :last-time time :scale scale :pause pause))
+
+(defun update-clock (clock &optional (delta 0 deltap))
+  (with-slots (current-time last-time delta-time scale pausep) clock
+    (setf delta-time nil)
+    (unless pausep
+      (setf last-time current-time)
+      (if deltap
+          (incf current-time (* delta scale))
+          (setf current-time (get-current-time))))))
+
+(defun clock-delta (clock)
+  (with-slots (current-time last-time delta-time) clock
+    (or delta-time
+        (setf delta-time (- current-time last-time)))))

core/utils.lisp

@@ -0,0 +1,145 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/core/utils
+  (:export #:safe-first #:safe-list
+           #:group #:ret
+           #:restartable
+           #:progress-step
+           #:loop-with-progress
+           #:add-hook #:remove-hook #:run-hook
+           #:shared-object #:refcount #:inc-ref #:dec-ref
+           #:extend-array #:shrink-array
+           #:error-implementation-unsupported
+           #:get-command-line-option
+           #:get-command-line-option-number
+           #:pathname-path
+           #:name #:id #:parent #:size
+           #:raw-data))
+(in-package :stoe/core/utils)
+
+(defun safe-first (x)
+  "Return the first element of `x' if it is a list, return `x' otherwise."
+  (if (listp x) (first x) x))
+
+(defun safe-list (x)
+  "Return `x' if it is a list, return '(x) otherwise."
+  (if (listp x) x (list x)))
+
+(defun group (source &optional (n 2))
+  "Regroup the list `source' elements by n."
+  (when (zerop n)
+    (error "zero length"))
+  (labels ((rec (source acc)
+             (let ((rest (nthcdr n source)))
+               (if (consp rest)
+                   (rec rest (cons (subseq source 0 n) acc))
+                   (nreverse (cons source acc))))))
+    (if source (rec source nil) nil)))
+
+(defmacro ret (var val &body body)
+  `(let ((,var ,val))
+     ,@body
+     ,var))
+
+(defmacro restartable (&body body)
+  "Provide a Continue restart."
+  `(restart-case
+       (progn
+         ,@body)
+     (continue () :report "Continue")))
+
+(defmacro loop-with-progress (msg &body body)
+  "Allow a looping process to display feedback."
+  `(let ((progress-max-columns 80))
+     (symbol-macrolet ((progress-step
+                        (progn
+                          (when (> progress-index progress-max-columns)
+                            (format t "~%")
+                            (setf progress-index 0))
+                          (format t "."))))
+       (format t ,msg)
+       (loop for progress-index upfrom ,(length msg)
+            ,@body)
+       (format t "~%"))))
+
+(defmacro add-hook (hook fun &optional append)
+  "Setup `fun' to be called within specified `hook'."
+  `(unless (member ,fun ,hook)
+     ,(if append
+          `(setf ,hook (append ,hook (list ,fun)))
+          `(push ,fun ,hook))))
+
+(defmacro remove-hook (hook fun)
+  "Remove `fun' from `hook'."
+  `(setf ,hook (delete ,fun ,hook)))
+
+(defun run-hook (hook &rest args)
+  "Apply all functions attached to `hook' with specified `args' if any."
+  (let (result)
+    (mapc (lambda (fun)
+            (setf result (apply fun args)))
+          hook)
+    result))
+
+(defclass shared-object ()
+  ((refcount :initform 0 :reader refcount)))
+
+(defgeneric inc-ref (obj))
+(defmethod inc-ref ((obj shared-object))
+  (with-slots (refcount) obj
+    (incf refcount)))
+
+(defgeneric dec-ref (obj))
+(defmethod dec-ref ((obj shared-object))
+  (with-slots (refcount) obj
+    (when (> refcount 0)
+      (decf refcount))))
+
+(let ((extend-ratio 1.5))
+  (defun extend-array (array)
+    "Extend an array to extend-ratio coefficient."
+    (when (= (fill-pointer array) (array-total-size array))
+      (adjust-array array (floor (* (array-total-size array) extend-ratio))))
+    (prog1
+        (fill-pointer array)
+      (incf (fill-pointer array))))
+
+  (defun shrink-array (array new-fill-pointer)
+    "Shrink an array to its fill-pointer."
+    (setf (fill-pointer array) new-fill-pointer)))
+
+(defun error-implementation-unsupported ()
+  "Return an error specifying the current lisp implementation is not supported."
+  (error "For now, only sbcl is supported."))
+
+(defun get-command-line-option (argv optname &optional default)
+  "Return the option designated by `optname' from the command-line `argv'."
+  (let ((opt (member optname argv :test #'equal)))
+    (or (and (cdr opt) (second opt)) default)))
+
+(defun get-command-line-option-number (argv optname &optional default)
+  "Return the option designated by `optname' from the command-line `argv' as a number."
+  (let ((opt (get-command-line-option argv optname)))
+    (if opt
+        (let ((value (with-input-from-string (in opt)
+                       (read in))))
+          (assert (numberp value))
+          value)
+        default)))
+
+(defun pathname-path (path)
+  (with-output-to-string (s)
+    (format s "~{~a/~}~a~@[.~a~]" (cdr (pathname-directory path))
+            (pathname-name path) (pathname-type path))))
+
+(defgeneric name (obj)
+  (:documentation "Return the name of an object."))
+(defgeneric id (obj)
+  (:documentation "Return the id of an object."))
+(defgeneric size (obj)
+  (:documentation "Return the size of an object."))
+(defgeneric raw-data (obj)
+  (:documentation "Return the raw data contained in an object."))

data/cube.dae

@@ -0,0 +1,199 @@
+<?xml version="1.0" encoding="utf-8"?>
+<COLLADA xmlns="http://www.collada.org/2005/11/COLLADASchema" version="1.4.1">
+  <asset>
+    <contributor>
+      <author>Blender User</author>
+      <authoring_tool>Blender 2.75.0 commit date:2015-07-07, commit time:14:56, hash:c27589e</authoring_tool>
+    </contributor>
+    <created>2015-08-19T17:43:33</created>
+    <modified>2015-08-19T17:43:33</modified>
+    <unit name="meter" meter="1"/>
+    <up_axis>Z_UP</up_axis>
+  </asset>
+  <library_cameras>
+    <camera id="Camera-camera" name="Camera">
+      <optics>
+        <technique_common>
+          <perspective>
+            <xfov sid="xfov">49.13434</xfov>
+            <aspect_ratio>1.777778</aspect_ratio>
+            <znear sid="znear">0.1</znear>
+            <zfar sid="zfar">100</zfar>
+          </perspective>
+        </technique_common>
+      </optics>
+      <extra>
+        <technique profile="blender">
+          <YF_dofdist>0</YF_dofdist>
+          <shiftx>0</shiftx>
+          <shifty>0</shifty>
+        </technique>
+      </extra>
+    </camera>
+  </library_cameras>
+  <library_lights>
+    <light id="Lamp-light" name="Lamp">
+      <technique_common>
+        <point>
+          <color sid="color">1 1 1</color>
+          <constant_attenuation>1</constant_attenuation>
+          <linear_attenuation>0</linear_attenuation>
+          <quadratic_attenuation>0.00111109</quadratic_attenuation>
+        </point>
+      </technique_common>
+      <extra>
+        <technique profile="blender">
+          <adapt_thresh>0.000999987</adapt_thresh>
+          <area_shape>1</area_shape>
+          <area_size>0.1</area_size>
+          <area_sizey>0.1</area_sizey>
+          <area_sizez>1</area_sizez>
+          <atm_distance_factor>1</atm_distance_factor>
+          <atm_extinction_factor>1</atm_extinction_factor>
+          <atm_turbidity>2</atm_turbidity>
+          <att1>0</att1>
+          <att2>1</att2>
+          <backscattered_light>1</backscattered_light>
+          <bias>1</bias>
+          <blue>1</blue>
+          <buffers>1</buffers>
+          <bufflag>0</bufflag>
+          <bufsize>2880</bufsize>
+          <buftype>2</buftype>
+          <clipend>30.002</clipend>
+          <clipsta>1.000799</clipsta>
+          <compressthresh>0.04999995</compressthresh>
+          <dist sid="blender_dist">29.99998</dist>
+          <energy sid="blender_energy">1</energy>
+          <falloff_type>2</falloff_type>
+          <filtertype>0</filtertype>
+          <flag>0</flag>
+          <gamma sid="blender_gamma">1</gamma>
+          <green>1</green>
+          <halo_intensity sid="blnder_halo_intensity">1</halo_intensity>
+          <horizon_brightness>1</horizon_brightness>
+          <mode>8192</mode>
+          <ray_samp>1</ray_samp>
+          <ray_samp_method>1</ray_samp_method>
+          <ray_samp_type>0</ray_samp_type>
+          <ray_sampy>1</ray_sampy>
+          <ray_sampz>1</ray_sampz>
+          <red>1</red>
+          <samp>3</samp>
+          <shadhalostep>0</shadhalostep>
+          <shadow_b sid="blender_shadow_b">0</shadow_b>
+          <shadow_g sid="blender_shadow_g">0</shadow_g>
+          <shadow_r sid="blender_shadow_r">0</shadow_r>
+          <sky_colorspace>0</sky_colorspace>
+          <sky_exposure>1</sky_exposure>
+          <skyblendfac>1</skyblendfac>
+          <skyblendtype>1</skyblendtype>
+          <soft>3</soft>
+          <spotblend>0.15</spotblend>
+          <spotsize>75</spotsize>
+          <spread>1</spread>
+          <sun_brightness>1</sun_brightness>
+          <sun_effect_type>0</sun_effect_type>
+          <sun_intensity>1</sun_intensity>
+          <sun_size>1</sun_size>
+          <type>0</type>
+        </technique>
+      </extra>
+    </light>
+  </library_lights>
+  <library_images/>
+  <library_effects>
+    <effect id="Material-effect">
+      <profile_COMMON>
+        <technique sid="common">
+          <phong>
+            <emission>
+              <color sid="emission">0 0 0 1</color>
+            </emission>
+            <ambient>
+              <color sid="ambient">0 0 0 1</color>
+            </ambient>
+            <diffuse>
+              <color sid="diffuse">0.64 0.64 0.64 1</color>
+            </diffuse>
+            <specular>
+              <color sid="specular">0.5 0.5 0.5 1</color>
+            </specular>
+            <shininess>
+              <float sid="shininess">50</float>
+            </shininess>
+            <index_of_refraction>
+              <float sid="index_of_refraction">1</float>
+            </index_of_refraction>
+          </phong>
+        </technique>
+      </profile_COMMON>
+    </effect>
+  </library_effects>
+  <library_materials>
+    <material id="Material-material" name="Material">
+      <instance_effect url="#Material-effect"/>
+    </material>
+  </library_materials>
+  <library_geometries>
+    <geometry id="Cube-mesh" name="Cube">
+      <mesh>
+        <source id="Cube-mesh-positions">
+          <float_array id="Cube-mesh-positions-array" count="24">1 1 -1 1 -1 -1 -1 -0.9999998 -1 -0.9999997 1 -1 1 0.9999995 1 0.9999994 -1.000001 1 -1 -0.9999997 1 -1 1 1</float_array>
+          <technique_common>
+            <accessor source="#Cube-mesh-positions-array" count="8" stride="3">
+              <param name="X" type="float"/>
+              <param name="Y" type="float"/>
+              <param name="Z" type="float"/>
+            </accessor>
+          </technique_common>
+        </source>
+        <source id="Cube-mesh-normals">
+          <float_array id="Cube-mesh-normals-array" count="36">0 0 -1 0 0 1 1 -5.96046e-7 3.27825e-7 -4.76837e-7 -1 0 -1 2.38419e-7 -1.19209e-7 2.08616e-7 1 0 0 0 -1 0 0 1 1 0 -2.38419e-7 0 -1 -4.76837e-7 -1 2.38419e-7 -1.49012e-7 2.68221e-7 1 2.38419e-7</float_array>
+          <technique_common>
+            <accessor source="#Cube-mesh-normals-array" count="12" stride="3">
+              <param name="X" type="float"/>
+              <param name="Y" type="float"/>
+              <param name="Z" type="float"/>
+            </accessor>
+          </technique_common>
+        </source>
+        <vertices id="Cube-mesh-vertices">
+          <input semantic="POSITION" source="#Cube-mesh-positions"/>
+        </vertices>
+        <polylist material="Material-material" count="12">
+          <input semantic="VERTEX" source="#Cube-mesh-vertices" offset="0"/>
+          <input semantic="NORMAL" source="#Cube-mesh-normals" offset="1"/>
+          <vcount>3 3 3 3 3 3 3 3 3 3 3 3 </vcount>
+          <p>0 0 1 0 2 0 7 1 6 1 5 1 4 2 5 2 1 2 5 3 6 3 2 3 2 4 6 4 7 4 0 5 3 5 7 5 3 6 0 6 2 6 4 7 7 7 5 7 0 8 4 8 1 8 1 9 5 9 2 9 3 10 2 10 7 10 4 11 0 11 7 11</p>
+        </polylist>
+      </mesh>
+    </geometry>
+  </library_geometries>
+  <library_controllers/>
+  <library_visual_scenes>
+    <visual_scene id="Scene" name="Scene">
+      <node id="Camera" name="Camera" type="NODE">
+        <matrix sid="transform">0.6858805 -0.3173701 0.6548619 7.481132 0.7276338 0.3124686 -0.6106656 -6.50764 -0.01081678 0.8953432 0.4452454 5.343665 0 0 0 1</matrix>
+        <instance_camera url="#Camera-camera"/>
+      </node>
+      <node id="Lamp" name="Lamp" type="NODE">
+        <matrix sid="transform">-0.2908646 -0.7711008 0.5663932 4.076245 0.9551712 -0.1998834 0.2183912 1.005454 -0.05518906 0.6045247 0.7946723 5.903862 0 0 0 1</matrix>
+        <instance_light url="#Lamp-light"/>
+      </node>
+      <node id="Cube" name="Cube" type="NODE">
+        <matrix sid="transform">1 0 0 0 0 1 0 0 0 0 1 0 0 0 0 1</matrix>
+        <instance_geometry url="#Cube-mesh" name="Cube">
+          <bind_material>
+            <technique_common>
+              <instance_material symbol="Material-material" target="#Material-material"/>
+            </technique_common>
+          </bind_material>
+        </instance_geometry>
+      </node>
+    </visual_scene>
+  </library_visual_scenes>
+  <scene>
+    <instance_visual_scene url="#Scene"/>
+  </scene>
+</COLLADA>

engine/all.lisp

@@ -0,0 +1,23 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2017 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/engine/all
+    (:nicknames :engine)
+  (:use-reexport
+   ;; :stoe/engine/gl-utils
+   ;; :stoe/engine/mesh
+   ;; :stoe/engine/scene-graph
+   ;; :stoe/engine/camera
+   ;; :stoe/engine/scene
+   ;; :stoe/engine/input
+   ;; :stoe/engine/viewport
+   ;; :stoe/engine/shaders
+   ;; :stoe/engine/render
+   ;; :stoe/engine/model
+   ;; #+stoe-foreign-assets
+   ;; :stoe/engine/import
+   :stoe/engine/window
+   :stoe/engine/render
+   ))

engine/camera.lisp

@@ -0,0 +1,39 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/engine/camera
+    (:use :cl :maths
+          :stoe/core/entity
+          :stoe/engine/scene-graph)
+    (:export #:camera-component #:projection #:view
+             #:update-view))
+(in-package :stoe/engine/camera)
+
+(defcomponent camera-component ()
+  ((fovy :initarg :fovy)
+   (aspect :initarg :aspect)
+   (near :initarg :near)
+   (far :initarg :far)
+   (projection :initarg :projection :reader projection)
+   (view :accessor view))
+  (:needs scene-object-component)
+  (:documentation "Component for a camera representing a view of the game world."))
+
+(defmethod initialize-instance :after ((camera camera-component) &key owner fovy aspect near far)
+  (with-slots (projection) camera
+    (setf projection (mperspective fovy aspect near far)))
+  (with-components (scene-object-component) owner
+    (with-slots (position direction) scene-object-component
+      (update-view camera position direction))))
+
+(defmethod print-object ((camera camera-component) stream)
+  (with-slots (fovy aspect near far) camera
+    (print-unreadable-object (camera stream :type t)
+      (format stream "~@<~:_fovy = ~a ~:_aspect = ~a ~:_near = ~a ~:_far = ~a~:>"
+              fovy aspect near far))))
+
+(defun update-view (camera position direction)
+  "Compute the world-to-view matrix from the position and the direction of the camera"
+  (setf (view camera) (m* (transpose (quat-to-mat4 direction)) (mtranslate (v- position)))))

engine/gl-utils.lisp

@@ -0,0 +1,50 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/engine/gl-utils
+    (:use :cl)
+  (:export #:gl-assert
+           #:gl-restart
+           #:ctype-size
+           #:ctype-to-gltype
+           #:ltype-to-ctype))
+(in-package :stoe/engine/gl-utils)
+
+(defmacro gl-assert (&body body)
+  `(progn
+     ,@(loop for form in body
+          collect `(prog1
+                       ,form
+                     (let ((err-sym (%gl:get-error)))
+                       (unless (eq err-sym :zero)
+                         (error "The OpenGL command `~a'~%~2iresulted in an error: ~s~%"
+                                ',form err-sym)))))))
+
+(defmacro gl-restart (form)
+  `(restart-case
+       (gl-assert ,form)
+     (continue () :report "Continue")))
+
+(defun ctype-size (type)
+  (ecase type
+    (:unsigned-char 1)
+    (:unsigned-short 2)
+    (:unsigned-int 4)
+    (:float 4)))
+
+(defun ctype-to-gltype (ctype)
+  (case ctype
+    (:unsigned-char :unsigned-byte)
+    (t ctype)))
+
+(defun ltype-to-ctype (ltype len)
+  (ecase ltype
+    (single-float :float)
+    (double-float :double)
+    (t (cond
+         ((< len 256) :unsigned-char)
+         ((< len 65536) :unsigned-short)
+         ((< len 4294967296) :unsigned-int)
+         (t :uint64)))))

engine/import.lisp

@@ -0,0 +1,99 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/engine/import
+    (:use :cl :maths
+          :stoe/core/utils
+          :stoe/core/jobs
+          :stoe/core/resources
+          :stoe/engine/gl-utils
+          :stoe/engine/mesh
+          :stoe/engine/scene
+          :stoe/engine/model)
+  (:export #:import-graphic-assets))
+(in-package :stoe/engine/import)
+
+(defun import-stream (stream attrib)
+  (let* ((len (array-total-size stream)))
+    (when (> len 0)
+      (let* ((count len)
+             (stride (array-total-size (aref stream 0)))
+             (elt-type (array-element-type (aref stream 0)))
+             (ctype (ltype-to-ctype elt-type (* count stride)))
+             (array (make-array (list (* count stride)) :element-type elt-type)))
+        (loop for i below count
+           do (let ((row (aref stream i)))
+                (loop for j below stride
+                   do (setf (aref array (+ j (* i stride))) (aref row j)))))
+        (make-vertex-stream array ctype count attrib stride)))))
+
+(defun import-faces (faces mode)
+  (let* ((count (array-total-size faces))
+         (stride (array-total-size (aref faces 0)))
+         (elt-type (array-element-type (aref faces 0)))
+         (ctype (ltype-to-ctype elt-type (* count stride)))
+         (array (make-array (list (* count stride)) :element-type 'fixnum)))
+    (loop for i below count
+       do (let ((row (aref faces i)))
+            (loop for j below stride
+               do (setf (aref array (+ j (* i stride))) (aref row j)))))
+    (make-index-stream array ctype count mode)))
+
+(defun import-transform (trans)
+  (let ((mat (mat-null 4 'single-float)))
+    (loop for i below (first (dimensions mat))
+       do (loop for j below (second (dimensions mat))
+             do (setf (mref mat i j) (aref trans (+ j (* i (second (dimensions mat))))))))
+    mat))
+
+(defun import-nodes (node)
+  (let ((len (length (classimp:children node)))
+        model-node)
+    (loop for i below len
+       for child = (aref (classimp:children node) i)
+       do (let ((child-node (import-nodes child)))
+            (when child-node
+              (unless model-node
+                (setf model-node
+                      (make-model-node
+                       (classimp:name node) (coerce (classimp:meshes node) 'list)
+                       nil (import-transform (classimp:transform node)))))
+              (attach-node child-node model-node))))
+    (when (and (null model-node) (> (length (classimp:meshes node)) 0))
+      (setf model-node (make-model-node
+                        (classimp:name node) (coerce (classimp:meshes node) 'list)
+                        nil (import-transform (classimp:transform node)))))
+    model-node))
+
+(defun import-modes (mesh)
+  (when (classimp:mesh-has-multiple-primitive-types mesh)
+    (error "Multiple primitive types are not yet supported"))
+  (cond
+    ((classimp:mesh-has-points mesh) :points)
+    ((classimp:mesh-has-lines mesh) :lines)
+    ((classimp:mesh-has-triangles mesh) :triangles)
+    ((classimp:mesh-has-polygons mesh) (error "Polygons mode is not supported."))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun import-graphic-assets (path)
+    (async-job (path)
+      (classimp:import-into-lisp path))))
+
+(defrestype "dae" model-resource
+  ((:load (path (ai-scene (import-graphic-assets path)) res)
+          (with-slots (root-node meshes) res
+            (setf meshes
+                  (coerce (loop for i below (array-total-size (classimp:meshes ai-scene))
+                             for mesh = (aref (classimp:meshes ai-scene) i)
+                             collect (make-mesh
+                                      (remove nil
+                                              (list (import-stream (classimp:vertices mesh)
+                                                                   :position)
+                                                    (when (> (length (classimp:colors mesh)) 0)
+                                                      (import-stream (aref (classimp:colors mesh) 0)
+                                                                     :color))))
+                                      (import-faces (classimp:faces mesh) (import-modes mesh))))
+                          'vector)
+                  root-node (import-nodes (classimp:root-node ai-scene)))))))

engine/input.lisp

@@ -3,17 +3,16 @@
   Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
 |#
 
-(in-package :cl-user)
-(defpackage stoe.input
-  (:nicknames :input)
-  (:use :cl :alexandria
-        :utils :containers)
-  (:export :initialize :finalize :update
-           :on-key-event :on-button-event :on-motion-event
-           :make-keymap :set-global-keymap
-           :define-key :global-set-key
-           :define-motion :global-set-motion))
-(in-package :stoe.input)
+(uiop:define-package :stoe/engine/input
+    (:use :cl :alexandria
+          :stoe/core/utils
+          :stoe/core/containers
+          :stoe/core/modules)
+  (:export #:on-key-event #:on-button-event #:on-motion-event
+           #:make-keymap #:set-global-keymap
+           #:define-key #:global-set-key
+           #:define-motion #:global-set-motion))
+(in-package :stoe/engine/input)
 
 (define-constant +keyevent-classes+ '(:press :release :repeat :continuous)
   :test #'equal :documentation "List of the available key event classes.")
@@ -64,6 +63,8 @@ trigger key events that occured this frame."
      do (process-event event))
   (mapc (lambda (key) (process-active-key key delta-time)) *active-keys*))
 
+(defmodule stoe/engine/input :input)
+
 (defun set-global-keymap (keymap)
   "Set the current global keymap."
   (setf *current-global-keymap* keymap))
@@ -187,8 +188,8 @@ trigger key events that occured this frame."
             (args (rest motion)))
         (if args
             (apply fun (mapcar (lambda (arg)
-                                 (if (and (keywordp arg) (slot-exists-p event (intern (symbol-name arg) :input)))
-                                     (slot-value event (intern (symbol-name arg) :input))
+                                 (if (and (keywordp arg) (slot-exists-p event (intern (symbol-name arg) :stoe/engine/input)))
+                                     (slot-value event (intern (symbol-name arg) :stoe/engine/input))
                                      arg))
                                args))
             (funcall fun))))))

engine/mesh.lisp

@@ -0,0 +1,101 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/engine/mesh
+    (:use :cl :cffi :maths :shader
+          :stoe/core/utils
+          :stoe/engine/gl-utils)
+  (:export #:mesh #:vertex-streams #:faces #:make-mesh
+           #:stream-array #:ctype
+           #:vertex-stream #:attrib
+           #:index-stream #:mode
+           #:make-stream-array #:make-vertex-stream #:make-index-stream #:bsize
+           #:mesh-initialize
+           #:render-mesh))
+(in-package :stoe/engine/mesh)
+
+(defclass mesh ()
+  ((streams :initarg :streams :reader vertex-streams)
+   (faces :initarg :faces :reader faces)
+   (material :initarg :material :reader material)
+   (vertex-buffers :initform nil :accessor vertex-buffers)
+   (index-buffer :initform nil :accessor index-buffer))
+  (:documentation "Class for a single mesh."))
+
+(defun make-mesh (&optional streams faces)
+  (make-instance 'mesh :streams streams :faces faces :material nil))
+
+(defclass stream-array ()
+  ((array :initarg :array :reader raw-data)
+   (ctype :initarg :ctype :reader ctype)
+   (count :initarg :count)))
+
+(defclass vertex-stream (stream-array)
+  ((attrib :initarg :attrib :reader attrib)
+   (stride :initarg :stride :reader stride)))
+
+(defclass index-stream (stream-array)
+  ((mode :initarg :mode :reader mode)))
+
+(defun make-stream-array (array ctype count stride)
+  (make-instance 'stream-array :array array :ctype ctype :count count :stride stride))
+
+(defun make-vertex-stream (array ctype count attrib stride)
+  (make-instance 'vertex-stream :array array :ctype ctype :count count :attrib attrib :stride stride))
+
+(defun make-index-stream (array ctype count mode)
+  (make-instance 'index-stream :array array :ctype ctype :count count :mode mode))
+
+(defmethod size ((stream stream-array))
+  (length (raw-data stream)))
+
+(defgeneric bsize (object))
+(defmethod bsize ((stream stream-array))
+  (* (ctype-size (ctype stream)) (length (raw-data stream))))
+
+(defun mesh-initialize (mesh)
+  (let ((vertex-buffers (gl:gen-buffers (length (vertex-streams mesh))))
+        (index-buffer (gl:gen-buffer)))
+    (loop for stream in (vertex-streams mesh)
+       for buffer-object in vertex-buffers
+       do (let* ((ctype (ctype stream)) (size (size stream)) (bsize (bsize stream))
+                 (data (raw-data stream))
+                 (ptr (foreign-alloc ctype :count size)))
+            (dotimes (i (length data))
+              (setf (mem-aref ptr ctype i) (aref data i)))
+            (gl:bind-buffer :array-buffer buffer-object)
+            (%gl:buffer-data :array-buffer bsize ptr :static-draw)
+            (foreign-free ptr)))
+    (gl:bind-buffer :array-buffer 0)
+    (let* ((faces (faces mesh)) (data (raw-data faces))
+           (size (size faces)) (bsize (bsize faces))
+           (ptr (foreign-alloc (ctype faces) :initial-contents data :count size)))
+      (gl:bind-buffer :element-array-buffer index-buffer)
+      (%gl:buffer-data :element-array-buffer bsize ptr :static-draw)
+      (foreign-free ptr)
+      (gl:bind-buffer :element-array-buffer 0))
+    (setf (vertex-buffers mesh) vertex-buffers
+          (index-buffer mesh) index-buffer)))
+
+(defun render-mesh (mesh program)
+  (with-accessors ((vertex-buffers vertex-buffers) (streams vertex-streams)
+                   (index-buffer index-buffer) (faces faces)) mesh
+    (loop for i below (length vertex-buffers)
+       for vertex in vertex-buffers
+       for stream in streams
+       with offset = 0
+       do (let* ((ctype (ctype stream)) (attrib (attrib stream))
+                 (bsize (bsize stream)) (stride (stride stream))
+                 (loc (get-location program attrib)))
+            (gl:bind-buffer :array-buffer vertex)
+            (gl-assert (gl:enable-vertex-attrib-array loc)
+                       (gl:vertex-attrib-pointer loc stride ctype
+                                                 :false 0 offset))
+            (incf offset bsize)))
+    (gl:bind-buffer :element-array-buffer index-buffer)
+    (gl-assert (%gl:draw-elements (mode faces) (bsize faces)
+                                  (ctype-to-gltype (ctype faces)) 0))
+    (gl:bind-buffer :element-array-buffer 0)
+    (gl:bind-buffer :array-buffer 0)))

engine/model.lisp

@@ -0,0 +1,73 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/engine/model
+    (:use :cl :maths
+          :stoe/core/utils
+          :stoe/core/entity
+          :stoe/core/resources
+          :stoe/engine/scene-graph
+          :stoe/engine/mesh
+          :stoe/engine/scene
+          :stoe/engine/render)
+  (:export #:model-node #:mesh-indexes #:make-model-node
+           #:model-resource #:root-node #:meshes #:meshref
+           #:mesh-component #:model #:make-mesh-component
+           #:create-model))
+(in-package :stoe/engine/model)
+
+(defclass model-node (node)
+  ((name :initarg :name :accessor name)
+   (mesh-indexes :initarg :mesh-indexes :accessor mesh-indexes)
+   (transform :initarg :transform :reader transform :type float44)))
+
+(defun make-model-node (name mesh-indexes &optional parent (transform (mat-id 4 'single-float)))
+  (make-instance 'model-node :parent parent :name name :mesh-indexes mesh-indexes :transform transform))
+
+(defclass model-resource (shared-resource)
+  ((root-node :initarg :root-node :accessor root-node :type model-node)
+   (meshes :initarg :meshes :accessor meshes))
+  (:documentation "Resource class containing the actual model data."))
+
+(defmethod root-node ((res resource-proxy))
+  (with-slots (resource) res
+    (when (tg:weak-pointer-value resource)
+      (root-node (tg:weak-pointer-value resource)))))
+
+(defmethod meshes ((res resource-proxy))
+  (with-slots (resource) res
+    (when (tg:weak-pointer-value resource)
+      (meshes (tg:weak-pointer-value resource)))))
+
+(defun meshref (model-proxy subscript)
+  (aref (meshes model-proxy) subscript))
+
+(defmethod resource-initialize ((res model-resource))
+  (with-slots (meshes) res
+    (on-render-thread (meshes)
+      (loop for mesh across meshes
+         do (mesh-initialize mesh)))))
+
+(defcomponent mesh-component (graph-node-component)
+  ((model :initarg :model :reader model)
+   (model-node :initarg :model-node :reader model-node :type model-node))
+  (:needs graph-node-component)
+  (:documentation "A graph node component that contains a single mesh."))
+
+(defun create-model (name path &optional (parent-entity (current-scene)))
+  "Create a model from a resource file and attach it to the parent entity or root."
+  (ret entity (create-entity name
+                (graph-node-component :parent parent-entity))
+    (with-resource (path model)
+      (with-components ((node graph-node-component)) entity
+        (labels ((clone-mesh (node parent)
+                   (setf parent (make-instance 'mesh-component :owner entity :parent parent
+                                               :transform (transform node) :model model :model-node node))
+                   (mapc (lambda (child) (clone-mesh child parent)) (children node))))
+          (mapc (lambda (child) (clone-mesh child node)) (children (root-node model))))))))
+
+(defmethod render ((mesh mesh-component))
+  (loop for mesh-idx in (mesh-indexes (model-node mesh))
+     do (render-single-mesh (meshref (model mesh) mesh-idx) (transform mesh))))

engine/render-gl.lisp

@@ -0,0 +1,109 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/engine/render
+    (:use :cl :cffi :maths :shader
+          :stoe/core/utils
+          :stoe/core/containers
+          :stoe/core/time
+          :stoe/core/modules
+          :stoe/core/thread
+          :stoe/core/jobs
+          :stoe/core/entity
+          :stoe/engine/gl-utils
+          :stoe/engine/mesh
+          :stoe/engine/viewport
+          :stoe/engine/scene-graph
+          :stoe/engine/camera
+          :stoe/engine/scene)
+    (:export #:on-render-thread
+             #:render #:render-single-mesh))
+(in-package :stoe/engine/render)
+
+(defclass render-thread (specialized-thread)
+  ())
+
+(defvar *render-thread* nil)
+(defvar *frames-per-second* 0.0)
+
+(defun initialize (&optional argv)
+  "Initialize the render module.
+Create an opengl context attached to a window."
+  (format t "Initialize Render module~%")
+  (viewport-configure argv)
+  (setf *render-thread* (push-new-thread 'render-thread "Render thread")))
+
+(defun finalize ()
+  "Finalize the render module.
+Destroy the opengl context and the related resources."
+  (format t "Finalize Render module~%")
+  (terminate-thread *render-thread*))
+
+(defun update (delta-time)
+  (declare (ignore delta-time)))
+
+(defmodule stoe/engine/render :render)
+
+(let ((time-counter 0.0)
+      (frames-counter 0))
+  (defun compute-fps (delta-time)
+    (incf time-counter delta-time)
+    (incf frames-counter)
+    (when (> time-counter 1000000.0)
+      (setf *frames-per-second* (if (> frames-counter 1)
+                                    frames-counter
+                                    (/ frames-counter (/ time-counter 1000000.0))))
+      (setf time-counter 0.0)
+      (setf frames-counter 0))))
+
+(defun render-single-mesh (mesh transform)
+  (using-program (program 'simple-shader)
+    (with-locations (model-to-camera camera-to-clip) program
+      (with-components (camera-component) (main-camera (world))
+        (let ((mtc (m* (view camera-component) transform))
+              (ctc (projection camera-component)))
+          (gl:uniform-matrix model-to-camera 4 (vector (raw-data mtc)) nil)
+          (gl:uniform-matrix camera-to-clip 4 (vector (raw-data ctc)) nil))))
+    (render-mesh mesh program)))
+
+(defgeneric render (node))
+
+(defmethod render ((node graph-node-component)))
+
+(defmethod render :after ((node graph-node-component))
+  (mapc #'render (children node)))
+
+(defun render-world (world)
+  (unless (null world)
+    (locking-scene
+      (with-components ((root graph-node-component)) (current-scene)
+        (render root)))))
+
+(defmethod thread-initialize ((thread render-thread))
+  (format t "Initialize ~a~%" (name thread))
+  (viewport-initialize)
+  (compile-all-shaders))
+
+(defmethod thread-finalize ((thread render-thread))
+  (format t "Finalize ~a~%" (name thread))
+  (destroy-all-shaders)
+  (viewport-finalize))
+
+(defmethod thread-process ((thread render-thread))
+  (let ((clock (make-clock)))
+    (loop until (thread-terminate-p thread)
+       do (restartable
+            (during-one-frame
+              (loop for job = (get-next-job thread)
+                 while job
+                 do (progn
+                      (format t "Thread ~a: Running job ~a~%" (name thread) (id job))
+                      (job-run job thread)))
+              (render-world (world)))
+            (update-clock clock)
+            (compute-fps (clock-delta clock))))))
+
+(defmacro on-render-thread (args &body body)
+  `(eval-on-thread ,args *render-thread* ,@body))

engine/render.lisp

@@ -0,0 +1,87 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2017 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/engine/render
+    (:use :cl :vk :alexandria :cffi
+          :stoe/core/modules
+          :stoe/engine/window))
+(in-package :stoe/engine/render)
+
+(defclass render-thread (specialized-thread)
+  ())
+
+(defvar *render-thread* nil)
+(defvar *frames-per-second* 0.0)
+
+(defvar *engine-name* "Stoe")
+(defvar *engine-version* 0)
+
+(defvar *instance-extension-properties* nil)
+(defvar *instance-layer-properties* nil)
+(defvar *physical-devices* nil)
+(defvar *physical-device-index* 0)
+(defvar *queue-family-properties* nil)
+(defvar *device-extension-properties* nil)
+(defvar *device* nil)
+
+(push :vk-xlib *features*)
+
+(defun initialize (&optional argv)
+  "Initialize the render module.
+Create a vulkan instance."
+  (declare (ignore argv))
+  (format t "Initialize Render module~%")
+  (window-initialize)
+  (setf *instance-layer-properties* (enumerate-instance-layer-properties))
+  (setf *instance-extension-properties* (enumerate-instance-extension-properties ""))
+  (unless (and (boundp '%vk::*instance*) %vk::*instance*)
+    (let ((layers '("VK_LAYER_LUNARG_standard_validation"))
+          (exts '("VK_EXT_debug_report"
+                  #+vk-xlib
+                  "VK_KHR_xlib_surface"
+                  #+vk-xcb
+                  "VK_KHR_xcb_surface"
+                  #+vk-wayland
+                  "VK_KHR_wayland_surface")))
+      (setf %vk::*instance-extensions* (make-hash-table))
+      (setf %vk::*instance-params* (list :layers layers :exts exts))
+      (let ((instance (vk-assert (create-instance :app "Stoe test" :app-version 0
+                                                  :engine *engine-name* :engine-version *engine-version*
+                                                  :layers layers
+                                                  :exts exts))))
+        (setf %vk::*instance* instance))))
+  (unless *device*
+   (let ((phys-devices (vk-assert (enumerate-physical-devices %vk::*instance*))))
+     (setf *physical-devices* phys-devices)
+     (setf *queue-family-properties*
+           (mapcar (lambda (phys-device)
+                     (get-physical-device-queue-family-properties phys-device))
+                   phys-devices))
+     (let ((queue-family-index
+             (loop for queue-family in (nth *physical-device-index*
+                                            *queue-family-properties*)
+                   for index = 0 then (1+ index)
+                   when (member :graphics (getf queue-family :queue-flags))
+                     return index)))
+       (setf *device-extension-properties* (enumerate-device-extension-properties
+                                            (nth *physical-device-index*
+                                                 *physical-devices*) ""))
+       (let ((device (vk-assert (create-device (first phys-devices)
+                                               :queue-family-index queue-family-index
+                                               :exts '("VK_KHR_swapchain")))))
+         (setf *device* device))))))
+
+(defun finalize ()
+  "Finalize the render module."
+  (format t "Finalize Render module~%")
+  (%vk::destroy-device *device* (null-pointer))
+  (setf *device* nil)
+  (%vk::destroy-instance %vk::*instance* (null-pointer))
+  (setf %vk::*instance* nil))
+
+(defun update (delta-time)
+  (declare (ignore delta-time)))
+
+(defmodule stoe/engine/render :render)

engine/scene-graph.lisp

@@ -0,0 +1,66 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/engine/scene-graph
+                     (:use :cl :maths
+                           :stoe/core/utils
+                           :stoe/core/entity)
+                     (:export #:graph-node-component #:transform #:update-transform
+                              #:scene-object-component
+                              #:position #:position-of
+                              #:direction #:direction-of
+                              #:scale #:scale-of
+                              #:move #:rotate #:scale))
+(in-package :stoe/engine/scene-graph)
+
+(defcomponent graph-node-component (node)
+  ((transform :initarg :transform :reader transform :type float44))
+  (:documentation "Node in the scene graph."))
+
+(defmethod attach-node ((node node) (parent entity))
+  (with-components (graph-node-component) parent
+    (attach-node node graph-node-component)))
+
+(defun update-transform (node position direction scale)
+  (with-slots (transform) node
+    (setf transform (m* (mtranslate position)
+                        (mscale scale)
+                        (quat-to-mat4 direction)))))
+
+(defcomponent scene-object-component ()
+  ((position :initarg :position :accessor position-of :type float3)
+   (direction :initarg :direction :accessor direction-of :type quaternion)
+   (scale :initarg :scale :accessor scale-of :type float3))
+  (:needs graph-node-component)
+  (:default-initargs
+   :position (vec 0.0 0.0 0.0)
+   :direction (quat)
+   :scale (vec 1.0 1.0 1.0))
+  (:documentation "Object in a scene."))
+
+(defmethod initialize-instance :after ((obj scene-object-component)
+                                       &key owner position direction scale)
+  (with-components ((node graph-node-component)) owner
+    (update-transform node position direction scale)))
+
+(defmethod print-object ((obj scene-object-component) stream)
+  (with-accessors ((pos position-of) (dir direction-of) (scale scale-of)) obj
+    (print-unreadable-object (obj stream :type t)
+      (format stream "~@<~:_position = ~a ~:_direction = ~a ~:_scale = ~a~:>"
+              pos dir scale))))
+
+(defun move (obj &key (dx 0.0) (dy 0.0) (dz 0.0))
+  (with-slots (position direction) obj
+    (setf position (v+ position (m* (quat-to-mat3 direction) (vec dx dy dz))))))
+
+(defun rotate (obj &key (dx 0.0) (dy 0.0) (dz 0.0))
+  (with-slots (direction) obj
+    (setf direction (q* (quat (vec 0.0 1.0 0.0) (deg-to-rad dx))
+                        (quat (vec 1.0 0.0 0.0) (deg-to-rad dy))
+                        (quat (vec 0.0 0.0 1.0) (deg-to-rad dz)) direction))))
+
+(defun scale (obj &key (dx 1.0) (dy 1.0) (dz 1.0))
+  (with-slots (scale) obj
+    (setf scale (vec (* dx (x scale)) (* dy (y scale)) (* dz (z scale))))))

engine/scene.lisp

@@ -0,0 +1,71 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/engine/scene
+    (:use :cl :maths
+          :stoe/core/utils
+          :stoe/core/entity
+          :stoe/core/thread
+          :stoe/engine/mesh
+          :stoe/engine/scene-graph
+          :stoe/engine/camera)
+    (:export #:world #:world-component #:current-scene #:main-camera
+             #:create-world #:destroy-world #:locking-scene))
+(in-package :stoe/engine/scene)
+
+(defvar *world* nil)
+
+(defun world () *world*)
+
+(defcomponent world-component ()
+  ((lock :initform (make-lock "scene-lock") :accessor scene-lock)
+   (scenes :initform nil :reader scenes)
+   (cameras :initform nil :reader cameras))
+  (:documentation "Component containing world's info."))
+
+(defun current-scene (&optional (world (world)))
+  (with-components (world-component) world
+    (first (scenes world-component))))
+
+(defun main-camera (&optional (world (world)))
+  (with-components (world-component) world
+    (first (cameras world-component))))
+
+(defmethod initialize-instance :after ((world world-component) &key scene camera)
+  (with-slots (scenes cameras) world
+    (when scene
+      (push scene scenes))
+    (when camera
+      (push camera cameras))))
+
+(defun make-scene (name)
+  (create-entity name graph-node-component))
+
+(defun make-camera (name scene)
+  (create-entity name
+    (graph-node-component :parent scene)
+    (scene-object-component :position (vec 0.0 0.0 2.0))
+    (camera-component :fovy 90 :aspect (/ 16 9) :near 1.0 :far 1000.0)))
+
+(defun create-world (name)
+  (when *world*
+    (error "World already exists."))
+  (let* ((scene (make-scene "Default Scene"))
+         (camera (make-camera "Default Camera" scene)))
+    (setf *world* (create-entity name
+                    (world-component :scene scene :camera camera)))))
+
+(defun destroy-world ()
+  (when *world*
+    (with-components (world-component) *world*
+      (with-slots (scenes cameras) world-component
+        (mapc #'destroy-entity scenes)
+        (mapc #'destroy-entity cameras)))
+    (destroy-entity *world*)
+    (setf *world* nil)))
+
+(defmacro locking-scene (&body body)
+  `(with-lock-held ((scene-lock (component (world) 'world-component)))
+     ,@body))

engine/shaders.lisp

@@ -1,13 +1,12 @@
 #|
   This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
 |#
 
-(in-package :cl-user)
-(defpackage stoe.render.shaders
+(uiop:define-package :stoe/engine/shaders
   (:nicknames :shaders)
-  (:use :stoe.shader.compiler))
-(in-package :stoe.render.shaders)
+  (:use :stoe/shader/compiler))
+(in-package :stoe/engine/shaders)
 
 (defshader simple-vertex ((position :vec4 :in)
                           (color :vec4 :in)
@@ -24,3 +23,15 @@
 (defprogram simple-shader ()
   :vertex-shader simple-vertex
   :fragment-shader simple-fragment)
+
+(defshader nocolor-vertex ((position :vec4 :in)
+                           (camera-to-clip :mat4 :uniform)
+                           (model-to-camera :mat4 :uniform))
+  (setf gl-position (* camera-to-clip model-to-camera position)))
+
+(defshader blue-fragment ((frag-color :vec4 :out))
+  (setf frag-color (vec4 0.0 0.0 1.0 0.0)))
+
+(defprogram blue-shader ()
+  :vertex-shader nocolor-vertex
+  :fragment-shader blue-fragment)

engine/viewport.lisp

@@ -0,0 +1,127 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/engine/viewport
+    (:use :cl :glop
+          :stoe/core/utils
+          :stoe/engine/input)
+  (:export #:viewport-width #:viewport-height #:need-resize-p
+           #:glsl-version
+           #:support-gl-version-p
+           #:viewport-configure
+           #:viewport-initialize
+           #:viewport-finalize
+           #:during-one-frame))
+(in-package :stoe/engine/viewport)
+
+(defstruct gl-config
+  major minor glsl)
+
+(defstruct viewport-config
+  title width height)
+
+(defvar *gl-config* nil)
+(defvar *main-conf* nil)
+(defvar *main-window* nil)
+
+(defun viewport-width () (window-width *main-window*))
+(defun viewport-height () (window-height *main-window*))
+(defun need-resize-p () (and *main-window*
+                             (or (/= (window-width *main-window*) (viewport-config-width *main-conf*))
+                             (/= (window-height *main-window*) (viewport-config-height *main-conf*)))))
+
+(defun support-gl-version-p (version)
+  (and *gl-config*
+       (multiple-value-bind (maj min) (floor version 10)
+         (or (< maj (gl-config-major *gl-config*))
+             (and (= maj (gl-config-major *gl-config*))
+                  (<= min (gl-config-minor *gl-config*)))))))
+
+(defun glsl-version () (and *gl-config* (gl-config-glsl *gl-config*)))
+
+(defun viewport-configure (&optional argv)
+  (let ((config (make-viewport-config :title (get-command-line-option argv "--title" "Stoe")
+                                      :width (get-command-line-option-number argv "--width" 800)
+                                      :height (get-command-line-option-number argv "--height" 600)))
+        (version (get-command-line-option-number argv "--opengl")))
+    (setf *main-conf* config)
+    (when version
+      (multiple-value-bind (maj min) (floor version 10)
+        (setf *gl-config* (make-gl-config :major maj :minor min))))))
+
+(defun initialize-context ()
+  (gl:enable :cull-face)
+  (gl:cull-face :back)
+  (gl:front-face :cw)
+  (gl:enable :depth-test)
+  (gl:depth-mask :true)
+  (gl:depth-func :lequal)
+  (gl:depth-range 0.0 1.0))
+
+(defun viewport-initialize ()
+  "Initialize the viewport."
+  (if *gl-config*
+      (setf *main-window* (create-window (viewport-config-title *main-conf*)
+                                         (viewport-config-width *main-conf*)
+                                         (viewport-config-height *main-conf*)
+                                         :major (gl-config-major *gl-config*)
+                                         :minor (gl-config-minor *gl-config*)))
+      (progn
+        (setf *main-window* (create-window (viewport-config-title *main-conf*)
+                                           (viewport-config-width *main-conf*)
+                                           (viewport-config-height *main-conf*)))
+        (setf *gl-config* (make-gl-config :major (gl:get-integer :major-version)
+                                          :minor (gl:get-integer :minor-version)))))
+  (setf (gl-config-glsl *gl-config*)
+        (with-input-from-string (in (gl:get-string :shading-language-version))
+          (stoe/core/file:safe-read in)))
+  (initialize-context))
+
+(defun viewport-finalize ()
+  "Finalize the viewport."
+  (when *main-window*
+    (destroy-window *main-window*)
+    (setf *main-window* nil)))
+
+(defun clear-buffers ()
+  (gl:clear-color 0 0 0 0)
+  (gl:clear-depth 1.0)
+  (gl:clear :color-buffer-bit :depth-buffer-bit))
+
+(defun swap-main-buffers ()
+  (swap-buffers *main-window*))
+
+(defmacro during-one-frame (&body body)
+  `(progn
+     (clear-buffers)
+     ,@body
+     (swap-main-buffers)
+     (poll-events)))
+
+(defun poll-events ()
+  "Poll events from the window manager.
+This needs to be called once per frame, at the beginning of the loop."
+  (when *main-window*
+    (setf (viewport-config-width *main-conf*) (window-width *main-window*)
+          (viewport-config-height *main-conf*) (window-height *main-window*))
+    (dispatch-events *main-window* :blocking nil :on-foo nil)))
+
+(defmethod on-event (window event)
+  (declare (ignore window))
+  (typecase event
+    (key-press-event (on-key-event t (keycode event) (keysym event) (text event)))
+    (key-release-event (on-key-event nil (keycode event) (keysym event) (text event)))
+    (button-press-event (on-button-event t (button event)))
+    (button-release-event (on-button-event nil (button event)))
+    (mouse-motion-event (on-motion-event (x event) (y event) (dx event) (dy event)))
+    (resize-event (on-resize-event (width event) (height event)))
+    (expose-event (on-resize-event (width event) (height event)))
+    ;; (visibility-event)
+    ;; (focus-event)
+    ;; (close-event)
+    (t (format t "Unhandled event type: ~s~%" (type-of event)))))
+
+(defun on-resize-event (width height)
+  (gl:viewport 0 0 width height))

engine/vk-utils.lisp

@@ -0,0 +1,26 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2017 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/engine/vk-utils
+    (:use :cl :vk))
+(in-package :stoe/engine/vk-utils)
+
+(defvar *engine-name* "Stoe")
+(defvar *engine-version* 0)
+
+(defvar *physical-devices* nil)
+(defvar *instance-layer-properties* nil)
+(defvar *instance-extension-properties* nil)
+
+(defun create-vk-instance (&key app-name app-version)
+  (setf *instance-layer-properties* (enumerate-instance-layer-properties))
+  (setf *instance-extension-properties* (enumerate-instance-extension-properties ""))
+  (let ((instance (vk:create-instance :app app-name :app-version app-version
+                                      :engine *engine-name* :engine-version *engine-version*
+                                      :layers '("VK_LAYER_LUNARG_standard_validation")
+                                      :exts '("VK_EXT_debug_report"
+                                              "VK_KHR_xlib_surface"))))
+    (setf *physical-devices* (vk:enumerate-physical-devices instance))
+    (setf cl-vulkan-bindings::*instance* instance)))

engine/window.lisp

@@ -0,0 +1,23 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2017 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/engine/window
+    (:use :cl :glop)
+  (:export
+   #:window-initialize #:window-finalize))
+(in-package :stoe/engine/window)
+
+(let ((main-window))
+  (defun window () main-window)
+
+  (defun window-initialize ()
+    "Initialize the window."
+    (setf *main-window* (create-window "Stoe" 1280 720 :gl nil)))
+
+  (defun window-finalize ()
+    "Finalize the window."
+    (when *main-window*
+      (destroy-window *main-window*)
+      (setf *main-window* nil))))

maths/all.lisp

@@ -0,0 +1,14 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/maths/all
+    (:nicknames :maths)
+  (:use-reexport
+   :stoe/maths/utils
+   :stoe/maths/types
+   :stoe/maths/vector
+   :stoe/maths/matrix
+   :stoe/maths/quaternion
+   :stoe/maths/geometry))

maths/geometry.lisp

@@ -0,0 +1,81 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/maths/geometry
+    (:use :cl
+          :stoe/maths/utils
+          :stoe/maths/types
+          :stoe/maths/vector
+          :stoe/maths/matrix
+          :stoe/maths/quaternion)
+  (:export #:mtranslate #:mscale #:mrotate
+           #:mperspective #:morthogonal))
+(in-package :stoe/maths/geometry)
+
+(defun mtranslate (vec)
+  (let ((mat (mat-id 4 'single-float)))
+    (setf (mref mat 3 0) (vref vec 0))
+    (setf (mref mat 3 1) (vref vec 1))
+    (setf (mref mat 3 2) (vref vec 2))
+    mat))
+
+(defun mscale (vec)
+  (let ((mat (mat-id 4 'single-float)))
+    (setf (mref mat 0 0) (vref vec 0))
+    (setf (mref mat 1 1) (vref vec 1))
+    (setf (mref mat 2 2) (vref vec 2))
+    mat))
+
+(defun mrotate (angle &optional axis)
+  (let ((cos (cos angle))
+        (sin (sin angle)))
+    (cond
+      ((null axis) (mat cos sin
+                        (- sin) cos))
+      ((eq axis :x) (mat 1.0 0.0 0.0 0.0
+                         0.0 cos sin 0.0
+                         0.0 (- sin) cos 0.0
+                         0.0 0.0 0.0 1.0))
+      ((eq axis :y) (mat cos 0.0 (- sin) 0.0
+                         0.0 1.0 0.0 0.0
+                         sin 0.0 cos 0.0
+                         0.0 0.0 0.0 1.0))
+      ((eq axis :z) (mat cos sin 0.0 0.0
+                         (- sin) cos 0.0 0.0
+                         0.0 0.0 1.0 0.0
+                         0.0 0.0 0.0 1.0))
+      ((subtypep (type-of axis) 'vect)
+       (let ((1-cos (- 1.0 cos))
+             (axis (safe-normalize axis nil))
+             (mat (mat-id 4 'single-float)))
+         (unless (null axis)
+           (with-swizzle (x y z) axis
+             (setf (mref mat 0 0) (+ (* 1-cos x x) cos))
+             (setf (mref mat 0 1) (+ (* 1-cos x y) (* sin z)))
+             (setf (mref mat 0 2) (- (* 1-cos x z) (* sin y)))
+             (setf (mref mat 1 0) (- (* 1-cos x y) (* sin z)))
+             (setf (mref mat 1 1) (+ (* 1-cos y y) cos))
+             (setf (mref mat 1 2) (+ (* 1-cos y z) (* sin x)))
+             (setf (mref mat 2 0) (+ (* 1-cos x z) (* sin y)))
+             (setf (mref mat 2 1) (- (* 1-cos y z) (* sin x)))
+             (setf (mref mat 2 2) (+ (* 1-cos z z) cos))))
+         mat)))))
+
+(defun mperspective (fovy aspect near far)
+  (let ((range (tan (/ (deg-to-rad fovy) 2.0))))
+    (let ((left (* (- range) aspect))
+          (right (* range aspect))
+          (bottom (- range))
+          (top range))
+      (mat (/ (* near 2) (- right left)) 0.0 0.0 0.0
+           0.0 (/ (* near 2) (- top bottom)) 0.0 0.0
+           0.0 0.0 (/ (+ far near) (- near far)) -1.0
+           0.0 0.0 (/ (* 2.0 far near) (- near far)) 0.0))))
+
+(defun morthogonal (width height)
+  (mat (/ 2.0 width) 0.0 0.0 0.0
+       0.0 (/ -2.0 height) 0.0 0.0
+       0.0 0.0 1.0 0.0
+       -1.0 1.0 0.0 1.0))

maths/matrix.lisp

@@ -0,0 +1,262 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/maths/matrix
+    (:use :cl :alexandria
+          :stoe/core/utils
+          :stoe/maths/types
+          :stoe/maths/vector)
+  (:import-from :stoe/maths/vector
+                #:fill-vector #:make-displaced-vector)
+  (:export #:mref
+           #:mat-null #:mat-id
+           #:make-matrix
+           #:mat #:mat2 #:mat3 #:mat4
+           #:transpose
+           #:m+ #:m- #:m*))
+(in-package :stoe/maths/matrix)
+
+(defmethod element-type ((m matrix)) (array-element-type (raw-data m)))
+
+(defun mref (m &rest subscripts)
+  (let ((len (length subscripts))
+        (dim-x (first (dimensions m)))
+        (dim-y (second (dimensions m))))
+    (assert (< len 3))
+    (case len
+      (2 (progn
+           (assert (< (first subscripts) dim-x))
+           (assert (< (second subscripts) dim-y))
+           (aref (slot-value m 'array) (+ (* (first subscripts) dim-y)
+                                          (second subscripts)))))
+      (1 (progn
+           (assert (< (first subscripts) dim-x))
+           (make-displaced-vector (slot-value m 'array)
+                                  (* (first subscripts) dim-y)
+                                  dim-y))))))
+
+(defun set-mref (m &rest subscripts-or-value)
+  (let ((len (length subscripts-or-value)))
+    (assert (< len 4))
+    (case len
+      (3 (setf (aref (slot-value m 'array) (+ (* (first subscripts-or-value)
+                                                 (second (dimensions m)))
+                                              (second subscripts-or-value)))
+               (third subscripts-or-value)))
+      (2 (let* ((dim (second (dimensions m)))
+                (offset (* (first subscripts-or-value) dim))
+                (v (second subscripts-or-value)))
+           (assert (= dim (dimensions v)))
+           (loop for i below dim
+              do (setf (aref (slot-value m 'array) (+ i offset)) (vref v i))
+              finally (return (second subscripts-or-value))))))))
+
+(defsetf mref set-mref)
+
+(defun matrix-type (dim-x dim-y type)
+  (if (/= dim-x dim-y)
+      'matrix
+      (case dim-x
+        (2 (case type (single-float 'float22) (fixnum 'int22) (otherwise 'matrix)))
+        (3 (case type (single-float 'float33) (fixnum 'int33) (otherwise 'matrix)))
+        (4 (case type (single-float 'float44) (fixnum 'int44) (otherwise 'matrix)))
+        (otherwise 'matrix))))
+
+(defun mat-null (dims type)
+  (let ((dim-x (if (listp dims) (first dims) dims))
+        (dim-y (if (listp dims) (second dims) dims)))
+    (make-instance (matrix-type dim-x dim-y type)
+                   :dims (list dim-x dim-y)
+                   :array (make-array (* dim-x dim-y) :element-type type))))
+
+(defun mat-id (dim type)
+  (let ((m (mat-null dim type)))
+    (loop for i below dim
+       do (setf (mref m i i) (coerce 1 type)))
+    m))
+
+(defun clone-matrix (dims type mat)
+  (let ((m (mat-null dims type)))
+    (loop for i below (first (dimensions mat))
+       do (loop for j below (second (dimensions mat))
+             do (setf (mref m i j) (mref mat i j))))
+    m))
+
+(defun make-matrix (dims type &rest attribs)
+  (let* ((m (mat-null dims type))
+         (v (make-displaced-vector (slot-value m 'array))))
+    (loop with i = 0
+       for attr in attribs
+       do (setf i (fill-vector v attr i)))
+    m))
+
+(defmacro mat (&rest attribs)
+  (once-only ((attrib (first attribs)))
+    (if (= (length attribs) 1)
+         `(clone-matrix (dimensions ,attrib) (element-type ,attrib) ,attrib)
+         (let ((dim (list '+ 0)) type)
+           (loop for attr in attribs
+              do (progn
+                   (unless type
+                     (setf type (cond
+                                  ((floatp attr) 'single-float)
+                                  ((integerp attr) 'fixnum))))
+                   (if (numberp attr)
+                       (setf (cadr dim) (1+ (cadr dim)))
+                       (setf dim (append dim (list `(dimensions ,attr)))))))
+           `(let* ((len ,dim)
+                   (dim-x (floor (sqrt len)))
+                   (dim-y (if (= (* dim-x dim-x) len) dim-x (/ len dim-x))))
+              (make-matrix (list dim-x dim-y)
+                           ,(if type
+                                `',type
+                                `(element-type ,attrib))
+                           ,attrib ,@(rest attribs)))))))
+
+(defmacro mat2 (&rest attribs)
+  (once-only ((attrib (first attribs)))
+    (if (= (length attribs) 1)
+      `(clone-matrix '(2 2) (element-type ,attrib) ,attrib)
+      (let (type)
+        (loop for attr in attribs
+           do (unless type
+                (setf type (cond
+                             ((floatp attr) 'single-float)
+                             ((integerp attr) 'fixnum)))))
+        `(make-matrix '(2 2)
+                      ,(if type
+                           `',type
+                           `(element-type ,attrib))
+                      ,attrib ,@(rest attribs))))))
+
+(defmacro mat3 (&rest attribs)
+  (once-only ((attrib (first attribs)))
+    (if (= (length attribs) 1)
+      `(clone-matrix '(3 3) (element-type ,attrib) ,attrib)
+      (let (type)
+        (loop for attr in attribs
+           do (unless type
+                (setf type (cond
+                             ((floatp attr) 'single-float)
+                             ((integerp attr) 'fixnum)))))
+        `(make-matrix '(3 3)
+                      ,(if type
+                           `',type
+                           `(element-type ,attrib))
+                      ,attrib ,@(rest attribs))))))
+
+(defmacro mat4 (&rest attribs)
+  (once-only ((attrib (first attribs)))
+    (if (= (length attribs) 1)
+      `(clone-matrix '(4 4) (element-type ,attrib) ,attrib)
+      (let (type)
+        (loop for attr in attribs
+           do (unless type
+                (setf type (cond
+                             ((floatp attr) 'single-float)
+                             ((integerp attr) 'fixnum)))))
+        `(make-matrix '(4 4)
+                      ,(if type
+                           `',type
+                           `(element-type ,attrib))
+                      ,attrib ,@(rest attribs))))))
+
+(defgeneric transpose (m))
+(defmethod transpose ((m matrix))
+  (let* ((dim-x (first (dimensions m)))
+         (dim-y (second (dimensions m)))
+         (transposed (mat-null (list dim-y dim-x) (element-type m))))
+    (loop for i below dim-x
+       do (loop for j below dim-y
+             do (setf (mref transposed j i) (mref m i j))))
+    transposed))
+
+(defgeneric madd (m1 m2))
+(defmethod madd ((m1 matrix) (m2 matrix))
+  (let ((dim (dimensions m1))
+        (type (element-type m1)))
+    (assert (equal dim (dimensions m2)))
+    (assert (eq type (element-type m2)))
+    (let ((mat (mat-null dim (element-type m1))))
+      (loop for i below (apply #'* dim)
+         do (setf (aref (slot-value mat 'array) i)
+                  (+ (aref (slot-value m1 'array) i)
+                     (aref (slot-value m2 'array) i))))
+      mat)))
+
+(defun m+ (&rest m-list)
+  (reduce #'madd m-list))
+
+(defgeneric msub (m1 m2))
+(defmethod msub ((m1 matrix) (m2 matrix))
+  (let ((dim (dimensions m1))
+        (type (element-type m1)))
+    (assert (equal dim (dimensions m2)))
+    (assert (eq type (element-type m2)))
+    (let ((mat (mat-null dim (element-type m1))))
+      (loop for i below (apply #'* dim)
+         do (setf (aref (slot-value mat 'array) i)
+                  (- (aref (slot-value m1 'array) i)
+                     (aref (slot-value m2 'array) i))))
+      mat)))
+
+(defun m- (&rest m-list)
+  (reduce #'msub m-list))
+
+(defgeneric mmul (m1 m2))
+(defmethod mmul ((m1 matrix) (m2 number))
+  (let* ((dim (dimensions m1))
+         (mat (mat-null dim (element-type m1))))
+    (loop for i below (apply #'* dim)
+       do (setf (aref (slot-value mat 'array) i)
+                (* (aref (slot-value m1 'array) i) m2)))
+    mat))
+
+(defmethod mmul ((m1 number) (m2 matrix))
+  (mmul m2 m1))
+
+(defmethod mmul ((m1 matrix) (m2 matrix))
+  (let ((dim-1 (dimensions m1))
+        (dim-2 (dimensions m2))
+        (type (element-type m1)))
+    (assert (= (first dim-1) (second dim-2)))
+    (assert (eq type (element-type m2)))
+    (let ((mat (mat-null (list (first dim-2) (second dim-1)) type)))
+      (loop for i below (first dim-2)
+         do (loop for j below (second dim-1)
+               do (setf (mref mat i j)
+                        (loop for k below (first dim-1)
+                           for l below (second dim-2)
+                           sum (* (mref m1 k j) (mref m2 i l))))))
+      mat)))
+
+(defmethod mmul ((m1 matrix) (m2 vect))
+  (let* ((dim-1 (dimensions m1))
+         (dim-2 (dimensions m2))
+         (type (element-type m1)))
+    (assert (= (first dim-1) dim-2))
+    (assert (eq type (element-type m2)))
+    (let ((vec (vec-null (second dim-1) type)))
+      (loop for i below (second dim-1)
+         do (setf (vref vec i)
+                  (loop for j below (second dim-1)
+                     sum (* (mref m1 j i) (vref m2 j)))))
+      vec)))
+
+(defmethod mmul ((m1 vect) (m2 matrix))
+  (let* ((dim-1 (dimensions m1))
+         (dim-2 (dimensions m2))
+         (type (element-type m1)))
+    (assert (= dim-1 (second dim-2)))
+    (assert (eq type (element-type m2)))
+    (let ((vec (vec-null (first dim-2) type)))
+      (loop for i below (first dim-2)
+         do (setf (vref vec i)
+                  (loop for j below (second dim-2)
+                     sum (* (vref m1 j) (mref m2 i j)))))
+      vec)))
+
+(defun m* (&rest mat-list)
+  (reduce #'mmul mat-list))

maths/quaternion.lisp

@@ -0,0 +1,75 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/maths/quaternion
+    (:use :cl
+          :stoe/maths/types
+          :stoe/maths/vector
+          :stoe/maths/matrix)
+  (:export #:quat #:conjug #:q* #:quat-to-mat3 #:quat-to-mat4)
+  (:import-from :stoe/maths/vector
+                #:fill-vector))
+(in-package :stoe/maths/quaternion)
+
+(defun make-quaternion (&rest attribs)
+  (let ((q (make-instance 'quaternion
+                          :array (make-array '(4) :element-type 'single-float))))
+    (loop with i = 0
+       for attr in attribs
+       do (setf i (fill-vector q attr i)))
+    q))
+
+(defun from-attribs (x y z w)
+  (let ((q (make-quaternion x y z w)))
+    (qnormalize q)))
+
+(defun from-axis-and-angle (vec angle)
+  (let ((v (normalize vec))
+        (sin (coerce (sin (/ angle 2)) 'single-float))
+        (cos (coerce (cos (/ angle 2)) 'single-float)))
+    (qnormalize (make-quaternion (v* v sin) cos))))
+
+(defmacro quat (&rest attribs)
+  (let ((len (length attribs)))
+    (assert (or (= len 0) (= len 2) (= len 4)))
+    (case len
+      (4 `(from-attribs ,@attribs))
+      (2 `(from-axis-and-angle ,@attribs))
+      (0 `(from-attribs 0.0 0.0 0.0 1.0)))))
+
+(defun conjug (quat)
+  (quat (- (x quat)) (- (y quat)) (- (z quat)) (w quat)))
+
+(defun quat-to-mat3 (quat)
+  (with-swizzle (x y z w) quat
+    (let ((2xx (* 2 x x)) (2yy (* 2 y y)) (2zz (* 2 z z))
+          (2xy (* 2 x y)) (2xz (* 2 x z)) (2xw (* 2 x w))
+          (2yz (* 2 y z)) (2yw (* 2 y w))
+          (2zw (* 2 z w)))
+      (mat (- 1 2yy 2zz) (- 2xy 2zw) (+ 2xz 2yw)
+           (+ 2xy 2zw) (- 1 2xx 2zz) (- 2yz 2xw)
+           (- 2xz 2yw) (+ 2yz 2xw) (- 1 2xx 2yy)))))
+
+(defun quat-to-mat4 (quat)
+  (let ((mat (mat4 (quat-to-mat3 quat))))
+    (setf (mref mat 3 3) 1.0)
+    mat))
+
+(defun qnormalize (q)
+  (let ((len (vlength q))
+        (quat (make-quaternion 0.0 0.0 0.0 0.0)))
+    (loop for i from 0 below 4
+       do (setf (vref quat i) (/ (vref q i) len)))
+    quat))
+
+(defun q* (&rest q-list)
+  (qnormalize (reduce (lambda (q1 q2)
+                        (with-swizzle ((ax x) (ay y) (az z) (aw w)) q1
+                          (with-swizzle ((bx x) (by y) (bz z) (bw w)) q2
+                            (quat (- (+ (* aw bx) (* ax bw) (* ay bz)) (* az by))
+                                  (- (+ (* aw by) (* ay bw) (* az bx)) (* ax bz))
+                                  (- (+ (* aw bz) (* az bw) (* ax by)) (* ay bx))
+                                  (- (* aw bw) (* ax bx) (* ay by) (* az bz))))))
+                      q-list)))

maths/types.lisp

@@ -0,0 +1,87 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/maths/types
+    (:use :cl :stoe/core/utils)
+    (:export #:vect #:raw-data
+             #:int2 #:int3 #:int4
+             #:float2 #:float3 #:float4
+             #:quaternion
+             #:matrix #:dims
+             #:int22 #:int33 #:int44
+             #:float22 #:float33 #:float44
+             #:dimensions #:element-type))
+(in-package :stoe/maths/types)
+
+(defgeneric dimensions (x))
+(defmethod dimensions ((x number)) 1)
+
+(defgeneric element-type (x))
+(defmethod element-type ((x float)) 'single-float)
+(defmethod element-type ((x integer)) 'fixnum)
+
+(defclass vect ()
+  ((array :type (array * (*))
+          :initarg :array
+          :reader raw-data
+          :documentation "The internal representation of the vector")))
+
+(defmethod print-object ((v vect) stream)
+  (with-slots (array) v
+    (print-unreadable-object (v stream :type t)
+      (format stream "~a" array))))
+
+(defclass int2 (vect)
+  ((array :type (array fixnum (2)))))
+
+(defclass int3 (vect)
+  ((array :type (array fixnum (3)))))
+
+(defclass int4 (vect)
+  ((array :type (array fixnum (4)))))
+
+(defclass float2 (vect)
+  ((array :type (array single-float (2)))))
+
+(defclass float3 (vect)
+  ((array :type (array single-float (3)))))
+
+(defclass float4 (vect)
+  ((array :type (array single-float (4)))))
+
+(defclass quaternion (float4)
+  ())
+
+(defclass matrix ()
+  ((dims :initarg :dims :reader dimensions
+               :documentation "The dimensions of the matrix")
+   (array :type (array * (*))
+          :initarg :array
+          :reader raw-data
+          :documentation "The internal representation of the matrix")))
+
+(defmethod print-object ((m matrix) stream)
+  (with-slots (dims array) m
+    (print-unreadable-object (m stream :type t)
+      (format stream "~a ~a" dims array))))
+
+(defclass int22 (matrix)
+  ((array :type (array fixnum (4)))))
+
+(defclass int33 (matrix)
+  ((array :type (array fixnum (9)))))
+
+(defclass int44 (matrix)
+  ((array :type (array fixnum (16)))))
+
+(defclass float22 (matrix)
+  ((array :type (array single-float (4)))))
+
+(defclass float33 (matrix)
+  ((array :type (array single-float (9)))))
+
+(defclass float44 (matrix)
+  ((array :type (array single-float (16)))))
+

maths/utils.lisp

@@ -1,15 +1,13 @@
 #|
   This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
 |#
 
-(in-package :cl-user)
-(defpackage stoe.maths
-  (:nicknames :maths)
-  (:use :cl)
-  (:export :lerp :clamp
-           :deg-to-rad :rad-to-deg))
-(in-package :stoe.maths)
+(uiop:define-package :stoe/maths/utils
+    (:use :cl)
+    (:export #:lerp #:clamp
+             #:deg-to-rad #:rad-to-deg))
+(in-package :stoe/maths/utils)
 
 (defun lerp (a b ratio)
   "Linear interpolation of `a' and `b' based on `ratio'."

maths/vector.lisp

@@ -0,0 +1,325 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/maths/vector
+    (:use :cl :alexandria :stoe/maths/types)
+  (:export #:vref
+           #:with-swizzle
+           #:vec-null
+           #:make-vector
+           #:vec #:vec2 #:vec3 #:vec4
+           #:v+ #:v- #:v* #:v/
+           #:vlengthsq #:vlength
+           #:normalize #:safe-normalize))
+(in-package :stoe/maths/vector)
+
+(defmethod dimensions ((v vect)) (array-dimension (slot-value v 'array) 0))
+(defmethod dimensions ((v int2)) 2)
+(defmethod dimensions ((v int3)) 3)
+(defmethod dimensions ((v int4)) 4)
+(defmethod dimensions ((v float2)) 2)
+(defmethod dimensions ((v float3)) 3)
+(defmethod dimensions ((v float4)) 4)
+
+(defmethod element-type ((v vect)) (array-element-type (slot-value v 'array)))
+(defmethod element-type ((v int2)) 'fixnum)
+(defmethod element-type ((v int3)) 'fixnum)
+(defmethod element-type ((v int4)) 'fixnum)
+(defmethod element-type ((v float2)) 'single-float)
+(defmethod element-type ((v float3)) 'single-float)
+(defmethod element-type ((v float4)) 'single-float)
+
+(defun vref (v subscript)
+  (aref (slot-value v 'array) subscript))
+(defun set-vref (v subscript x)
+  (setf (aref (slot-value v 'array) subscript) x))
+(defsetf vref set-vref)
+
+(defgeneric fill-vector (v attr subscript))
+(defmethod fill-vector (v attr subscript)
+  (setf (vref v subscript) attr)
+  (1+ subscript))
+
+(defmethod fill-vector (v (attr vect) subscript)
+  (loop for i from 0 below (dimensions attr)
+     for j from subscript
+     do (setf (vref v j) (vref attr i))
+     finally (return (1+ j))))
+
+(defun vect-type (dim type)
+  (case dim
+    (2 (case type (single-float 'float2) (fixnum 'int2) (otherwise 'vect)))
+    (3 (case type (single-float 'float3) (fixnum 'int3) (otherwise 'vect)))
+    (4 (case type (single-float 'float4) (fixnum 'int4) (otherwise 'vect)))
+    (otherwise 'vect)))
+
+(defun vec-null (dim type)
+  (make-instance (vect-type dim type)
+                 :array (make-array dim :element-type type)))
+
+(defun make-vector (dim type &rest attribs)
+  (let ((v (vec-null dim type)))
+    (loop with i = 0
+       for attr in attribs
+       do (setf i (fill-vector v attr i)))
+    v))
+
+(defun make-displaced-vector (array &optional (index 0) dim)
+  (let ((dim (or dim (array-dimension array 0)))
+        (type (array-element-type array)))
+    (make-instance (vect-type dim type)
+                   :array (make-array dim :element-type type :displaced-to array
+                                      :displaced-index-offset index))))
+
+(defmacro vec (&rest attribs)
+  (once-only ((attrib (first attribs)))
+    (let ((dim (list '+ 0)) type)
+     (loop for attr in attribs
+        do (progn
+             (unless type
+               (setf type (cond
+                            ((floatp attr) 'single-float)
+                            ((integerp attr) 'fixnum))))
+             (if (numberp attr)
+                 (setf (cadr dim) (1+ (cadr dim)))
+                 (setf dim (append dim (list `(dimensions ,attr)))))))
+     `(make-vector ,(if (eq (cddr dim) nil) (cadr dim) dim)
+                   ,(if type
+                        `',type
+                        `(element-type ,attrib))
+                   ,attrib ,@(rest attribs)))))
+
+(defmacro vec2 (&rest attribs)
+  (once-only ((attrib (first attribs)))
+    (let (type)
+      (loop for attr in attribs
+         do (unless type
+              (setf type (cond
+                           ((floatp attr) 'single-float)
+                           ((integerp attr) 'fixnum)))))
+      `(make-vector 2 ,(if type
+                           `',type
+                           `(element-type ,attrib))
+                    ,@attribs))))
+
+(defmacro vec3 (&rest attribs)
+  (once-only ((attrib (first attribs)))
+    (let (type)
+      (loop for attr in attribs
+         do (unless type
+              (setf type (cond
+                           ((floatp attr) 'single-float)
+                           ((integerp attr) 'fixnum)))))
+      `(make-vector 3 ,(if type
+                           `',type
+                           `(element-type ,attrib))
+                    ,@attribs))))
+
+(defmacro vec4 (&rest attribs)
+  (once-only ((attrib (first attribs)))
+    (let (type)
+      (loop for attr in attribs
+         do (unless type
+              (setf type (cond
+                           ((floatp attr) 'single-float)
+                           ((integerp attr) 'fixnum)))))
+      `(make-vector 4 ,(if type
+                           `',type
+                           `(element-type ,attrib))
+                    ,@attribs))))
+
+(defmacro defswizzle (attribs)
+  (labels ((index (attr)
+           (case attr
+             (#\X 0)
+             (#\Y 1)
+             (#\Z 2)
+             (#\W 3)))
+         (ref-vect (v dim x neutral)
+           (if (or (numberp dim) (= (index x) 0))
+               (if (or (= (index x) 0) (> dim (index x)))
+                   (list 'vref v (index x))
+                   neutral)
+               `(if (> ,dim ,(index x))
+                    (vref ,v ,(index x))
+                    ,neutral))))
+    (let* ((name (symbol-name attribs))
+           (len (length name)))
+      `(progn
+         (defgeneric ,attribs (v))
+         (defmethod ,attribs ((v vect))
+           ,(if (< len 2)
+               (ref-vect 'v '(dimensions v) (char name 0) '(coerce 0 (element-type v)))
+               `(make-vector ,len (element-type v)
+                             ,@(loop for x across name
+                                  collect (ref-vect 'v '(dimensions v) x '(coerce 0 (element-type v)))))))
+         ,@(loop for cls in '(int2 int3 int4 float2 float3 float4)
+              for type in '(fixnum fixnum fixnum single-float single-float single-float)
+              for dim in '(2 3 4 2 3 4)
+              for neutral in '(0 0 0 0.0 0.0 0.0)
+              collect (list 'defmethod attribs `((v ,cls))
+                            (if (< len 2)
+                                (ref-vect 'v dim (char name 0) neutral)
+                                `(make-vector ,len ',type
+                                              ,@(loop for x across name
+                                                   collect (ref-vect 'v dim x neutral))))))
+         (export ',attribs)))))
+
+(defswizzle x)
+(defswizzle y)
+(defswizzle z)
+(defswizzle w)
+(defswizzle xy)
+(defswizzle xz)
+(defswizzle xw)
+(defswizzle yz)
+(defswizzle yw)
+(defswizzle zw)
+(defswizzle xyz)
+(defswizzle xyw)
+(defswizzle xzw)
+(defswizzle yzw)
+(defswizzle xyzw)
+(defswizzle xyxy)
+(defswizzle wzyx)
+
+(defmacro with-swizzle (attr-list v &body body)
+  "Binds a list of variables with x y z w or some swizzled vector for use in BODY"
+  `(let ,(mapcar (lambda (attr)
+                   (let* ((var (if (listp attr) (first attr) attr))
+                          (sym (if (listp attr) (second attr) attr)))
+                     (list var `(,sym ,v))))
+                 attr-list)
+     ,@body))
+
+(defgeneric vadd (v1 v2))
+(defmethod vadd ((v vect) (s number))
+  (let ((vec (make-vector (dimensions v) (element-type v))))
+    (loop for i from 0 below (dimensions v)
+       do (setf (vref vec i) (+ (vref v i) s)))
+    vec))
+
+(defmethod vadd ((s number) (v vect))
+  (let ((vec (make-vector (dimensions v) (element-type v))))
+    (loop for i from 0 below (dimensions v)
+       do (setf (vref vec i) (+ s (vref v i))))
+    vec))
+
+(defmethod vadd ((v1 vect) (v2 vect))
+  (let ((vec (make-vector (dimensions v1) (element-type v1))))
+    (loop for i from 0 below (dimensions v1)
+       do (setf (vref vec i) (+ (vref v1 i) (vref v2 i))))
+    vec))
+
+(defmethod vadd ((v1 float2) (v2 float2))
+  (make-vector 2 'single-float
+               (+ (x v1) (x v2))
+               (+ (y v1) (y v2))))
+
+(defun v+ (&rest v-list)
+  (reduce #'vadd v-list))
+
+(defgeneric vsub (v1 v2))
+(defmethod vsub ((v vect) (s number))
+  (let ((vec (make-vector (dimensions v) (element-type v))))
+    (loop for i from 0 below (dimensions v)
+       do (setf (vref vec i) (- (vref v i) s)))
+    vec))
+
+(defmethod vsub ((s number) (v vect))
+  (let ((vec (make-vector (dimensions v) (element-type v))))
+    (loop for i from 0 below (dimensions v)
+       do (setf (vref vec i) (- s (vref v i))))
+    vec))
+
+(defmethod vsub ((v1 vect) (v2 vect))
+  (let ((vec (make-vector (dimensions v1) (element-type v1))))
+    (loop for i from 0 below (dimensions v1)
+       do (setf (vref vec i) (- (vref v1 i) (vref v2 i))))
+    vec))
+
+(defmethod vsub ((v1 float2) (v2 float2))
+  (make-vector 2 'single-float
+               (- (x v1) (x v2))
+               (- (y v1) (y v2))))
+
+(defun v- (&rest v-list)
+  (let ((v (first v-list))
+         (r (rest v-list)))
+    (if (null r)
+        (vsub (vec-null (dimensions v) (element-type v)) v)
+        (reduce #'vsub v-list))))
+
+(defgeneric vmul (v1 v2))
+(defmethod vmul ((v vect) (s number))
+  (let ((vec (make-vector (dimensions v) (element-type v))))
+    (loop for i from 0 below (dimensions v)
+       do (setf (vref vec i) (* (vref v i) s)))
+    vec))
+
+(defmethod vmul ((s number) (v vect))
+  (let ((vec (make-vector (dimensions v) (element-type v))))
+    (loop for i from 0 below (dimensions v)
+       do (setf (vref vec i) (* s (vref v i))))
+    vec))
+
+(defun v* (&rest v-list)
+  (reduce #'vmul v-list))
+
+(defgeneric vdiv (v1 v2))
+(defmethod vdiv ((v vect) (s number))
+  (let ((vec (make-vector (dimensions v) (element-type v))))
+    (loop for i from 0 below (dimensions v)
+       do (setf (vref vec i) (/ (vref v i) s)))
+    vec))
+
+(defmethod vdiv ((s number) (v vect))
+  (let ((vec (make-vector (dimensions v) (element-type v))))
+    (loop for i from 0 below (dimensions v)
+       do (setf (vref vec i) (/ s (vref v i))))
+    vec))
+
+(defun v/ (&rest v-list)
+  (reduce #'vdiv v-list))
+
+(defgeneric dot (v1 v2))
+(defmethod dot ((v1 vect) (v2 vect))
+  (loop for i below (dimensions v1)
+       sum (* (vref v1 i) (vref v2 i))))
+
+(defgeneric cross (v1 v2))
+(defmethod cross ((v1 int3) (v2 int3))
+  (let ((vec (make-vector 3 'fixnum)))
+    (setf (vref vec 0) (- (* (vref v1 1) (vref v2 2))
+                          (* (vref v2 1) (vref v1 2))))
+    (setf (vref vec 1) (- (* (vref v1 2) (vref v2 0))
+                          (* (vref v2 2) (vref v1 0))))
+    (setf (vref vec 2) (- (* (vref v1 0) (vref v2 1))
+                          (* (vref v2 0) (vref v1 1))))))
+
+(defmethod cross ((v1 float3) (v2 float3))
+  (let ((vec (make-vector 3 'single-float)))
+    (setf (vref vec 0) (- (* (vref v1 1) (vref v2 2))
+                          (* (vref v2 1) (vref v1 2))))
+    (setf (vref vec 1) (- (* (vref v1 2) (vref v2 0))
+                          (* (vref v2 2) (vref v1 0))))
+    (setf (vref vec 2) (- (* (vref v1 0) (vref v2 1))
+                          (* (vref v2 0) (vref v1 1))))))
+
+(defgeneric vlengthsq (v))
+(defmethod vlengthsq ((v vect))
+  (reduce #'+ (map 'list (lambda (x) (* x x)) (slot-value v 'array))))
+
+(defun vlength (v)
+  (sqrt (vlengthsq v)))
+
+(defun normalize (v)
+  (v/ v (vlength v)))
+
+(defun safe-normalize (v &optional default)
+  (let ((lensq (vlengthsq v)))
+    (if (zerop lensq)
+        (or default v)
+        (normalize v))))

references/macroexpand-dammit.lisp

@@ -0,0 +1,414 @@
+;;; Macroexpand dammit -- a portable code walker for Common Lisp
+
+;;; Written by John Fremlin at MSI (http://www.msi.co.jp) Released
+;;; into the public domain. 
+
+;;; http://john.freml.in/macroexpand-dammit
+
+;;; Transforms code to return a quoted version its macroexpansion
+;;; using the host lisp to implicitly augment the lexical environment.
+;;; Expands macros, macrolets, symbol-macros, symbol-macrolets, and
+;;; compiler-macros.  Removes macrolets and symbol-macrolets.
+
+;;; Supports a few non-standard special forms for current (2009) Lisps.
+
+;;; Lightly tested on SBCL 1.0.29, ClozureCL 1.4-pre, Lispworks 5.1,
+;;; Allegro 8.1
+
+;;; 20100301 
+;; -- do not totally discard macrolet bodies (doh), as
+;;; reported by mathrick on #lisp
+;; 20100701
+;; - correct the mistaken loop bindings to remove warnings for CCL. 
+;;; reported by Daniel Gackle
+
+(cl:defpackage #:macroexpand-dammit
+  #+lispworks (:import-from #:lispworks #:compiler-let)
+  #+ccl (:import-from #:ccl #:compiler-let)
+  (:use #:cl)
+  (:export #:macroexpand-dammit
+           #:macroexpand-dammit-as-macro
+           #:macroexpand-dammit-expansion))
+(cl:in-package #:macroexpand-dammit)
+
+(eval-when (:compile-toplevel :load-toplevel :execute) 
+  (defvar *form-handler* (make-hash-table))
+
+  (defun force-first (x)
+    (if (listp x) (first x) x))
+  (defun force-list (x)
+    (if (listp x) x (list x))))
+
+(defvar *env*)
+
+(defun binding-to-symbol (binding)
+  (let ((name (force-first binding)))
+    (cond ((listp name)
+           (assert (eq 'setf (first name)))
+           (check-type (second name) symbol)
+           (second name))
+          (t
+           name))))
+
+(defmacro with-imposed-bindings (&body body)
+  `(locally ,@body)
+  #+sbcl
+  (destructuring-bind ((binder bindings &rest binder-body))
+      body
+    `(locally
+         (declare (sb-ext:disable-package-locks ,@(mapcar 'binding-to-symbol bindings)))
+       (,binder ,bindings 
+                ,@binder-body))))
+
+(defmacro without-package-locking (&body body)
+  `(
+    #. (progn 'progn
+              #+sbcl 'sb-ext:without-package-locks)
+       ,@body))
+
+(defmacro defhandler (symbol lambda-list &body body)
+  (let ((syms (force-list symbol)))
+    (let ((func (intern (format nil "~A~A" 'handler- (first syms)))))
+      `(progn
+         (defun ,func ,lambda-list
+           ,@body)
+         (setf
+          ,@(loop for sym in syms
+               collect `(gethash ',sym *form-handler*)
+               collect `',func))))))
+
+(defun e-list (list)
+  (mapcar #'e list))
+
+(defhandler (progn locally) (progn &rest body)
+  `(list ',progn
+         ,@(e-list body)))
+
+
+(defhandler let (let bindings &rest body)
+  (let* ((names (loop for binding in bindings 
+                   collect 
+                     (force-first binding)))
+         (symbol-macrolet-names
+          (loop for name in names
+             when (nth-value 1 (macroexpand-1 name *env*))
+             collect name)))
+    `(list*
+      ',let
+      (list 
+       ,@(loop for binding in bindings
+            collect 
+              (if (symbolp binding)
+                  `',binding
+                  `(list ',(first binding)
+                         ,@(e-list (rest binding))))))
+      (with-imposed-bindings
+          (,let ,symbol-macrolet-names
+            (declare (ignorable ,@symbol-macrolet-names))
+            (m-list ,@body))))))
+
+
+(defun dump-fbinding (name lambda-list &rest body)
+  (let (bound-vars)
+    (labels (
+             (binding-vars (&rest body)
+               `(let ,bound-vars
+                  (declare (ignorable ,@bound-vars))
+                  (m-list ,@body)))
+             (l (lambda-arg)
+               (cond ((member lambda-arg lambda-list-keywords)
+                      `',lambda-arg)
+                     (t
+                      (destructuring-bind
+                            (var &optional (val nil val-present-p) present-var)
+                          (force-list lambda-arg)
+                        (prog1
+                            (if (listp lambda-arg)
+                                `(list ',var ,@(when val-present-p `((car ,(binding-vars val)))) 
+                                       ,@(when present-var `(',present-var)))
+                                `',var)
+                          (push var bound-vars)
+                          (when present-var (push present-var bound-vars))))))))
+
+      `(list* ',name (list ,@(mapcar #'l lambda-list))
+              ,(apply #'binding-vars body)))))
+
+(defun dump-fbindings (bindings)
+  `(list ,@(mapcar (lambda (f) (apply 'dump-fbinding f)) bindings)))
+
+(defun declare-fbindings-ignorable (bindings)
+  `(declare (ignorable ,@(mapcar (lambda (f)
+                                   `(function ,(force-first f))) bindings))))
+
+(defun declare-lambda-list-ignorable (lambda-list)
+  `(declare (ignorable 
+             ,@(loop for binding in lambda-list
+                  append 
+                    (unless (member binding lambda-list-keywords)
+                      (destructuring-bind (var &optional default present-var)
+                          (force-list binding)
+                        (declare (ignore default))
+                        (list* var (when present-var (list present-var)))))))))
+
+(defun maybe-locally (forms)
+  (flet ((starts-with-declare ()
+           (and (listp (first forms)) (eq (first (first forms)) 'declare))))
+    (cond ((or (rest forms) (starts-with-declare))
+           (list* (if (starts-with-declare) 'locally 'progn) forms))
+          (t
+           (first forms)))))
+
+(defhandler declare (declare &rest body)
+  `(list ',declare 
+         ,@(mapcar (lambda (f) `',f) body)))
+
+(defhandler block (block name &rest body)
+  `(list ',block ',name
+         ,@(e-list body)))
+
+(defhandler return-from (return-from name &optional (value nil value-p))
+  `(list ',return-from ',name
+         ,@(when value-p
+                 `(,(e value)))))
+
+(defhandler catch (catch tag &rest body)
+  `(list ',catch ,(e tag) ,@(e-list body)))
+
+(defhandler load-time-value (load-time-value form &optional (read-only-p nil rop-p))
+  `(list ',load-time-value ,(e form) 
+         ,@(when rop-p
+                 `(',read-only-p))))
+
+(defhandler 
+    (macrolet 
+        symbol-macrolet 
+      compiler-let ; mostly for Lispworks
+      ) 
+    (macrolet bindings &rest body)
+  `(maybe-locally
+    (with-imposed-bindings
+        (,macrolet ,bindings
+          (m-list ,@body)))))
+
+(defun clean-fbindings (bindings)
+  "Return a set of bindings that always defaults to nil"
+  (flet ((clean-argument-bindings (bindings)
+           (loop for binding in bindings
+              collect 
+                (destructuring-bind (var &optional default present-var) 
+                    (force-list binding)
+                  (declare (ignore default))
+                  (if present-var
+                      `(,var nil ,present-var)
+                      var)))))
+    (loop for (func lambda-list) in bindings
+       for clean-lambda-list = (clean-argument-bindings lambda-list)
+       collect `(,func ,clean-lambda-list 
+                       ,(declare-lambda-list-ignorable clean-lambda-list)))))
+
+(defhandler flet (flet bindings &rest body)
+  `(list* ',flet
+          ,(dump-fbindings bindings)
+          (with-imposed-bindings
+              (,flet ,(clean-fbindings bindings)
+                ,(declare-fbindings-ignorable bindings)
+                (m-list ,@body)))))
+
+(defhandler labels (labels bindings &rest body)
+  `(with-imposed-bindings
+       (,labels ,(clean-fbindings bindings)
+         ,(declare-fbindings-ignorable bindings)
+         (list* ',labels
+                ,(dump-fbindings bindings)
+                (m-list ,@body)))))
+
+(defhandler let* (let* bindings &rest body)
+  (if (not bindings)
+      (e `(locally ,@body))
+      (destructuring-bind (first &rest rest)
+          bindings
+        (e `(let (,first)
+              ,@(if rest
+                    `((,let* ,rest (locally ,@body)))
+                    body))))))
+
+(defhandler eval-when (eval-when situation &rest body)
+  `(list ',eval-when ',situation
+         ,@(e-list body)))
+
+#+sbcl
+(defhandler sb-int:named-lambda (named-lambda name lambda-list &rest body)
+  `(list* ',named-lambda ,(apply 'dump-fbinding name lambda-list body)))
+
+(defhandler defun (defun name lambda-list &rest body)
+  `(list* ',defun ,(apply 'dump-fbinding name lambda-list body)))
+
+
+(defhandler lambda (lambda lambda-list &rest body)
+  (apply 'dump-fbinding lambda lambda-list body))
+
+(defun tagbody-restore-tags (list)
+  (loop for f in list
+     collect 		    
+       (cond ((or (symbolp f) (integerp f))
+              `(progn ,f))
+             ((and (listp f) (eq 'tagbody-restore-tag (first f)))
+              (second f))
+             (t
+              f))))
+
+(defhandler tagbody (tagbody &rest tags-and-forms)
+  `(list* ',tagbody
+          (tagbody-restore-tags 
+           (list
+            ,@(loop for f in tags-and-forms 
+                 collect
+                   (if (or (symbolp f) (integerp f))
+                       `(list 'tagbody-restore-tag ',f)
+                       (e f)))))))
+
+(defhandler setq (setq &rest pairs)
+  (declare (ignore setq))
+  (let ((vars (loop for s in pairs by #'cddr collect (macroexpand s *env*))))
+    (let ((expanded (loop for n in vars for r in (rest pairs) by #'cddr
+                       collect n collect r)))
+      (if (some 'listp vars)
+          (e `(setf ,@expanded))
+          `(list 'setq ,@(e-list expanded))))))
+
+(defun function-name-p (name)
+  (or (symbolp name) 
+      (and (listp name) (eq (first name) 'setf) (symbolp (second name)) (not (cddr name)))))
+
+(defhandler function (function name)
+  `(list ',function
+         ,(if (function-name-p name)
+              `',name
+              (e name))))
+
+(defhandler the (the value-type form)
+  `(list ',the ',value-type ,(e form)))
+
+(defhandler go (go tag)
+  `(list ',go ',tag))
+
+(defhandler unwind-protect (unwind-protect protected-form &rest cleanup)
+  `(list ',unwind-protect ,(e protected-form) ,@(e-list cleanup)))
+
+(defhandler progv (progv symbols values &rest body)
+  `(list ',progv
+         (list ,@(e-list symbols))
+         (list ,@(e-list values))
+         ,@(e-list body)))
+
+(defhandler quote (quote object)
+  `(list ',quote ',object))
+
+(defun default-form-handler (first &rest rest)
+  `(list ,(if (symbolp first)
+              `',first
+              (e first)) ,@(e-list rest)))
+
+(defun form-handler (first)
+  (gethash first *form-handler*
+           'default-form-handler))
+
+(defun compiler-macroexpand-1 (form &optional *env*)
+  (let ((cm 
+         (and (listp form) (function-name-p (first form)) 
+              (compiler-macro-function (first form) *env*))))
+    (if cm
+        (funcall *macroexpand-hook* cm form *env*)
+        form)))
+
+(defun e (form)
+  (flet ((handle (form)
+           (apply (form-handler (first form)) form)))
+    (cond ((and (listp form) (gethash (first form) *form-handler*))
+           (handle form))
+          (t
+           (multiple-value-bind (form expanded)
+               (macroexpand-1 form *env*)
+             (cond (expanded
+                    (e form))
+                   (t
+                    (typecase form
+                      (null nil)
+                      (list
+                       (let ((next (compiler-macroexpand-1 form)))
+                         (if (eq form next)
+                             (handle form)
+                             (e next))))
+                      (t
+                       `',form)))))))))
+
+(defmacro m (form &environment *env*)
+  (e form))
+
+(defmacro m-list (&body body &environment *env*)
+  `(list ,@(e-list body)))
+
+(defun walk-tree (fn tree &optional (cache (make-hash-table :test 'eq)))
+  (funcall fn tree
+           ;; given as `cont'
+           (lambda (subforms)
+             (%walk-tree-rec subforms fn cache))))
+
+(defun %walk-tree-rec (lst fn cache)
+  (if (endp lst) nil
+      (multiple-value-bind (value found) (gethash lst cache)
+        (if found value
+            (let* ((result (walk-tree fn (car lst) cache))
+                   (cell (cons result nil)))
+              (setf (gethash lst cache) cell) ;; cdr is not computed
+              (setf (cdr cell) ;; this is not stack-free... but is necessary for circular list
+                    (%walk-tree-rec (cdr lst) fn cache))
+              cell)))))
+
+(defun macroexpand-all-except-macrobindings (body env)
+  (walk-tree
+   (lambda (subform cont)
+     (let ((expansion (macroexpand subform env)))
+       (if (consp expansion)
+           (case (first expansion)
+             ((declare quote) expansion)
+             ((macrolet symbol-macrolet)
+              ;; ignore macrolet and symbol-macrolet
+              `(,(first expansion) ,(second expansion)
+                 ,@(funcall cont (cddr expansion))))
+             (function
+              (let ((fname (second expansion)))
+                (if (consp fname)
+                    (case (first fname)
+                      (lambda 
+                          `(lambda ,(second fname)
+                             ,@(funcall cont (cddr fname))))
+                      #+sbcl
+                      (sb-int:named-lambda
+                          `(sb-int:named-lambda ,(second fname) ,(third fname)
+                             ,@(funcall cont (cdddr fname))))
+                      (t expansion))
+                    expansion)))
+             (t
+              (funcall cont expansion)))
+           expansion)))
+   body))
+
+(defun macroexpand-dammit (form &optional *env*)
+  (let ((evalform (e form)))
+    (macroexpand-all-except-macrobindings
+     (eval evalform)
+     *env*)))
+
+(defmacro macroexpand-dammit-as-macro (form)
+  `(m ,form))
+(defun macroexpand-dammit-expansion (form &optional *env*)
+  (e form))
+
+;;; Some shenanigans to support running with or without swank
+(defun runtime-symbol (name package-name)
+  (or (find-symbol (symbol-name name)
+                   (or (find-package package-name) (error "No package ~A" package-name)))
+      (error "No symbol ~A in package ~A" name package-name)))
+(defun macroexpand-dammit-string (str)
+  (funcall (runtime-symbol 'apply-macro-expander 'swank) 'macroexpand-dammit str))

references/memory.lisp

@@ -0,0 +1,218 @@
+;;;; memory.lisp
+
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation files
+;;; (the "Software"), to deal in the Software without restriction,
+;;; including without limitation the rights to use, copy, modify, merge,
+;;; publish, distribute, sublicense, and/or sell copies of the Software,
+;;; and to permit persons to whom the Software is furnished to do so,
+;;; subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;;; SOFTWARE.
+
+;;; Utility functions to measure memory consumption in SBCL
+;;; With lots of code and ideas from David Lichteblau's graph.lisp and
+;;; object-size.lisp from darcsweb.
+
+;; Some useful links:
+;; - http://sbcl-internals.cliki.net/tag%20bit
+;;   Explanation of lowtags and widetags
+;; - http://coding.derkeiler.com/Archive/Lisp/comp.lang.lisp/2006-05/msg00863.html
+;;   About FDEFN
+
+(defpackage #:memory
+  (:use #:cl))
+
+(in-package #:memory)
+
+(defconstant +n+ sb-vm:n-word-bytes
+  "The number of bytes in a word.")
+
+(defun native-address (object)
+  "The address of the object without the lowtag bits"
+  (logandc2 (sb-kernel:get-lisp-obj-address object)
+            sb-vm:lowtag-mask))
+
+(defun native-pointer (object)
+  (sb-sys:int-sap (native-address object)))
+
+(defun object-ref-lispobj (object index)
+  (sb-sys:without-gcing
+    (sb-kernel:make-lisp-obj
+     (sb-sys:sap-ref-word (native-pointer object) (* index +n+)))))
+
+(defun recurse-descendant-objects (object function)
+  "Goes through OBJECT and all its descendants calling FUNCTION on
+  each one."
+  (let ((seen-objects (make-hash-table)))
+    (labels ((recurse (object)
+               (unless (gethash object seen-objects)
+                 (setf (gethash object seen-objects) t)
+                 (funcall function object)
+                 (typecase object
+                   ((or number string character sb-sys:system-area-pointer)
+                    (values))
+                   (symbol
+                    (recurse (symbol-name object))
+                    (recurse (symbol-plist object))
+                    (when (boundp object)
+                      (recurse (symbol-value object)))
+                    (when (fboundp object)
+                      (recurse (symbol-function object))))
+                   (cons
+                    (recurse (car object))
+                    (recurse (cdr object)))
+                   (sb-kernel:funcallable-instance
+                    (loop
+                       for i from 1 to (sb-kernel:get-closure-length object) do
+                       (recurse (object-ref-lispobj object i))))
+                   (sb-kernel:instance
+                    (let* ((len (sb-kernel:%instance-length object))
+                           (layout (sb-kernel:%instance-layout object))
+                           (nuntagged (sb-kernel:layout-n-untagged-slots layout)))
+                      (loop
+                         for i from 0 below (- len nuntagged) do
+                         (recurse (sb-kernel:%instance-ref object i)))))
+                   (function
+                    (let ((widetag (sb-kernel:widetag-of object)))
+                      (cond ((= widetag sb-vm:simple-fun-header-widetag)
+                             (recurse (sb-kernel:fun-code-header object)))
+                            ((= widetag sb-vm:closure-header-widetag)
+                             (let ((len (sb-kernel:get-closure-length object)))
+                               (recurse (sb-kernel:%closure-fun object))
+                               ;; from 2 BELOW or TO? TO seems to bork
+                               (loop for i from 2 below len do
+                                    (recurse (object-ref-lispobj object i)))))
+                            (t
+                             (error "Unknown function object")))))
+                   ;; Meh...
+                   (simple-vector
+                    (recurse (coerce object 'list)))
+                   (array
+                    (dotimes (i (apply #'* (array-dimensions object)))
+                      (recurse (row-major-aref object i))))
+                   ;; Mmmm...
+                   (sb-vm::code-component
+                    (let ((length (sb-kernel:get-header-data object)))
+                      (do ((i sb-vm::code-constants-offset (1+ i)))
+                          ((= i length))
+                        (recurse (sb-vm::code-header-ref object i)))))
+                   (sb-kernel:fdefn
+                    (recurse (sb-kernel:fdefn-name object))
+                    (recurse (sb-kernel:fdefn-fun object)))
+                   ;; Here be dragons
+                   (sb-ext:weak-pointer
+                    (multiple-value-bind (value alive)
+                        (sb-ext:weak-pointer-value object)
+                      (when alive
+                        (recurse value))))
+                   (sb-kernel::random-class
+                    ;; FIXME: no clue what to do here
+                    )
+                   (t
+                    (warn "Unknown type ~s" (type-of object)))))))
+      (recurse object))))
+
+(defun immediate-p (object)
+  "Whether or not OBJECT is immediate, ie, do not use any memory (?)"
+  (or (null object)
+      (eq object t)
+      (evenp (sb-kernel:lowtag-of object))))
+
+(defun calculate-allocated-memory (object)
+  "Returns the memory allocated in the heap by OBJECT."
+  (if (immediate-p object)
+      0
+      (typecase object
+        ((or integer single-float double-float (complex single-float)
+             (complex double-float) #+long-float (complex long-float)
+             sb-sys:system-area-pointer sb-kernel:fdefn)
+         (* (1+ (sb-kernel:get-header-data object)) +n+))
+        (cons
+         (* 2 +n+))
+        (symbol
+         (* sb-vm:symbol-size +n+))
+        (simple-vector
+         (* (+ 2 (length object)) +n+))
+        ((simple-array * (*))
+         (align (* +n+ (size-of object))))
+        (array
+         (+ +n+ (* (array-total-size object)
+                   +n+)))
+        (function
+         (if (or (eql (type-of object)
+                      'sb-kernel:funcallable-instance)
+                 (= (sb-kernel:widetag-of object)
+                    sb-vm:closure-header-widetag))
+             (* (1+ (sb-kernel:get-closure-length object)) +n+)
+             0))
+        (sb-kernel:instance
+         (* (1+ (sb-kernel:%instance-length object)) +n+))
+        (t
+         0))))
+
+(defparameter *context* nil
+  "Context to store progress in current execution.")
+
+(defstruct
+    (context (:constructor make-context (stream)))
+  stream
+  (length 0)
+  (unknown 0)
+  (details nil))
+
+(defun calculate-and-store-memory (object)
+  (let ((m (calculate-allocated-memory object)))
+    (incf (context-length *context*) m)))
+
+(defun dump-memory (object &key (stream t))
+  "Calculates the memory used by OBJECT."
+  (let ((*context* (make-context stream)))
+    (recurse-descendant-objects object #'calculate-and-store-memory)
+    (report-memory *context* :verbosity :min)))
+
+(defun sanitize-bytes-value (value)
+  (cond
+    ((< value 1000)
+     (format nil "~f bytes" value))
+    ((< value 1000000)
+     (format nil "~f KB" (/ value 1000)))
+    ((< value 1000000000)
+     (format nil "~f MB" (/ value 1000000)))
+    (t
+     (format nil "~f GB" (/ value 1000000000)))))
+
+(defun report-memory (context &key (verbosity :default))
+  (let ((total (reduce #'+ (context-details context) :key #'cdr)))
+    (ccase verbosity
+      (:min
+       (format t "Total memory used: ~a~%" (sanitize-bytes-value (context-length context))))
+      (:default
+       (let ((details (context-details context)))
+         (dolist (detail details)
+           (format t "Memory for type ~a: ~a~%" (car detail) (cdr detail)))
+         (format t "~%Total memory used: ~a~%" total))))))
+
+(sb-alien:define-alien-variable "sizetab" (array (* t) 256))
+
+(defun align (address)
+  (- address (nth-value 1 (ceiling address (1+ sb-vm:lowtag-mask)))))
+
+(defun size-of (object)
+  (sb-sys:with-pinned-objects (object)
+    (sb-alien:with-alien
+        ((fn (* (function sb-alien:long (* t)))
+             (sb-sys:sap-ref-sap (sb-alien:alien-sap sizetab)
+                                 (* +n+ (sb-kernel:widetag-of object)))))
+      (sb-alien:alien-funcall fn (native-pointer object)))))
+

shader/all.lisp

@@ -0,0 +1,12 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/shader/all
+    (:nicknames :shader)
+  (:use-reexport
+   :stoe/shader/shader
+   :stoe/shader/walker
+   :stoe/shader/glsl
+   :stoe/shader/compiler))

shader/compiler.lisp

@@ -3,15 +3,18 @@
   Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
 |#
 
-(in-package :cl-user)
-(defpackage stoe.shader.compiler
-  (:use :cl :utils :gl-utils :shader :glsl)
-  (:nicknames :compiler)
-  (:export :defshader
-           :defprogram
-           :compile-all-shaders
-           :destroy-all-shaders))
-(in-package :stoe.shader.compiler)
+(uiop:define-package :stoe/shader/compiler
+    (:use :cl
+          :stoe/core/utils
+          :stoe/engine/gl-utils
+          :stoe/engine/viewport
+          :stoe/shader/shader
+          :stoe/shader/glsl)
+  (:export #:defshader
+           #:defprogram
+           #:compile-all-shaders
+           #:destroy-all-shaders))
+(in-package :stoe/shader/compiler)
 
 (defvar *shaders-table* (make-hash-table))
 (defvar *programs-table* (make-hash-table))
@@ -23,8 +26,8 @@
   "Define a shader defining function.
 The newly created shader will be put in a special package: `%stoe.shaders'."
   `(progn
-     (set ',name (%defshader ',lambda-list ',body))
-     (when (gl-initialized-p)
+     (defparameter ,name (%defshader ',lambda-list ',body))
+     (when (not (null (glsl-version)))
        (mapc (lambda (program)
                (delete-program program)
                (compile-program program)) (gethash ',name *shaders-table*)))))
@@ -46,10 +49,10 @@ The newly created shader will be put in a special package: `%stoe.shaders'."
   `(progn
      (when (gethash ',name *programs-table*)
        (clean-dep ',name (gethash ',name *programs-table*)))
-     (set ',name (%defprogram ',lambda-list ',body))
+     (defparameter ,name (%defprogram ',lambda-list ',body))
      (setf (gethash ',name *programs-table*) ',body)
      (add-dep ',name ',body)
-     (when (gl-initialized-p)
+     (when (not (null (glsl-version)))
        (compile-program ',name))))
 
 (defun compile-shader (type shader)

shader/glsl.lisp

@@ -3,12 +3,14 @@
   Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
 |#
 
-(in-package :cl-user)
-(defpackage stoe.shader.glsl
-  (:use :cl :utils :walker :shader)
-  (:nicknames :glsl)
-  (:export :glsl-compile :glsl-print))
-(in-package :stoe.shader.glsl)
+(uiop:define-package :stoe/shader/glsl
+    (:use :cl
+          :stoe/core/utils
+          :stoe/engine/viewport
+          :stoe/shader/walker
+          :stoe/shader/shader)
+  (:export #:glsl-compile #:glsl-print))
+(in-package :stoe/shader/glsl)
 
 (defvar *form-handlers* (make-hash-table)
   "Hash table for the form handlers for a glsl dsl.")
@@ -26,7 +28,8 @@ if non-nil, the dsl will be printed in comments together with the glsl code.")
 (defvar *version-profiles* '((1.3 . "#version 130
 // #extension ARB_explicit_attrib_location : require")
                              (3.3 . "#version 330 core")
-                             (4.4 . "#version 440 core")))
+                             (4.4 . "#version 440 core")
+                             (4.5 . "#version 450 core")))
 
 (defvar *glsl-symbols* '(:gl-position "gl_Position"
                          :gl-fragcoord "gl_FragCoord"
@@ -124,18 +127,18 @@ the forms comprised of these keywords will be printed in comments."
 
 (defun handle-preamble (form)
   "Handle a preamble declaration."
-  (make-var (intern (symbol-name (first form)) :keyword) (glsl-name (first form))
-            (second form) (cddr form)
-            (format nil "~@[layout (location = ~a) ~]~@[~(~a~) ~]~(~a~) ~(~a~) ~(~a~);~%"
-                    (awhen (member :location form) (cadr it))
-                    (awhen (member :interp form) (cadr it))
-                    (third form) (second form) (glsl-name (first form)))))
+  (let ((location (second (member :location form)))
+        (interp (second (member :interp form))))
+    (make-var (intern (symbol-name (first form)) :keyword) (glsl-name (first form))
+              (second form) (cddr form)
+              (format nil "~@[layout (location = ~a) ~]~@[~(~a~) ~]~(~a~) ~(~a~) ~(~a~);~%"
+                      location interp (third form) (second form) (glsl-name (first form))))))
 
 (defun glsl-compile (lambda-list body)
   "Compile the shader defined in BODY to glsl format.
 The forms contained in LAMBDA-LIST are used to define the global variables of
 the shader."
-  (merge-shaders (make-shader :version (cdr (assoc gl-utils:*glsl-version* *version-profiles*
+  (merge-shaders (make-shader :version (cdr (assoc (glsl-version) *version-profiles*
                                                    :test #'equal)))
                  (flet ((merge-preamble (sh1 sh2)
                           (merge-shaders sh1 (handle-preamble sh2))))
@@ -148,7 +151,7 @@ the shader."
 (defun glsl-print (shader)
   "Returns a string containing the complete SHADER in glsl format."
   (format nil "~@[~a~%~%~]~{~a~}~%~a"
-          (or (shader-version shader) (cdr (assoc gl-utils:*glsl-version* *version-profiles*
+          (or (shader-version shader) (cdr (assoc (glsl-version) *version-profiles*
                                                    :test #'equal)))
           (loop for var in (shader-vars shader)
                collect (var-exp var)) (shader-exp shader)))

shader/shader.lisp

@@ -3,30 +3,28 @@
   Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
 |#
 
-(in-package :cl-user)
-(defpackage stoe.shader
-  (:nicknames :shader)
-  (:use :cl :utils :gl-utils)
-  (:export :make-shader
-           :make-var
-           :make-exp
-           :merge-shaders
-           :shader-version
-           :shader-vars
-           :shader-exp
-           :var-symb
-           :var-name
-           :var-qualifiers
-           :var-target
-           :var-exp
-           :make-program
-           :program-stages
-           :program-vars
-           :program-id
-           :get-location
-           :using-program
-           :with-locations))
-(in-package :stoe.shader)
+(uiop:define-package :stoe/shader/shader
+  (:use :cl :stoe/core/utils :stoe/engine/gl-utils)
+  (:export #:make-shader
+           #:make-var
+           #:make-exp
+           #:merge-shaders
+           #:shader-version
+           #:shader-vars
+           #:shader-exp
+           #:var-symb
+           #:var-name
+           #:var-qualifiers
+           #:var-target
+           #:var-exp
+           #:make-program
+           #:program-stages
+           #:program-vars
+           #:program-id
+           #:get-location
+           #:using-program
+           #:with-locations))
+(in-package :stoe/shader/shader)
 
 (defstruct shader
   "Structure containing the shader in glsl format together with metadata used to
@@ -102,7 +100,7 @@ If the program is compiled into glsl, it keeps track of the object id."
 
 (defmacro using-program ((var program) &body body)
   "Use the specified program and bind all its attributes and uniforms for use in BODY."
-  `(let ((,var (symbol-value (find-symbol (symbol-name ,program) :stoe.render.shaders))))
+  `(let ((,var (symbol-value (find-symbol (symbol-name ,program) :stoe/engine/shaders))))
      (gl-assert (gl:use-program (program-id ,var)))
      ,@body
      (gl-assert (gl:use-program 0))))

shader/walker.lisp

@@ -3,15 +3,13 @@
   Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
 |#
 
-(in-package :cl-user)
-(defpackage stoe.shader.walker
-  (:use :cl :utils)
-  (:nicknames :walker)
-  (:export :walk-1
-           :walk-list
-           :walk
-           :defhandler))
-(in-package :stoe.shader.walker)
+(uiop:define-package :stoe/shader/walker
+  (:use :cl :stoe/core/utils)
+  (:export #:walk-1
+           #:walk-list
+           #:walk
+           #:defhandler))
+(in-package :stoe/shader/walker)
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defvar *form-handlers* (make-hash-table)

src/camera.lisp

@@ -1,40 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.camera
-  (:nicknames :camera)
-  (:use :cl)
-  (:export :camera :view :proj
-           :make-camera
-           :update-view)
-  (:import-from :object
-                :object :pos :dir))
-(in-package :stoe.camera)
-
-(defclass camera (object)
-  ((fovy :initarg :fovy :accessor fovy)
-   (aspect :initarg :aspect :accessor aspect)
-   (near :initarg :near :accessor near)
-   (far :initarg :far :accessor far)
-   (projection :initarg :projection :accessor proj :type 'f44:float44)
-   (view :accessor view :type 'f44:float44))
-  (:documentation "Base class for a camera representing a view of the game world."))
-
-(defun make-camera (fovy aspect near far)
-  (let ((camera (make-instance 'camera :position (v:vec 0 0 2)
-                               :direction (q:from-axis-and-angle (v:vec 0 0 1) 0)
-                               :fovy fovy
-                               :aspect aspect
-                               :near near
-                               :far far
-                               :projection (geom:make-persp-matrix fovy aspect near far))))
-    (update-view camera)
-    camera))
-
-(defun update-view (camera)
-  "Compute the world to view matrix from the position and the direction of `camera'."
-  (with-accessors ((pos pos) (dir dir) (view view)) camera
-    (setf view (m:* (m::transpose (q:to-float44 dir)) (geom:mat-trans (v:- pos))))))

src/debug.lisp

@@ -1,51 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.debug
-  (:nicknames :debug)
-  (:use :cl
-        :utils)
-  (:import-from :modules
-               :defmodule))
-(in-package :stoe.debug)
-
-(defvar *swank-server-port* 4006)
-(defvar *frames-per-second* 0.0)
-
-(defun initialize (&optional argv)
-  "Initialize the debug module.
-Check if the current thread is named `repl-thread' and if not,
-start the swank server to accept remote connection."
-  (declare (ignore argv))
-  (format t "Initialize Debug module~%")
-  (when (not (string= (thread:thread-name (thread:current-thread)) "repl-thread"))
-    #+swank
-    (swank:create-server :port *swank-server-port* :dont-close nil)))
-
-(defun finalize ()
-  "Finalize the debug module."
-  (format t "Finalize Debug module~%")
-  (when (not (string= (thread:thread-name (thread:current-thread)) "repl-thread"))
-    #+swank
-    (swank:stop-server *swank-server-port*)))
-
-(let ((time-counter 0.0)
-      (frames-counter 0))
-  (defun update (delta-time)
-    "Eval the repl each frame."
-    #+swank
-    (let ((conn (or swank::*emacs-connection*
-                    (swank::default-connection))))
-      (when conn
-        (swank::handle-requests conn t)))
-    (incf time-counter delta-time)
-    (incf frames-counter)
-    (when (> time-counter 1000000.0)
-      (setf *frames-per-second* frames-counter)
-      (setf time-counter 0.0)
-      (setf frames-counter 0))))
-
-(defmodule debug)

src/file.lisp

@@ -1,25 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.file
-  (:nicknames :file)
-  (:use :cl)
-  (:export :load-file))
-(in-package :stoe.file)
-
-(defun do-load-file (filepath type)
-  "Load the file specified by `filepath' and store it in the object returned."
-  (with-open-file (stream filepath :direction :input :element-type type)
-    (when stream
-      (let ((buffer (make-array (file-length stream) :element-type type)))
-        (read-sequence buffer stream)
-        buffer))))
-
-(defun load-file (filepath &key (sync nil) (type '(unsigned-byte 8)))
-  "Load the file specified by `filepath' asynchronally unless `sync' is true."
-  (if sync
-      (do-load-file filepath type)
-      (jobs:push-job #'do-load-file (list filepath type))))

src/game.lisp

@@ -1,61 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.game
-  (:use :cl)
-  (:nicknames :game)
-  (:export :get-world-origin
-           :get-current-camera)
-  (:import-from :modules
-                :defmodule)
-  (:import-from :camera
-                :make-camera :update-view))
-(in-package :stoe.game)
-
-(defconstant +loop-step-time+ 16000.0
-  "The length of one game loop frame.")
-
-(defvar *last-frame-remaining-time* 0.0
-  "The game loop advance +loop-step-time+ at a time but when the delta time doesn't correspond
-we need to keep the remaining time.")
-
-(defvar *current-camera* nil
-  "The camera used to render the scene.")
-
-(defvar *world-origin* nil
-  "The origin node of the scene.")
-
-(defun initialize (&optional argv)
-  "Initialize the game module."
-  (declare (ignore argv))
-  (format t "Initialize Game module~%")
-  (input:initialize)
-  (setf *world-origin* (object:make-object))
-  (setf *current-camera* (make-camera 90 (/ 16 9) 1.0 1000.0))
-  (scene:attach *current-camera* *world-origin*))
-
-(defun finalize ()
-  "Finalize the game module."
-  (setf *current-camera* nil)
-  (setf *world-origin* nil)
-  (input:finalize))
-
-(defun update (delta-time)
-  "Update the game module.
-Advance the world by `delta-time', +loop-step-time+ at a time."
-  (setf delta-time (+ delta-time *last-frame-remaining-time*))
-  (loop while (> delta-time +loop-step-time+)
-     do (progn
-          (when *current-camera*
-            (update-view *current-camera*))
-          (input:update +loop-step-time+)
-          (decf delta-time +loop-step-time+)))
-  (setf *last-frame-remaining-time* delta-time))
-
-(defmodule game)
-
-(defun get-world-origin () *world-origin*)
-(defun get-current-camera () *current-camera*)

src/jobs.lisp

@@ -1,177 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.jobs
-  (:nicknames :jobs)
-  (:use :cl
-        :utils
-        :thread
-        :containers)
-  (:export :job
-           :job-result
-           :push-job
-           :wait-for-job
-           :cancel-job)
-  (:import-from :modules
-                :defmodule))
-(in-package :stoe.jobs)
-
-(defstruct job
-  (handle -1 :read-only t)
-  (fun nil :read-only t)
-  (args nil :read-only t)
-  (assigned-thread -1)
-  (running nil)
-  (completed nil)
-  (result nil)
-  (canceled nil)
-  (waitqueue (make-waitqueue))
-  (mutex (make-mutex)))
-
-(defstruct command
-  (fun nil :read-only t)
-  (args nil :read-only t))
-
-(defstruct (thread (:constructor %make-thread))
-  (id 0 :read-only t)
-  (thread nil)
-  (termination-requested nil)
-  (command-queue (make-safe-queue nil)))
-
-(defvar *thread-list* nil)
-(defvar *job-list* (make-queue))
-(defvar *job-waitqueue* (make-waitqueue :name "job-waitqueue"))
-(defvar *job-mutex* (make-mutex "job-mutex"))
-(defvar *next-handle* -1)
-
-(defun make-job-thread (fun id &optional args)
-  "Create a new thread."
-  (let* ((thread-object (%make-thread :id id))
-         (thread (make-thread fun :name (format nil "Thread ~a" id) :args (append (list thread-object) args))))
-    (setf (thread-thread thread-object) thread)
-    thread-object))
-
-(defun initialize (&optional argv)
-  "Initialize the jobs module."
-  (format t "Initialize Job system~%")
-  (let ((thread-count (get-command-line-option-number argv "-j" 1)))
-    (when (> thread-count 0)
-      (setf *thread-list*
-            (make-array (list thread-count) :initial-contents
-                        (loop for i below thread-count
-                           collect (let ((thread (make-job-thread #'thread-loop i)))
-                                     (push-command #'initialize-thread nil thread)
-                                     thread)))))))
-
-(defun finalize ()
-  "Finalize the jobs module."
-  (format t "Finalize Job system~%")
-  (loop for i below (array-dimension *thread-list* 0)
-     do (push-command #'terminate-thread nil i))
-  (loop while (some (lambda (elt) (not (null elt))) *thread-list*)
-     do (update 0)))
-
-(defun update (delta-time)
-  "Tick all running jobs to update their timer and retrieve their result value.
-If a thread is available, assign a new job to it."
-  (declare (ignorable delta-time))
-  (loop for i below (array-dimension *thread-list* 0)
-     do (let ((thread (aref *thread-list* i)))
-          (when thread
-            (if (not (thread-alive-p (thread-thread thread)))
-                (finalize-thread thread))))))
-
-(defmodule jobs)
-
-(defun push-job (fun args)
-  "Create a new job using `fun' and `data' and push it into the job-list."
-  (let ((job (make-job :handle (incf *next-handle*) :fun fun :args args)))
-    (with-mutex (*job-mutex*)
-      (enqueue *job-list* job)
-      (condition-notify *job-waitqueue*))
-    job))
-
-(defun wait-for-job (job &optional (waitp t) timeout)
-  "Wait for `job' to be completed. Return immediately either way if `waitp' is non-nil.
-If `timeout' is specified, return even if job hasn't been completed.
-
-Returns t if the job has completed, nil otherwise."
-  (or (job-completed job)
-      (and waitp
-           (with-mutex ((job-mutex job))
-             (if timeout
-                 (condition-wait (job-waitqueue job) (job-mutex job) :timeout timeout)
-                 (loop until (job-completed job)
-                    do (condition-wait (job-waitqueue job) (job-mutex job))))
-             (job-completed job)))))
-
-(defun cancel-job (job)
-  "Try and cancel a job request.
-Return t if job has been successfully canceled, nil if it currently running."
-  (with-mutex (*job-mutex*)
-    (and (not (job-running job))
-         (setf (job-canceled job) t))))
-
-(defun push-command (fun args thread-or-id)
-  "Assign the command `fun' to the thread `thread-id'."
-  (let ((thread (or (and (thread-p thread-or-id) thread-or-id) (aref *thread-list* thread-or-id))))
-    (when thread
-      (enqueue (thread-command-queue thread) (make-command :fun fun :args args))
-      (with-mutex (*job-mutex*)
-        (condition-broadcast *job-waitqueue*)))))
-
-(defun initialize-thread (thread)
-  "Initialize a thread."
-  (format t "Initialize thread ~a~%" (thread-id thread)))
-
-(defun finalize-thread (thread)
-  "Finalize a thread."
-  (let ((thread-id (thread-id thread)))
-    (format t "Finalize thread ~a~%" thread-id)
-    (join-thread (thread-thread thread) :default 'join-error)
-    (if (not (thread-termination-requested thread))
-        ;; If the thread wasn't requested to terminate, something wrong happened, restart a new one
-        (let ((new-thread (make-job-thread #'thread-loop thread-id)))
-          (push-command #'initialize-thread nil new-thread)
-          (setf (aref *thread-list* thread-id) new-thread))
-        (setf (aref *thread-list* thread-id) nil))))
-
-(defun terminate-thread (thread)
-  "Set a thread's `termination-requested' flag to t."
-  (setf (thread-termination-requested thread) t))
-
-(defun wait-for-next-job (waitqueue job-list lock)
-  "Wait for a job to be available and return it."
-  (with-mutex (lock)
-    (let ((job nil))
-      (condition-wait waitqueue lock)
-      (when (peek job-list)
-        (setf job (dequeue job-list))
-        (setf (job-running job) t))
-      job)))
-
-(defun thread-loop (thread)
-  "Run the thread loop.
-Wait on the job queue for a new job and update the thread status."
-  (loop until (thread-termination-requested thread)
-     do (let ((job (wait-for-next-job *job-waitqueue* *job-list* *job-mutex*)))
-          (restartable
-              (when job
-                (format t "Thread ~a: Running job ~a~%" (thread-id thread) (job-handle job))
-                (run-job job))
-            (update-thread thread)))))
-
-(defun update-thread (thread)
-  "Update a thread status.
-throw `exit-thread-loop' if the main thread has requested it to terminate."
-  (let ((command (dequeue (thread-command-queue thread))))
-    (when command
-      (apply (command-fun command) thread (command-args command)))))
-
-(defun run-job (job)
-  (setf (job-result job) (apply (job-fun job) (job-args job)))
-  (atomic-set-flag (job-completed job) t)
-  (atomic-set-flag (job-running job) nil))

src/maths/float2.lisp

@@ -1,16 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.maths.float2
-  (:nicknames :float2 :f2)
-  (:use :cl)
-  (:export :float2 :vec))
-(in-package :stoe.maths.float2)
-
-(deftype float2 () '(simple-array single-float (2)))
-
-(defun vec (x y)
-  (v:vec x y))

src/maths/float22.lisp

@@ -1,24 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.maths.float22
-  (:nicknames :float22 :f22)
-  (:use :cl)
-  (:export :float22 :mat :mat-null :mat-ident))
-(in-package :stoe.maths.float22)
-
-(deftype float22 () '(simple-array single-float (2 2)))
-
-(defun mat (e00 e01 e10 e11)
-  (m:mat e00 e01 e10 e11))
-
-(defun mat-null ()
-  (mat 0 0
-       0 0))
-
-(defun mat-ident ()
-  (mat 1 0
-       0 1))

src/maths/float3.lisp

@@ -1,16 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.maths.float3
-  (:nicknames :float3 :f3)
-  (:use :cl)
-  (:export :float3 :vec))
-(in-package :stoe.maths.float3)
-
-(deftype float3 () '(simple-array single-float (3)))
-
-(defun vec (x y z)
-  (v:vec x y z))

src/maths/float33.lisp

@@ -1,28 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.maths.float33
-  (:nicknames :float33 :f33)
-  (:use :cl)
-  (:export :float33 :mat :mat-null :mat-ident))
-(in-package :stoe.maths.float33)
-
-(deftype float33 () '(simple-array single-float (3 3)))
-
-(defun mat (e00 e01 e02 e10 e11 e12 e20 e21 e22)
-  (m:mat e00 e01 e02
-         e10 e11 e12
-         e20 e21 e22))
-
-(defun mat-null ()
-  (mat 0 0 0
-       0 0 0
-       0 0 0))
-
-(defun mat-ident ()
-  (mat 1 0 0
-       0 1 0
-       0 0 1))

src/maths/float4.lisp

@@ -1,16 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.maths.float4
-  (:nicknames :float4 :f4)
-  (:use :cl)
-  (:export :float4 :vec))
-(in-package :stoe.maths.float4)
-
-(deftype float4 () '(simple-array single-float (4)))
-
-(defun vec (x y z w)
-  (v:vec x y z w))

src/maths/float44.lisp

@@ -1,31 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.maths.float44
-  (:nicknames :float44 :f44)
-  (:use :cl)
-  (:export :float44 :mat :mat-null :mat-ident))
-(in-package :stoe.maths.float44)
-
-(deftype float44 () '(simple-array single-float (4 4)))
-
-(defun mat (e00 e01 e02 e03 e10 e11 e12 e13 e20 e21 e22 e23 e30 e31 e32 e33)
-  (m:mat e00 e01 e02 e03
-         e10 e11 e12 e13
-         e20 e21 e22 e23
-         e30 e31 e32 e33))
-
-(defun mat-null ()
-  (mat 0 0 0 0
-       0 0 0 0
-       0 0 0 0
-       0 0 0 0))
-
-(defun mat-ident ()
-  (mat 1 0 0 0
-       0 1 0 0
-       0 0 1 0
-       0 0 0 1))

src/maths/geometry.lisp

@@ -1,74 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.maths.geometry
-  (:nicknames :geometry :geom)
-  (:use :cl)
-  (:export :mat-trans :mat-scale :mat-rot
-           :make-persp-matrix :make-ortho-matrix))
-(in-package :stoe.maths.geometry)
-
-(defun mat-trans (vec)
-  (declare (type f3:float3 vec))
-  (let ((mat (f44:mat-ident)))
-    (m:setcol mat 3 vec)))
-
-(defun mat-scale (dim vec)
-  (let ((mat (m:mat-ident (array-element-type vec) dim)))
-    (m:setdiag mat vec)))
-
-(defun mat-rot (angle &optional axis)
-  (let ((cos (cos angle))
-        (sin (sin angle)))
-    (cond
-      ((null axis) (f22:mat cos (- sin) sin cos))
-      ((eq axis :x) (f44:mat 1 0 0 0
-                             0 cos (- sin) 0
-                             0 sin cos 0
-                             0 0 0 1))
-      ((eq axis :y) (f44:mat cos 0 sin 0
-                             0 1 0 0
-                             (- sin) 0 cos 0
-                             0 0 0 1))
-      ((eq axis :z) (f44:mat cos (- sin) 0 0
-                             sin cos 0 0
-                             0 0 1 0
-                             0 0 0 1))
-      ((arrayp axis)
-       (let ((1-cos (- 1.0 cos))
-             (axis (v:safe-normalize axis nil))
-             (mat (f44:mat-ident)))
-         (unless (null axis)
-           (v:with-attributes (x y z) axis
-                              (setf (aref mat 0 0) (+ (* x x) (* (- 1 (* x x)) cos)))
-                              (setf (aref mat 0 1) (- (* x y 1-cos) (* z sin)))
-                              (setf (aref mat 0 2) (+ (* x z 1-cos) (* y sin)))
-                              (setf (aref mat 1 0) (+ (* x y 1-cos) (* z sin)))
-                              (setf (aref mat 1 1) (+ (* y y) (* (- 1 (* y y)) cos)))
-                              (setf (aref mat 1 2) (- (* y z 1-cos) (* x sin)))
-                              (setf (aref mat 2 0) (- (* x z 1-cos) (* y sin)))
-                              (setf (aref mat 2 1) (+ (* y z 1-cos) (* x sin)))))
-         mat)))))
-
-(defun calc-frustum-scale (fovy)
-  (tan (/ (maths:deg-to-rad fovy) 2.0)))
-
-(defun make-persp-matrix (fovy aspect near far)
-  (let ((range (calc-frustum-scale fovy)))
-    (let ((left (* (- range) aspect))
-          (right (* range aspect))
-          (bottom (- range))
-          (top range))
-      (f44:mat (/ (* near 2) (- right left)) 0.0 0.0 0.0
-               0.0 (/ (* near 2) (- top bottom)) 0.0 0.0
-               0.0 0.0 (/ (+ far near) (- near far)) -1.0
-               0.0 0.0 (/ (* 2.0 far near) (- near far)) 0.0))))
-
-(defun make-ortho-matrix (width height)
-  (f44:mat (/ 2.0 width)             0.0 0.0 -1.0
-                     0.0 (/ -2.0 height) 0.0  1.0
-                     0.0             0.0 1.0  0.0
-                     0.0             0.0 0.0  1.0))

src/maths/matrix.lisp

@@ -1,112 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.maths.matrix
-  (:nicknames :matrix :m)
-  (:use :cl)
-  (:shadow :+ :- :*)
-  (:export :mat :mat-null :mat-ident
-           :setrow :setcol :setdiag
-           :+ :- :*))
-(in-package :stoe.maths.matrix)
-
-(defun make-matrix (type dim-x dim-y attrs)
-  `(make-array (list ,dim-x ,dim-y) :element-type ',type
-               :initial-contents (list ,@(loop for i below dim-x
-                                            collect `(list ,@(loop for j below dim-y
-                                                                collect (let ((x (pop attrs)))
-                                                                          (if (numberp x)
-                                                                              (coerce x type)
-                                                                              `(coerce ,x ',type)))))))))
-
-(defmacro mat (&rest attrs)
-  (let* ((len (length attrs))
-         (dim-x (floor (sqrt len)))
-         (dim-y (if (= (cl:* dim-x dim-x) len) dim-x (cl:/ len dim-x))))
-    (make-matrix 'single-float dim-x dim-y attrs)))
-
-(defun mat-null (type dim-x dim-y)
-  (make-array `(,dim-x ,dim-y) :element-type type :initial-element (coerce 0 type)))
-
-(defun mat-ident (type dim)
-  (let* ((ident-elt (coerce 1 type))
-         (mat (mat-null type dim dim)))
-    (loop for i below dim
-       do (setf (aref mat i i) ident-elt))
-    mat))
-
-(defun setrow (mat subscript vec)
-  (loop for i below (array-dimension vec 0)
-     do (setf (aref mat subscript i) (aref vec i)))
-  mat)
-
-(defun setcol (mat subscript vec)
-  (loop for i below (array-dimension vec 0)
-     do (setf (aref mat i subscript) (aref vec i)))
-  mat)
-
-(defun setdiag (mat vec)
-  (loop for i below (array-dimension vec 0)
-     do (setf (aref mat i i) (aref vec i)))
-  mat)
-
-(defun transpose (mat)
-  (let ((transposed (mat-null (array-element-type mat) (array-dimension mat 1) (array-dimension mat 0))))
-    (loop for i below (array-dimension mat 0)
-       do (loop for j below (array-dimension mat 1)
-             do (setf (aref transposed j i) (aref mat i j))))
-    transposed))
-
-(defun add-mat (mat-a mat-b)
-  (let* ((mat (mat-null (array-element-type mat-a) (array-dimension mat-a 0) (array-dimension mat-a 1)))
-        (len (array-total-size mat)))
-    (loop for i below len
-       do (setf (row-major-aref mat i) (cl:+ (row-major-aref mat-a i) (row-major-aref mat-b i))))
-    mat))
-
-(defun sub-mat (mat-a mat-b)
-  (let* ((mat (mat-null (array-element-type mat-a) (array-dimension mat-a 0) (array-dimension mat-a 1)))
-        (len (array-total-size mat)))
-    (loop for i below len
-       do (setf (row-major-aref mat i) (cl:- (row-major-aref mat-a i) (row-major-aref mat-b i))))
-    mat))
-
-(defun mul-scalar (mat scalar)
-  (let* ((newmat (mat-null (array-element-type mat) (array-dimension mat 0) (array-dimension mat 1)))
-        (len (array-total-size newmat)))
-    (loop for i below len
-       do (setf (row-major-aref newmat i) (cl:* (row-major-aref mat i) scalar)))
-    newmat))
-
-(defun mul-mat (mat-a mat-b)
-  (let ((mat (mat-null (array-element-type mat-a) (array-dimension mat-b 1) (array-dimension mat-a 0))))
-    (loop for i below (array-dimension mat 0)
-       do (loop for j below (array-dimension mat 1)
-             do (setf (aref mat i j) (loop for k below (array-dimension mat-a 1)
-                                        for l below (array-dimension mat-b 0)
-                                        sum (cl:* (aref mat-a i k) (aref mat-b l j))))))
-    mat))
-
-(defun mul-vec (mat vec)
-  (apply #'v::make-vector (cons (array-element-type mat)
-                                (loop for i below (array-dimension mat 0)
-                                   collect (loop for j below (array-dimension mat 1)
-                                              sum (cl:* (aref mat i j) (aref vec j)))))))
-
-(defun + (&rest mat-list)
-  (reduce #'add-mat mat-list))
-
-(defun - (&rest mat-list)
-  (reduce #'sub-mat mat-list))
-
-(defun * (&rest mat-list)
-  (reduce #'(lambda (a b)
-              (cond
-                ((not (typep a 'simple-array)) (mul-scalar b a))
-                ((not (typep b 'simple-array)) (mul-scalar a b))
-                ((= (array-rank b) 1) (mul-vec a b))
-                (t (mul-mat a b))))
-          mat-list))

src/maths/quaternion.lisp

@@ -1,53 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.maths.quaternion
-  (:nicknames :quaternion :q)
-  (:use :cl)
-  (:shadow :* :conjugate)
-  (:export :quaternion :quat
-           :from-axis-and-angle
-           :to-float33 :to-float44
-           :* :conjugate))
-(in-package :stoe.maths.quaternion)
-
-(deftype quaternion () '(simple-array single-float (4)))
-
-(defun quat (x y z w)
-  (v:normalize (v:vec x y z w)))
-
-(defun from-axis-and-angle (vec angle)
-  "Create a quaternion from an axis and an angle."
-  (let ((vec (v:normalize vec))
-        (sin (coerce (sin (/ angle 2)) 'single-float))
-        (cos (coerce (cos (/ angle 2)) 'single-float)))
-    (v:normalize (v:vec (v:* vec sin) cos))))
-
-(defun conjugate (quat)
-  (quat (v:- (v:x quat)) (v:- (v:y quat)) (v:- (v:z quat)) (v:w quat)))
-
-(defun * (&rest quat-list)
-  (v:normalize (reduce (lambda (q1 q2)
-                         (v:with-attributes ((ax x) (ay y) (az z) (aw w)) q1
-                           (v:with-attributes ((bx x) (by y) (bz z) (bw w)) q2
-                             (quat (cl:- (cl:+ (cl:* aw bx) (cl:* ax bw) (cl:* ay bz)) (cl:* az by))
-                                   (cl:- (cl:+ (cl:* aw by) (cl:* ay bw) (cl:* az bx)) (cl:* ax bz))
-                                   (cl:- (cl:+ (cl:* aw bz) (cl:* az bw) (cl:* ax by)) (cl:* ay bx))
-                                   (cl:- (cl:* aw bw) (cl:* ax bx) (cl:* ay by) (cl:* az bz))))))
-                       quat-list)))
-
-(defun to-float33 (quat)
-  (v:with-attributes (x y z w) quat
-    (f33:mat (cl:- 1 (cl:* 2 y y) (cl:* 2 z z)) (cl:- (cl:* 2 x y) (cl:* 2 w z)) (cl:+ (cl:* 2 x z) (cl:* 2 w y))
-             (cl:+ (cl:* 2 x y) (cl:* 2 w z)) (cl:- 1 (cl:* 2 x x) (cl:* 2 z z)) (cl:- (cl:* 2 y z) (cl:* 2 w x))
-             (cl:- (cl:* 2 x z) (cl:* 2 w y)) (cl:+ (cl:* 2 y z) (cl:* 2 w x)) (cl:- 1 (cl:* 2 x x) (cl:* 2 y y)))))
-
-(defun to-float44 (quat)
-  (v:with-attributes (x y z w) quat
-    (f44:mat (cl:- 1 (cl:* 2 y y) (cl:* 2 z z)) (cl:- (cl:* 2 x y) (cl:* 2 w z)) (cl:+ (cl:* 2 x z) (cl:* 2 w y)) 0.0
-             (cl:+ (cl:* 2 x y) (cl:* 2 w z)) (cl:- 1 (cl:* 2 x x) (cl:* 2 z z)) (cl:- (cl:* 2 y z) (cl:* 2 w x)) 0.0
-             (cl:- (cl:* 2 x z) (cl:* 2 w y)) (cl:+ (cl:* 2 y z) (cl:* 2 w x)) (cl:- 1 (cl:* 2 x x) (cl:* 2 y y)) 0.0
-             0.0 0.0 0.0 1.0)))

src/maths/vector.lisp

@@ -1,116 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.maths.vector
-  (:nicknames :vector :v)
-  (:use :cl)
-  (:shadow :+ :- :* :/ :length)
-  (:export :vec :vec-int :x :y :z :w
-           :swizzle :with-attributes
-           :+ :- :* :/
-           :lengthsq :length
-           :normalize :safe-normalize))
-(in-package :stoe.maths.vector)
-
-(defun make-vector (type components)
-  (let ((dim (cl:length components)))
-    (make-array dim :element-type type :initial-contents (loop for i in components
-                                                            collect (coerce i type)))))
-
-(defun decompose (&rest components)
-  "Decompose a list of potential vectors into a single list."
-  (reduce #'append (mapcar (lambda (attr)
-                             (if (typep attr 'sequence)
-                                 (coerce attr 'list)
-                                 (list attr)))
-                           components)))
-
-(defmacro vec (&rest components)
-  `(make-vector 'single-float (decompose ,@components)))
-
-(defmacro vec-int (&rest components)
-  `(make-vector 'fixnum (decompose ,@components)))
-
-(defun x (vec) (if (> (array-dimension vec 0) 0) (aref vec 0) (coerce 0 (array-element-type vec))))
-(defun y (vec) (if (> (array-dimension vec 0) 1) (aref vec 1) (coerce 0 (array-element-type vec))))
-(defun z (vec) (if (> (array-dimension vec 0) 2) (aref vec 2) (coerce 0 (array-element-type vec))))
-(defun w (vec) (if (> (array-dimension vec 0) 3) (aref vec 3) (coerce 0 (array-element-type vec))))
-
-(defmacro swizzle (vec attributes)
-  (let* ((name (symbol-name attributes))
-         (len (cl:length name)))
-    `(make-array ,len :element-type (array-element-type ,vec)
-                 :initial-contents (list ,@(loop for x being the element of name
-                                              collect `(,(intern (concatenate 'string `(,x)) 'stoe.maths.vector)
-                                                         ,vec))))))
-
-(defmacro with-attributes (attr-list vec &body body)
-  "Binds a list of variables with x y z w or some swizzled vector for use in `body'."
-  `(let ,(mapcar (lambda (attr)
-                   (let* ((var (if (listp attr) (car attr) attr))
-                          (sym (symbol-name (if (listp attr) (cadr attr) attr)))
-                          (sym-len (cl:length sym)))
-                     (if (> sym-len 1)
-                         (list var `(swizzle ,vec ,(intern sym 'vector)))
-                         (list var `(,(intern sym 'vector) ,vec)))))
-                 attr-list)
-     ,@body))
-
-(defun op-scalar (fun vec scalar)
-  (map (type-of vec) #'(lambda (attr) (funcall fun attr scalar)) vec))
-
-(defun op-vec (fun vec-a vec-b)
-  (map (type-of vec-a) fun vec-a vec-b))
-
-(defun + (&rest vec-list)
-  (reduce #'(lambda (a b)
-              (cond
-                ((not (typep a 'simple-array)) (op-scalar #'cl:+ b a))
-                ((not (typep b 'simple-array)) (op-scalar #'cl:+ a b))
-                (t (op-vec #'cl:+ a b))))
-          vec-list))
-
-(defun - (&rest vec-list)
-  (if (= (cl:length vec-list) 1)
-      (let ((vec (car vec-list)))
-        (map (type-of vec) #'cl:- vec))
-      (reduce #'(lambda (a b)
-                  (cond
-                    ((not (typep a 'simple-array)) (op-scalar #'cl:- b a))
-                    ((not (typep b 'simple-array)) (op-scalar #'cl:- a b))
-                    (t (op-vec #'cl:- a b))))
-              vec-list)))
-
-(defun * (&rest vec-list)
-  (reduce #'(lambda (a b)
-              (cond
-                ((not (typep a 'simple-array)) (op-scalar #'cl:* b a))
-                ((not (typep b 'simple-array)) (op-scalar #'cl:* a b))
-                (t (op-vec #'cl:* a b))))
-          vec-list))
-
-(defun / (&rest vec-list)
-  (reduce #'(lambda (a b)
-              (cond
-                ((not (typep a 'simple-array)) (op-scalar #'cl:/ b a))
-                ((not (typep b 'simple-array)) (op-scalar #'cl:/ a b))
-                (t (op-vec #'cl:/ a b))))
-          vec-list))
-
-(defun lengthsq (vec)
-  (reduce #'cl:+ (map 'list #'(lambda (x) (cl:* x x)) vec)))
-
-(defun length (vec)
-  (sqrt (lengthsq vec)))
-
-(defun normalize (vec)
-  (/ vec (length vec)))
-
-(defun safe-normalize (vec &optional default)
-  (let ((lensq (lengthsq vec)))
-    (if (zerop lensq)
-        (or default vec)
-        (/ vec (sqrt lensq)))))

src/modules.lisp

@@ -1,58 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.modules
-  (:nicknames :modules)
-  (:use :cl
-        :utils)
-  (:export :initialize :finalize :update
-           :defmodule)
-  (:import-from :alexandria
-                :once-only))
-(in-package :stoe.modules)
-
-(defparameter *initialize-hook* nil
-  "Hook run on initialization.
-Functions attached to this hook should expect an optional argument containing
-the program argv.")
-
-(defparameter *finalize-hook* nil
-  "Hook run on finalization.")
-
-(defparameter *update-hook* nil
-  "Hook run each frame.
-Functions attached to this hook should expect an argument containing the time
-since last frame.")
-
-(defmacro initialize (&optional argv)
-  "Perform the engine and subsystems initialization process."
-  `(progn
-     (format t "Initialize...~%")
-     ,@(loop for fun in *initialize-hook*
-          collect (list fun argv))))
-
-(defmacro finalize ()
-  "Perform the engine and subsystems finalization process."
-  `(progn
-     (format t "Finalize...~%")
-     ,@(loop for fun in *finalize-hook*
-          collect (list fun))))
-
-(defmacro update (delta-time)
-  "Update the modules each loop."
-  `(progn
-     ,@(loop for fun in *update-hook*
-          collect (list fun delta-time))))
-
-(defmacro defmodule (module)
-  "Register a new module.
-The module is expected to have at least `initialize', `update', and `finalize' functions.
-`initialize' accepts an optional `argv' argument,
-`update' accepts a delta-time argument."
-  `(progn
-     (setf *initialize-hook* (append *initialize-hook* (list (intern "INITIALIZE" ',module))))
-     (push (intern "FINALIZE" ',module) *finalize-hook*)
-     (setf *update-hook* (append *update-hook* (list (intern "UPDATE" ',module))))))

src/object.lisp

@@ -1,33 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.object
-  (:use :cl)
-  (:nicknames :object)
-  (:export :object :pos :dir :trans-mat :components
-           :make-object :update-trans-matrix)
-  (:import-from :scene
-                :scene-node :parent))
-(in-package :stoe.object)
-
-(defclass object (scene-node)
-  ((position :initarg :position :accessor pos :type 'f3:float3)
-   (direction :initarg :direction :accessor dir :type 'q:quaternion)
-   (trans-matrix :initform (f44:mat-ident) :accessor trans-mat :type 'f44:float44)
-   (components :initform nil :reader components))
-  (:documentation "Base class for all objects existing in the game world."))
-
-(defun make-object (&key (pos (v:vec 0 0 0)) (dir (q:from-axis-and-angle (v:vec 0 0 1) 0)) mesh)
-  (let ((obj (make-instance 'object :position pos :direction dir)))
-    (when mesh
-      (with-slots (components) obj
-        (push mesh components)))
-    obj))
-
-(defun update-trans-matrix (node)
-  (setf (trans-mat node) (m:* (trans-mat (parent node))
-                              (geom:mat-trans (pos node))
-                              (q:to-float44 (dir node)))))

src/render/gl-utils.lisp

@@ -1,70 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.render.gl-utils
-  (:nicknames :gl-utils)
-  (:use :cl)
-  (:export :*major-version*
-           :*minor-version*
-           :*glsl-version*
-           :gl-initialized-p
-           :initialize
-           :finalize
-           :version-supported-p
-           :gl-assert
-           :gl-restart
-           :size-of))
-(in-package :stoe.render.gl-utils)
-
-(defvar *major-version* nil)
-(defvar *minor-version* nil)
-(defvar *glsl-version* nil)
-
-(let ((initializedp))
-  (defun gl-initialized-p ()
-    initializedp)
-
-  (defun initialize (version)
-    "Initialize the local opengl configuration.
-Store values like the drivers version."
-    (if (/= version 0)
-        (multiple-value-bind (maj min) (floor version 10)
-          (setf *major-version* maj
-                *minor-version* min))
-        (setf *major-version* (gl:get-integer :major-version)
-              *minor-version* (gl:get-integer :minor-version)))
-    (setf *glsl-version* (with-input-from-string (in (gl:get-string :shading-language-version))
-                           (read in)))
-    (setf initializedp t))
-
-  (defun finalize ()
-    (setf initializedp nil)))
-
-(defun version-supported-p (version)
-  (multiple-value-bind (maj min) (floor version 10)
-    (and (<= maj *major-version*)
-         (<= min *minor-version*))))
-
-(defmacro gl-assert (&body body)
-  `(progn
-     ,@(loop for form in body
-          collect `(prog1
-                       ,form
-                     (let ((err-sym (%gl:get-error)))
-                       (unless (eq err-sym :zero)
-                         (error "The OpenGL command `~a'~%~2iresulted in an error: ~s~%"
-                                ',form err-sym)))))))
-
-(defmacro gl-restart (form)
-  `(restart-case
-       (gl-assert ,form)
-     (continue () :report "Continue")))
-
-(defun size-of (type)
-  (ecase type
-    (:byte 1)
-    (:unsigned-short 2)
-    (:float 4)))

src/render/mesh.lisp

@@ -1,140 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.render.mesh
-  (:nicknames :mesh)
-  (:use :cl :utils)
-  (:export :make-mesh))
-(in-package :stoe.render.mesh)
-
-(defstruct attrib
-  (symb nil)
-  type
-  size
-  offset)
-
-(defstruct (vertex-buffer (:constructor %make-vertex-buffer))
-  data
-  attribs
-  buffer-object)
-
-(defstruct (index-buffer (:constructor %make-index-buffer))
-  type
-  mode
-  size
-  data
-  buffer-object)
-
-(defstruct (mesh-stream (:constructor %make-mesh-stream))
-  program
-  vertex-buffer
-  index-buffer)
-
-(defclass mesh ()
-  ((name :initform "" :reader mesh-name)
-   (streams :initform nil :reader mesh-streams)))
-
-(defun make-vertex-buffer (data)
-  (let ((buffer-data nil)
-        (buffer-size 0)
-        (end-offset 0))
-    (let* ((attribs (mapcar (lambda (attrib)
-                              (let ((symb (first attrib))
-                                    (type (second attrib))
-                                    (size (third attrib))
-                                    (buffer (fourth attrib)))
-                                (prog1
-                                    (make-attrib :symb (intern (symbol-name symb) :keyword) :type type
-                                                 :size size :offset end-offset)
-                                  (setf buffer-data (cons buffer buffer-data))
-                                  (let ((len (length buffer)))
-                                    (incf buffer-size len)
-                                    (incf end-offset (* len (gl-utils:size-of type)))))))
-                            data))
-           (vertex-buffer (%make-vertex-buffer :data (make-array buffer-size) :attribs attribs))
-           (buffer-index 0))
-      (setf buffer-data (nreverse buffer-data))
-      (loop for buffer in buffer-data
-         do (dotimes (i (length buffer))
-              (setf (aref (vertex-buffer-data vertex-buffer) buffer-index) (aref buffer i))
-              (incf buffer-index)))
-      (setf (vertex-buffer-buffer-object vertex-buffer) (first (gl:gen-buffers 1)))
-      (let ((ptr (cffi:foreign-alloc :float :initial-contents (vertex-buffer-data vertex-buffer) :count end-offset)))
-        (gl:bind-buffer :array-buffer (vertex-buffer-buffer-object vertex-buffer))
-        (%gl:buffer-data :array-buffer end-offset ptr :static-draw)
-        (gl:bind-buffer :array-buffer 0)
-        (cffi:foreign-free ptr))
-      vertex-buffer)))
-
-(defun make-index-buffer (data)
-  (let ((type (first data))
-        (mode (second data))
-        (size (length (third data)))
-        (data (third data)))
-    (let ((index-buffer (%make-index-buffer :type type :mode mode :size size :data data)))
-      (setf (index-buffer-buffer-object index-buffer) (first (gl:gen-buffers 1)))
-      (let ((ptr (cffi:foreign-alloc type :initial-contents data :count size)))
-        (gl:bind-buffer :element-array-buffer (index-buffer-buffer-object index-buffer))
-        (%gl:buffer-data :element-array-buffer (* size (gl-utils:size-of type)) ptr :static-draw)
-        (gl:bind-buffer :element-array-buffer 0)
-        (cffi:foreign-free ptr))
-      index-buffer)))
-
-(defun %set-mesh-stream-program (stream symbol)
-  (setf (mesh-stream-program stream) symbol))
-
-(defun %set-mesh-stream-vertex-buffer (stream data)
-  (setf (mesh-stream-vertex-buffer stream) (make-vertex-buffer data)))
-
-(defun %set-mesh-stream-index-buffer (stream data)
-  (setf (mesh-stream-index-buffer stream) (make-index-buffer data)))
-
-(defun make-mesh-stream (data)
-  (let ((stream (%make-mesh-stream))
-        (alist (group data)))
-    (mapc (lambda (pair) (apply (intern (concatenate 'string "%SET-MESH-STREAM-" (symbol-name (first pair))) :mesh)
-                           stream (list (second pair))))
-          alist)
-    stream))
-
-(defun %set-mesh-name (mesh name)
-  (setf (slot-value mesh 'name) name))
-
-(defun %set-mesh-streams (mesh streams)
-  (setf (slot-value mesh 'streams) (mapcar 'make-mesh-stream streams)))
-
-(defun make-mesh (data)
-  (let ((mesh (make-instance 'mesh))
-        (alist (group data)))
-    (mapc (lambda (pair) (apply (intern (concatenate 'string "%SET-MESH-" (symbol-name (first pair))) :mesh)
-                           mesh (list (second pair))))
-          alist)
-    mesh))
-
-;; (defun load-mesh (data)
-;;   (let ((mesh (make-instance 'mesh :name (getf data :name))))
-;;     (with-slots (index-stream vertex-streams material) mesh
-;;       (setf index-stream (getf (third data) :index-stream))
-;;       (setf vertex-streams (getf (third data) :vertex-streams))
-;;       (setf material (getf (third data) :material))
-;;       ;; (let ((buffers (gl:gen-buffers 2)))
-;;       ;;   (gl:bind-buffer :array-buffer (first buffers))
-;;       ;;   (gl:with-gl-array arr :float :count (length )))
-;;       )
-;;     mesh))
-
-
-;; (defmacro defmesh (name &body body)
-;;   (let ((mesh-symbol (gensym)))
-;;     `(let ((,mesh-symbol (make-instance 'mesh :name ,(symbol-name name))))
-;;        (with-slots (indices vertices) ,mesh-symbol
-;;          ,@(loop while body
-;;               collect (let* ((stream (pop body))
-;;                              (stream-name (pop stream)))
-;;                         (if (eq stream-name :index)
-;;                             `(setf indices (make-index-stream ,@stream))
-;;                             `(push (make-vertex-stream :name ,stream-name ,@stream) vertices)))))
-;;        ,mesh-symbol)))

src/render/render.lisp

@@ -1,142 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.render
-  (:nicknames :render)
-  (:use :cl :utils :gl-utils :shader)
-  (:export :poll-events)
-  (:import-from :modules
-                :defmodule)
-  (:import-from :game
-                :get-current-camera)
-  (:import-from :scene
-                :children)
-  (:import-from :object
-                :trans-mat :components :update-trans-matrix)
-  (:import-from :camera
-                :proj :view))
-(in-package :stoe.render)
-
-(defvar *window* nil)
-
-(defun initialize-renderer ()
-  (gl:enable :cull-face)
-  (gl:cull-face :back)
-  (gl:front-face :cw)
-  (gl:enable :depth-test)
-  (gl:depth-mask :true)
-  (gl:depth-func :lequal)
-  (gl:depth-range 0.0 1.0))
-
-(defun initialize (&optional argv)
-  "Initialize the render module.
-Create an opengl context attached to a window and initialize the shader system."
-  (format t "Initialize Render module~%")
-  (let ((title (get-command-line-option argv "--title" "Stoe"))
-        (width (get-command-line-option-number argv "--width" 800))
-        (height (get-command-line-option-number argv "--height" 600))
-        (version (get-command-line-option-number argv "--opengl")))
-    (if version
-        (progn
-          (gl-utils:initialize version)
-          (setf *window* (glop:create-window title width height
-                                             :major gl-utils:*major-version*
-                                             :minor gl-utils:*minor-version*)))
-        (progn
-          (setf *window* (glop:create-window title width height))
-          (gl-utils:initialize 0)))
-    (compile-all-shaders))
-  (initialize-renderer))
-
-(defun finalize ()
-  "Finalize the render module.
-Destroy the opengl context and the related resources."
-  (format t "Finalize Render module~%")
-  (destroy-all-shaders)
-  (glop:destroy-window *window*)
-  (setf *window* nil)
-  (gl-utils:finalize))
-
-(defun update (delta-time)
-  "Update the render module.
-Render a frame and swap buffers."
-  (declare (ignore delta-time))
-  (gl:clear-color 0 0 0 0)
-  (gl:clear-depth 1.0)
-  (gl:clear :color-buffer-bit :depth-buffer-bit)
-  (render-scene (game:get-world-origin))
-  (glop:swap-buffers *window*))
-
-(defmodule render)
-
-(defun poll-events ()
-  "Poll events from the window manager.
-This needs to be called once per frame, at the beginning of the loop."
-  (when *window*
-    (glop:dispatch-events *window* :blocking nil :on-foo nil)))
-
-(defmethod glop:on-event (window event)
-  (declare (ignore window))
-  (typecase event
-    (glop:key-press-event (input:on-key-event t (glop:keycode event) (glop:keysym event) (glop:text event)))
-    (glop:key-release-event (input:on-key-event nil (glop:keycode event) (glop:keysym event) (glop:text event)))
-    (glop:button-press-event (input:on-button-event t (glop:button event)))
-    (glop:button-release-event (input:on-button-event nil (glop:button event)))
-    (glop:mouse-motion-event (input:on-motion-event (glop:x event) (glop:y event) (glop:dx event) (glop:dy event)))
-    (glop:resize-event (on-resize-event (glop:width event) (glop:height event)))))
-
-(defvar *width* 0)
-(defvar *height* 0)
-
-(defun on-resize-event (width height)
-  (setf (proj (get-current-camera)) (geom:make-persp-matrix 30 (/ width height) 1.0 1000.0))
-  (setf *width* width)
-  (setf *height* height)
-  (gl:viewport 0 0 width height))
-
-(defun render-mesh (node mesh)
-  "Render a single mesh."
-  (loop for stream in (mesh::mesh-streams mesh)
-     do (using-program (program (mesh::mesh-stream-program stream))
-          (with-locations (model-to-camera camera-to-clip) program
-            (gl:uniform-matrix model-to-camera 4 (vector (m:* (view (get-current-camera))
-                                                              (trans-mat node))))
-            (gl:uniform-matrix camera-to-clip 4 (vector (proj (get-current-camera)))))
-          (let* ((vertex-buffer (mesh::mesh-stream-vertex-buffer stream))
-                 (index-buffer (mesh::mesh-stream-index-buffer stream))
-                 (attribs (mesh::vertex-buffer-attribs vertex-buffer)))
-            (gl:bind-buffer :array-buffer (mesh::vertex-buffer-buffer-object vertex-buffer))
-            (loop for attrib in attribs
-               do (let* ((attrib-name (mesh::attrib-symb attrib))
-                         (attrib-loc (get-location program attrib-name)))
-                    (unless (= attrib-loc -1)
-                      (gl-assert (gl:enable-vertex-attrib-array attrib-loc)
-                                 (gl:vertex-attrib-pointer attrib-loc (mesh::attrib-size attrib)
-                                                           (mesh::attrib-type attrib) :false 0
-                                                           (mesh::attrib-offset attrib))))))
-            (gl:bind-buffer :element-array-buffer (mesh::index-buffer-buffer-object index-buffer))
-            (gl-assert (%gl:draw-elements (mesh::index-buffer-mode index-buffer)
-                                          (mesh::index-buffer-size index-buffer)
-                                          (mesh::index-buffer-type index-buffer) 0))
-            (gl:disable-vertex-attrib-array 0)
-            (gl:bind-buffer :element-array-buffer 0)
-            (gl:bind-buffer :array-buffer 0)))))
-
-(defun render-node (node)
-  "Render a single node."
-  (with-accessors ((components components)) node
-    (let ((mesh (car (member-if (lambda (c) (typep c 'mesh::mesh)) components))))
-      (when mesh
-        (render-mesh node mesh)))))
-
-(defun render-scene (node)
-  "Walk the scene graph and render the graphical components."
-  (with-accessors ((children children)) node
-    (loop for child in children
-       do (progn
-            (update-trans-matrix child)
-            (render-node child)
-            (render-scene child)))))

src/scene.lisp

@@ -1,45 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.scene
-  (:use :cl)
-  (:nicknames :scene)
-  (:export :scene-node :parent :children
-           :attach :detach
-           :walk))
-(in-package :stoe.scene)
-
-(defclass scene-node ()
-  ((parent :initform nil :reader parent)
-   (children :initform nil :reader children))
-  (:documentation "Base class for a node in the scene graph."))
-
-(defgeneric attach (scene-node parent)
-  (:documentation "Attach a new node to the scene graph to be rendered."))
-
-(defmethod attach ((scene-node scene-node) (parent scene-node))
-  (with-slots (children) parent
-    (with-slots ((new-parent parent)) scene-node
-      (push scene-node children)
-      (setf new-parent parent))))
-
-(defgeneric detach (scene-node)
-  (:documentation "Detach a node from the scene graph to prevent it and its
-children from being rendered."))
-
-(defmethod detach ((scene-node scene-node))
-  (with-slots (parent) scene-node
-    (with-slots (children) parent
-      (setf children (remove scene-node children))
-      (setf parent nil))))
-
-(defun walk (fun node)
-  "Walk through the scene graph and apply `fun' at each node."
-  (with-slots (children) node
-    (loop for child in children
-       do (progn
-            (apply fun child)
-            (walk fun child)))))

src/stoe.lisp

@@ -1,86 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe
-  (:use :cl
-        :utils)
-  (:import-from :scene
-                :attach)
-  (:import-from :object
-                :make-object :dir)
-  (:import-from :game
-                :get-current-camera
-                :get-world-origin)
-  (:import-from :input
-                :global-set-key
-                :global-set-motion))
-(in-package :stoe)
-
-(let ((exit-main-loop nil))
-  (defun main-loop (&optional unprotected)
-    "Run the protected main-loop. An error will be catched with the possibility to
-continue unless `unprotected' is t."
-    (setf exit-main-loop nil)
-    (let ((clock (make-clock)))
-      (update-current-time)
-      (loop while (not exit-main-loop)
-           do (restartable unprotected
-                (update-current-time)
-                (update-clock clock (get-delta-time))
-                (render:poll-events)
-                (update (clock-delta clock))))))
-
-  (defun quit ()
-    "Quit the main loop."
-    (setf exit-main-loop t)))
-
-(global-set-key :escape #'quit)
-
-(let (freelook-mode
-      start-orient
-      (start-coords '(0.0 . 0.0)))
-  (defun set-freelook (enable)
-    (setf freelook-mode enable)
-    (setf start-orient (dir (get-current-camera))))
-
-  (defun freelook-move (x y)
-    (if freelook-mode
-        (let ((dx (- (car start-coords) x))
-              (dy (- (cdr start-coords) y)))
-          (setf (dir (get-current-camera)) (q:* (q:from-axis-and-angle (v:vec 0 1 0) (maths:deg-to-rad (- dx)))
-                                                start-orient
-                                                (q:from-axis-and-angle (v:vec 1 0 0) (maths:deg-to-rad dy)))))
-        (setf start-coords (cons x y))))
-
-  (global-set-key 3 #'set-freelook t)
-  (global-set-key (3 :release) #'set-freelook nil)
-  (global-set-motion #'freelook-move :x :y))
-
-(defun game-start ()
-  (let ((f (file:load-file #P"../data/cube.lisp" :sync t :type 'character)))
-    (attach (make-object :mesh (with-input-from-string (s f)
-                                 (mesh:make-mesh (read s)))) (get-world-origin))))
-
-(defun initialize (&optional argv)
-  "Initialize all the modules passing the optional argv"
-  (modules:initialize argv))
-
-(defun finalize ()
-  "Finalize all the modules"
-  (modules:finalize))
-
-(defun update (delta-time)
-  "Update all the modules passing the delta time since the last frame"
-  (modules:update delta-time))
-
-(defun main (&optional argv)
-  "Run the program."
-  (initialize argv)
-  (unwind-protect
-       (progn
-         (game-start)
-         (main-loop))
-    (finalize)))

src/thread.lisp

@@ -1,111 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.thread
-  (:nicknames :thread)
-  (:use :cl
-        :utils)
-  (:export :make-thread :join-thread :thread-alive-p :current-thread :thread-name
-           :make-mutex :grab-mutex :release-mutex
-           :with-mutex :with-recursive-lock
-           :make-waitqueue :waitqueue-name :condition-wait :condition-notify :condition-broadcast
-           :atomic-set-flag))
-(in-package :stoe.thread)
-
-(defun make-thread (fun &key name args)
-  "Create a new thread named `name' that runs `fun', with `args' passed as
-arguments."
-  #+(and sbcl sb-thread) (sb-thread:make-thread fun :name name :arguments args)
-  #-(and sbcl sb-thread) (error-implementation-unsupported))
-
-(defun join-thread (thread &key (default nil defaultp) timeout)
-  "Suspend current thread until `thread' exits. Return the result values of the
-thread function."
-  #+(and sbcl sb-thread)
-  (if defaultp
-      (sb-thread:join-thread thread :default default :timeout timeout)
-      (sb-thread:join-thread thread :timeout timeout))
-  #-(and sbcl sb-thread) (error-implementation-unsupported))
-
-(defun thread-alive-p (thread)
-  "Return t if `thread' is alive."
-  #+(and sbcl sb-thread) (sb-thread:thread-alive-p thread)
-  #-(and sbcl sb-thread) (error-implementation-unsupported))
-
-(defun current-thread ()
-  "Return the current thread."
-  #+(and sbcl sb-thread) sb-thread:*current-thread*
-  #-(and sbcl sb-thread) (error-implementation-unsupported))
-
-(defun thread-name (thread)
-  "Return the name of THREAD."
-  #+(and sbcl sb-thread) (sb-thread:thread-name thread)
-  #-(and sbcl sb-thread) (error-implementation-unsupported))
-
-(defun make-mutex (&optional name)
-  "Create a mutex."
-  #+(and sbcl sb-thread) (sb-thread:make-mutex :name name)
-  #-(and sbcl sb-thread) (error-implementation-unsupported))
-
-(defun grab-mutex (mutex &key (waitp t) (timeout nil))
-  "Acquire mutex for the current thread."
-  #+(and sbcl sb-thread) (sb-thread:grab-mutex mutex :waitp waitp :timeout timeout)
-  #-(and sbcl sb-thread) (error-implementation-unsupported))
-
-(defun release-mutex (mutex)
-  "Release `mutex'."
-  #+(and sbcl sb-thread) (sb-thread:release-mutex mutex :if-not-owner :punt)
-  #-(and sbcl sb-thread) (error-implementation-unsupported))
-
-(defmacro with-mutex ((mutex &key (waitp t) timeout) &body body)
-  "Acquire `mutex' for the dynamic scope of body."
-  #+(and sbcl sb-thread)
-  `(sb-thread:with-mutex (,mutex :wait-p ,waitp :timeout ,timeout)
-     ,@body)
-  #-(and sbcl sb-thread)
-  `(error-implementation-unsupported))
-
-(defmacro with-recursive-lock ((mutex &key (waitp t) timeout) &body body)
-  "Acquire `mutex' for the dynamic scope of body and allow recursive lock."
-  #+(and sbcl sb-thread)
-  `(sb-thread:with-recursive-lock (,mutex :wait-p ,waitp :timeout ,timeout)
-     ,@body)
-  #-(and sbcl sb-thread)
-  `(error-implementation-unsupported))
-
-(defun make-waitqueue (&key name)
-  "Create a waitqueue."
-  #+(and sbcl sb-thread) (sb-thread:make-waitqueue :name name)
-  #-(and sbcl sb-thread) (error-implementation-unsupported))
-
-(defun waitqueue-name (instance)
-  "The name of the waitqueue."
-  #+(and sbcl sb-thread) (sb-thread:waitqueue-name instance)
-  #-(and sbcl sb-thread) (error-implementation-unsupported))
-
-(defun condition-wait (queue mutex &key timeout)
-  "Start waiting on `queue' until another thread wakes us up."
-  #+(and sbcl sb-thread) (sb-thread:condition-wait queue mutex :timeout timeout)
-  #-(and sbcl sb-thread) (error-implementation-unsupported))
-
-(defun condition-notify (queue &optional (n 1))
-  "Notify `n' threads waiting on `queue'."
-  #+(and sbcl sb-thread) (sb-thread:condition-notify queue n)
-  #-(and sbcl sb-thread) (error-implementation-unsupported))
-
-(defun condition-broadcast (queue)
-  "Notify all threads waiting on `queue'."
-  #+(and sbcl sb-thread) (sb-thread:condition-broadcast queue)
-  #-(and sbcl sb-thread) (error-implementation-unsupported))
-
-(defmacro atomic-set-flag (place flag)
-  "Set the variable pointed to by `place' to the value `flag' atomically."
-  #+ (and sbcl sb-thread)
-  `(flet ((set-flag (flag place)
-            (declare (ignore place))
-            flag))
-     (sb-ext:atomic-update ,place #'set-flag ,flag))
-  #- (and sbcl sb-thread) (error-implemntation-unsupported))

src/utils.lisp

@@ -1,166 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.utils
-  (:use :cl)
-  (:nicknames :utils)
-  (:export :it :aif :awhen
-           :safe-first :safe-list
-           :group
-           :restartable
-           :progress-step
-           :loop-with-progress
-           :add-hook :remove-hook :run-hook
-           :update-current-time :get-delta-time
-           :make-clock :clock-time :clock-delta
-           :update-clock :compare-clocks
-           :get-command-line-option
-           :get-command-line-option-number))
-(in-package :stoe.utils)
-
-(declaim (optimize (debug 3) (safety 3) (speed 0)))
-
-(defmacro aif (test then else)
-  "Bind the result of evaluating `test' to a variable named `it', as per Paul Graham's On Lisp."
-  `(let ((it ,test))
-     (if it
-         ,then
-         ,else)))
-
-(defmacro awhen (test &body body)
-  "Bind the result of evaluating `test' to a variable named `it', as per Paul Graham's On Lisp."
-  `(let ((it ,test))
-     (when it
-       ,@body)))
-
-(defun safe-first (x)
-  "Return the first element of `x' if it is a list, return `x' otherwise."
-  (if (listp x) (first x) x))
-
-(defun safe-list (x)
-  "Return `x' if it is a list, return '(x) otherwise."
-  (if (listp x) x (list x)))
-
-(defun group (source &optional (n 2))
-  "Regroup the list `source' elements by n."
-  (when (zerop n)
-    (error "zero length"))
-  (labels ((rec (source acc)
-             (let ((rest (nthcdr n source)))
-               (if (consp rest)
-                   (rec rest (cons (subseq source 0 n) acc))
-                   (nreverse (cons source acc))))))
-    (if source (rec source nil) nil)))
-
-(defmacro restartable (unprotected &body body)
-  "Provide a Continue restart unless `unprotected' is t."
-  `(if ,unprotected
-       (progn
-         ,@body)
-      (restart-case
-          (progn
-            ,@body)
-        (continue () :report "Continue"))))
-
-(defmacro loop-with-progress (msg &body body)
-  "Allow a looping process to display feedback."
-  `(let ((progress-max-columns 80))
-     (symbol-macrolet ((progress-step
-                        (progn
-                          (when (> progress-index progress-max-columns)
-                            (format t "~%")
-                            (setf progress-index 0))
-                          (format t "."))))
-       (format t ,msg)
-       (loop for progress-index upfrom ,(length msg)
-            ,@body)
-       (format t "~%"))))
-
-(defmacro add-hook (hook fun &optional append)
-  "Setup `fun' to be called within specified `hook'."
-  `(unless (member ,fun ,hook)
-     ,(if append
-          `(setf ,hook (append ,hook (list ,fun)))
-          `(push ,fun ,hook))))
-
-(defmacro remove-hook (hook fun)
-  "Remove `fun' from `hook'."
-  `(delete ,fun ,hook))
-
-(defun run-hook (hook &rest args)
-  "Apply all functions attached to `hook' with specified `args' if any."
-  (let (result)
-    (mapc (lambda (fun)
-            (setf result (apply fun args)))
-          hook)
-    result))
-
-(defun get-current-time ()
-  "Return the current time in seconds and microseconds."
-  #+sbcl (sb-ext:get-time-of-day)
-  #-sbcl
-  (let* ((time (get-internal-real-time))
-         (sec (/ time internal-time-units-per-second))
-         (usec (* time (/ 1000000 internal-time-units-per-second))))
-    (values sec usec)))
-
-(let ((last-time (cons 0 0))
-      (current-time (cons 0 0)))
-
-  (defun update-current-time ()
-    "Update the cached time in seconds and microseconds."
-    (setf (car last-time) (car current-time))
-    (setf (cdr last-time) (cdr current-time))
-    (multiple-value-bind (sec usec) (get-current-time)
-      (setf (car current-time) sec)
-      (setf (cdr current-time) usec)))
-
-  (defun get-delta-time ()
-    "Return the difference between the last two cached timers."
-    (+ (* (- (car current-time) (car last-time)) 1000000)
-       (- (cdr current-time) (cdr last-time)))))
-
-(defstruct (clock (:constructor %make-clock))
-  (time 0)
-  (last-time 0)
-  (scale 1.0)
-  (paused nil))
-
-(defun make-clock (&optional (time 0) (scale 1.0) (paused nil))
-  "Create a new clock instance with specified parameters or using reasonable defaults."
-  (%make-clock :time time :last-time time :scale scale :paused paused))
-
-(defun update-clock (clock &optional delta-time)
-  "Update clock using `sec' and `usec' values passed as parameter."
-  (unless (clock-paused clock)
-    (setf (clock-last-time clock) (clock-time clock))
-    (incf (clock-time clock) (* (or delta-time (get-delta-time)) (clock-scale clock)))))
-
-(defun clock-delta (clock)
-  (- (clock-time clock) (clock-last-time clock)))
-
-(defun compare-clocks (clock1 clock2)
-  "Return the difference between `clock1' and `clock2'."
-  (- (clock-time clock1) (clock-time clock2)))
-
-(defun error-implementation-unsupported ()
-  "Return an error specifying the current lisp implementation is not supported."
-  (error "For now, only sbcl is supported."))
-
-(defun get-command-line-option (argv optname &optional default)
-  "Return the option designated by `optname' from the command-line `argv'."
-  (let ((opt (member optname argv :test #'equal)))
-    (or (and (cdr opt) (second opt)) default)))
-
-(defun get-command-line-option-number (argv optname &optional default)
-  "Return the option designated by `optname' from the command-line `argv' as a number."
-  (let ((opt (get-command-line-option argv optname)))
-    (if opt
-        (let ((value (with-input-from-string (in opt)
-                       (read in))))
-          (assert (numberp value))
-          value)
-        default)))

stoe-test.asd

@@ -1,21 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe-test-asd
-  (:use :cl :asdf))
-(in-package :stoe-test-asd)
-
-(defsystem stoe-test
-  :author "Renaud Casenave-Péré"
-  :license "GPL3"
-  :depends-on (:stoe
-               :prove)
-  :components ((:module "t"
-                :components
-                ((:file "stoe")
-                 (:file "maths")
-                 (:file "shader"))))
-  :perform (load-op :after (op c) (asdf:clear-system c)))

stoe.asd

@@ -1,6 +1,6 @@
 #|
   This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
 |#
 
 #|
@@ -14,61 +14,13 @@
   (:use :cl :asdf))
 (in-package :stoe-asd)
 
+;; (pushnew :stoe-foreign-assets *features*) ; classimp is out-of-date
+(pushnew :stoe-debug *features*)
+
 (defsystem stoe
-  :version "0.1"
+  :version (:read-file-form "VERSION")
   :author "Renaud Casenave-Péré"
   :license "GPL3"
-  :depends-on (:swank
-               :alexandria
-               :glop
-               :cl-opengl)
-  :components ((:module "src"
-                :components
-                ((:file "utils")
-                 (:module "maths"
-                          :components
-                          ((:file "maths")
-                           (:file "vector")
-                           (:file "float2")
-                           (:file "float3")
-                           (:file "float4")
-                           (:file "matrix")
-                           (:file "float22")
-                           (:file "float33")
-                           (:file "float44")
-                           (:file "quaternion")
-                           (:file "geometry")))
-                 (:file "thread"
-                        :depends-on ("utils"))
-                 (:file "containers")
-                 (:file "modules"
-                        :depends-on ("utils"))
-                 (:file "debug"
-                        :depends-on ("modules" "thread"))
-                 (:file "jobs"
-                        :depends-on ("thread" "containers" "utils"))
-                 (:file "file"
-                        :depends-on ("jobs"))
-                 (:file "scene")
-                 (:file "object")
-                 (:file "camera")
-                 (:file "input")
-                 (:file "game")
-                 (:module "render"
-                          :components
-                          ((:file "gl-utils")
-                           (:module "shader"
-                                    :components
-                                    ((:file "shader")
-                                     (:file "walker")
-                                     (:file "glsl")
-                                     (:file "compiler")))
-                           (:file "mesh")
-                           (:file "render")
-                           (:file "shaders"))
-                          :depends-on ("modules" "utils"))
-                 (:file "stoe"
-                        :depends-on ("utils" "modules")))))
   :description "SaintOEngine - A 3d engine in common-lisp"
   :long-description
   #.(with-open-file (stream (merge-pathnames
@@ -82,4 +34,32 @@
                                :fill-pointer t)))
           (setf (fill-pointer seq) (read-sequence seq stream))
           seq)))
-  :in-order-to ((test-op (load-op stoe-test))))
+  :defsystem-depends-on (:asdf-package-system)
+  :class :package-inferred-system
+  :around-compile (lambda (thunk)
+                    #+stoe-debug
+                    (proclaim '(optimize (debug 3) (safety 3) (speed 0)))
+                    (funcall thunk))
+  :depends-on ("alexandria"
+               "trivial-garbage"
+               "bordeaux-threads"
+               "blackbird"
+               #+stoe-foreign-assets
+               ;; "classimp"
+               "closer-mop"
+               "cl-vulkan"
+               "stoe/core/all"
+               "stoe/maths/all"
+               "stoe/engine/all")
+  :components ((:file "stoe"))
+  :in-order-to ((test-op (load-op stoe/test))))
+
+(defsystem stoe/test
+  :depends-on ("prove" "stoe" "stoe/test/all"))
+
+(register-system-packages "stoe/maths/all" '(:maths))
+(register-system-packages "stoe/core/all" '(:core))
+(register-system-packages "stoe/engine/all" '(:engine))
+(register-system-packages "stoe/test/all" '(:stoe/test))
+
+(register-system-packages "cl-vulkan" '(:vk))

stoe.lisp

@@ -0,0 +1,69 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe
+    (:use :cl :maths :core)
+  (:reexport :maths :core)
+  (:export #:main #:quit))
+(in-package :stoe)
+
+(defvar *argv* nil)
+(defvar *swank-server-port* 4006)
+
+(defconstant +loop-step-time+ 16000.0
+  "The length of one game loop frame.")
+
+(defvar *last-frame-remaining-time* 0.0
+  "The game loop advance +loop-step-time+ at a time but when the delta time doesn't correspond
+we need to keep the remaining time.")
+
+(defun initialize (&optional argv)
+  "Initialize all the modules passing the optional argv."
+  (initialize-modules argv))
+
+(defun finalize ()
+  "Finalize all the modules."
+  (finalize-modules))
+
+(defun update (delta-time)
+  "Update all the modules passing the delta time since the last frame."
+  (update-modules delta-time))
+
+(let (exit-main-loop)
+  (defun main-loop ()
+    "Run the protected main-loop. An error will be catched with the possibility to continue."
+    (setf exit-main-loop nil)
+    (let ((clock (make-clock)))
+      (loop until exit-main-loop
+         for remaining-time = 0 then delta-time
+         for delta-time = (clock-delta clock) then (+ (clock-delta clock) remaining-time)
+         do (progn
+              (loop while (> delta-time +loop-step-time+)
+                 do (restartable
+                      (update +loop-step-time+)
+                      (decf delta-time +loop-step-time+)))
+              (update-clock clock)))))
+
+  (defun quit ()
+    "Quit the main loop."
+    (setf exit-main-loop t)))
+
+(defun startup-stoe (argv)
+  (initialize argv)
+  (unwind-protect
+       (main-loop)
+    (finalize)))
+
+(defun main (&optional argv)
+  "Run the game."
+  (setf *argv* argv)
+  (if (string-equal (thread-name (current-thread)) "repl-thread")
+      (make-thread (lambda () (startup-stoe *argv*)) :name "Main Thread")
+      (progn
+        #+swank
+        (swank:create-server :port *swank-server-port* :dont-close nil)
+        (startup-stoe argv)
+        #+swank
+        (swank:stop-server *swank-server-port*))))

t/maths.lisp

@@ -1,68 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe-test.maths
-  (:use :cl
-        :stoe
-        :prove))
-(in-package :stoe-test.maths)
-
-(plan 23)
-
-(diag "Vector Constructor Tests")
-(is (v:vec 1 2 3) #(1.0 2.0 3.0) "Float Vector Constructor" :test #'equalp)
-(is (v:vec-int 1 2 3) #(1 2 3) "Integer Vector Constructor" :test #'equalp)
-(is (f2:vec 2 3) (v:vec 2 3) "Float2 Constructor" :test #'equalp)
-(is (f3:vec 2 3 4) (v:vec 2 3 4) "Float3 Constructor" :test #'equalp)
-(is (f4:vec 2 3 4 5) (v:vec 2 3 4 5) "Float4 Constructor" :test #'equalp)
-
-(defvar *vector2* (f2:vec 2 3))
-(defvar *vector3* (f3:vec 4 5 6))
-(defvar *vector4* (f4:vec 7 8 9 10))
-
-(diag "Swizzle Tests")
-(is (v:swizzle *vector4* xy) (f2:vec 7 8) "Swizzle f4:xy" :test #'equalp)
-(is (v:swizzle *vector2* xyz) (f3:vec 2 3 0) "Swizzle f2:xyz" :test #'equalp)
-(is (v:swizzle *vector3* xyz) *vector3* "Swizzle f3:xyz (identity)" :test #'equalp)
-(is (v:swizzle *vector4* wzyx) (f4:vec 10 9 8 7) "Swizzle f4:wzyx (reverse)" :test #'equalp)
-(is (v:swizzle *vector2* xyxy) (f4:vec 2 3 2 3)
-    "Swizzle f2:xyxy (multiple attributes)" :test #'equalp)
-
-(diag "Simple vector operations")
-(is (v:+ *vector2* (v:swizzle *vector4* xy)) #(9.0 11.0) "Add f2" :test #'equalp)
-(is (v:- *vector3* *vector3*) #(0.0 0.0 0.0) "Substract f3 to itself" :test #'equalp)
-(is (v:* *vector4* (v:swizzle *vector2* xyxy)) #(14.0 24.0 18.0 30.0) "Multiply f4" :test #'equalp)
-(is (v:/ *vector2* (v:swizzle *vector3* xz)) #(0.5 0.5) "Divide f2" :test #'equalp)
-
-(diag "Simple vector / scalar operations")
-(is (v:+ *vector2* 3) #(5.0 6.0) "Add f2" :test #'equalp)
-(is (v:- *vector3* 1) #(3.0 4.0 5.0) "Substract f3" :test #'equalp)
-(is (v:* *vector4* 2) #(14.0 16.0 18.0 20.0) "Multiply f4" :test #'equalp)
-(is (v:/ *vector2* 5) #(0.4 0.6)  "Divide f2" :test #'equalp)
-
-(diag "Matrix Constructor Tests")
-(is (m:mat 1 2 3 4 5 6 7 8 9 10 11 12) #2A((1.0 2.0 3.0 4.0) (5.0 6.0 7.0 8.0) (9.0 10.0 11.0 12.0))
-    "Matrix Constructor" :test #'equalp)
-
-(defvar *matrix22* (f22:mat 1 2
-                            3 4))
-(defvar *matrix33* (f33:mat 1 2 3
-                            4 5 6
-                            7 8 9))
-(defvar *matrix44* (f44:mat 1  2  3  4
-                            5  6  7  8
-                            9  10 11 12
-                            13 14 15 16))
-
-(is *matrix22* #2a((1.0 2.0) (3.0 4.0)) "Matrix22 Constructor" :test #'equalp)
-(is *matrix33* #2a((1.0 2.0 3.0) (4.0 5.0 6.0) (7.0 8.0 9.0)) "Matrix33 Constructor" :test #'equalp)
-(is *matrix44* #2a((1.0 2.0 3.0 4.0) (5.0 6.0 7.0 8.0) (9.0 10.0 11.0 12.0) (13.0 14.0 15.0 16.0))
-    "Matrix44 Constructor" :test #'equalp)
-
-(diag "Simple Matrix Operations")
-(is (m:+ *matrix22* (f22:mat-ident)) #2a((2.0 2.0) (3.0 5.0)) "Add f22" :test #'equalp)
-
-(finalize)

test/all.lisp

@@ -0,0 +1,12 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/test/all
+    (:nicknames :test)
+  (:use-reexport
+   :stoe/test/maths
+   :stoe/test/jobs
+   :stoe/test/resources
+   :stoe/test/entity))

test/entity.lisp

@@ -0,0 +1,106 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/test/entity
+  (:use :cl :prove
+        :stoe/core/utils
+        :stoe/core/graph
+        :stoe/core/entity))
+(in-package :stoe/test/entity)
+
+(defparameter *old-entity-array* stoe/core/entity::*entity-array*)
+(defparameter *old-components-table-table* stoe/core/entity::*components-table-table*)
+(defparameter *old-system-dependency-graph* stoe/core/entity::*system-dependency-graph*)
+(setf stoe/core/entity::*entity-array* (make-array 10 :adjustable t :fill-pointer 0))
+(setf stoe/core/entity::*components-table-table* (make-hash-table))
+(setf stoe/core/entity::*system-dependency-graph* (make-graph-node))
+
+(stoe/core/entity::ensure-components-table 'component)
+
+(plan 21)
+(diag "Define components")
+
+(defcomponent comp-base1 ()
+  ())
+
+(ok (stoe/core/entity::components-table 'comp-base1)
+    "define component 1")
+
+(defcomponent comp-base2 (component)
+  ())
+
+(ok (stoe/core/entity::components-table 'comp-base2)
+    "define component 2")
+
+(defcomponent comp-derived (comp-base1)
+  ())
+
+(ok (stoe/core/entity::components-table 'comp-derived)
+    "define subcomponent")
+
+(diag "Entity Creation")
+(defparameter ent1 (create-entity "ent1"))
+
+(is (object-id ent1) 0 "Object ID 0")
+
+(defparameter ent2 (create-entity "ent2"
+                     comp-base1))
+
+(is (object-id ent2) 1 "Object ID 1")
+(is (length (all-components ent2)) 1 "all-components 2")
+(is (length (components ent2 'comp-base1)) 1 "get-component comp-base1")
+
+(defparameter ent3 (create-entity "ent3"
+                     comp-derived))
+
+(is (object-id ent3) 2 "Object ID 2")
+(is (length (all-components ent3)) 1 "all-components 3")
+(is (length (components ent3 'comp-derived)) 1 "get-component comp-derived")
+(is (length (components ent3 'comp-base1)) 1 "get-components comp-base1")
+
+(defparameter ent4 (create-entity "ent4"
+                     comp-base1
+                     comp-base2
+                     comp-derived))
+
+(is (object-id ent4) 3 "Object ID 3")
+(is (length (all-components ent4)) 3 "all-components 4")
+(is (length (components ent4 'comp-base1)) 2 "get-components comp-base1")
+(is (length (components ent4 'comp-base2)) 1 "get-components comp-base2")
+(is (length (components ent4 'comp-derived)) 1 "get-component comp-derived")
+
+(diag "Entity Systems")
+(defesystem system1 (entity (comp comp-base1))
+  (declare (ignore entity comp)))
+
+(is (first (prior-nodes system1)) stoe/core/entity::*system-dependency-graph*
+    "defesystem 1")
+
+(defesystem system2 (entity (comp comp-base1))
+  (declare (ignore entity comp)))
+
+(is (length (stoe/core/entity::system-precedence-list system2)) 1
+    "defesystem 2")
+
+(defesystem system3 :after system2 (entity (comp comp-base2))
+  (declare (ignore entity comp)))
+
+(is (length (prior-nodes system3)) 1
+    "defesystem 3")
+
+(defesystem system4 :before system3 :after system2 (entity (comp comp-base2))
+  (declare (ignore entity comp)))
+
+(is (length (stoe/core/entity::system-precedence-list system4)) 2
+    "defesystem 4")
+
+(is (length (stoe/core/entity::system-precedence-list system3)) 3
+    "system3 precedence-list")
+
+(finalize)
+
+(setf stoe/core/entity::*entity-array* *old-entity-array*)
+(setf stoe/core/entity::*components-table-table* *old-components-table-table*)
+(setf stoe/core/entity::*system-dependency-graph* *old-system-dependency-graph*)

test/jobs.lisp

@@ -0,0 +1,57 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/test/jobs
+    (:use :cl :prove
+          :stoe/core/containers
+          :stoe/core/thread
+          :stoe/core/jobs))
+(in-package :stoe/test/jobs)
+
+(stoe/core/jobs::initialize)
+
+(defmacro with-new-job-thread (count &body body)
+  `(progn
+     (dotimes (i ,count)
+       (push-new-job-thread (format nil "Test thread ~d" i)))
+     ,@body
+     (mapc (lambda (thread) (terminate-thread thread))
+           stoe/core/jobs::*thread-list*)
+     (sleep 0.5)
+     (stoe/core/jobs::update 0)))
+
+(defun counter (x)
+  (dotimes (i 10 x)
+    (format t "~a~%" x)
+    (incf x)))
+
+(plan 3)
+
+(with-new-job-thread 1
+  (async-job () (counter 0))
+  (sleep 1)
+  (async-job () (counter 0))
+  (sleep 1)
+  (async-job () (counter 0))
+  (sleep 1))
+(is (size stoe/core/jobs::*job-queue*) 0 "1 thread, 3 jobs, 1 at a time.")
+
+(async-job () (counter 0))
+(async-job () (counter 0))
+(async-job () (counter 0))
+(with-new-job-thread 1
+  (sleep 1))
+(is (size stoe/core/jobs::*job-queue*) 0 "1 thread, 3 jobs, all at once.")
+
+(with-new-job-thread 3
+  (async-job () (counter 0))
+  (async-job () (counter 0))
+  (async-job () (counter 0))
+  (sleep 1))
+(is (size stoe/core/jobs::*job-queue*) 0 "3 threads, 3 jobs, all at once.")
+
+(finalize)
+
+(stoe/core/jobs::finalize)

test/maths.lisp

@@ -0,0 +1,64 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2017 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/test/maths
+    (:use :cl :prove :maths))
+(in-package :stoe/test/maths)
+
+(plan 20)
+
+(diag "Vector Constructor Tests")
+(is (raw-data (vec 1 2 3)) #(1 2 3) "Integer Vector Constructor" :test #'equalp)
+(is (raw-data (vec 1.0 2.0 3.0)) #(1.0 2.0 3.0) "Float Vector Constructor" :test #'equalp)
+(is (raw-data (vec 2.0 3.0)) #(2.0 3.0) "Float2 Constructor" :test #'equalp)
+(is (raw-data (vec 2.0 3.0 4.0)) #(2.0 3.0 4.0) "Float3 Constructor" :test #'equalp)
+(is (raw-data (vec 2.0 3.0 4.0 5.0)) #(2.0 3.0 4.0 5.0) "Float4 Constructor" :test #'equalp)
+
+(defvar *vector2* (vec 2 3))
+(defvar *vector3* (vec 4 5 6))
+(defvar *vector4* (vec 7 8 9 10))
+(defvar *vector2f* (vec 2.0 3.0))
+
+(diag "Swizzle Tests")
+(is (raw-data (xy *vector4*)) (raw-data (vec 7 8)) "Swizzle int4:xy" :test #'equalp)
+(is (raw-data (xyz *vector2*)) (raw-data (vec 2 3 0)) "Swizzle int2:xyz" :test #'equalp)
+(is (raw-data (xyz *vector3*)) (raw-data *vector3*) "Swizzle int3:xyz (identity)" :test #'equalp)
+(is (raw-data (wzyx *vector4*)) (raw-data (vec 10 9 8 7)) "Swizzle int4:wzyx (reverse)" :test #'equalp)
+
+(diag "Simple vector operations")
+(is (raw-data (v+ *vector2* (xy *vector4*))) #(9 11) "Add f2" :test #'equalp)
+(is (raw-data (v- *vector3* *vector3*)) #(0 0 0) "Substract f3 to itself" :test #'equalp)
+
+(diag "Simple vector / scalar operations")
+(is (raw-data (v+ *vector2* 3)) #(5 6) "Add f2" :test #'equalp)
+(is (raw-data (v- *vector3* 1)) #(3 4 5) "Substract f3" :test #'equalp)
+(is (raw-data (v* *vector4* 2)) #(14 16 18 20) "Multiply f4" :test #'equalp)
+(is (raw-data (v/ *vector2f* 5)) #(0.4 0.6)  "Divide f2" :test #'equalp)
+
+(diag "Matrix Constructor Tests")
+(is (raw-data (mat 1 2 3 4 5 6 7 8 9 10 11 12)) #(1 2 3 4 5 6 7 8 9 10 11 12)
+    "Matrix Constructor" :test #'equalp)
+
+(defvar *matrix22* (mat 1 2
+                        3 4))
+(defvar *matrix33* (mat 1 2 3
+                        4 5 6
+                        7 8 9))
+(defvar *matrix44* (mat 1  2  3  4
+                        5  6  7  8
+                        9  10 11 12
+                        13 14 15 16))
+(defvar *matrix22f* (mat 1.0 2.0
+                         3.0 4.0))
+
+(is (raw-data *matrix22*) #(1 2 3 4) "Matrix22 Constructor" :test #'equalp)
+(is (raw-data *matrix33*) #(1 2 3 4 5 6 7 8 9) "Matrix33 Constructor" :test #'equalp)
+(is (raw-data *matrix44*) #(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)
+    "Matrix44 Constructor" :test #'equalp)
+
+(diag "Simple Matrix Operations")
+(is (raw-data (m+ *matrix22* (mat-id 2 'fixnum))) #(2 2 3 5) "Add f22" :test #'equalp)
+
+(finalize)

test/resources.lisp

@@ -0,0 +1,84 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/test/resources
+    (:use :cl :prove
+          :stoe/core/utils
+          :stoe/core/resources))
+(in-package :stoe/test/resources)
+
+(setq *random-state* (make-random-state))
+(defvar *data-dir* #P".data/")
+(defparameter *res-array* (make-array '(10)))
+
+(defun get-resource-path (index &optional (ext "bin"))
+  (merge-pathnames (make-pathname :name (format nil "~2,'0d" index) :type ext) *data-dir*))
+
+(defun generate-files ()
+  (ensure-directories-exist *data-dir*)
+
+  ;; Make a bunch of files full of random binary+lisp data
+  (loop-with-progress "Generating files" for i below 10
+    do (unless (and (probe-file (get-resource-path i))
+                    (probe-file (get-resource-path i "lisp")))
+           (let ((data (loop for j below (* 1024 1024 (+ 0.5 (random 1.0)))
+                          collect (random 255))))
+          (with-open-file (stream (get-resource-path i) :direction :output
+                                                        :element-type '(unsigned-byte 8)
+                                                        :if-exists :supersede)
+            (write-sequence data stream))
+          (with-open-file (stream (get-resource-path i "lisp") :direction :output
+                                                               :if-exists :supersede)
+            (write data :stream stream))
+          progress-step))))
+
+(generate-files)
+
+(stoe/core/resources::initialize)
+
+(plan 47)
+
+(diag "Sync load of binary files")
+(dotimes (i 10 t)
+  (with-resource ((get-resource-path i) proxy)
+    (is (res-loaded-p proxy) t (format nil "file ~2,'0d.bin loaded in memory" i))
+    (setf (aref *res-array* i) proxy)))
+
+(dotimes (i 5 t)
+  (unload-resource (aref *res-array* i))
+  (is (res-loaded-p (aref *res-array* i)) nil (format nil "file ~2,'0d.bin unloaded" i)))
+
+(setf *res-array* (make-array '(10)))
+(tg:gc :full t)
+(is (hash-table-count stoe/core/resources::*resources-db*) 0 "All resources unloaded")
+
+(dotimes (i 10)
+  (with-resource ((get-resource-path i) proxy)
+    (setf (aref *res-array* i) proxy)
+    (with-open-file (stream (get-resource-path (+ 10 i))
+                            :direction :output
+                            :element-type '(unsigned-byte 8) :if-exists :supersede)
+      (write-sequence (raw-data (aref *res-array* i)) stream))
+    (is (sb-ext:process-exit-code
+         (sb-ext:run-program "diff" (list (pathname-path (get-resource-path i))
+                                          (pathname-path (get-resource-path (+ 10 i))))
+                             :search t)) 0 (format nil "file ~2,'0d.bin integrity" i))))
+
+(diag "Shared load of binary files")
+(dotimes (i 10)
+  (with-resource ((get-resource-path i) proxy)
+    (is (refcount (tg:weak-pointer-value (slot-value proxy 'resource))) 2 (format nil "file ~2,'0d.bin has 2 refs" i))
+    (unload-resource proxy)
+    (is (refcount (tg:weak-pointer-value (slot-value (aref *res-array* i) 'resource))) 1 (format nil "file ~2,'0d.bin has 1 ref" i))
+    (unload-resource (aref *res-array* i))))
+(is (hash-table-count stoe/core/resources::*resources-db*) 0 "All resources unloaded")
+
+(stoe/core/resources::finalize)
+(setf *res-array* nil)
+(tg:gc :full t)
+
+(finalize)
+
+(uiop:delete-directory-tree *data-dir* :validate t)