floss/stoe
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Refactor packages layout using inferred-packages-system

Browse source
This commit is contained in:
Renaud Casenave-Péré 2015-05-27 13:39:44 +02:00
parent dbc009d466
commit fc69969099
46 changed files with 1061 additions and 676 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
VERSION Normal file
View file

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

16
core/all.lisp Normal file
View file

@ -0,0 +1,16 @@
#|
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/thread
:stoe/core/containers
:stoe/core/modules
:stoe/core/debug
:stoe/core/jobs
:stoe/core/file
:stoe/core/input))

20
src/containers.lisp → core/containers.lisp
View file

@ -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/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/core/containers)
(defclass container ()
((data :initform nil))
@ -71,7 +67,7 @@
(first data)))
(defclass safe-container-mixin ()
((mutex :initform (thread:make-mutex))
((mutex :initform (make-mutex))
(waitp :initarg :waitp :accessor safe-container-wait-p))
(:documentation "A mixin for thread-safe containers."))

19
src/debug.lisp → core/debug.lisp
View file

@ -3,14 +3,11 @@
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)
(uiop:define-package :stoe/core/debug
(:use :cl :stoe/core/utils :stoe/core/thread)
(:import-from :stoe/core/modules
#:defmodule))
(in-package :stoe/core/debug)
(defvar *swank-server-port* 4006)
(defvar *frames-per-second* 0.0)
@ -21,14 +18,14 @@ 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"))
(when (not (string= (thread-name (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"))
(when (not (string= (thread-name (current-thread)) "repl-thread"))
#+swank
(swank:stop-server *swank-server-port*)))
@ -48,4 +45,4 @@ start the swank server to accept remote connection."
(setf time-counter 0.0)
(setf frames-counter 0))))
(defmodule debug)
(defmodule stoe/core/debug)

12
src/file.lisp → core/file.lisp
View file

@ -3,12 +3,10 @@
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)
(uiop:define-package :stoe/core/file
(:use :cl :stoe/core/jobs)
(:export #:load-file))
(in-package :stoe/core/file)
(defun do-load-file (filepath type)
"Load the file specified by `filepath' and store it in the object returned."
@ -22,4 +20,4 @@
"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))))
(push-job #'do-load-file (list filepath type))))

29
src/input.lisp → core/input.lisp
View file

@ -3,17 +3,14 @@
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/core/input
(:use :cl :alexandria
:stoe/core/utils :stoe/core/containers)
(: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/core/input)
(define-constant +keyevent-classes+ '(:press :release :repeat :continuous)
:test #'equal :documentation "List of the available key event classes.")
@ -46,17 +43,17 @@
"List containing the currently active (pressed) keys.
Only those will trigger the release event.")
(defun initialize (&optional argv)
(defun initialize-input (&optional argv)
"Initialize the input module."
(declare (ignore argv))
(format t "Initialize Input module~%"))
(defun finalize ()
(defun finalize-input ()
"Finalize the input module."
(format t "Finalize Input module~%")
(set-global-keymap nil))
(defun update (delta-time)
(defun update-input (delta-time)
"Update the input module.
trigger key events that occured this frame."
(loop for event = (dequeue *event-queue*)
@ -187,8 +184,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/core/input)))
(slot-value event (intern (symbol-name arg) :stoe/core/input))
arg))
args))
(funcall fun))))))

30
src/jobs.lisp → core/jobs.lisp
View file

@ -3,21 +3,19 @@
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)
(uiop:define-package :stoe/core/jobs
(:use :cl
:stoe/core/utils
:stoe/core/thread
:stoe/core/containers)
(:export #:job
#:job-result
#:push-job
#:wait-for-job
#:cancel-job)
(:import-from :stoe/core/modules
#:defmodule))
(in-package :stoe/core/jobs)
(defstruct job
(handle -1 :read-only t)
@ -84,7 +82,7 @@ If a thread is available, assign a new job to it."
(if (not (thread-alive-p (thread-thread thread)))
(finalize-thread thread))))))
(defmodule jobs)
(defmodule stoe/core/jobs)
(defun push-job (fun args)
"Create a new job using `fun' and `data' and push it into the job-list."

20
src/modules.lisp → core/modules.lisp
View file

@ -3,16 +3,10 @@
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)
(uiop:define-package :stoe/core/modules
(:use :cl)
(:export #:initialize-modules #:finalize-modules #:update-modules #:defmodule))
(in-package :stoe/core/modules)
(defparameter *initialize-hook* nil
"Hook run on initialization.
@ -27,21 +21,21 @@ the program argv.")
Functions attached to this hook should expect an argument containing the time
since last frame.")
(defmacro initialize (&optional argv)
(defmacro initialize-modules (&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 ()
(defmacro finalize-modules ()
"Perform the engine and subsystems finalization process."
`(progn
(format t "Finalize...~%")
,@(loop for fun in *finalize-hook*
collect (list fun))))
(defmacro update (delta-time)
(defmacro update-modules (delta-time)
"Update the modules each loop."
`(progn
,@(loop for fun in *update-hook*

20
src/thread.lisp → core/thread.lisp
View file

@ -3,17 +3,15 @@
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)
(uiop:define-package :stoe/core/thread
(:use :cl :stoe/core/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/core/thread)
(defun make-thread (fun &key name args)
"Create a new thread named `name' that runs `fun', with `args' passed as

33
src/utils.lisp → core/utils.lisp
View file

@ -3,25 +3,20 @@
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)))
(uiop:define-package :stoe/core/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/core/utils)
(defmacro aif (test then else)
"Bind the result of evaluating `test' to a variable named `it', as per Paul Graham's On Lisp."

16
engine/all.lisp Normal file
View file

@ -0,0 +1,16 @@
#|
This file is a part of stoe project.
Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
|#
(uiop:define-package :stoe/engine/all
(:nicknames :engine)
(:use-reexport
:stoe/engine/gl-utils
:stoe/engine/scene
:stoe/engine/object
:stoe/engine/mesh
:stoe/engine/camera
:stoe/engine/render
:stoe/engine/shaders
:stoe/engine/shader/all))

32
src/camera.lisp → engine/camera.lisp
View file

@ -1,40 +1,38 @@
#|
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.camera
(:nicknames :camera)
(:use :cl)
(:export :camera :view :proj
:make-camera
:update-view)
(:import-from :object
:object :pos :dir))
(in-package :stoe.camera)
(uiop:define-package :stoe/engine/camera
(:use :cl :maths)
(:export #:camera #:view #:proj
#:make-camera
#:update-view)
(:import-from :stoe/engine/object
#:object #:pos #:dir))
(in-package :stoe/engine/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))
(projection :initarg :projection :accessor proj :type 'float44)
(view :accessor view :type '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)
(let ((camera (make-instance 'camera :position (vec 0.0 0.0 2.0)
:direction (quat (vec 0.0 0.0 1.0) 0.0)
:fovy fovy
:aspect aspect
:near near
:far far
:projection (geom:make-persp-matrix fovy aspect near far))))
:projection (mperspective 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))))))
(setf view (m* (transpose (quat-to-mat4 dir)) (mtranslate (v- pos))))))

48
src/render/gl-utils.lisp → engine/gl-utils.lisp
View file

@ -1,52 +1,50 @@
#|
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.gl-utils
(uiop:define-package :stoe/engine/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)
(:export #:*gl-major-version*
#:*gl-minor-version*
#:*glsl-version*
#:gl-initialized-p
#:gl-initialize
#:gl-finalize
#:version-supported-p
#:gl-assert
#:gl-restart
#:size-of))
(in-package :stoe/engine/gl-utils)
(defvar *major-version* nil)
(defvar *minor-version* nil)
(defvar *gl-major-version* nil)
(defvar *gl-minor-version* nil)
(defvar *glsl-version* nil)
(let ((initializedp))
(defun gl-initialized-p ()
initializedp)
(defun initialize (version)
(defun gl-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 *gl-major-version* maj
*gl-minor-version* min))
(setf *gl-major-version* (gl:get-integer :major-version)
*gl-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 ()
(defun gl-finalize ()
(setf initializedp nil)))
(defun version-supported-p (version)
(multiple-value-bind (maj min) (floor version 10)
(and (<= maj *major-version*)
(<= min *minor-version*))))
(and (<= maj *gl-major-version*)
(<= min *gl-minor-version*))))
(defmacro gl-assert (&body body)
`(progn

31
src/render/mesh.lisp → engine/mesh.lisp
View file

@ -1,14 +1,27 @@
#|
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.mesh
(:nicknames :mesh)
(:use :cl :utils)
(:export :make-mesh))
(in-package :stoe.render.mesh)
(uiop:define-package :stoe/engine/mesh
(:use :cl :stoe/core/utils)
(:export #:mesh
#:make-mesh
#:mesh-streams
#:mesh-stream-program
#:mesh-stream-vertex-buffer
#:mesh-stream-index-buffer
#:vertex-buffer-attribs
#:vertex-buffer-buffer-object
#:index-buffer-buffer-object
#:index-buffer-mode
#:index-buffer-size
#:index-buffer-type
#:attrib-symb
#:attrib-size
#:attrib-type
#:attrib-offset))
(in-package :stoe/engine/mesh)
(defstruct attrib
(symb nil)
@ -95,7 +108,7 @@
(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)
(mapc (lambda (pair) (apply (intern (concatenate 'string "%SET-MESH-STREAM-" (symbol-name (first pair))) :stoe/engine/mesh)
stream (list (second pair))))
alist)
stream))
@ -109,7 +122,7 @@
(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)
(mapc (lambda (pair) (apply (intern (concatenate 'string "%SET-MESH-" (symbol-name (first pair))) :stoe/engine/mesh)
mesh (list (second pair))))
alist)
mesh))

31
engine/object.lisp Normal file
View file

@ -0,0 +1,31 @@
#|
This file is a part of stoe project.
Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
|#
(uiop:define-package :stoe/engine/object
(:use :cl :maths)
(:export #:object #:pos #:dir #:trans-mat #:components
#:make-object #:update-trans-matrix)
(:import-from :stoe/engine/scene
#:scene-node #:parent))
(in-package :stoe/engine/object)
(defclass object (scene-node)
((position :initarg :position :accessor pos :type 'float3)
(direction :initarg :direction :accessor dir :type 'quaternion)
(trans-matrix :initform (mat-id 4 'single-float) :accessor trans-mat :type 'float44)
(components :initform nil :reader components))
(:documentation "Base class for all objects existing in the game world."))
(defun make-object (&key (pos (vec 0.0 0.0 0.0)) (dir (quat (vec 0.0 0.0 1.0) 0.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))
(mtranslate (pos node))
(quat-to-mat4 (dir node)))))

100
src/render/render.lisp → engine/render.lisp
View file

@ -1,24 +1,28 @@
#|
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
(: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)
(uiop:define-package :stoe/engine/render
(:use :cl
:maths
:shader
:stoe/core/utils
:stoe/core/input
:stoe/engine/gl-utils
:stoe/engine/mesh)
(:export #:poll-events)
(:import-from :stoe/core/modules
#:defmodule)
(:import-from :stoe/game/game
#:get-world-origin #:get-current-camera)
(:import-from :stoe/engine/scene
#:children)
(:import-from :stoe/engine/object
#:trans-mat #:components #:update-trans-matrix)
(:import-from :stoe/engine/camera
#:proj #:view))
(in-package :stoe/engine/render)
(defvar *window* nil)
@ -41,13 +45,13 @@ Create an opengl context attached to a window and initialize the shader system."
(version (get-command-line-option-number argv "--opengl")))
(if version
(progn
(gl-utils:initialize version)
(gl-initialize version)
(setf *window* (glop:create-window title width height
:major gl-utils:*major-version*
:minor gl-utils:*minor-version*)))
:major *gl-major-version*
:minor *gl-minor-version*)))
(progn
(setf *window* (glop:create-window title width height))
(gl-utils:initialize 0)))
(gl-initialize 0)))
(compile-all-shaders))
(initialize-renderer))
@ -58,7 +62,7 @@ Destroy the opengl context and the related resources."
(destroy-all-shaders)
(glop:destroy-window *window*)
(setf *window* nil)
(gl-utils:finalize))
(gl-finalize))
(defun update (delta-time)
"Update the render module.
@ -67,10 +71,10 @@ Render a frame and swap buffers."
(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))
(render-scene (get-world-origin))
(glop:swap-buffers *window*))
(defmodule render)
(defmodule stoe/engine/render)
(defun poll-events ()
"Poll events from the window manager.
@ -81,46 +85,46 @@ This needs to be called once per frame, at the beginning of the loop."
(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:key-press-event (on-key-event t (glop:keycode event) (glop:keysym event) (glop:text event)))
(glop:key-release-event (on-key-event nil (glop:keycode event) (glop:keysym event) (glop:text event)))
(glop:button-press-event (on-button-event t (glop:button event)))
(glop:button-release-event (on-button-event nil (glop:button event)))
(glop:mouse-motion-event (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 (proj (get-current-camera)) (mperspective 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))
(loop for stream in (mesh-streams mesh)
do (using-program (program (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))
(gl:uniform-matrix model-to-camera 4 (vector (slot-value (m* (view (get-current-camera))
(trans-mat node)) 'array)))
(gl:uniform-matrix camera-to-clip 4 (vector (slot-value (proj (get-current-camera)) 'array))))
(let* ((vertex-buffer (mesh-stream-vertex-buffer stream))
(index-buffer (mesh-stream-index-buffer stream))
(attribs (vertex-buffer-attribs vertex-buffer)))
(gl:bind-buffer :array-buffer (vertex-buffer-buffer-object vertex-buffer))
(loop for attrib in attribs
do (let* ((attrib-name (mesh::attrib-symb attrib))
do (let* ((attrib-name (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:vertex-attrib-pointer attrib-loc (attrib-size attrib)
(attrib-type attrib) :false 0
(attrib-offset attrib))))))
(gl:bind-buffer :element-array-buffer (index-buffer-buffer-object index-buffer))
(gl-assert (%gl:draw-elements (index-buffer-mode index-buffer)
(index-buffer-size index-buffer)
(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)))))
@ -128,7 +132,7 @@ This needs to be called once per frame, at the beginning of the loop."
(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))))
(let ((mesh (car (member-if (lambda (c) (typep c 'mesh)) components))))
(when mesh
(render-mesh node mesh)))))

17
src/scene.lisp → engine/scene.lisp
View file

@ -1,16 +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.scene
(:use :cl)
(:nicknames :scene)
(:export :scene-node :parent :children
:attach :detach
:walk))
(in-package :stoe.scene)
(uiop:define-package :stoe/engine/scene
(:export #:scene-node #:parent #:children
#:attach #:detach
#:walk-graph))
(in-package :stoe/engine/scene)
(defclass scene-node ()
((parent :initform nil :reader parent)
@ -36,7 +33,7 @@ children from being rendered."))
(setf children (remove scene-node children))
(setf parent nil))))
(defun walk (fun node)
(defun walk-scene (fun node)
"Walk through the scene graph and apply `fun' at each node."
(with-slots (children) node
(loop for child in children

12
engine/shader/all.lisp Normal file
View file

@ -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/engine/shader/all
(:nicknames :shader)
(:use-reexport
:stoe/engine/shader/shader
:stoe/engine/shader/walker
:stoe/engine/shader/glsl
:stoe/engine/shader/compiler))

20
src/render/shader/compiler.lisp → engine/shader/compiler.lisp
View file

@ -3,15 +3,17 @@
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/engine/shader/compiler
(:use :cl
:stoe/core/utils
:stoe/engine/gl-utils
:stoe/engine/shader/shader
:stoe/engine/shader/glsl)
(:export #:defshader
#:defprogram
#:compile-all-shaders
#:destroy-all-shaders))
(in-package :stoe/engine/shader/compiler)
(defvar *shaders-table* (make-hash-table))
(defvar *programs-table* (make-hash-table))

10
src/render/shader/glsl.lisp → engine/shader/glsl.lisp
View file

@ -3,12 +3,10 @@
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/engine/shader/glsl
(:use :cl :stoe/core/utils :stoe/engine/shader/walker :stoe/engine/shader/shader)
(:export #:glsl-compile #:glsl-print))
(in-package :stoe/engine/shader/glsl)
(defvar *form-handlers* (make-hash-table)
"Hash table for the form handlers for a glsl dsl.")

48
src/render/shader/shader.lisp → engine/shader/shader.lisp
View file

@ -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/engine/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/engine/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))))

16
src/render/shader/walker.lisp → engine/shader/walker.lisp
View file

@ -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/engine/shader/walker
(:use :cl :stoe/core/utils)
(:export #:walk-1
#:walk-list
#:walk
#:defhandler))
(in-package :stoe/engine/shader/walker)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *form-handlers* (make-hash-table)

9
src/render/shaders.lisp → engine/shaders.lisp
View file

@ -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/engine/shader/compiler))
(in-package :stoe/engine/shaders)
(defshader simple-vertex ((position :vec4 :in)
(color :vec4 :in)

10
game/all.lisp Normal file
View file

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

37
src/game.lisp → game/game.lisp
View file

@ -1,19 +1,20 @@
#|
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.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)
(uiop:define-package :stoe/game/game
(:use :cl :stoe/engine/object :stoe/engine/scene)
(:export #:get-world-origin
#:get-current-camera)
(:import-from :stoe/core/modules
#:defmodule)
(:import-from :stoe/engine/camera
#:make-camera #:update-view)
(:import-from :stoe/core/input
#:initialize-input #:finalize-input
#:update-input))
(in-package :stoe/game/game)
(defconstant +loop-step-time+ 16000.0
"The length of one game loop frame.")
@ -32,16 +33,16 @@ we need to keep the remaining time.")
"Initialize the game module."
(declare (ignore argv))
(format t "Initialize Game module~%")
(input:initialize)
(setf *world-origin* (object:make-object))
(initialize-input)
(setf *world-origin* (make-object))
(setf *current-camera* (make-camera 90 (/ 16 9) 1.0 1000.0))
(scene:attach *current-camera* *world-origin*))
(attach *current-camera* *world-origin*))
(defun finalize ()
"Finalize the game module."
(setf *current-camera* nil)
(setf *world-origin* nil)
(input:finalize))
(finalize-input))
(defun update (delta-time)
"Update the game module.
@ -51,11 +52,11 @@ Advance the world by `delta-time', +loop-step-time+ at a time."
do (progn
(when *current-camera*
(update-view *current-camera*))
(input:update +loop-step-time+)
(update-input +loop-step-time+)
(decf delta-time +loop-step-time+)))
(setf *last-frame-remaining-time* delta-time))
(defmodule game)
(defmodule stoe/game/game)
(defun get-world-origin () *world-origin*)
(defun get-current-camera () *current-camera*)

48
src/stoe.lisp → game/stoe.lisp
View file

@ -1,23 +1,23 @@
#|
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
(: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)
(uiop:define-package :stoe/game/stoe
(:use :cl :maths
:stoe/core/utils :stoe/core/file :stoe/core/modules
:stoe/engine/render :stoe/engine/mesh)
(:import-from :stoe/engine/scene
#:attach)
(:import-from :stoe/engine/object
#:make-object #:dir)
(:import-from :stoe/game/game
#:get-current-camera
#:get-world-origin)
(:import-from :stoe/core/input
#:global-set-key
#:global-set-motion))
(in-package :stoe/game/stoe)
(let ((exit-main-loop nil))
(defun main-loop (&optional unprotected)
@ -30,7 +30,7 @@ continue unless `unprotected' is t."
do (restartable unprotected
(update-current-time)
(update-clock clock (get-delta-time))
(render:poll-events)
(poll-events)
(update (clock-delta clock))))))
(defun quit ()
@ -50,9 +50,9 @@ continue unless `unprotected' is t."
(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)))
(setf (dir (get-current-camera)) (q* (quat (vec 0.0 1.0 0.0) (deg-to-rad (- dx)))
start-orient
(q:from-axis-and-angle (v:vec 1 0 0) (maths:deg-to-rad dy)))))
(quat (vec 1.0 0.0 0.0) (deg-to-rad dy)))))
(setf start-coords (cons x y))))
(global-set-key 3 #'set-freelook t)
@ -60,21 +60,21 @@ continue unless `unprotected' is t."
(global-set-motion #'freelook-move :x :y))
(defun game-start ()
(let ((f (file:load-file #P"../data/cube.lisp" :sync t :type 'character)))
(let ((f (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))))
(make-mesh (read s)))) (get-world-origin))))
(defun initialize (&optional argv)
"Initialize all the modules passing the optional argv"
(modules:initialize argv))
(initialize-modules argv))
(defun finalize ()
"Finalize all the modules"
(modules:finalize))
(finalize-modules))
(defun update (delta-time)
"Update all the modules passing the delta time since the last frame"
(modules:update delta-time))
(update-modules delta-time))
(defun main (&optional argv)
"Run the program."

14
maths/all.lisp Normal file
View file

@ -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))

21
src/maths/geometry.lisp → maths/geometry.lisp
View file

@ -3,13 +3,16 @@
Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
|#
(in-package :cl-user)
(defpackage stoe.maths.geometry
(:nicknames :geometry :geom)
(:use :cl :types :vector :matrix :quaternion)
(:export :mat-trans :mat-scale :mat-rot
:make-persp-matrix :make-ortho-matrix))
(in-package :stoe.maths.geometry)
(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)))
@ -35,7 +38,7 @@
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
((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))
@ -61,7 +64,7 @@
mat)))))
(defun mperspective (fovy aspect near far)
(let ((range (tan (/ deg-to-rad fovy) 2.0)))
(let ((range (tan (/ (deg-to-rad fovy) 2.0))))
(let ((left (* (- range) aspect))
(right (* range aspect))
(bottom (- range))

133
src/maths/matrix.lisp → maths/matrix.lisp
View file

@ -3,19 +3,17 @@
Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
|#
(in-package :cl-user)
(defpackage stoe.maths.matrix
(:nicknames :matrix :m)
(:use :cl :alexandria :types :vector)
(:import-from :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)
(uiop:define-package :stoe/maths/matrix
(:use :cl :alexandria :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 dimension ((m matrix)) (slot-value m 'dimensions))
@ -69,7 +67,7 @@
(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)
:dimensions dims
:dimensions (list dim-x dim-y)
:array (make-array (* dim-x dim-y) :element-type type))))
(defun mat-id (dim type)
@ -80,8 +78,10 @@
(defun clone-matrix (dims type mat)
(let ((m (mat-null dims type)))
(loop for i below (reduce #'* (dimension mat))
do (setf (mref m i) (mref mat i)))))
(loop for i below (first (dimension mat))
do (loop for j below (second (dimension 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))
@ -92,50 +92,75 @@
m))
(defmacro mat (&rest attribs)
(if (= (length attribs) 1)
(once-only ((attrib (first attribs)))
`(clone-matrix (dimension ,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 `(dimension ,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) ',type ,@attribs)))))
(once-only ((attrib (first attribs)))
(if (= (length attribs) 1)
`(clone-matrix (dimension ,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 `(dimension ,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))
,@attribs))))))
(defmacro mat2 (&rest attribs)
(let (type)
(loop for attr in attribs
do (unless type
(setf type (cond
((floatp attr) 'single-float)
((integerp attr) 'fixnum)))))
`(make-matrix '(2 2) ',type ,@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))
,@attribs)))))
(defmacro mat3 (&rest attribs)
(let (type)
(loop for attr in attribs
do (unless type
(setf type (cond
((floatp attr) 'single-float)
((integerp attr) 'fixnum)))))
`(make-matrix '(3 3) ',type ,@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))
,@attribs)))))
(defmacro mat4 (&rest attribs)
(let (type)
(loop for attr in attribs
do (unless type
(setf type (cond
((floatp attr) 'single-float)
((integerp attr) 'fixnum)))))
`(make-matrix '(4 4) ',type ,@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))
,@attribs)))))
(defgeneric transpose (m))
(defmethod transpose ((m matrix))

29
src/maths/quaternion.lisp → maths/quaternion.lisp
View file

@ -3,18 +3,19 @@
Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
|#
(in-package :cl-user)
(defpackage stoe.maths.quaternion
(:nicknames :quaternion :q)
(:use :cl :types :vector :matrix)
(:export :quat
:from-axis-and-angle
:to-float33 :to-float44))
(in-package :stoe.maths.quaternion)
(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))))
:array (make-array '(4) :element-type 'single-float))))
(loop with i = 0
for attr in attribs
do (setf i (fill-vector q attr i)))
@ -40,7 +41,7 @@
(defun conjug (quat)
(quat (- (x quat)) (- (y quat)) (- (z quat)) (w quat)))
(defun to-f33 (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))
@ -50,8 +51,10 @@
(+ 2xy 2zw) (- 1 2xx 2zz) (- 2yz 2xw)
(- 2xz 2yw) (+ 2yz 2xw) (- 1 2xx 2yy)))))
(defun to-f44 (quat)
(setf (mref (mat4 (to-f33 quat)) 3 3) 1.0))
(defun quat-to-mat4 (quat)
(let ((mat (mat4 (quat-to-mat3 quat))))
(setf (mref mat 3 3) 1.0)
mat))
(defun q* (&rest q-list)
(normalize (reduce (lambda (q1 q2)
@ -61,4 +64,4 @@
(- (+ (* 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)))
q-list)))

27
src/maths/types.lisp → maths/types.lisp
View file

@ -3,18 +3,17 @@
Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
|#
(in-package :cl-user)
(defpackage stoe.maths.types
(:nicknames :types)
(:use :cl)
(:export :vect :array
:int2 :int3 :int4
:float2 :float3 :float4
:matrix :dimensions
:int22 :int33 :int44
:float22 :float33 :float44
:dimension :element-type))
(in-package :stoe.maths.types)
(uiop:define-package :stoe/maths/types
(:use :cl)
(:export #:vect #:array
#:int2 #:int3 #:int4
#:float2 #:float3 #:float4
#:quaternion
#:matrix #:dimensions
#:int22 #:int33 #:int44
#:float22 #:float33 #:float44
#:dimension #:element-type))
(in-package :stoe/maths/types)
(defclass vect ()
((array :type (array * (*))
@ -68,4 +67,8 @@
((array :type (array 'single-float (16)))))
(defgeneric dimension (x))
(defmethod dimension ((x number)) 1)
(defgeneric element-type (x))
(defmethod element-type ((x float)) 'single-float)
(defmethod element-type ((x integer)) 'fixnum)

11
src/maths/utils.lisp → maths/utils.lisp
View file

@ -3,12 +3,11 @@
Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
|#
(in-package :cl-user)
(defpackage stoe.maths.utils
(:use :cl)
(:export :lerp :clamp
:deg-to-rad :rad-to-deg))
(in-package :stoe.maths.utils)
(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'."

60
src/maths/vector.lisp → maths/vector.lisp
View file

@ -3,19 +3,17 @@
Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
|#
(in-package :cl-user)
(defpackage stoe.maths.vector
(:nicknames :vector :v)
(:use :cl :alexandria :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)
(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 dimension ((v vect)) (array-dimension (slot-value v 'array) 0))
(defmethod dimension ((v int2)) 2)
@ -172,7 +170,7 @@
"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 (symbol-name (if (listp attr) (second attr) attr))))
(sym (if (listp attr) (second attr) attr)))
(list var `(,sym ,v))))
attr-list)
,@body))
@ -181,17 +179,20 @@
(defmethod vadd ((v vect) (s number))
(let ((vec (make-vector (dimension v) (element-type v))))
(loop for i from 0 below (dimension v)
do (setf (vref vec i) (+ (vref v i) s)))))
do (setf (vref vec i) (+ (vref v i) s)))
vec))
(defmethod vadd ((s number) (v vect))
(let ((vec (make-vector (dimension v) (element-type v))))
(loop for i from 0 below (dimension v)
do (setf (vref vec i) (+ s (vref v i))))))
do (setf (vref vec i) (+ s (vref v i))))
vec))
(defmethod vadd ((v1 vect) (v2 vect))
(let ((v (make-vector (dimension v1) (element-type v1))))
(let ((vec (make-vector (dimension v1) (element-type v1))))
(loop for i from 0 below (dimension v1)
do (setf (vref v i) (+ (vref v1 i) (vref v2 i))))))
do (setf (vref vec i) (+ (vref v1 i) (vref v2 i))))
vec))
(defmethod vadd ((v1 float2) (v2 float2))
(make-vector 2 'single-float
@ -205,17 +206,20 @@
(defmethod vsub ((v vect) (s number))
(let ((vec (make-vector (dimension v) (element-type v))))
(loop for i from 0 below (dimension v)
do (setf (vref vec i) (- (vref v i) s)))))
do (setf (vref vec i) (- (vref v i) s)))
vec))
(defmethod vsub ((s number) (v vect))
(let ((vec (make-vector (dimension v) (element-type v))))
(loop for i from 0 below (dimension v)
do (setf (vref vec i) (- s (vref v i))))))
do (setf (vref vec i) (- s (vref v i))))
vec))
(defmethod vsub ((v1 vect) (v2 vect))
(let ((v (make-vector (dimension v1) (element-type v1))))
(let ((vec (make-vector (dimension v1) (element-type v1))))
(loop for i from 0 below (dimension v1)
do (setf (vref v i) (- (vref v1 i) (vref v2 i))))))
do (setf (vref vec i) (- (vref v1 i) (vref v2 i))))
vec))
(defmethod vsub ((v1 float2) (v2 float2))
(make-vector 2 'single-float
@ -229,12 +233,14 @@
(defmethod vmul ((v vect) (s number))
(let ((vec (make-vector (dimension v) (element-type v))))
(loop for i from 0 below (dimension v)
do (setf (vref vec i) (* (vref v i) s)))))
do (setf (vref vec i) (* (vref v i) s)))
vec))
(defmethod vmul ((s number) (v vect))
(let ((vec (make-vector (dimension v) (element-type v))))
(loop for i from 0 below (dimension v)
do (setf (vref vec i) (* s (vref v i))))))
do (setf (vref vec i) (* s (vref v i))))
vec))
(defun v* (&rest v-list)
(reduce #'vmul v-list))
@ -243,12 +249,14 @@
(defmethod vdiv ((v vect) (s number))
(let ((vec (make-vector (dimension v) (element-type v))))
(loop for i from 0 below (dimension v)
do (setf (vref vec i) (/ (vref v i) s)))))
do (setf (vref vec i) (/ (vref v i) s)))
vec))
(defmethod vdiv ((s number) (v vect))
(let ((vec (make-vector (dimension v) (element-type v))))
(loop for i from 0 below (dimension v)
do (setf (vref vec i) (/ s (vref v i))))))
do (setf (vref vec i) (/ s (vref v i))))
vec))
(defun v/ (&rest v-list)
(reduce #'vdiv v-list))

16
src/maths/float2.lisp
View file

@ -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))

24
src/maths/float22.lisp
View file

@ -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))

16
src/maths/float3.lisp
View file

@ -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))

28
src/maths/float33.lisp
View file

@ -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))

16
src/maths/float4.lisp
View file

@ -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))

31
src/maths/float44.lisp
View file

@ -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))

28
src/maths/maths.lisp
View file

@ -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
(:nicknames :maths)
(:use :cl)
(:export :lerp :clamp
:deg-to-rad :rad-to-deg))
(in-package :stoe.maths)
(defun lerp (a b ratio)
"Linear interpolation of `a' and `b' based on `ratio'."
(+ (* b ratio) (* a (- 1.0 ratio))))
(defun deg-to-rad (deg)
"Convert an angle from degree to radian."
(* deg (/ (* (coerce pi 'single-float) 2.0) 360.0)))
(defun rad-to-deg (rad)
"Convert an angle from radian to degree."
(/ rad (/ (* (coerce pi 'single-float) 2.0) 360.0)))
(defun clamp (number min max)
"Clamp a `number' between `min' and `max'."
(min max (max min number)))

33
src/object.lisp
View file

@ -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)))))

83
stoe.asd
View file

@ -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)
|#
#|
@ -15,60 +15,9 @@
(in-package :stoe-asd)
(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 +31,30 @@
: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)
(proclaim '(optimize (debug 3) (safety 3) (speed 0)))
(funcall thunk))
:depends-on ("alexandria"
"cl-opengl"
"glop"
"stoe/maths/all"
"stoe/core/all"
"stoe/engine/all"
"stoe/engine/shader/all"
"stoe/game/all")
:in-order-to ((test-op (load-op stoe/test))))
(defsystem stoe/test
:depends-on ("stoe/test/all")
:perform (load-op :after (op c) (asdf:clear-system c)))
(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/engine/shader/all" '(:shader))
(register-system-packages "stoe/game/all" '(:game))
(register-system-packages "stoe/test/all" '(:stoe/test))
(register-system-packages "cl-opengl" '(:gl))

414
test/macroexpand-dammit.lisp Normal file
View file

@ -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))

68
test/maths.lisp Normal file
View file

@ -0,0 +1,68 @@
#|
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)

0
t/shader.lisp → test/shader.lisp
View file

0
t/stoe.lisp → test/stoe.lisp
View file