├── src ├── math │ ├── math.lisp │ ├── common.lisp │ ├── vec4.lisp │ ├── mat3.lisp │ ├── packages.lisp │ ├── vec3.lisp │ ├── quat.lisp │ ├── vec2.lisp │ └── mat4.lisp ├── memory │ ├── system.lisp │ ├── packages.lisp │ ├── memory.lisp │ └── allocator.lisp ├── packages.lisp ├── host │ ├── system │ │ ├── linux.lisp │ │ ├── windows.lisp │ │ └── android.lisp │ └── packages.lisp ├── physics │ ├── physx │ │ ├── dispatcher.lisp │ │ ├── material.lisp │ │ ├── physics.lisp │ │ ├── foundation.lisp │ │ ├── vdb.lisp │ │ ├── actor.lisp │ │ ├── math.lisp │ │ └── scene.lisp │ ├── packages.lisp │ └── physics.lisp ├── graphics │ ├── filament │ │ ├── engine.lisp │ │ ├── swap-chain.lisp │ │ ├── box.lisp │ │ ├── entity.lisp │ │ ├── scene.lisp │ │ ├── image.lisp │ │ ├── skybox.lisp │ │ ├── camera.lisp │ │ ├── renderer.lisp │ │ ├── transform.lisp │ │ ├── utils.lisp │ │ ├── view.lisp │ │ ├── material.lisp │ │ ├── light.lisp │ │ ├── renderable.lisp │ │ ├── buffer.lisp │ │ ├── math.lisp │ │ └── texture.lisp │ ├── varjo │ │ └── varjo.lisp │ ├── surface.lisp │ └── skia │ │ └── skia.lisp ├── framework │ ├── packages.lisp │ └── framework.lisp └── audio │ ├── audio.lisp │ ├── packages.lisp │ ├── openal │ └── openal.lisp │ └── opus │ └── opus.lisp ├── .distignore ├── .gitignore ├── tools ├── packages.lisp ├── resources │ ├── resources.lisp │ ├── packages.lisp │ ├── scene │ │ ├── scene.lisp │ │ └── utils.lisp │ ├── image.lisp │ └── gltf.lisp ├── graphics │ ├── packages.lisp │ ├── graphics.lisp │ └── filament │ │ ├── material.lisp │ │ └── image.lisp └── ui │ └── packages.lisp ├── LICENSE ├── README.md └── alien-works.asd /src/math/math.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.math) 2 | -------------------------------------------------------------------------------- /.distignore: -------------------------------------------------------------------------------- 1 | /\..* # any file or directory starting with dot 2 | -------------------------------------------------------------------------------- /src/memory/system.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.memory) 2 | 3 | (u:init-system-allocation-routines aligned-alloc aligned-free) 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # lisp junk 2 | *.FASL 3 | *.fasl 4 | *.lisp-temp 5 | 6 | # emacs junk 7 | *~ 8 | 9 | # system dependent junk 10 | local/ 11 | -------------------------------------------------------------------------------- /tools/packages.lisp: -------------------------------------------------------------------------------- 1 | (alien-works.utils:define-umbrella-package :alien-works.tools 2 | :alien-works.tools.graphics 3 | :alien-works.tools.resources 4 | :alien-works.tools.ui) 5 | -------------------------------------------------------------------------------- /src/math/common.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.math) 2 | 3 | 4 | (define-symbol-macro +epsilon+ 5 | (handler-case 6 | (%glm:glm+epsilon) 7 | (serious-condition () 8 | `(%glm:glm+epsilon)))) 9 | -------------------------------------------------------------------------------- /src/packages.lisp: -------------------------------------------------------------------------------- 1 | (alien-works.utils:define-umbrella-package :alien-works 2 | #:alien-works.memory 3 | #:alien-works.math 4 | #:alien-works.host 5 | #:alien-works.audio 6 | #:alien-works.graphics 7 | #:alien-works.framework) 8 | -------------------------------------------------------------------------------- /src/host/system/linux.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.host) 2 | 3 | 4 | (defun %init-host ()) 5 | 6 | 7 | (defun %window-surface (wm-info) 8 | (cref:c-val ((wm-info %sdl:sys-w-minfo)) 9 | (cffi:make-pointer (wm-info :info :x11 :window)))) 10 | 11 | 12 | (defun %native-gl-context (sdl-gl-context) 13 | sdl-gl-context) 14 | -------------------------------------------------------------------------------- /tools/resources/resources.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.tools.resources) 2 | 3 | 4 | (defun resize-file (path new-size) 5 | (unless (zerop (%filament.util:aw+filament+tools+util+resize-file 6 | 'claw-utils:claw-string (namestring (truename path)) 7 | :unsigned-long new-size)) 8 | (error "Failed to resize file ~A" path))) 9 | -------------------------------------------------------------------------------- /src/host/system/windows.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.host) 2 | 3 | 4 | (defun %init-host () 5 | (%sdl:set-hint %sdl:+hint-windows-dpi-scaling+ "1")) 6 | 7 | 8 | (defun %window-surface (wm-info) 9 | (cref:c-val ((wm-info %sdl:sys-w-minfo)) 10 | (wm-info :info :win :window))) 11 | 12 | 13 | (defun %native-gl-context (sdl-gl-context) 14 | sdl-gl-context) 15 | -------------------------------------------------------------------------------- /src/physics/physx/dispatcher.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.physics.physx) 2 | 3 | 4 | (defun make-cpu-dispatcher (thread-count) 5 | (%physx:physx+px-default-cpu-dispatcher-create 6 | '%physx:physx+px-u32 thread-count 7 | '(:pointer %physx:physx+px-u32) (cffi:null-pointer))) 8 | 9 | 10 | (defun destroy-cpu-dispatcher (dispatcher) 11 | (%physx:physx+release 12 | '(:pointer %physx:physx+px-default-cpu-dispatcher) dispatcher)) 13 | -------------------------------------------------------------------------------- /src/physics/physx/material.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.physics.physx) 2 | 3 | 4 | (defun make-material (physics) 5 | (%physx:physx+create-material '(:pointer %physx:physx+px-physics) physics 6 | '%physx:physx+px-real 0.5f0 7 | '%physx:physx+px-real 0.5f0 8 | '%physx:physx+px-real 0.6f0)) 9 | 10 | 11 | (defun destroy-material (material) 12 | (%physx:physx+release '(:pointer %physx:physx+px-material) material)) 13 | -------------------------------------------------------------------------------- /src/host/system/android.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.host) 2 | 3 | (u:define-enumval-extractor gl-attr %sdl:g-lattr) 4 | (u:define-enumval-extractor gl-profile %sdl:g-lprofile) 5 | 6 | 7 | (defun %init-host () 8 | (%sdl:set-hint %sdl:+hint-mouse-touch-events+ "0") 9 | (%sdl:set-hint %sdl:+hint-touch-mouse-events+ "0")) 10 | 11 | 12 | (defun %window-surface (wm-info) 13 | (cref:c-val ((wm-info %sdl:sys-w-minfo)) 14 | (wm-info :info :android :surface))) 15 | 16 | 17 | (defun %native-gl-context (sdl-gl-context) 18 | sdl-gl-context) 19 | -------------------------------------------------------------------------------- /src/physics/physx/physics.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.physics.physx) 2 | 3 | 4 | (defun make-physics (foundation pvd scale) 5 | (%physx:px-create-physics '%physx:physx+px-u32 67174656 6 | '(:pointer %physx:physx+px-foundation) foundation 7 | '(:pointer %physx:physx+px-tolerances-scale) scale 8 | :bool t 9 | '(:pointer %physx:physx+px-pvd) pvd)) 10 | 11 | 12 | (defun destroy-physics (physics) 13 | (%physx:physx+release '(:pointer %physx:physx+px-physics) physics)) 14 | -------------------------------------------------------------------------------- /src/graphics/filament/engine.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.filament) 2 | 3 | (defun create-engine (&optional shared-context) 4 | (%filament:engine+create 5 | '%filament::engine+backend (cffi:foreign-enum-value 6 | '%filament:engine+backend 7 | :opengl) 8 | '(claw-utils:claw-pointer %filament::engine+platform) (cffi:null-pointer) 9 | '(claw-utils:claw-pointer :void) (or shared-context (cffi:null-pointer)) 10 | '(claw-utils:claw-pointer %filament::engine+config) (cffi:null-pointer))) 11 | 12 | 13 | (defun destroy-engine (engine) 14 | (%filament:engine+destroy 15 | '(claw-utils:claw-pointer %filament::engine) engine)) 16 | -------------------------------------------------------------------------------- /src/framework/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage :alien-works.framework 2 | (:local-nicknames (:a :alexandria) 3 | (:cref :cffi-c-ref) 4 | (:sv :static-vectors) 5 | 6 | (:u :alien-works.utils) 7 | (:math :alien-works.math) 8 | (:host :alien-works.host) 9 | (:audio :alien-works.audio) 10 | (:graphics :alien-works.graphics) 11 | (:physics :alien-works.physics) 12 | 13 | (:%host :%alien-works.host) 14 | (:%audio :%alien-works.audio) 15 | (:%graphics :%alien-works.graphics)) 16 | (:use :cl) 17 | (:export #:with-alien-works)) 18 | -------------------------------------------------------------------------------- /src/graphics/filament/swap-chain.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.filament) 2 | 3 | 4 | (defun create-swap-chain (engine native-window) 5 | (%filament::create-swap-chain 6 | '(claw-utils:claw-pointer %filament::engine) engine 7 | '(claw-utils:claw-pointer :void) native-window 8 | '%filament::uint64-t 0)) 9 | 10 | 11 | (defun create-headless-swap-chain (engine width height) 12 | (%filament::create-swap-chain 13 | '(claw-utils:claw-pointer %filament::engine) engine 14 | '%filament::uint32-t (floor width) 15 | '%filament::uint32-t (floor height) 16 | '%filament::uint64-t 0)) 17 | 18 | 19 | (defun destroy-swap-chain (engine swap-chain) 20 | (%filament:destroy 21 | '(claw-utils:claw-pointer %filament::engine) engine 22 | '(claw-utils:claw-pointer %filament::swap-chain) swap-chain)) 23 | -------------------------------------------------------------------------------- /src/physics/physx/foundation.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.physics.physx) 2 | 3 | 4 | (defun make-foundation (allocator error-callback) 5 | (%physx:px-create-foundation '%physx:physx+px-u32 67174656 6 | '(:pointer %physx:physx+px-allocator-callback) allocator 7 | '(:pointer %physx:physx+px-error-callback) error-callback)) 8 | 9 | 10 | (defun destroy-foundation (foundation) 11 | (%physx:physx+release '(:pointer %physx:physx+px-foundation) foundation)) 12 | 13 | 14 | (defun run-with-default-callbacks (action) 15 | (iffi:with-intricate-instances ((default-allocator %physx:physx+px-default-allocator) 16 | (default-error-callback %physx:physx+px-default-error-callback)) 17 | (funcall action default-allocator default-error-callback))) 18 | -------------------------------------------------------------------------------- /src/graphics/filament/box.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.filament) 2 | 3 | 4 | (defun create-box (min-x min-y min-z max-x max-y max-z) 5 | (let ((box (iffi:make-intricate-instance '%filament:box))) 6 | (with-vec3f (min-vec min-x min-y min-z) 7 | (with-vec3f (max-vec max-x max-y max-z) 8 | (%filament:set 9 | '(claw-utils:claw-pointer %filament::box) box 10 | '(claw-utils:claw-pointer %filament::math+float3) min-vec 11 | '(claw-utils:claw-pointer %filament::math+float3) max-vec))) 12 | box)) 13 | 14 | 15 | (defun destroy-box (box) 16 | (iffi:destroy-intricate-instance '%filament:box box)) 17 | 18 | 19 | (defmacro with-box ((box min-x min-y min-z max-x max-y max-z) &body body) 20 | `(let ((,box (create-box ,min-x ,min-y ,min-z ,max-x ,max-y ,max-z))) 21 | (unwind-protect 22 | (progn ,@body) 23 | (destroy-box ,box)))) 24 | -------------------------------------------------------------------------------- /src/graphics/filament/entity.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.filament) 2 | 3 | 4 | (defun entity-manager (engine) 5 | (%filament:get-entity-manager 6 | '(claw-utils:claw-pointer %filament::engine) engine)) 7 | 8 | 9 | (defun create-entity (entity-manager) 10 | (let ((entity (iffi:intricate-alloc '%filament:utils+entity))) 11 | (%filament:utils+create 12 | '(claw-utils:claw-pointer %filament:utils+entity) entity 13 | '(claw-utils:claw-pointer %filament:utils+entity-manager) entity-manager))) 14 | 15 | 16 | (defun destroy-entity (entity-manager entity) 17 | (%filament:utils+destroy 18 | '(claw-utils:claw-pointer %filament:utils+entity-manager) entity-manager 19 | '(claw-utils:claw-pointer %filament:utils+entity) entity) 20 | (iffi:intricate-free entity)) 21 | 22 | 23 | (defun destroy-engine-entity (engine entity) 24 | (%filament:destroy 25 | '(claw-utils:claw-pointer %filament:engine) engine 26 | '(claw-utils:claw-pointer %filament:utils+entity) entity)) 27 | -------------------------------------------------------------------------------- /src/memory/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage :%alien-works.memory 2 | (:use) 3 | (:export #:memory-vector-pointer)) 4 | 5 | 6 | (cl:defpackage :alien-works.memory 7 | (:local-nicknames (:a :alexandria) 8 | (:u :alien-works.utils) 9 | (:cltl2 :alien-works.cltl2) 10 | (:sv :static-vectors) 11 | (:cref :cffi-c-ref)) 12 | (:use :cl :%alien-works.memory) 13 | (:export #:with-system-memory-allocator 14 | 15 | #:make-stack-allocator 16 | #:destroy-stack-allocator 17 | #:with-stack-allocator 18 | #:stack-alloc 19 | #:stack-free 20 | 21 | #:define-memory-layout 22 | #:memory-layout-size 23 | #:memory-layout-slot-offset 24 | #:access-memory 25 | #:with-memory-access 26 | 27 | #:make-memory-vector 28 | #:destroy-memory-vector 29 | #:with-memory-vector 30 | #:with-memory-vectors)) 31 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 Pavel Korolev 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /src/physics/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage :alien-works.physics.physx 2 | (:local-nicknames (:u :alien-works.utils)) 3 | (:use :cl) 4 | (:export #:with-vec3 5 | #:x 6 | #:y 7 | #:z 8 | #:w 9 | 10 | #:with-scale 11 | 12 | #:with-transform 13 | #:transform-position 14 | 15 | #:make-foundation 16 | #:destroy-foundation 17 | 18 | #:with-scene-descriptor 19 | #:scene-descriptor-valid-p 20 | #:gravity 21 | 22 | #:make-scene 23 | #:simulate-scene 24 | #:finish-simulation 25 | #:destroy-scene 26 | 27 | #:make-cpu-dispatcher 28 | #:destroy-cpu-dispatcher 29 | 30 | #:make-material 31 | #:destroy-material 32 | 33 | #:make-pvd 34 | #:connect-pvd 35 | #:destroy-pvd 36 | 37 | #:make-physics 38 | #:destroy-physics 39 | 40 | #:make-transport 41 | #:destroy-transport 42 | 43 | #:add-box 44 | #:actor-global-pose 45 | 46 | #:run-with-default-callbacks)) 47 | 48 | 49 | (cl:defpackage :alien-works.physics 50 | (:local-nicknames (:px :alien-works.physics.physx)) 51 | (:use :cl)) 52 | -------------------------------------------------------------------------------- /src/framework/framework.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.framework) 2 | 3 | 4 | (defun call-with-framework (fu &key (window-title "Alien-Works") 5 | window-width 6 | window-height) 7 | (handler-bind ((serious-condition (lambda (c) 8 | (format *error-output* "~%Unhandled serious condition:~%") 9 | (u:with-bounded-wrapped-output-stream 10 | (bounded *error-output* 4096) 11 | (dissect:present c bounded))))) 12 | (dissect:with-capped-stack () 13 | (float-features:with-float-traps-masked t 14 | (%host:with-window (:title window-title 15 | :width window-width 16 | :height window-height) 17 | (%audio:with-audio () 18 | (%graphics:with-renderer () 19 | (funcall fu)))))))) 20 | 21 | 22 | (defmacro with-alien-works ((&key window-title window-width window-height) &body body) 23 | `(call-with-framework 24 | (lambda () ,@body) 25 | ,@(when window-title 26 | `(:window-title ,window-title)) 27 | ,@(when window-width 28 | `(:window-width ,window-width)) 29 | ,@(when window-height 30 | `(:window-height ,window-height)))) 31 | -------------------------------------------------------------------------------- /src/graphics/filament/scene.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.filament) 2 | 3 | 4 | (defun create-scene (engine) 5 | (%filament::create-scene 6 | '(claw-utils:claw-pointer %filament::engine) engine)) 7 | 8 | 9 | (defun destroy-scene (engine scene) 10 | (%filament:destroy 11 | '(claw-utils:claw-pointer %filament::engine) engine 12 | '(claw-utils:claw-pointer %filament::scene) scene)) 13 | 14 | 15 | (defun scene-skybox (scene) 16 | (%filament::get-skybox 17 | :const 18 | '(claw-utils:claw-pointer %filament::scene) scene)) 19 | 20 | 21 | (defun (setf scene-skybox) (skybox scene) 22 | (%filament::set-skybox 23 | '(claw-utils:claw-pointer %filament::scene) scene 24 | '(claw-utils:claw-pointer %filament::skybox) skybox) 25 | skybox) 26 | 27 | 28 | (defun (setf scene-indirect-light) (indirect-light scene) 29 | (%filament::set-indirect-light 30 | '(claw-utils:claw-pointer %filament::scene) scene 31 | '(claw-utils:claw-pointer %filament::indirect-light) indirect-light) 32 | indirect-light) 33 | 34 | 35 | (defun add-scene-entity (scene entity) 36 | (%filament::add-entity 37 | '(claw-utils:claw-pointer %filament::scene) scene 38 | '(claw-utils:claw-pointer %filament::utils+entity) entity)) 39 | 40 | 41 | (defun remove-scene-entity (scene entity) 42 | (%filament::remove 43 | '(claw-utils:claw-pointer %filament::scene) scene 44 | '(claw-utils:claw-pointer %filament::utils+entity) entity)) 45 | -------------------------------------------------------------------------------- /src/graphics/filament/image.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.filament) 2 | 3 | 4 | (defmacro with-compressed-texture-decoder ((decoder-var engine internal-format &rest internal-formats) 5 | &body body) 6 | (a:once-only (engine) 7 | `(iffi:with-intricate-instance 8 | (,decoder-var %filament:ktxreader+ktx2reader 9 | '(claw-utils:claw-pointer %filament::ktxreader+ktx2reader+engine) ,engine 10 | :bool nil) 11 | (%filament:ktxreader+request-format 12 | '(claw-utils:claw-pointer %filament::ktxreader+ktx2reader) ,decoder-var 13 | '%filament::texture+internal-format ,internal-format) 14 | ,@(loop :for format :in internal-formats 15 | :collect `(%filament:ktxreader+request-format 16 | '(claw-utils:claw-pointer %filament::ktxreader+ktx2reader) ,decoder-var 17 | '%filament::texture+internal-format ,format)) 18 | ,@body))) 19 | 20 | 21 | (defun decode-compressed-texture (decoder byte-vector &optional (transfer-function :linear)) 22 | (u:with-pinned-array-pointer (data-ptr byte-vector) 23 | (%filament:ktxreader+load 24 | '(claw-utils:claw-pointer %filament::ktxreader+ktx2reader) decoder 25 | '(claw-utils:claw-pointer :void) data-ptr 26 | '%filament::size-t (length byte-vector) 27 | '%filament::ktxreader+ktx2reader+transfer-function transfer-function))) 28 | -------------------------------------------------------------------------------- /src/graphics/filament/skybox.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.filament) 2 | 3 | ;;; 4 | ;;; SKYBOX 5 | ;;; 6 | (warp-intricate-builder-option skybox-builder :environment 7 | %filament:environment 8 | '(claw-utils:claw-pointer %filament:skybox+builder) 9 | '(claw-utils:claw-pointer %filament:texture)) 10 | 11 | (warp-intricate-builder-option skybox-builder :show-sun 12 | %filament:show-sun 13 | '(claw-utils:claw-pointer %filament:skybox+builder) 14 | ':bool) 15 | 16 | (warp-intricate-builder-option skybox-builder :intensity 17 | %filament:intensity 18 | '(claw-utils:claw-pointer %filament:skybox+builder) 19 | ':float) 20 | 21 | (warp-intricate-builder-option skybox-builder :color 22 | %filament:color 23 | '(claw-utils:claw-pointer %filament:skybox+builder) 24 | '(claw-utils:claw-pointer %filament:math+float4)) 25 | 26 | 27 | (defmacro with-skybox-builder ((name &rest steps) &body body) 28 | (flet ((ctor-expander () 29 | '(%filament:skybox+builder)) 30 | (build-expander (builder) 31 | `(%filament:build 32 | '(claw-utils:claw-pointer %filament:skybox+builder) ,builder 33 | '(claw-utils:claw-pointer %filament:engine) !::engine))) 34 | (explode-builder name 35 | 'skybox-builder 36 | #'ctor-expander 37 | #'build-expander 38 | '(!::engine) 39 | steps 40 | body))) 41 | 42 | 43 | (defun destroy-skybox (engine skybox) 44 | (%filament:destroy 45 | '(claw-utils:claw-pointer %filament::engine) engine 46 | '(claw-utils:claw-pointer %filament::skybox) skybox)) 47 | -------------------------------------------------------------------------------- /src/math/vec4.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.math) 2 | 3 | 4 | (u:definline vec4 (vec idx) 5 | (cffi:mem-ref (%glm:glm+operator[] '(:pointer %glm:glm+vec4) vec :int idx) :float)) 6 | 7 | 8 | (u:definline (setf vec4) (value vec idx) 9 | (let ((ptr (%glm:glm+operator[] '(:pointer %glm:glm+vec4) vec :int idx))) 10 | (setf (cffi:mem-ref ptr :float) (float value 0f0)))) 11 | 12 | (u:definline make-vec4 (x y z w) 13 | (iffi:make-intricate-instance '%glm:glm+vec4 14 | :float (float x 0f0) 15 | :float (float y 0f0) 16 | :float (float z 0f0) 17 | :float (float w 0f0))) 18 | 19 | (u:definline destroy-vec4 (vec) 20 | (iffi:destroy-intricate-instance '%glm:glm+vec4 vec)) 21 | 22 | 23 | (defmacro with-vec4 ((vec &key (x 0f0) (y 0f0) (z 0f0) (w 0f0)) &body body) 24 | `(let ((,vec (make-vec4 ,x ,y ,z ,w))) 25 | (unwind-protect 26 | (progn ,@body) 27 | (destroy-vec3 ,vec)))) 28 | 29 | 30 | (defmacro with-vec4* ((&rest declarations) &body body) 31 | (u:expand-multibinding 'with-vec4 declarations body)) 32 | 33 | 34 | (u:definline vec4-add (result this that) 35 | (%glm:glm+operator+ 36 | '(:pointer %glm:glm+vec4) result 37 | '(:pointer %glm:glm+vec4) this 38 | '(:pointer %glm:glm+vec4) that)) 39 | 40 | 41 | (u:definline vec4-mult (result this that) 42 | (%glm:glm+operator* 43 | '(:pointer %glm:glm+vec4) result 44 | '(:pointer %glm:glm+vec4) this 45 | '(:pointer %glm:glm+vec4) that)) 46 | 47 | 48 | (u:definline vec4-dot (this that) 49 | (%glm:glm+dot 50 | '(:pointer %glm:glm+vec4) this 51 | '(:pointer %glm:glm+vec4) that)) 52 | -------------------------------------------------------------------------------- /src/physics/physx/vdb.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.physics.physx) 2 | 3 | 4 | (u:define-enumval-extractor instrumentation-flag-enum %physx:physx+px-pvd-instrumentation-flag+enum) 5 | 6 | 7 | (defun make-pvd (foundation) 8 | (%physx:physx+px-create-pvd '(:pointer %physx:physx+px-foundation) foundation)) 9 | 10 | 11 | (defun make-instrumentation-flags (flag) 12 | (iffi:make-intricate-instance 13 | '%physx:physx+px-flags 14 | '%physx:physx+px-pvd-instrumentation-flag+enum (instrumentation-flag-enum flag))) 15 | 16 | 17 | (defun destroy-instrumentation-flags (instance) 18 | (iffi:destroy-intricate-instance 19 | '%physx:physx+px-flags 20 | instance)) 21 | 22 | 23 | (defun connect-pvd (pvd &key (host "127.0.0.1") (port 5425)) 24 | (let ((transport (%physx:physx+px-default-pvd-socket-transport-create 25 | 'claw-utils:claw-string host 26 | :int port 27 | :unsigned-int 10)) 28 | (instrumentation-flags (make-instrumentation-flags :all))) 29 | (unwind-protect 30 | (prog1 transport 31 | (%physx:physx+connect '(:pointer %physx:physx+px-pvd) pvd 32 | '(:pointer %physx:physx+px-pvd-transport) transport 33 | '(:pointer %physx:physx+px-pvd-instrumentation-flags) instrumentation-flags)) 34 | (destroy-instrumentation-flags instrumentation-flags)))) 35 | 36 | 37 | (defun destroy-transport (connection) 38 | (%physx:physx+release '(:pointer %physx:physx+px-pvd-transport) connection)) 39 | 40 | 41 | (defun destroy-pvd (pvd) 42 | (%physx:physx+release '(:pointer %physx:physx+px-pvd) pvd)) 43 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # alien-works 2 | 3 | High-performance cross-platform game foundation framework. This isn't intended 4 | as a full-featured game engine, but rather a stylobate for one. 5 | 6 | ### Principles 7 | 8 | * Performance first 9 | * Non-consing in tight loops 10 | * Non-modular highly-coupled subsystems 11 | * Multiplatform: Windows, MacOS, Linux, Android, iOS 12 | * SBCL, CCL, LispWorks and ECL compatible 13 | * Implementation purity last 14 | * Pure Lisp vs foreign solutions is the least concern 15 | * If any pure CL alternative exists with the same or better performance and 16 | similar feature set, it must replace foreign library 17 | * If foreign alternative exists with better performance and similar feature 18 | set, it must replace pure CL variant 19 | * Explicit runtime and tooling systems 20 | * Ship only things required 21 | * Package-level versioning 22 | * Stable interface is guaranteed only in versioned packages 23 | 24 | 25 | ### Capabilities 26 | 27 | * SIMD-optimized math 28 | * 3D and 2D graphics 29 | * 3D and 2D physics 30 | * Spatial audio 31 | * Keyboard/Mouse, Controller/Joystick 32 | * Resource handling 33 | * Editor/Debug UI 34 | 35 | 36 | ### Foundation 37 | 38 | * [GLM](https://github.com/g-truc/glm) 39 | * [SDL2](https://libsdl.org/) 40 | * [Filament](https://github.com/google/filament) 41 | * [Skia](https://skia.org/) 42 | * [PhysX](https://github.com/NVIDIAGameWorks/PhysX) 43 | * [Chipmunk](https://github.com/slembcke/Chipmunk2D) 44 | * [OpenAL](https://github.com/kcat/openal-soft) 45 | * [Opus](https://github.com/xiph/opus) 46 | * [Assimp](https://github.com/assimp/assimp) 47 | * [sndfile](https://github.com/libsndfile/libsndfile) 48 | * [stb_image](https://github.com/nothings/stb/blob/master/stb_image.h) 49 | * [ImGui](https://github.com/ocornut/imgui) 50 | -------------------------------------------------------------------------------- /src/math/mat3.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.math) 2 | 3 | 4 | (defun mat3 (mat col row) 5 | (vec4 (%glm:glm+operator[] '(:pointer %glm:glm+mat3) mat :int col) row)) 6 | 7 | 8 | (defun (setf mat3) (value mat col row) 9 | (let ((ptr (%glm:glm+operator[] '(:pointer %glm:glm+mat3) mat :int col))) 10 | (setf (vec4 ptr row) value))) 11 | 12 | 13 | (defun make-mat3 (x0 x1 x2 14 | y0 y1 y2 15 | z0 z1 z2) 16 | (iffi:make-intricate-instance 17 | '%glm:glm+mat3 18 | :float (float x0 0f0) 19 | :float (float y0 0f0) 20 | :float (float z0 0f0) 21 | 22 | :float (float x1 0f0) 23 | :float (float y1 0f0) 24 | :float (float z1 0f0) 25 | 26 | :float (float x2 0f0) 27 | :float (float y2 0f0) 28 | :float (float z2 0f0))) 29 | 30 | 31 | (defun make-mat3-from-basis (x-vec3 y-vec3 z-vec3) 32 | (iffi:make-intricate-instance 33 | '%glm:glm+mat3 34 | '(:pointer %glm::glm+vec3) x-vec3 35 | '(:pointer %glm::glm+vec3) y-vec3 36 | '(:pointer %glm::glm+vec3) z-vec3)) 37 | 38 | 39 | (defun destroy-mat3 (mat) 40 | (iffi:destroy-intricate-instance '%glm:glm+mat3 mat)) 41 | 42 | 43 | (defmacro with-mat3 ((mat &key 44 | (x0 1f0) (x1 0f0) (x2 0f0) 45 | (y0 0f0) (y1 1f0) (y2 0f0) 46 | (z0 0f0) (z1 0f0) (z2 1f0)) 47 | &body body) 48 | `(let ((,mat (make-mat3 ,x0 ,x1 ,x2 49 | ,y0 ,y1 ,y2 50 | ,z0 ,z1 ,z2))) 51 | (unwind-protect 52 | (progn ,@body) 53 | (destroy-mat3 ,mat)))) 54 | 55 | 56 | (defmacro with-mat3-from-basis ((mat x-vec y-vec z-vec) &body body) 57 | `(let ((,mat (make-mat3-from-basis ,x-vec ,y-vec ,z-vec))) 58 | (unwind-protect 59 | (progn ,@body) 60 | (destroy-mat3 ,mat)))) 61 | -------------------------------------------------------------------------------- /src/graphics/filament/camera.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.filament) 2 | 3 | 4 | (defun create-camera (engine entity) 5 | (%filament:create-camera 6 | '(claw-utils:claw-pointer %filament::engine) engine 7 | '(claw-utils:claw-pointer %filament::utils+entity) entity)) 8 | 9 | 10 | (defun destroy-camera (engine camera) 11 | (%filament:destroy-camera-component 12 | '(claw-utils:claw-pointer %filament::engine) engine 13 | '(claw-utils:claw-pointer %filament::utils+entity) camera)) 14 | 15 | 16 | (u:define-enumval-extractor projection-enum %filament:camera+projection) 17 | 18 | 19 | (defun update-camera-projection (camera kind left right bottom top near far) 20 | (%filament:set-projection 21 | '(claw-utils:claw-pointer %filament::camera) camera 22 | '%filament::camera+projection kind 23 | :double (float left 0d0) 24 | :double (float right 0d0) 25 | :double (float bottom 0d0) 26 | :double (float top 0d0) 27 | :double (float near 0d0) 28 | :double (float far 0d0))) 29 | 30 | 31 | (defun update-camera-fov-projection (camera fov aspect near far direction) 32 | (%filament::set-projection 33 | '(claw-utils:claw-pointer %filament::camera) camera 34 | :double (float fov 0d0) 35 | :double (float aspect 0d0) 36 | :double (float near 0d0) 37 | :double (float far 0d0) 38 | '%filament::camera+fov direction)) 39 | 40 | 41 | (defun update-camera-lens-projection (camera focal-length aspect near far) 42 | (%filament::set-lens-projection 43 | '(claw-utils:claw-pointer %filament::camera) camera 44 | :double (float focal-length 0d0) 45 | :double (float aspect 0d0) 46 | :double (float near 0d0) 47 | :double (float far 0d0))) 48 | 49 | 50 | (defun update-camera-model-matrix (camera transform) 51 | (%filament:set-model-matrix 52 | '(claw-utils:claw-pointer %filament::camera) camera 53 | '(claw-utils:claw-pointer %filament::math+mat4f) transform)) 54 | -------------------------------------------------------------------------------- /src/math/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage :%alien-works.math 2 | (:use) 3 | (:export #:vec2-element-ptr 4 | #:vec2-ptr 5 | 6 | #:vec3-element-ptr 7 | #:vec3-ptr)) 8 | 9 | 10 | (cl:defpackage :alien-works.math 11 | (:local-nicknames (:a :alexandria) 12 | (:! :alien-works.utils.empty) 13 | (:u :alien-works.utils) 14 | (:%math :%alien-works.math)) 15 | (:use :cl) 16 | (:export #:+epsilon+ 17 | 18 | #:vec2 19 | #:make-vec2 20 | #:destroy-vec2 21 | #:with-vec2 22 | #:with-vec2* 23 | #:vec2-add 24 | #:vec2-subt 25 | #:vec2-mult 26 | #:vec2-scalar-mult 27 | #:vec2-dot 28 | #:vec2-length 29 | #:vec2-normalize 30 | #:vec2-equal 31 | #:vec2-copy 32 | 33 | #:vec3 34 | #:make-vec3 35 | #:destroy-vec3 36 | #:with-vec3 37 | #:with-vec3* 38 | #:vec3-add 39 | #:vec3-mult 40 | #:vec3-dot 41 | #:vec3-cross 42 | 43 | #:vec4 44 | #:make-vec4 45 | #:destroy-vec4 46 | #:with-vec4 47 | #:with-vec4* 48 | 49 | #:mat3 50 | #:make-mat3 51 | #:make-mat3-from-basis 52 | #:destroy-mat3 53 | #:with-mat3 54 | #:with-mat3-from-basis 55 | 56 | #:mat4 57 | #:make-mat4 58 | #:destroy-mat4 59 | #:with-mat4 60 | #:with-mat4* 61 | #:rotate-mat4 62 | #:translate-mat4 63 | #:scale-mat4 64 | #:mat4-mult 65 | #:mat4-vec-mult 66 | 67 | #:quat 68 | #:make-quat 69 | #:destroy-quat 70 | #:with-quat 71 | #:mat3->quat 72 | #:normalize-quat 73 | #:positivize-quat 74 | #:negate-quat)) 75 | -------------------------------------------------------------------------------- /tools/resources/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage :alien-works.tools.resources 2 | (:local-nicknames (:cref :cffi-c-ref) 3 | (:a :alexandria) 4 | (:sv :static-vectors) 5 | (:cref :cffi-c-ref) 6 | (:u :alien-works.utils) 7 | (:m :alien-works.math) 8 | (:%awt.fm :%alien-works.tools.filament) 9 | (:%host :%alien-works.host) 10 | (:host :alien-works.host) 11 | (:%ai :%assimp) 12 | (:% :%assimp)) 13 | (:use :cl) 14 | (:export #:resize-file 15 | #:parse-scene 16 | #:scene-meshes 17 | #:scene-images 18 | #:scene-materials 19 | #:destroy-scene 20 | 21 | #:mesh-vertex-buffer 22 | #:mesh-index-buffers 23 | #:mesh-material-index 24 | #:mesh-material 25 | #:mesh-aabb 26 | 27 | #:aabb-min 28 | #:aabb-max 29 | 30 | #:buffer-data 31 | #:buffer-size 32 | #:buffer-descriptor 33 | 34 | #:material-texture 35 | 36 | #:texture-name 37 | #:texture-channels 38 | 39 | #:load-image 40 | #:load-image-from-octet-vector 41 | #:read-image-into-octet-vector 42 | #:encode-image-octet-vector-into-png 43 | 44 | #:images-to-cubemap-cross 45 | 46 | #:make-material-provider 47 | #:destroy-material-provider 48 | #:make-gltf-loader 49 | #:destroy-gltf-loader 50 | #:load-gltf-model-from-byte-vector 51 | #:destroy-gltf-model 52 | #:add-scene-gltf-model 53 | #:remove-scene-gltf-model 54 | #:gltf-model-resource-names 55 | #:make-gltf-resource-loader 56 | #:destroy-gltf-resource-loader 57 | #:with-gltf-resource-loader 58 | #:load-gltf-model-resources)) 59 | -------------------------------------------------------------------------------- /src/math/vec3.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.math) 2 | 3 | 4 | (u:definline vec3 (vec idx) 5 | (cffi:mem-ref (%glm:glm+operator[] '(:pointer %glm:glm+vec3) vec :int idx) :float)) 6 | 7 | 8 | (u:definline %math:vec3-element-ptr (vec idx) 9 | (%glm:glm+operator[] '(:pointer %glm:glm+vec3) vec :int idx)) 10 | 11 | 12 | (u:definline %math:vec3-ptr (vec) 13 | (%glm:glm+value-ptr '(:pointer %glm:glm+vec3) vec)) 14 | 15 | 16 | (u:definline (setf vec3) (value vec idx) 17 | (let ((ptr (%glm:glm+operator[] '(:pointer %glm:glm+vec3) vec :int idx))) 18 | (setf (cffi:mem-ref ptr :float) (float value 0f0)))) 19 | 20 | 21 | (u:definline make-vec3 (x y z) 22 | (iffi:make-intricate-instance '%glm:glm+vec3 23 | :float (float x 0f0) 24 | :float (float y 0f0) 25 | :float (float z 0f0))) 26 | 27 | (u:definline destroy-vec3 (vec) 28 | (iffi:destroy-intricate-instance '%glm:glm+vec3 vec)) 29 | 30 | 31 | (defmacro with-vec3 ((vec &key (x 0f0) (y 0f0) (z 0f0)) &body body) 32 | `(let ((,vec (make-vec3 ,x ,y ,z))) 33 | (unwind-protect 34 | (progn ,@body) 35 | (destroy-vec3 ,vec)))) 36 | 37 | 38 | (defmacro with-vec3* ((&rest declarations) &body body) 39 | (u:expand-multibinding 'with-vec3 declarations body)) 40 | 41 | 42 | (u:definline vec3-add (result this that) 43 | (%glm:glm+operator+ 44 | '(:pointer %glm:glm+vec3) result 45 | '(:pointer %glm:glm+vec3) this 46 | '(:pointer %glm:glm+vec3) that)) 47 | 48 | 49 | (u:definline vec3-mult (result this that) 50 | (%glm:glm+operator* 51 | '(:pointer %glm:glm+vec3) result 52 | '(:pointer %glm:glm+vec3) this 53 | '(:pointer %glm:glm+vec3) that)) 54 | 55 | 56 | (u:definline vec3-dot (this that) 57 | (%glm:glm+dot 58 | '(:pointer %glm:glm+vec3) this 59 | '(:pointer %glm:glm+vec3) that)) 60 | 61 | 62 | (u:definline vec3-cross (result this that) 63 | (%glm:glm+cross 64 | '(:pointer %glm:glm+vec3) result 65 | '(:pointer %glm:glm+vec3) this 66 | '(:pointer %glm:glm+vec3) that)) 67 | -------------------------------------------------------------------------------- /src/math/quat.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.math) 2 | 3 | 4 | (defun quat (quat idx) 5 | (cffi:mem-ref (%glm:glm+operator[] '(:pointer %glm:glm+quat) quat :int idx) :float)) 6 | 7 | 8 | (defun (setf quat) (value quat idx) 9 | (let ((ptr (%glm:glm+operator[] '(:pointer %glm:glm+quat) quat :int idx))) 10 | (setf (cffi:mem-ref ptr :float) (float value 0f0)))) 11 | 12 | 13 | (defun make-quat (x y z w) 14 | (iffi:make-intricate-instance '%glm:glm+quat 15 | :float (float x 0f0) 16 | :float (float y 0f0) 17 | :float (float z 0f0) 18 | :float (float w 0f0))) 19 | 20 | 21 | (defun mat3->quat (result mat3) 22 | (%glm:glm+quat-cast 23 | '(:pointer %glm:glm+quat) result 24 | '(:pointer %glm:glm+mat3) mat3)) 25 | 26 | 27 | (defun destroy-quat (quat) 28 | (iffi:destroy-intricate-instance '%glm:glm+quat quat)) 29 | 30 | 31 | (defmacro with-quat ((quat &key (x 0f0) (y 0f0) (z 0f0) (w 1f0)) &body body) 32 | `(let ((,quat (make-quat ,x ,y ,z ,w))) 33 | (unwind-protect 34 | (progn ,@body) 35 | (destroy-quat ,quat)))) 36 | 37 | 38 | (defmacro with-quat-from-mat3 ((quat mat3) &body body) 39 | `(let ((,quat (mat3->quat (iffi:make-intricate-instance '%glm:glm+quat) ,mat3))) 40 | (unwind-protect 41 | (progn ,@body) 42 | (destroy-quat, quat)))) 43 | 44 | 45 | (defun normalize-quat (result quat) 46 | (%glm:glm+normalize 47 | '(:pointer %glm:glm+quat) result 48 | '(:pointer %glm:glm+quat) quat)) 49 | 50 | 51 | (defun copy-quat (result quat) 52 | (%glm:glm+operator= 53 | '(:pointer %glm:glm+quat) result 54 | '(:pointer %glm:glm+quat) quat)) 55 | 56 | 57 | (defun negate-quat (result quat) 58 | (%glm:glm+operator- 59 | '(:pointer %glm:glm+quat) result 60 | '(:pointer %glm:glm+quat) quat)) 61 | 62 | 63 | (defun positivize-quat (result quat) 64 | (unless (cffi:pointer-eq result quat) 65 | (copy-quat result quat)) 66 | (when (< (quat result 3) 0f0) 67 | (negate-quat result quat)) 68 | result) 69 | -------------------------------------------------------------------------------- /src/graphics/filament/renderer.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.filament) 2 | 3 | 4 | (defun create-renderer (engine) 5 | (%filament:create-renderer '(claw-utils:claw-pointer %filament::engine) engine)) 6 | 7 | 8 | (defun destroy-renderer (engine renderer) 9 | (%filament:destroy 10 | '(claw-utils:claw-pointer %filament::engine) engine 11 | '(claw-utils:claw-pointer %filament::renderer) renderer)) 12 | 13 | 14 | (defun update-renderer-clear-options (renderer &key clear-color 15 | (clear nil clear-provided-p) 16 | (discard nil discard-provided-p)) 17 | (iffi:with-intricate-instance (opts %filament::renderer+clear-options) 18 | (iffi:with-intricate-slots %filament::renderer+clear-options 19 | ((%clear-color %filament:clear-color) 20 | (%clear %filament:clear) 21 | (%discard %filament:discard)) 22 | opts 23 | (when clear-color 24 | (with-vec4f (new-clear-color 25 | (m:vec4 clear-color 0) 26 | (m:vec4 clear-color 1) 27 | (m:vec4 clear-color 2) 28 | (m:vec4 clear-color 3)) 29 | (setf %clear-color new-clear-color))) 30 | (when clear-provided-p 31 | (setf %clear (and clear t))) 32 | (when discard-provided-p 33 | (setf %discard (and discard t)))) 34 | (%filament::set-clear-options 35 | '(claw-utils:claw-pointer %filament::renderer) renderer 36 | '(claw-utils:claw-pointer %filament::renderer+clear-options) opts))) 37 | 38 | 39 | (defun render-view (renderer view) 40 | (%filament::render 41 | '(claw-utils:claw-pointer %filament::renderer) renderer 42 | '(claw-utils:claw-pointer %filament::view) view)) 43 | 44 | 45 | (defun begin-frame (renderer swap-chain) 46 | (%filament:begin-frame 47 | '(claw-utils:claw-pointer %filament::renderer) renderer 48 | '(claw-utils:claw-pointer %filament::swap-chain) swap-chain 49 | '%filament::uint64-t 0)) 50 | 51 | 52 | (defun end-frame (renderer) 53 | (%filament:end-frame 54 | '(claw-utils:claw-pointer %filament::renderer) renderer)) 55 | -------------------------------------------------------------------------------- /src/audio/audio.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.audio) 2 | 3 | 4 | (defun decode-audio (octet-stream-in &key (channels 1)) 5 | (flexi-streams:with-output-to-sequence (out :element-type '(signed-byte 16)) 6 | (%aw.opus:decode-audio octet-stream-in out 48000 channels))) 7 | 8 | 9 | (defun encode-audio (s16-mono-pcm-stream-in octet-stream-out &key (channels 1)) 10 | (let ((frame-duration 20) ;; msec 11 | (sample-rate 48000)) 12 | (%aw.opus:encode-audio s16-mono-pcm-stream-in octet-stream-out 13 | (* (/ sample-rate 1000) frame-duration channels) 14 | sample-rate 15 | channels))) 16 | 17 | 18 | (defun play-audio (s16-mono-pcm) 19 | (%aw.al:play-pcm-s16-mono s16-mono-pcm)) 20 | 21 | 22 | (defmacro %audio:with-audio (() &body body) 23 | `(%aw.al:with-context () 24 | ,@body)) 25 | 26 | 27 | (defun make-audio-buffer (s16-48k-pcm &key (channels 1)) 28 | (let ((buffer (%aw.al:make-audio-buffer))) 29 | (setf (%aw.al:audio-buffer-data buffer :channels channels) s16-48k-pcm) 30 | buffer)) 31 | 32 | 33 | (defun destroy-audio-buffer (buffer) 34 | (%aw.al:destroy-audio-buffer buffer)) 35 | 36 | 37 | (defun make-audio-source (buffer) 38 | (let ((source (%aw.al:make-audio-source))) 39 | (setf (%aw.al:audio-source-buffer source) buffer) 40 | source)) 41 | 42 | 43 | (defun make-audio-source-from-pcm (s16-48k-pcm &key (channels 1)) 44 | (let ((buffer (%aw.al:make-audio-buffer)) 45 | (source (%aw.al:make-audio-source))) 46 | (setf (%aw.al:audio-buffer-data buffer :channels channels) s16-48k-pcm 47 | (%aw.al:audio-source-buffer source) buffer) 48 | (values source buffer))) 49 | 50 | 51 | (defun destroy-audio-source (source) 52 | (%aw.al:destroy-audio-source source)) 53 | 54 | 55 | (defun play-audio-source (source) 56 | (%aw.al:play-audio-source source)) 57 | 58 | 59 | (defun pause-audio-source (source) 60 | (%aw.al:pause-audio-source source)) 61 | 62 | 63 | (defun stop-audio-source (source) 64 | (%aw.al:stop-audio-source source)) 65 | 66 | 67 | (defun audio-source-state (source) 68 | (%aw.al:audio-source-state source)) 69 | -------------------------------------------------------------------------------- /src/graphics/filament/transform.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.filament) 2 | 3 | 4 | (defun transform-manager (engine) 5 | (%filament:get-transform-manager 6 | '(claw-utils:claw-pointer %filament:engine) engine)) 7 | 8 | 9 | (defmacro with-transform-instance ((instance entity) transform-manager &body body) 10 | `(iffi:with-intricate-instance (,instance %filament:transform-manager+instance) 11 | (%filament:get-instance 12 | :const 13 | '(claw-utils:claw-pointer %filament:transform-manager+instance) ,instance 14 | '(claw-utils:claw-pointer %filament:transform-manager) ,transform-manager 15 | '(claw-utils:claw-pointer %filament:utils+entity) ,entity) 16 | ,@body)) 17 | 18 | 19 | (defun (setf transform) (mat4f transform-manager entity-instance) 20 | (%filament:set-transform 21 | '(claw-utils:claw-pointer %filament:transform-manager) transform-manager 22 | '(claw-utils:claw-pointer %filament:transform-manager+instance) entity-instance 23 | '(claw-utils:claw-pointer %filament:math+mat4f) mat4f)) 24 | 25 | 26 | (defun attach-transform (transform-manager entity-instance) 27 | (iffi:with-intricate-instance (transform-instance %filament:transform-manager+instance) 28 | (%filament:create 29 | '(claw-utils:claw-pointer %filament:transform-manager) transform-manager 30 | '(claw-utils:claw-pointer %filament:utils+entity) entity-instance 31 | '(claw-utils:claw-pointer %filament:transform-manager+instance) transform-instance))) 32 | 33 | 34 | (defun detach-transform (transform-manager entity-instance) 35 | (%filament:destroy 36 | '(claw-utils:claw-pointer %filament:transform-manager) transform-manager 37 | '(claw-utils:claw-pointer %filament:utils+entity) entity-instance)) 38 | 39 | 40 | (defun (setf transform-parent) (parent-instance transform-manager entity-instance) 41 | (%filament:set-parent 42 | '(claw-utils:claw-pointer %filament:transform-manager) transform-manager 43 | '(claw-utils:claw-pointer %filament:transform-manager+instance) entity-instance 44 | '(claw-utils:claw-pointer %filament:transform-manager+instance) parent-instance)) 45 | 46 | 47 | (defun transform-parent (transform-manager entity-instance) 48 | (declare (ignore transform-manager entity-instance)) 49 | (error "Not implemented")) 50 | -------------------------------------------------------------------------------- /tools/graphics/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage :%alien-works.tools.filament 2 | (:local-nicknames (:a :alexandria) 3 | (:! :alien-works.utils.empty) 4 | (:u :alien-works.utils) 5 | (:m :alien-works.math) 6 | (:%aw.fm :%alien-works.filament)) 7 | (:use :cl) 8 | (:export #:serialize-material 9 | #:material-data-pointer 10 | #:material-data-size 11 | #:with-serialized-material-data 12 | 13 | #:make-image 14 | #:image-width 15 | #:image-height 16 | #:image-channels 17 | #:image-data-ptr 18 | #:image-data-size 19 | #:destroy-image 20 | #:decode-image 21 | #:encode-image 22 | 23 | #:with-compressed-texture-encoder-builder 24 | #:compressed-texture-encoder-builder-linear 25 | #:compressed-texture-encoder-builder-mip-level 26 | #:encode-compressed-texture)) 27 | 28 | 29 | (cl:defpackage :alien-works.tools.graphics 30 | (:local-nicknames (:a :alexandria) 31 | (:%aw.fm :%alien-works.filament) 32 | (:%gx :%alien-works.graphics) 33 | (:gx :alien-works.graphics) 34 | (:%gxs :%alien-works.tools.filament) 35 | (:u :alien-works.utils) 36 | (:sv :static-vectors) 37 | (:cref :cffi-c-ref) 38 | (:m :alien-works.math) 39 | (:mem :alien-works.memory) 40 | (:%mem :%alien-works.memory) 41 | (:host :alien-works.host)) 42 | (:use :cl) 43 | (:import-from :%alien-works.tools.filament 44 | #:make-image 45 | #:image-width 46 | #:image-height 47 | #:image-channels 48 | #:destroy-image 49 | #:decode-image 50 | #:encode-image) 51 | (:export #:make-material 52 | #:encode-material 53 | 54 | #:make-image 55 | #:image-width 56 | #:image-height 57 | #:image-channels 58 | #:destroy-image 59 | #:decode-image 60 | #:encode-image 61 | #:encode-texture)) 62 | -------------------------------------------------------------------------------- /src/physics/physx/actor.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.physics.physx) 2 | 3 | 4 | (defun add-box (physics scene material) 5 | (iffi:with-intricate-instances ((transform %physx:physx+px-transform 6 | '%physx:physx+px-identity :px-identity) 7 | (geom %physx:physx+px-box-geometry 8 | '%physx:physx+px-real 0.5f0 9 | '%physx:physx+px-real 0.5f0 10 | '%physx:physx+px-real 0.5f0)) 11 | (let* ((flags (iffi:make-intricate-instance 12 | '%physx:physx+px-flags 13 | '%physx:physx+px-shape-flag+enum (cffi:foreign-bitfield-value 14 | '%physx:physx+px-shape-flag+enum 15 | '(:visualization 16 | :scene-query-shape 17 | :simulation-shape)))) 18 | (shape (%physx:physx+create-shape 19 | '(:pointer %physx:physx+px-physics) physics 20 | '(:pointer %physx:physx+px-geometry) geom 21 | '(:pointer %physx:physx+px-material) material 22 | ':bool nil 23 | '(:pointer %physx:physx+px-shape-flags) flags)) 24 | 25 | (body (%physx:physx+create-rigid-dynamic 26 | '(:pointer %physx:physx+px-physics) physics 27 | '(:pointer %physx:physx+px-transform) transform))) 28 | (prog1 body 29 | (%physx:physx+attach-shape 30 | '(:pointer %physx:physx+px-rigid-actor) body 31 | '(:pointer %physx:physx+px-shape) shape) 32 | (%physx:physx+add-actor 33 | '(:pointer %physx:physx+px-scene) scene 34 | '(:pointer %physx:physx+px-actor) body 35 | '(:pointer %physx:physx+px-bvh-structure) (cffi:null-pointer)) 36 | (%physx:physx+release '(:pointer %physx:physx+px-shape) shape))))) 37 | 38 | 39 | (defun actor-global-pose (transform actor) 40 | (%physx:physx+get-global-pose :const 41 | '(:pointer %physx:physx+px-transform) transform 42 | '(:pointer %physx:physx+px-rigid-actor) actor)) 43 | -------------------------------------------------------------------------------- /src/graphics/filament/utils.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.filament) 2 | 3 | 4 | ;;; 5 | ;;; BUILDER 6 | ;;; 7 | (defun explode-function (signature args) 8 | (let ((name (first signature)) 9 | (types (rest signature))) 10 | (when (/= (length types) (length args)) 11 | (error "Wrong number of arguments for ~A: required ~A, but got ~A" 12 | name types args)) 13 | `(,name ,@(loop for type in types 14 | for arg in args 15 | append (list type arg))))) 16 | 17 | 18 | (defmacro warp-intricate-function (name intricate-name &body params) 19 | (let ((args (loop for nil in params 20 | collect (gensym)))) 21 | `(defun ,name (,@args) 22 | ,(explode-function (list* intricate-name params) args)))) 23 | 24 | 25 | (defgeneric builder-option-intricate-function (builder option)) 26 | 27 | 28 | (defun explode-builder (name-and-opts 29 | builder-name 30 | ctor-expander 31 | build-expander 32 | maker-args 33 | steps 34 | body) 35 | (a:with-gensyms (builder) 36 | (destructuring-bind (name &rest opts) (a:ensure-list name-and-opts) 37 | (destructuring-bind (&key instance &allow-other-keys) opts 38 | `(iffi:with-intricate-instance (,builder ,@(funcall ctor-expander)) 39 | ,@(loop for (name . args) in steps 40 | collect (explode-function (builder-option-intricate-function builder-name name) 41 | (list* builder args))) 42 | (flet ((,name (,@maker-args) 43 | ,(funcall build-expander builder))) 44 | (,@(if instance 45 | `(let ((,instance ,builder))) 46 | '(progn)) 47 | ,@body))))))) 48 | 49 | 50 | (defmacro warp-intricate-builder-option (builder option-name intricate-function &body params) 51 | (let ((intricate-signature (list* intricate-function params))) 52 | `(progn 53 | (warp-intricate-function ,(a:symbolicate builder '- option-name) ,@intricate-signature) 54 | (defmethod builder-option-intricate-function ((builder (eql ',builder)) 55 | (option (eql ,option-name))) 56 | (declare (ignore builder option)) 57 | ',intricate-signature)))) 58 | -------------------------------------------------------------------------------- /src/physics/physics.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.physics) 2 | 3 | ;;; 4 | ;;; DEMO 5 | ;;; 6 | (defun report-actor-position (actor) 7 | (px:with-transform (transform) 8 | (px:actor-global-pose transform actor) 9 | (let ((pos (px:transform-position transform))) 10 | (format t "~&POSITION: ~8F ~8F ~8F" (px:x pos) (px:y pos) (px:z pos))) 11 | (finish-output))) 12 | 13 | 14 | (defun setup-scene (physics dispatcher) 15 | (px:with-scene-descriptor (descriptor physics dispatcher) 16 | (px:with-vec3 (vec) 17 | (setf (px:x vec) 0 18 | (px:y vec) -9.81 19 | (px:z vec) 0) 20 | (setf (px:gravity descriptor) vec)) 21 | (unless (px:scene-descriptor-valid-p descriptor) 22 | (error "Scene descriptor invalid")) 23 | (px:make-scene physics descriptor))) 24 | 25 | 26 | (defun run-simulation (physics) 27 | (let* ((dispatcher (px:make-cpu-dispatcher 2)) 28 | (scene (setup-scene physics dispatcher)) 29 | (material (px:make-material physics)) 30 | (box (px:add-box physics scene material))) 31 | (unwind-protect 32 | (progn 33 | (report-actor-position box) 34 | (loop repeat 10 35 | do (px:simulate-scene scene 0.14) 36 | (px:finish-simulation scene) 37 | (report-actor-position box))) 38 | (px:destroy-material material) 39 | (px:destroy-scene scene) 40 | (px:destroy-cpu-dispatcher dispatcher)))) 41 | 42 | 43 | (defun run-with-physics (foundation action) 44 | (px:with-scale (scale) 45 | (let* ((pvd (px:make-pvd foundation)) 46 | (connection (px:connect-pvd pvd))) 47 | (let ((physics (px:make-physics foundation pvd scale))) 48 | (unwind-protect 49 | (funcall action physics) 50 | (px:destroy-physics physics) 51 | (px:destroy-transport connection) 52 | (px:destroy-pvd pvd)))))) 53 | 54 | 55 | (defun run-with-foundation (action) 56 | (flet ((%run-with-foundation (allocator error-callback) 57 | (let ((foundation (px:make-foundation allocator error-callback))) 58 | (unwind-protect 59 | (funcall action foundation) 60 | (px:destroy-foundation foundation))))) 61 | (px:run-with-default-callbacks #'%run-with-foundation))) 62 | 63 | 64 | (defun run-physics (foundation) 65 | (run-with-physics foundation #'run-simulation)) 66 | 67 | 68 | (defun run-physics-demo () 69 | (run-with-foundation #'run-physics)) 70 | -------------------------------------------------------------------------------- /src/physics/physx/math.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.physics.physx) 2 | 3 | 4 | (defmacro with-scale ((scale) &body body) 5 | `(iffi:with-intricate-instance (,scale %physx:physx+px-tolerances-scale) 6 | (progn ,@body))) 7 | 8 | 9 | (defun make-vec3 () 10 | (iffi:make-intricate-instance '%physx:physx+px-vec3 :float 0f0)) 11 | 12 | 13 | (defun destroy-vec3 (vec) 14 | (iffi:destroy-intricate-instance '%physx:physx+px-vec3 vec)) 15 | 16 | 17 | (defmacro with-vec3 ((vec) &body body) 18 | `(let ((,vec (make-vec3))) 19 | (unwind-protect 20 | (progn ,@body) 21 | (destroy-vec3 ,vec)))) 22 | 23 | 24 | (defun x (vec) 25 | (iffi:intricate-slot-value vec 26 | '%physx:physx+px-vec3 27 | '%physx:x)) 28 | 29 | 30 | (defun (setf x) (value vec) 31 | (setf (iffi:intricate-slot-value vec 32 | '%physx:physx+px-vec3 33 | '%physx:x) 34 | (float value 0f0))) 35 | 36 | 37 | (defun y (vec) 38 | (iffi:intricate-slot-value vec 39 | '%physx:physx+px-vec3 40 | '%physx:y)) 41 | 42 | 43 | (defun (setf y) (value vec) 44 | (setf (iffi:intricate-slot-value vec 45 | '%physx:physx+px-vec3 46 | '%physx:y) 47 | (float value 0f0))) 48 | 49 | 50 | (defun z (vec) 51 | (iffi:intricate-slot-value vec 52 | '%physx:physx+px-vec3 53 | '%physx:z)) 54 | 55 | 56 | (defun (setf z) (value vec) 57 | (setf (iffi:intricate-slot-value vec 58 | '%physx:physx+px-vec3 59 | '%physx:z) 60 | (float value 0f0))) 61 | 62 | 63 | (defun make-transform () 64 | (iffi:make-intricate-instance '%physx:physx+px-transform 65 | '%physx:physx+px-identity :px-identity)) 66 | 67 | 68 | (defun destroy-transform (transform) 69 | (iffi:destroy-intricate-instance '%physx:physx+px-transform transform)) 70 | 71 | 72 | (defmacro with-transform ((transform) &body body) 73 | `(let ((,transform (make-transform))) 74 | (unwind-protect 75 | (progn ,@body) 76 | (destroy-transform ,transform)))) 77 | 78 | 79 | (defun transform-position (transform) 80 | (iffi:intricate-slot-value transform '%physx:physx+px-transform '%physx:p)) 81 | 82 | 83 | (defun transform-rotation (transform) 84 | (iffi:intricate-slot-value transform '%physx:physx+px-transform '%physx:q)) 85 | -------------------------------------------------------------------------------- /src/math/vec2.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.math) 2 | 3 | 4 | (u:definline vec2 (vec idx) 5 | (cffi:mem-ref (%glm:glm+operator[] '(:pointer %glm:glm+vec2) vec :int idx) :float)) 6 | 7 | 8 | (u:definline (setf vec2) (value vec idx) 9 | (let ((ptr (%glm:glm+operator[] '(:pointer %glm:glm+vec2) vec :int idx))) 10 | (setf (cffi:mem-ref ptr :float) (float value 0f0)))) 11 | 12 | 13 | (u:definline %math:vec2-element-ptr (vec idx) 14 | (%glm:glm+operator[] '(:pointer %glm:glm+vec2) vec :int idx)) 15 | 16 | 17 | (u:definline %math:vec2-ptr (vec) 18 | (%glm:glm+value-ptr '(:pointer %glm:glm+vec2) vec)) 19 | 20 | 21 | (defmacro with-vec2 ((vec &key (x 0f0) (y 0f0)) &body body) 22 | `(let ((,vec (make-vec2 ,x ,y))) 23 | (unwind-protect 24 | (progn ,@body) 25 | (destroy-vec2 ,vec)))) 26 | 27 | 28 | (defmacro with-vec2* ((&rest declarations) &body body) 29 | (u:expand-multibinding 'with-vec2 declarations body)) 30 | 31 | 32 | (defun make-vec2 (x y) 33 | (iffi:make-intricate-instance '%glm:glm+vec2 34 | :float (float x 0f0) 35 | :float (float y 0f0))) 36 | 37 | 38 | (defun destroy-vec2 (vec) 39 | (iffi:destroy-intricate-instance '%glm:glm+vec2 vec)) 40 | 41 | 42 | (u:definline vec2-add (result this that) 43 | (%glm:glm+operator+ 44 | '(:pointer %glm:glm+vec2) result 45 | '(:pointer %glm:glm+vec2) this 46 | '(:pointer %glm:glm+vec2) that)) 47 | 48 | 49 | (u:definline vec2-subt (result this that) 50 | (%glm:glm+operator- 51 | '(:pointer %glm:glm+vec2) result 52 | '(:pointer %glm:glm+vec2) this 53 | '(:pointer %glm:glm+vec2) that)) 54 | 55 | 56 | (u:definline vec2-mult (result this that) 57 | (%glm:glm+operator* 58 | '(:pointer %glm:glm+vec2) result 59 | '(:pointer %glm:glm+vec2) this 60 | '(:pointer %glm:glm+vec2) that)) 61 | 62 | 63 | (u:definline vec2-scalar-mult (result vec2 scalar) 64 | (%glm:glm+operator* 65 | '(:pointer %glm:glm+vec2) result 66 | '(:pointer %glm:glm+vec2) vec2 67 | :float (float scalar 0f0))) 68 | 69 | 70 | (u:definline vec2-dot (this that) 71 | (%glm:glm+dot 72 | '(:pointer %glm:glm+vec2) this 73 | '(:pointer %glm:glm+vec2) that)) 74 | 75 | 76 | (u:definline vec2-normalize (result vec2) 77 | (%glm:glm+normalize 78 | '(:pointer %glm:glm+vec2) result 79 | '(:pointer %glm:glm+vec2) vec2)) 80 | 81 | 82 | (u:definline vec2-copy (result vec2) 83 | (%glm:glm+operator= 84 | '(:pointer %glm:glm+vec2) result 85 | '(:pointer %glm:glm+vec2) vec2)) 86 | 87 | 88 | (u:definline vec2-equal (this that &optional (epsilon +epsilon+)) 89 | (with-vec2 (result) 90 | (vec2-subt result this that) 91 | (and (>= epsilon (abs (vec2 result 0))) 92 | (>= epsilon (abs (vec2 result 1)))))) 93 | 94 | 95 | (u:definline vec2-length (vec2) 96 | (%glm:glm+length 97 | '(:pointer %glm:glm+vec2) vec2)) 98 | -------------------------------------------------------------------------------- /tools/graphics/graphics.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.tools.graphics) 2 | 3 | 4 | (defun make-material (material-name &key base-path 5 | debug 6 | (target-api :opengl) 7 | (platform :all) 8 | (optimization :performance)) 9 | (let ((source (%gx:format-material-source material-name))) 10 | (%gxs:with-serialized-material-data (material-data source 11 | :base-path base-path 12 | :debug debug 13 | :target-api target-api 14 | :platform platform 15 | :optimization optimization) 16 | (%aw.fm:with-material-builder (%make-material 17 | (:package (%gxs:material-data-pointer material-data) 18 | (%gxs:material-data-size material-data))) 19 | (%make-material (%alien-works.graphics:engine-handle)))))) 20 | 21 | 22 | (defun encode-material (material-name &key base-path debug 23 | (target-api :opengl) 24 | (platform :all) 25 | (optimization :performance)) 26 | (let ((source (%gx:format-material-source material-name))) 27 | (%gxs:with-serialized-material-data (material-data source 28 | :base-path base-path 29 | :debug debug 30 | :target-api target-api 31 | :platform platform 32 | :optimization optimization) 33 | (let ((serialized-mat-data (mem:make-memory-vector 34 | (%gxs:material-data-size material-data)))) 35 | (host:memcpy (%mem:memory-vector-pointer serialized-mat-data) 36 | (%gxs:material-data-pointer material-data) 37 | (length serialized-mat-data)) 38 | serialized-mat-data)))) 39 | 40 | 41 | (defun encode-texture (image) 42 | (%gxs:with-compressed-texture-encoder-builder 43 | (((%build-encoder :instance builder) 1 1)) 44 | (%gxs:compressed-texture-encoder-builder-linear builder t) 45 | (%gxs:compressed-texture-encoder-builder-mip-level builder 0 0 image) 46 | (let ((encoder (%build-encoder))) 47 | (multiple-value-bind (data-ptr size) 48 | (%gxs:encode-compressed-texture encoder) 49 | (let ((encoded (cffi:make-shareable-byte-vector size))) 50 | (cffi:with-pointer-to-vector-data (encoded-ptr encoded) 51 | (host:memcpy encoded-ptr data-ptr size)) 52 | encoded))))) 53 | -------------------------------------------------------------------------------- /src/physics/physx/scene.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.physics.physx) 2 | 3 | 4 | (defun make-scene-descriptor (physics dispatcher) 5 | (let* ((scale (%physx:physx+get-tolerances-scale 6 | :const 7 | '(:pointer %physx:physx+px-physics) physics)) 8 | (descriptor (iffi:make-intricate-instance '%physx:physx+px-scene-desc 9 | '(:pointer %physx:physx+px-tolerances-scale) scale)) 10 | (default-filter (iffi:intricate-function-pointer 11 | '%physx:physx+px-default-simulation-filter-shader 12 | '(:pointer %physx:physx+px-filter-flags) 13 | '%physx:physx+px-filter-object-attributes 14 | '(:pointer %physx:physx+px-filter-data) 15 | '%physx:physx+px-filter-object-attributes 16 | '(:pointer %physx:physx+px-filter-data) 17 | '(:pointer %physx:physx+px-pair-flags) 18 | '(:pointer :void) 19 | '%physx:physx+px-u32))) 20 | (setf 21 | (iffi:intricate-slot-value descriptor '%physx:physx+px-scene-desc '%physx:cpu-dispatcher) dispatcher 22 | (iffi:intricate-slot-value descriptor '%physx:physx+px-scene-desc '%physx:filter-shader) default-filter) 23 | descriptor)) 24 | 25 | 26 | (defun scene-descriptor-valid-p (descriptor) 27 | (%physx:physx+is-valid :const '(:pointer %physx:physx+px-scene-desc) descriptor)) 28 | 29 | 30 | (defun destroy-scene-descriptor (descriptor) 31 | (iffi:destroy-intricate-instance '%physx:physx+px-scene-desc descriptor)) 32 | 33 | 34 | (defun (setf gravity) (value descriptor) 35 | (setf (iffi:intricate-slot-value descriptor '%physx:physx+px-scene-desc '%physx:gravity) value)) 36 | 37 | 38 | (defmacro with-scene-descriptor ((descriptor physics dispatcher) &body body) 39 | `(let ((,descriptor (make-scene-descriptor ,physics ,dispatcher))) 40 | (unwind-protect 41 | (progn ,@body) 42 | (destroy-scene-descriptor ,descriptor)))) 43 | 44 | 45 | (defun make-scene (physics descriptor) 46 | (%physx:physx+create-scene 47 | '(:pointer %physx:physx+px-physics) physics 48 | '(:pointer %physx:physx+px-scene-desc) descriptor)) 49 | 50 | 51 | (defun destroy-scene (scene) 52 | (%physx:physx+release '(:pointer %physx:physx+px-scene) scene)) 53 | 54 | 55 | (defun simulate-scene (scene step) 56 | (%physx:physx+simulate 57 | '(:pointer %physx:physx+px-scene) scene 58 | '%physx:physx+px-real (float step 0f0) 59 | '(:pointer %physx:physx+px-base-task) (cffi:null-pointer) 60 | '(:pointer :void) (cffi:null-pointer) 61 | '%physx:physx+px-u32 0 62 | ':bool t)) 63 | 64 | 65 | (defun finish-simulation (scene) 66 | (%physx:physx+fetch-results 67 | '(:pointer %physx:physx+px-scene) scene 68 | ':bool t 69 | '(:pointer %physx:physx+px-u32) (cffi:null-pointer))) 70 | -------------------------------------------------------------------------------- /src/math/mat4.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.math) 2 | 3 | 4 | (u:definline mat4 (mat col row) 5 | (vec4 (%glm:glm+operator[] '(:pointer %glm:glm+mat4) mat :int col) row)) 6 | 7 | 8 | (u:definline (setf mat4) (value mat col row) 9 | (let ((ptr (%glm:glm+operator[] '(:pointer %glm:glm+mat4) mat :int col))) 10 | (setf (vec4 ptr row) value))) 11 | 12 | 13 | (u:definline make-mat4 (x0 x1 x2 x3 14 | y0 y1 y2 y3 15 | z0 z1 z2 z3 16 | w0 w1 w2 w3) 17 | (let ((instance (iffi:make-intricate-instance '%glm:glm+mat4))) 18 | (setf (mat4 instance 0 0) x0 19 | (mat4 instance 0 1) y0 20 | (mat4 instance 0 2) z0 21 | (mat4 instance 0 3) w0 22 | 23 | (mat4 instance 1 0) x1 24 | (mat4 instance 1 1) y1 25 | (mat4 instance 1 2) z1 26 | (mat4 instance 1 3) w1 27 | 28 | (mat4 instance 2 0) x2 29 | (mat4 instance 2 1) y2 30 | (mat4 instance 2 2) z2 31 | (mat4 instance 2 3) w2 32 | 33 | (mat4 instance 3 0) x3 34 | (mat4 instance 3 1) y3 35 | (mat4 instance 3 2) z3 36 | (mat4 instance 3 3) w3) 37 | instance)) 38 | 39 | 40 | (u:definline destroy-mat4 (mat) 41 | (iffi:destroy-intricate-instance '%glm:glm+mat4 mat)) 42 | 43 | 44 | (defmacro with-mat4 ((mat &key 45 | (x0 1f0) (x1 0f0) (x2 0f0) (x3 0f0) 46 | (y0 0f0) (y1 1f0) (y2 0f0) (y3 0f0) 47 | (z0 0f0) (z1 0f0) (z2 1f0) (z3 0f0) 48 | (w0 0f0) (w1 0f0) (w2 0f0) (w3 1f0)) 49 | &body body) 50 | `(let ((,mat (make-mat4 ,x0 ,x1 ,x2 ,x3 51 | ,y0 ,y1 ,y2 ,y3 52 | ,z0 ,z1 ,z2 ,z3 53 | ,w0 ,w1 ,w2 ,w3))) 54 | (unwind-protect 55 | (progn ,@body) 56 | (destroy-mat4 ,mat)))) 57 | 58 | 59 | (defmacro with-mat4* ((&rest declarations) &body body) 60 | (u:expand-multibinding 'with-mat4 declarations body)) 61 | 62 | 63 | (u:definline rotate-mat4 (result source angle vec3) 64 | (%glm:glm+rotate 65 | '(:pointer %glm::glm+mat4) result 66 | '(:pointer %glm::glm+mat4) source 67 | ':float (float angle 0f0) 68 | '(:pointer %glm::glm+vec3) vec3)) 69 | 70 | 71 | (u:definline translate-mat4 (result source vec3) 72 | (%glm:glm+translate 73 | '(:pointer %glm::glm+mat4) result 74 | '(:pointer %glm::glm+mat4) source 75 | '(:pointer %glm::glm+vec3) vec3)) 76 | 77 | 78 | (u:definline scale-mat4 (result source vec3) 79 | (%glm:glm+scale 80 | '(:pointer %glm::glm+mat4) result 81 | '(:pointer %glm::glm+mat4) source 82 | '(:pointer %glm::glm+vec3) vec3)) 83 | 84 | 85 | (u:definline mat4-mult (result this that) 86 | (%glm:glm+operator* 87 | '(:pointer %glm::glm+mat4) result 88 | '(:pointer %glm::glm+mat4) this 89 | '(:pointer %glm::glm+mat4) that)) 90 | 91 | 92 | (u:definline mat4-vec-mult (result-vec4 mat4 vec4) 93 | (%glm:glm+operator* 94 | '(:pointer %glm::glm+vec4) result-vec4 95 | '(:pointer %glm::glm+mat4) mat4 96 | '(:pointer %glm::glm+vec4) vec4)) 97 | -------------------------------------------------------------------------------- /src/graphics/filament/view.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.filament) 2 | 3 | 4 | (defun create-view (engine) 5 | (%filament:create-view 6 | '(claw-utils:claw-pointer %filament:engine) engine)) 7 | 8 | 9 | (defun destroy-view (engine view) 10 | (%filament:destroy 11 | '(claw-utils:claw-pointer %filament:engine) engine 12 | '(claw-utils:claw-pointer %filament:view) view)) 13 | 14 | 15 | (defun (setf view-camera) (camera view) 16 | (%filament:set-camera 17 | '(claw-utils:claw-pointer %filament:view) view 18 | '(claw-utils:claw-pointer %filament:camera) camera)) 19 | 20 | 21 | (defun (setf view-scene) (scene view) 22 | (%filament:set-scene 23 | '(claw-utils:claw-pointer %filament:view) view 24 | '(claw-utils:claw-pointer %filament:scene) scene)) 25 | 26 | 27 | (u:define-enumval-extractor view-anti-aliasing-enum %filament:view+anti-aliasing) 28 | (u:define-enumval-extractor view-dithering-enum %filament:view+dithering) 29 | 30 | 31 | (defun (setf view-anti-aliasing) (antialiasing view) 32 | (%filament:set-anti-aliasing 33 | '(claw-utils:claw-pointer %filament:view) view 34 | '%filament:view+anti-aliasing (view-anti-aliasing-enum antialiasing))) 35 | 36 | 37 | (defun (setf view-sample-count) (count view) 38 | (%filament:set-sample-count 39 | '(claw-utils:claw-pointer %filament:view) view 40 | '%filament:uint8-t (floor count))) 41 | 42 | 43 | (defun (setf view-dithering) (dithering view) 44 | (%filament:set-dithering 45 | '(claw-utils:claw-pointer %filament:view) view 46 | '%filament:view+dithering (view-dithering-enum dithering))) 47 | 48 | 49 | (defun update-view-bloom-options (view &key (enabled nil enabled-provided-p)) 50 | (iffi:with-intricate-instance (bloom-options %filament:bloom-options) 51 | (iffi:with-intricate-slots %filament:bloom-options 52 | ((bloom-enabled %filament:enabled)) bloom-options 53 | (when enabled-provided-p 54 | (setf bloom-enabled enabled)) 55 | (%filament:set-bloom-options 56 | '(claw-utils:claw-pointer %filament:view) view 57 | '(claw-utils:claw-pointer %filament:view+bloom-options) bloom-options)))) 58 | 59 | 60 | (defun disable-view-color-grading (view) 61 | (%filament:set-color-grading 62 | '(claw-utils:claw-pointer %filament:view) view 63 | '(claw-utils:claw-pointer %filament:color-grading) (cffi:null-pointer))) 64 | 65 | 66 | (defun (setf view-post-processing-enabled-p) (enabled-p view) 67 | (%filament:set-post-processing-enabled 68 | '(claw-utils:claw-pointer %filament:view) view 69 | :bool enabled-p)) 70 | 71 | 72 | (defun (setf view-shadows-enabled-p) (enabled-p view) 73 | (%filament:set-shadowing-enabled 74 | '(claw-utils:claw-pointer %filament:view) view 75 | :bool enabled-p)) 76 | 77 | 78 | (defun (setf view-blend-mode) (mode view) 79 | (%filament:set-blend-mode 80 | '(claw-utils:claw-pointer %filament:view) view 81 | '%filament:view+blend-mode mode)) 82 | 83 | 84 | (defun update-view-viewport (view x y width height) 85 | (iffi:with-intricate-instance (viewport %filament:viewport 86 | '%filament:int32-t (floor x) 87 | '%filament:int32-t (floor y) 88 | '%filament:uint32-t (floor width) 89 | '%filament:uint32-t (floor height)) 90 | (%filament:set-viewport 91 | '(claw-utils:claw-pointer %filament:view) view 92 | '(claw-utils:claw-pointer %filament:viewport) viewport))) 93 | -------------------------------------------------------------------------------- /tools/resources/scene/scene.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.tools.resources) 2 | 3 | 4 | ;;; 5 | ;;; LOGGING 6 | ;;; 7 | (cffi:defcallback write-assimp-log :void ((message :pointer) (data :pointer)) 8 | (declare (ignore data)) 9 | (format *standard-output* "~A" (cffi:foreign-string-to-lisp message))) 10 | 11 | 12 | (defmacro with-logging (() &body body) 13 | (a:with-gensyms (logger) 14 | `(cref:c-with ((,logger (:struct %ai:log-stream))) 15 | (setf (,logger :callback) (cffi:callback write-assimp-log)) 16 | (%ai:attach-log-stream (,logger &)) 17 | (unwind-protect 18 | (progn ,@body) 19 | (%ai:detach-log-stream (,logger &)))))) 20 | 21 | 22 | ;;; 23 | ;;; SCENE 24 | ;;; 25 | (u:define-enumbit-combiner post-process-steps-bit %assimp:post-process-steps) 26 | 27 | 28 | (defun call-with-scene (path callback) 29 | (with-logging () 30 | (let* ((*scene* (%ai:import-file (namestring (truename path)) 31 | (logior %ai:+process-preset-target-realtime-max-quality+ 32 | (post-process-steps-bit :optimize-graph 33 | :find-instances 34 | :optimize-meshes 35 | :calc-tangent-space 36 | :gen-smooth-normals 37 | :gen-uv-coords 38 | :debone 39 | :sort-by-p-type 40 | :join-identical-vertices 41 | :triangulate 42 | :improve-cache-locality 43 | :gen-bounding-boxes))))) 44 | (unless *scene* 45 | (error "Failed to parse asset file '~A'" path)) 46 | (unwind-protect 47 | (funcall callback) 48 | (%ai:release-import *scene*))))) 49 | 50 | 51 | (defmacro with-imported-scene ((path) &body body) 52 | `(call-with-scene ,path (lambda () ,@body))) 53 | 54 | 55 | (defclass scene () 56 | ((meshes :initarg :meshes :initform nil :reader scene-meshes) 57 | (images :initarg :images :initform nil :reader scene-images))) 58 | 59 | 60 | (defun destroy-scene (scene) 61 | (with-slots (meshes images) scene 62 | (loop for mesh in meshes 63 | do (destroy-mesh mesh)) 64 | (loop for image in images 65 | do (destroy-image image)))) 66 | 67 | 68 | (defun parse-scene (path) 69 | (with-imported-scene (path) 70 | (let* ((*images* (list)) 71 | (*materials* (loop with table = (make-hash-table :test #'equal) 72 | for material in (parse-materials) 73 | do (setf (gethash (material-id material) table) material) 74 | finally (return table)))) 75 | (make-instance 'scene 76 | :meshes (parse-meshes) 77 | :images (loop for image in *images* 78 | for full-path = (merge-pathnames 79 | image 80 | (uiop:pathname-directory-pathname path)) 81 | collect (load-image image full-path)))))) 82 | -------------------------------------------------------------------------------- /src/audio/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage :alien-works.audio.openal 2 | (:local-nicknames (:u :alien-works.utils) 3 | (:cref :cffi-c-ref) 4 | (:%math :%alien-works.math) 5 | (:math :alien-works.math) 6 | (:sv :static-vectors)) 7 | (:use :cl) 8 | (:export #:with-context 9 | #:do-output-audio-devices 10 | 11 | #:play-pcm-s16-mono 12 | 13 | #:audio-listener-gain 14 | #:audio-listener-position 15 | #:audio-listener-velocity 16 | #:audio-listener-orientation 17 | 18 | #:make-audio-buffer 19 | #:audio-buffer-data 20 | #:destroy-audio-buffer 21 | 22 | #:make-audio-source 23 | #:destroy-audio-source 24 | #:audio-source-state 25 | #:audio-source-buffer 26 | #:play-audio-source 27 | #:pause-audio-source 28 | #:stop-audio-source 29 | #:audio-source-pitch 30 | #:audio-source-gain 31 | #:audio-source-distance 32 | #:audio-source-max-distance 33 | #:audio-source-reference-distance 34 | #:audio-source-rolloff 35 | #:audio-source-position 36 | #:audio-source-velocity 37 | #:audio-source-direction 38 | #:audio-source-offset 39 | #:audio-source-looping-p)) 40 | 41 | 42 | (cl:defpackage :alien-works.audio.opus 43 | (:local-nicknames (:u :alien-works.utils) 44 | (:host :alien-works.host) 45 | (:a :alexandria) 46 | (:cref :cffi-c-ref) 47 | (:sv :static-vectors)) 48 | (:use :cl) 49 | (:export #:encode-audio 50 | #:decode-audio)) 51 | 52 | 53 | (cl:defpackage :%alien-works.audio 54 | (:export #:with-audio)) 55 | 56 | 57 | (cl:defpackage :alien-works.audio 58 | (:local-nicknames (:%aw.al :alien-works.audio.openal) 59 | (:%aw.opus :alien-works.audio.opus) 60 | (:%audio :%alien-works.audio)) 61 | (:use :cl) 62 | (:import-from :alien-works.audio.openal 63 | #:do-output-audio-devices 64 | #:audio-listener-gain 65 | #:audio-listener-position 66 | #:audio-listener-velocity 67 | #:audio-listener-orientation 68 | #:audio-source-pitch 69 | #:audio-source-gain 70 | #:audio-source-distance 71 | #:audio-source-max-distance 72 | #:audio-source-reference-distance 73 | #:audio-source-rolloff 74 | #:audio-source-position 75 | #:audio-source-velocity 76 | #:audio-source-direction 77 | #:audio-source-offset 78 | #:audio-source-looping-p) 79 | (:export #:play-audio 80 | #:decode-audio 81 | #:encode-audio 82 | 83 | #:make-audio-buffer 84 | #:destroy-audio-buffer 85 | 86 | #:make-audio-source 87 | #:make-audio-source-from-pcm 88 | #:destroy-audio-source 89 | #:play-audio-source 90 | #:pause-audio-source 91 | #:stop-audio-source 92 | #:audio-source-state 93 | #:audio-source-pitch 94 | #:audio-source-gain 95 | #:audio-source-distance 96 | #:audio-source-max-distance 97 | #:audio-source-reference-distance 98 | #:audio-source-rolloff 99 | #:audio-source-position 100 | #:audio-source-velocity 101 | #:audio-source-direction 102 | #:audio-source-offset 103 | #:audio-source-looping-p 104 | 105 | #:do-output-audio-devices 106 | #:audio-listener-gain 107 | #:audio-listener-position 108 | #:audio-listener-velocity 109 | #:audio-listener-orientation)) 110 | -------------------------------------------------------------------------------- /tools/resources/image.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.tools.resources) 2 | 3 | 4 | (defun load-image (path) 5 | (%awt.fm:decode-image (alexandria:read-file-into-byte-vector path))) 6 | 7 | 8 | (defun load-image-from-octet-vector (data) 9 | (%awt.fm:decode-image data)) 10 | 11 | 12 | (defun save-image (image path) 13 | (host:with-open-host-file (out path :direction :output) 14 | (%host:write-foreign-array (%awt.fm:image-data-ptr image) 15 | (%awt.fm:image-data-size image) 16 | out))) 17 | 18 | 19 | (defun read-image-into-octet-vector (image) 20 | (let* ((data-ptr (%awt.fm:image-data-ptr image)) 21 | (data-size (%awt.fm:image-data-size image)) 22 | (result (make-array data-size :element-type '(unsigned-byte 8)))) 23 | (u:with-pinned-array-pointer (result-ptr result) 24 | (alien-works:memcpy result-ptr data-ptr data-size)) 25 | result)) 26 | 27 | 28 | (defun encode-image-octet-vector-into-png (data width height channels) 29 | (let ((image (%awt.fm:make-image width height channels))) 30 | (unwind-protect 31 | (alien-works:with-memory-vector (tmp 32 | (%awt.fm:image-data-size image)) 33 | (u:with-pinned-array-pointer (data-ptr data) 34 | (host:memcpy (%awt.fm:image-data-ptr image) 35 | data-ptr 36 | (%awt.fm:image-data-size image))) 37 | (let ((written (%awt.fm:encode-image image tmp :format :png))) 38 | (make-array written :element-type '(unsigned-byte 8) 39 | :initial-contents tmp)))))) 40 | 41 | 42 | (defun images-to-cubemap-cross (px-path nx-path py-path ny-path pz-path nz-path 43 | target-path) 44 | (let* ((images (loop for path in (list px-path nx-path py-path ny-path pz-path nz-path) 45 | collect (load-image path))) 46 | (width (%awt.fm:image-width (first images))) 47 | (height (%awt.fm:image-height (first images))) 48 | (channels (%awt.fm:image-channels (first images)))) 49 | (loop for image in images 50 | unless (and (= (%awt.fm:image-width image) width) 51 | (= (%awt.fm:image-height image) height) 52 | (= (%awt.fm:image-channels image) channels)) 53 | do (error "Cubemap face image with wrong dimensions found")) 54 | (let* ((target-width (* width 4)) 55 | (target-height (* height 3)) 56 | (target-size (* channels target-width target-height)) 57 | (target-data (cffi:foreign-alloc :char :count target-size))) 58 | (host:memset target-data 0 target-size) 59 | (flet ((%insert (image x-sector y-sector) 60 | (let ((x (* x-sector width)) 61 | (y (* y-sector height))) 62 | (loop with dst-stride = (* target-width channels) 63 | with src-stride = (* width channels) 64 | with src-data = (%awt.fm:image-data-ptr image) 65 | for j below height 66 | for dst-ptr = (cffi:inc-pointer target-data (+ (* x channels) (* y dst-stride))) 67 | then (cffi:inc-pointer dst-ptr dst-stride) 68 | for src-ptr = src-data then (cffi:inc-pointer src-ptr src-stride) 69 | do (host:memcpy dst-ptr src-ptr src-stride))))) 70 | (destructuring-bind (px nx py ny pz nz) images 71 | (%insert px 2 1) 72 | (%insert nx 0 1) 73 | (%insert py 1 0) 74 | (%insert ny 1 2) 75 | (%insert pz 1 1) 76 | (%insert nz 3 1)) 77 | (not 78 | (zerop 79 | (save-image (make-instance 'image 80 | :width target-width 81 | :height target-height 82 | :data target-data 83 | :channels channels 84 | :name (file-namestring target-path)) 85 | target-path))))))) 86 | -------------------------------------------------------------------------------- /src/graphics/filament/material.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.filament) 2 | 3 | 4 | ;;; 5 | ;;; MATERIAL PARSER 6 | ;;; 7 | (warp-intricate-builder-option material-builder :package 8 | %filament:package 9 | '(claw-utils:claw-pointer %filament::material+builder) 10 | '(claw-utils:claw-pointer :void) 11 | '%filament:size-t) 12 | 13 | 14 | (defmacro with-material-builder ((name &rest steps) &body body) 15 | (flet ((ctor-expander () 16 | '(%filament:material+builder)) 17 | (build-expander (builder) 18 | `(%filament:build 19 | '(claw-utils:claw-pointer %filament:material+builder) ,builder 20 | '(claw-utils:claw-pointer %filament:engine) !::engine))) 21 | (explode-builder name 22 | 'material-builder 23 | #'ctor-expander 24 | #'build-expander 25 | '(!::engine) 26 | steps 27 | body))) 28 | 29 | 30 | (defun destroy-material (engine material) 31 | (%filament:destroy 32 | '(claw-utils:claw-pointer %filament::engine) engine 33 | '(claw-utils:claw-pointer %filament::material) material)) 34 | 35 | 36 | (defun material-name (material) 37 | (cffi:foreign-string-to-lisp 38 | (%filament:get-name 39 | :const 40 | '(claw-utils:claw-pointer %filament::material) material))) 41 | 42 | 43 | (defun default-material-instance (material) 44 | (%filament:get-default-instance 45 | '(claw-utils:claw-pointer %filament::material) material)) 46 | 47 | 48 | (defun make-material-instance (material &optional name) 49 | (%filament:create-instance 50 | :const 51 | '(claw-utils:claw-pointer %filament::material) material 52 | 'claw-utils:claw-string (or name (cffi:null-pointer)))) 53 | 54 | 55 | (defun material-instance-name (material) 56 | (cffi:foreign-string-to-lisp 57 | (%filament:get-name 58 | :const 59 | '(claw-utils:claw-pointer %filament::material-instance) material))) 60 | 61 | 62 | (defun destroy-material-instance (engine instance) 63 | (%filament:destroy 64 | '(claw-utils:claw-pointer %filament::engine) engine 65 | '(claw-utils:claw-pointer %filament::material-instance) instance)) 66 | 67 | 68 | (defun (setf material-instance-parameter-float) (value material name) 69 | (cref:c-with ((fval :float)) 70 | (setf fval (float value 0f0)) 71 | (%filament:set-parameter 72 | '(claw-utils:claw-pointer %filament::material-instance) material 73 | 'claw-utils:claw-string name 74 | '(claw-utils:claw-pointer :float) (fval &))) 75 | value) 76 | 77 | 78 | (defun (setf material-instance-parameter-float2) (value material name) 79 | (%filament:set-parameter 80 | '(claw-utils:claw-pointer %filament::material-instance) material 81 | 'claw-utils:claw-string name 82 | '(claw-utils:claw-pointer %filament::math+float2) value)) 83 | 84 | 85 | (defun (setf material-instance-parameter-float3) (value material name) 86 | (%filament:set-parameter 87 | '(claw-utils:claw-pointer %filament::material-instance) material 88 | 'claw-utils:claw-string name 89 | '(claw-utils:claw-pointer %filament::math+float3) value)) 90 | 91 | 92 | (defun (setf material-instance-parameter-float4) (value material name) 93 | (%filament:set-parameter 94 | '(claw-utils:claw-pointer %filament::material-instance) material 95 | 'claw-utils:claw-string name 96 | '(claw-utils:claw-pointer %filament::math+float4) value)) 97 | 98 | 99 | (defun (setf material-instance-parameter-mat3) (mat3 material name) 100 | (%filament:set-parameter 101 | '(claw-utils:claw-pointer %filament::material-instance) material 102 | 'claw-utils:claw-string name 103 | '(claw-utils:claw-pointer %filament::math+mat3f) mat3)) 104 | 105 | 106 | (defun (setf material-instance-parameter-mat4) (mat4 material name) 107 | (%filament:set-parameter 108 | '(claw-utils:claw-pointer %filament::material-instance) material 109 | 'claw-utils:claw-string name 110 | '(claw-utils:claw-pointer %filament::math+mat4f) mat4)) 111 | 112 | 113 | (defun (setf material-instance-parameter-sampler) (value material name texture) 114 | (%filament::set-parameter 115 | '(claw-utils:claw-pointer %filament::material-instance) material 116 | 'claw-utils:claw-string name 117 | '(claw-utils:claw-pointer %filament::texture) texture 118 | '(claw-utils:claw-pointer %filament::texture-sampler) value)) 119 | -------------------------------------------------------------------------------- /src/host/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage :%alien-works.host 2 | (:use) 3 | (:export #:with-window 4 | 5 | #:get-clipboard-foreign-text 6 | #:set-clipboard-foreign-text 7 | 8 | #:event-input-foreign-text 9 | 10 | #:make-shared-context-thread 11 | #:window-graphics-context 12 | #:window-surface 13 | 14 | #:write-foreign-array)) 15 | 16 | 17 | (cl:defpackage :alien-works.host 18 | (:local-nicknames (:cref :cffi-c-ref) 19 | (:a :alexandria) 20 | (:gray :trivial-gray-streams) 21 | (:sv :static-vectors) 22 | (:u :alien-works.utils) 23 | (:%host :%alien-works.host) 24 | (:%math :%alien-works.math)) 25 | (:use :cl :%alien-works.host) 26 | (:export #:display-name 27 | #:display-x 28 | #:display-y 29 | #:display-width 30 | #:display-height 31 | #:display-orientation 32 | #:display-dpi 33 | #:list-displays 34 | 35 | #:window-display 36 | #:window-width 37 | #:window-height 38 | #:framebuffer-width 39 | #:framebuffer-height 40 | 41 | #:handle-events 42 | #:event-kind 43 | #:event-key-scan-code 44 | #:event-mouse-button 45 | #:event-mouse-wheel 46 | #:event-mouse-position 47 | #:event-game-controller-id 48 | #:event-game-controller-button 49 | #:event-gamepad-id 50 | #:event-gamepad-button 51 | #:event-text-input 52 | 53 | #:make-mouse-state 54 | #:mouse-state 55 | #:mouse-state-x 56 | #:mouse-state-y 57 | #:mouse-state-left-button-pressed-p 58 | #:mouse-state-right-button-pressed-p 59 | #:mouse-state-middle-button-pressed-p 60 | 61 | #:make-keyboard-modifier-state 62 | #:keyboard-modifier-state 63 | #:keyboard-modifier-state-pressed-p 64 | #:keyboard-modifier-state-some-pressed-p 65 | 66 | #:event-finger-id 67 | #:event-finger-x 68 | #:event-finger-y 69 | #:event-finger-x-offset 70 | #:event-finger-y-offset 71 | #:event-finger-position 72 | 73 | #:event-simple-gesture-finger-count 74 | #:event-simple-gesture-distance-offset 75 | #:event-simple-gesture-rotation-offset 76 | #:event-simple-gesture-x 77 | #:event-simple-gesture-y 78 | 79 | #:scancode 80 | 81 | #:do-game-controller-ids 82 | #:grab-game-controller 83 | #:release-game-controller 84 | #:game-controller-name-by-id 85 | #:game-controller-name 86 | #:game-controller-power-level 87 | #:game-controller-haptic-p 88 | #:game-controller-button-count 89 | #:game-controller-button-pressed-p 90 | #:game-controller-axes-count 91 | #:game-controller-axis-short-value 92 | #:game-controller-axis-float-value 93 | #:game-controller-ball-count 94 | #:game-controller-ball-value 95 | #:game-controller-hat-count 96 | #:game-controller-hat-value 97 | 98 | #:load-gamepad-mappings-from-host-file 99 | #:do-gamepad-ids 100 | #:gamepad-name-by-id 101 | #:grab-gamepad 102 | #:release-gamepad 103 | #:gamepad-name 104 | #:gamepad-power-level 105 | #:gamepad-haptic-p 106 | #:gamepad-button-pressed-p 107 | #:gamepad-axis-short-value 108 | #:gamepad-axis-float-value 109 | 110 | #:do-haptic-device-ids 111 | #:grab-haptic-device 112 | #:grab-game-controller-haptic-device 113 | #:grab-gamepad-haptic-device 114 | #:release-haptic-device 115 | #:add-rumble 116 | #:play-rumble 117 | 118 | #:run 119 | #:definit 120 | 121 | #:memcpy 122 | #:memset 123 | #:open-host-file 124 | #:with-open-host-file 125 | #:read-host-file-into-static-vector 126 | #:read-host-file-into-shareable-vector 127 | #:working-directory 128 | 129 | #:delay 130 | #:clock-clicks-per-second 131 | #:clock-clicks 132 | #:within-clicks-frame)) 133 | -------------------------------------------------------------------------------- /src/graphics/varjo/varjo.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.varjo) 2 | 3 | 4 | (declaim (special *root-function*)) 5 | 6 | 7 | (defun gen-shader-string (post-proc-obj) 8 | (let* ((funcs (varjo.internals::all-functions post-proc-obj)) 9 | (func-code (remove nil (mapcar #'varjo.internals::glsl-code funcs))) 10 | (func-sigs (remove nil (a:mappend #'varjo.internals::signatures funcs)))) 11 | (with-slots (env) post-proc-obj 12 | (format 13 | nil "~{~%~{~a~%~}~}" 14 | (remove nil 15 | (list (varjo.internals::used-user-structs post-proc-obj) 16 | (varjo.internals::gs-invocations post-proc-obj) 17 | (varjo.internals::shared-decls post-proc-obj) 18 | (varjo.internals::remove-empty 19 | (append 20 | (mapcar #'varjo.internals::%glsl-decl 21 | (varjo.internals::uniforms post-proc-obj)) 22 | (mapcar #'varjo.internals::%glsl-decl 23 | (varjo.internals::stemcells post-proc-obj)))) 24 | func-sigs 25 | (reverse func-code))))))) 26 | 27 | 28 | (defun final-string-compose (post-proc-obj) 29 | (values (gen-shader-string post-proc-obj) 30 | post-proc-obj)) 31 | 32 | (defgeneric compile-pass (stage env)) 33 | 34 | (defun make-entry-function (entry-name env) 35 | (let ((func (first 36 | (varjo.internals::get-external-function-by-name *root-function* nil)))) 37 | (varjo.internals:build-function entry-name 38 | (varjo.internals::in-args func) 39 | (varjo.internals::code func) 40 | nil env))) 41 | 42 | (defmethod compile-pass ((stage varjo.internals::vertex-stage) env) 43 | (values (make-entry-function :|materialVertex| env) 44 | stage 45 | env)) 46 | 47 | 48 | (defmethod compile-pass ((stage varjo.internals::fragment-stage) env) 49 | (values (make-entry-function :|material| env) 50 | stage 51 | env)) 52 | 53 | 54 | (defun format-glsl (root-function stage-kind) 55 | (varjo.internals::flow-id-scope 56 | (let* ((stage (varjo:make-stage stage-kind '() nil '(:330) `((return)))) 57 | (env (varjo.internals::%make-base-environment stage)) 58 | (*root-function* root-function)) 59 | 60 | (varjo.utils::pipe-> (stage env) 61 | #'varjo.internals::add-context-glsl-vars 62 | #'varjo.internals::add-context-glsl-funcs 63 | #'varjo.internals::validate-inputs 64 | #'varjo.internals::process-primitive-type 65 | #'varjo.internals::expand-input-variables 66 | #'varjo.internals::process-uniforms 67 | #'varjo.internals::process-shared 68 | #'compile-pass 69 | #'varjo.internals::make-post-process-obj 70 | #'varjo.internals::process-gs-invocations 71 | #'varjo.internals::process-output-primitive 72 | #'varjo.internals::make-out-set 73 | #'varjo.internals::check-stemcells 74 | #'varjo.internals::filter-used-items 75 | #'varjo.internals::validate-outputs 76 | #'varjo.internals::gen-in-arg-strings 77 | #'varjo.internals::gen-in-decl-strings 78 | #'varjo.internals::gen-out-var-strings 79 | #'varjo.internals::final-uniform-strings 80 | #'varjo.internals::gen-shared-decls 81 | #'varjo.internals::dedup-used-types 82 | #'final-string-compose)))) 83 | 84 | 85 | (varjo.internals::define-vari-special-operator letvar (bindings &rest body) 86 | :args-valid t 87 | :return 88 | (let* ((binding-names (mapcar (lambda (_) (varjo.utils:nth-or-self 0 _)) bindings)) 89 | (dup-names (varjo.utils::find-duplicates binding-names))) 90 | (assert (not dup-names) () 'dup-names-in-let :names dup-names) 91 | (unless body 92 | (error 'body-block-empty :form-name 'let)) 93 | (let ((updated-env (loop with updated-env = env 94 | for (name glsl-name type &key read-only) in bindings 95 | do (setf updated-env 96 | (varjo.internals:add-symbol-binding 97 | name 98 | (varjo.internals::v-make-value 99 | (varjo.internals::type-spec->type 100 | type 101 | (varjo.internals::%gl-flow-id!)) 102 | env 103 | :glsl-name glsl-name 104 | :read-only read-only) 105 | updated-env)) 106 | finally (return updated-env)))) 107 | (varjo.internals::merge-progn 108 | (varjo.internals::compile-progn body updated-env) env updated-env)))) 109 | -------------------------------------------------------------------------------- /tools/graphics/filament/material.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.tools.filament) 2 | 3 | 4 | (u:define-enumval-extractor target-api-enum %filament.util:matc+config+target-api) 5 | (u:define-enumval-extractor platform-enum %filament.util:matc+config+platform) 6 | (u:define-enumval-extractor optimization-enum %filament.util:matc+config+optimization) 7 | 8 | ;;; 9 | ;;; MATERIAL COMPILER 10 | ;;; 11 | (defun serialize-material (source &key base-path debug 12 | target-api 13 | platform 14 | optimization) 15 | ;; fixme: pray i can convince filament authors to remove assert for material 16 | ;; file existence 17 | (uiop:with-temporary-file (:pathname temp-file :directory base-path) 18 | (let ((name (uiop:native-namestring temp-file))) 19 | (iffi:with-intricate-instances ((config %filament.util:aw+filament+tools+memio+in-memory-config 20 | 'claw-utils:claw-string name 21 | 'claw-utils:claw-string source 22 | ;; FIXME: this is not really a good way 23 | ;; to figure out real unicode string length 24 | '%filament.util:size-t (length source)) 25 | (compiler %filament.util:matc+material-compiler)) 26 | 27 | (%filament.util:aw+filament+tools+memio+set-debug 28 | '(claw-utils:claw-pointer %filament.util::aw+filament+tools+memio+in-memory-config) config 29 | :bool (and debug t)) 30 | 31 | (%filament.util:aw+filament+tools+memio+set-target-api 32 | '(claw-utils:claw-pointer %filament.util::aw+filament+tools+memio+in-memory-config) config 33 | '%filament.util::matc+config+target-api (or target-api :all)) 34 | 35 | (%filament.util:aw+filament+tools+memio+set-platform 36 | '(claw-utils:claw-pointer %filament.util::aw+filament+tools+memio+in-memory-config) config 37 | '%filament.util::matc+config+platform (or platform :all)) 38 | 39 | (%filament.util:aw+filament+tools+memio+set-output-format 40 | '(claw-utils:claw-pointer %filament.util::aw+filament+tools+memio+in-memory-config) config 41 | '%filament.util::matc+config+output-format :blob) 42 | 43 | (%filament.util:matc+set-optimization-level 44 | '(claw-utils:claw-pointer %filament.util::matc+config) config 45 | '%filament.util::matc+config+optimization (or optimization :performance)) 46 | 47 | (%filament.util:matc+run '(:pointer %filament.util::matc+material-compiler) compiler 48 | '(:pointer %filament.util::matc+config) config) 49 | 50 | (let* ((out (%filament.util:aw+filament+tools+memio+get-output 51 | :const 52 | '(:pointer %filament.util::aw+filament+tools+memio+in-memory-config) config))) 53 | (%filament.util:aw+filament+tools+memio+material-data 54 | '(:pointer %filament.util::aw+filament+tools+memio+in-memory-output) out)))))) 55 | 56 | 57 | (defun destroy-material-data (data) 58 | ;; we can't use intricate destroy here because instance was allocated in 59 | ;; foreign code using unaligend (default) allocation 60 | (%filament.util:aw+filament+tools+memio+~material-data 61 | '(:pointer %filament.util:aw+filament+tools+memio+material-data) data)) 62 | 63 | 64 | (defun material-data-pointer (data) 65 | (%filament.util:aw+filament+tools+memio+data 66 | '(:pointer %filament.util::aw+filament+tools+memio+material-data) data)) 67 | 68 | 69 | (defun material-data-size (data) 70 | (%filament.util:aw+filament+tools+memio+size 71 | '(:pointer %filament.util::aw+filament+tools+memio+material-data) data)) 72 | 73 | 74 | (defmacro with-serialized-material-data ((material-data source &key base-path debug 75 | target-api 76 | platform 77 | optimization) 78 | &body body) 79 | `(let ((,material-data (serialize-material ,source 80 | ,@(when base-path 81 | `(:base-path ,base-path)) 82 | ,@(when debug 83 | `(:debug ,debug)) 84 | ,@(when target-api 85 | `(:target-api ,target-api)) 86 | ,@(when platform 87 | `(:platform ,platform)) 88 | ,@(when optimization 89 | `(:optimization ,optimization))))) 90 | (unwind-protect 91 | (progn ,@body) 92 | (destroy-material-data ,material-data)))) 93 | -------------------------------------------------------------------------------- /src/memory/memory.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.memory) 2 | 3 | 4 | (defun symbolicate-memory-layout-name (name) 5 | (u:symbolicate* name '$alien-works$memory-layout)) 6 | 7 | 8 | (defun find-foreign-type (type) 9 | (let ((layout-type `(:struct 10 | ,(symbolicate-memory-layout-name 11 | type)))) 12 | (if (ignore-errors (cffi::parse-type layout-type)) 13 | (values layout-type t) 14 | (if (ignore-errors (cffi::parse-type type)) 15 | (values type nil) 16 | nil)))) 17 | 18 | 19 | (defmacro define-memory-layout (name-and-opts &body slots) 20 | (destructuring-bind (name &rest opts) (a:ensure-list name-and-opts) 21 | (declare (ignore opts)) 22 | (let ((safe-name (symbolicate-memory-layout-name name))) 23 | `(cffi:defcstruct ,safe-name 24 | ,@(loop for slot in slots 25 | collect (destructuring-bind (name type &rest rest) slot 26 | `(,name 27 | ,(or (find-foreign-type type) type) 28 | ,@rest))))))) 29 | 30 | 31 | (defun memory-layout-slot-offset (layout slot-name) 32 | (let* ((type `(:struct ,(symbolicate-memory-layout-name layout))) 33 | (slot (cref::find-slot-name type slot-name))) 34 | (cffi:foreign-slot-offset type slot))) 35 | 36 | 37 | (define-compiler-macro memory-layout-slot-offset (&whole whole layout slot-name) 38 | (let ((unquoted-layout (u:unquote layout)) 39 | (unquoted-slot-name (u:unquote slot-name))) 40 | (if (and (not (eq layout unquoted-layout)) 41 | (and (or (keywordp slot-name) 42 | (not (eq unquoted-slot-name slot-name))))) 43 | (let ((type `(:struct ,(symbolicate-memory-layout-name unquoted-layout)))) 44 | `(cffi:foreign-slot-offset 45 | ,type 46 | ',(cref::find-slot-name type slot-name))) 47 | whole))) 48 | 49 | 50 | (defun memory-layout-size (layout-name) 51 | (cffi:foreign-type-size `(:struct ,(symbolicate-memory-layout-name layout-name)))) 52 | 53 | 54 | (define-compiler-macro memory-layout-size (&whole whole layout-name) 55 | (let ((unquoted-layout (u:unquote layout-name))) 56 | (if (not (eq layout-name unquoted-layout)) 57 | `(cffi:foreign-type-size 58 | '(:struct 59 | ,(symbolicate-memory-layout-name unquoted-layout))) 60 | whole))) 61 | 62 | 63 | (defmacro access-memory (memory-vector layout &rest accessors) 64 | `(cref:c-ref (memory-vector-pointer ,memory-vector) 65 | ',(symbolicate-memory-layout-name (u:unquote layout)) 66 | ,@accessors)) 67 | 68 | 69 | (defmacro with-memory-access ((name memory-vector layout &key offset) &body body) 70 | `(cref:c-let ((,name (:struct ,(symbolicate-memory-layout-name layout)) 71 | :from ,(if offset 72 | `(cffi:inc-pointer 73 | (memory-vector-pointer ,memory-vector) 74 | ,offset) 75 | `(memory-vector-pointer ,memory-vector)))) 76 | ,@body)) 77 | 78 | 79 | (defun make-memory-vector (length &key (type :uint8) initial-contents) 80 | (sv:make-static-vector (* length (find-foreign-type type)) 81 | :element-type '(unsigned-byte 8) 82 | :initial-contents initial-contents)) 83 | 84 | 85 | (define-compiler-macro make-memory-vector (&whole whole length &key (type :uint8) initial-contents) 86 | (let ((actual-type (find-foreign-type (u:unquote type)))) 87 | (if actual-type 88 | `(sv:make-static-vector (* ,length ,(cffi:foreign-type-size actual-type)) 89 | :element-type '(unsigned-byte 8) 90 | ,@(when initial-contents 91 | `(:initial-contents ,initial-contents))) 92 | whole))) 93 | 94 | 95 | (defun %alien-works.memory:memory-vector-pointer (memory-vector &optional offset) 96 | (let ((ptr (sv:static-vector-pointer memory-vector))) 97 | (if offset 98 | (cffi:inc-pointer ptr offset) 99 | ptr))) 100 | 101 | 102 | (define-compiler-macro %alien-works.memory:memory-vector-pointer (memory-vector 103 | &optional offset) 104 | (if offset 105 | `(cffi:inc-pointer (sv:static-vector-pointer ,memory-vector) ,offset) 106 | `(sv:static-vector-pointer ,memory-vector))) 107 | 108 | 109 | (defun destroy-memory-vector (memory-vector) 110 | (sv:free-static-vector memory-vector)) 111 | 112 | 113 | (defmacro with-memory-vector ((binding length &optional type) &body body) 114 | `(let ((,binding (make-memory-vector ,length ,@(when type `(',type))))) 115 | (unwind-protect 116 | (progn ,@body) 117 | (destroy-memory-vector ,binding)))) 118 | 119 | 120 | (defmacro with-memory-vectors (bindings &body body) 121 | (labels ((%expand (bindings) 122 | (if bindings 123 | `(with-memory-vector ,(first bindings) 124 | ,(%expand (rest bindings))) 125 | `(progn ,@body)))) 126 | (%expand bindings))) 127 | -------------------------------------------------------------------------------- /tools/resources/gltf.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.tools.resources) 2 | 3 | ;;; 4 | ;;; MATERIAL PROVIDER 5 | ;;; 6 | (defun make-material-provider () 7 | (%filament:gltfio+create-jit-shader-provider 8 | '(claw-utils:claw-pointer %filament::engine) (%alien-works.graphics:engine-handle) 9 | :bool t)) 10 | 11 | 12 | (defun destroy-material-provider (provider) 13 | (%filament:gltfio+~material-provider 14 | '(claw-utils:claw-pointer %filament::gltfio+material-provider) provider)) 15 | 16 | 17 | ;;; 18 | ;;; GLTF LOADER 19 | ;;; 20 | (defun make-gltf-loader (material-provider) 21 | (iffi:with-intricate-instance (cfg %filament:gltfio+asset-configuration) 22 | (iffi:with-intricate-slots %filament:gltfio+asset-configuration 23 | ((cfg-engine %filament:engine) 24 | (cfg-materials %filament:materials)) 25 | cfg 26 | (setf cfg-engine (%alien-works.graphics:engine-handle) 27 | cfg-materials material-provider)) 28 | 29 | (%filament:gltfio+asset-loader+create 30 | '(claw-utils:claw-pointer %filament:gltfio+asset-configuration) cfg))) 31 | 32 | 33 | (defun destroy-gltf-loader (loader) 34 | (cref:c-with ((ptr :pointer)) 35 | (setf ptr loader) 36 | (%filament:gltfio+asset-loader+destroy 37 | '(claw-utils:claw-pointer (claw-utils:claw-pointer %filament::gltfio+asset-loader)) (ptr &)))) 38 | 39 | 40 | (defun load-gltf-model-from-byte-vector (loader data) 41 | (u:with-pinned-array-pointer (ptr data) 42 | (%filament:gltfio+create-asset 43 | '(claw-utils:claw-pointer %filament::gltfio+asset-loader) loader 44 | '(claw-utils:claw-pointer %filament::uint8-t) ptr 45 | '%filament::uint32-t (length data)))) 46 | 47 | 48 | (defun load-gltf-model (loader path) 49 | (let ((data (host:read-host-file-into-static-vector path :element-type '(unsigned-byte 8)))) 50 | (unwind-protect 51 | (load-gltf-model-from-byte-vector loader data) 52 | (sv:free-static-vector data)))) 53 | 54 | 55 | (defun destroy-gltf-model (loader asset) 56 | (%filament:gltfio+destroy-asset 57 | '(claw-utils:claw-pointer %filament::gltfio+asset-loader) loader 58 | '(claw-utils:claw-pointer %filament::gltfio+filament-asset) asset)) 59 | 60 | 61 | (defun add-scene-gltf-model (scene asset) 62 | (let ((entities (%filament:gltfio+get-entities 63 | :const 64 | '(claw-utils:claw-pointer %filament::gltfio+filament-asset) asset)) 65 | (count (%filament:gltfio+get-entity-count 66 | :const 67 | '(claw-utils:claw-pointer %filament::gltfio+filament-asset) asset))) 68 | (%filament:add-entities 69 | '(claw-utils:claw-pointer %filament::scene) (alien-works.graphics::handle-of scene) 70 | '(claw-utils:claw-pointer %filament::utils+entity) entities 71 | '%filament::size-t count))) 72 | 73 | 74 | (defun remove-scene-gltf-model (scene asset) 75 | (let ((entities (%filament:gltfio+get-entities 76 | :const 77 | '(claw-utils:claw-pointer %filament::gltfio+filament-asset) asset)) 78 | (count (%filament:gltfio+get-entity-count 79 | :const 80 | '(claw-utils:claw-pointer %filament::gltfio+filament-asset) asset))) 81 | (%filament:remove-entities 82 | '(claw-utils:claw-pointer %filament::scene) (alien-works.graphics::handle-of scene) 83 | '(claw-utils:claw-pointer %filament::utils+entity) entities 84 | '%filament::size-t count))) 85 | 86 | 87 | (defun gltf-model-resource-names (asset) 88 | (let ((resource-uri-count (%filament:gltfio+get-resource-uri-count 89 | :const 90 | '(claw-utils:claw-pointer %filament::gltfio+filament-asset) asset)) 91 | (resources-uris (%filament:gltfio+get-resource-uris 92 | :const 93 | '(claw-utils:claw-pointer %filament::gltfio+filament-asset) asset))) 94 | (cref:c-val ((resources-uris (:pointer :string))) 95 | (loop for i from 0 below resource-uri-count 96 | collect (resources-uris i))))) 97 | 98 | 99 | ;;; 100 | ;;; RESOURCE LOADER 101 | ;;; 102 | (defun make-gltf-resource-loader () 103 | (iffi:with-intricate-instance (cfg %filament:gltfio+resource-configuration) 104 | (iffi:with-intricate-slots %filament:gltfio+resource-configuration 105 | ((cfg-engine %filament:engine)) 106 | cfg 107 | (setf cfg-engine (%alien-works.graphics:engine-handle))) 108 | 109 | (iffi:make-intricate-instance 110 | '%filament:gltfio+resource-loader 111 | '(claw-utils:claw-pointer %filament::gltfio+resource-configuration) cfg))) 112 | 113 | 114 | (defun destroy-gltf-resource-loader (loader) 115 | (iffi:destroy-intricate-instance '%filament:gltfio+resource-loader loader)) 116 | 117 | 118 | (defun load-gltf-model-resources (loader asset) 119 | (%filament:gltfio+load-resources 120 | '(claw-utils:claw-pointer %filament::gltfio+resource-loader) loader 121 | '(claw-utils:claw-pointer %filament::gltfio+filament-asset) asset)) 122 | 123 | 124 | (defmacro with-gltf-resource-loader ((loader) &body body) 125 | `(let ((,loader (make-gltf-resource-loader))) 126 | (unwind-protect 127 | (progn ,@body) 128 | (destroy-gltf-resource-loader ,loader)))) 129 | 130 | 131 | ;;; 132 | ;;; 133 | ;;; 134 | -------------------------------------------------------------------------------- /tools/resources/scene/utils.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.tools.resources) 2 | 3 | 4 | (declaim (special *scene* 5 | *mesh* 6 | *material* 7 | *images* 8 | *materials*)) 9 | 10 | 11 | (a:define-constant +attribute-alignment+ 4) 12 | 13 | 14 | (defvar *dry-run* nil) 15 | 16 | (defmacro with-ai-struct ((var type &optional value) &body body) 17 | `(cref:c-let ((,var (:struct ,type) :from ,(or value var))) 18 | ,@body)) 19 | 20 | 21 | (defmacro with-scene ((scene-var) &body body) 22 | `(with-ai-struct (,scene-var %ai:scene *scene*) 23 | ,@body)) 24 | 25 | 26 | (defmacro with-mesh ((mesh-var &optional mesh-val) &body body) 27 | `(with-ai-struct (,mesh-var %ai:mesh (or ,mesh-val *mesh*)) 28 | ,@body)) 29 | 30 | 31 | (defmacro with-material ((var &optional value) &body body) 32 | `(with-ai-struct (,var %ai:material (or ,value *material*)) 33 | ,@body)) 34 | 35 | 36 | (defmacro with-material-property ((var &optional value) &body body) 37 | `(with-ai-struct (,var %ai:material-property ,value) 38 | ,@body)) 39 | 40 | 41 | (defmacro with-vector3d ((var &optional src) &body body) 42 | (if src 43 | `(cref:c-let ((,var (:struct %ai:vector3d) :from ,src)) 44 | ,@body) 45 | `(cref:c-val ((,var (:struct %ai:vector3d))) 46 | ,@body))) 47 | 48 | 49 | (defmacro with-vector3d* ((&rest bindings) &body body) 50 | (u:expand-multibinding 'with-vector3d bindings body)) 51 | 52 | 53 | (defmacro with-color4d ((var &optional src) &body body) 54 | (if src 55 | `(cref:c-let ((,var (:struct %ai:color4d) :from ,src)) 56 | ,@body) 57 | `(cref:c-val ((,var (:struct %ai:color4d))) 58 | ,@body))) 59 | 60 | 61 | (defmacro with-face ((var &optional src) &body body) 62 | (if src 63 | `(cref:c-let ((,var (:struct %ai:face) :from ,src)) 64 | ,@body) 65 | `(cref:c-val ((,var (:struct %ai:face))) 66 | ,@body))) 67 | 68 | 69 | (defun ai-string-to-lisp (ai-string) 70 | (cref:c-val ((ai-string (:struct %ai:string))) 71 | (cffi:foreign-string-to-lisp (ai-string :data &) :count (ai-string :length)))) 72 | 73 | 74 | (defmacro write-primitives (buffer type values) 75 | (a:with-gensyms (idx value) 76 | (a:once-only (buffer) 77 | `(cref:c-val ((,buffer ,type)) 78 | (loop for ,value in ,values 79 | for ,idx from 0 80 | unless *dry-run* 81 | do (setf (,buffer ,idx) ,value) 82 | finally (return (* (cffi:foreign-type-size ,type) (1+ ,idx)))))))) 83 | 84 | 85 | (defun write-float (buffer &rest values) 86 | (write-primitives buffer :float values)) 87 | 88 | 89 | (defun write-int16 (buffer &rest values) 90 | (write-primitives buffer :int16 values)) 91 | 92 | 93 | (defun write-uint16 (buffer &rest values) 94 | (write-primitives buffer :uint16 values)) 95 | 96 | 97 | (defun write-uint32 (buffer &rest values) 98 | (write-primitives buffer :uint32 values)) 99 | 100 | 101 | (defun write-int8 (buffer &rest values) 102 | (write-primitives buffer :int8 values)) 103 | 104 | 105 | (defun normalize-uint8 (float) 106 | (let ((uint8-size (1- (ash 1 8)))) 107 | (round (* uint8-size (rem float 1f0))))) 108 | 109 | 110 | (defun denormalize-uint8 (value) 111 | (let ((uint8-size (1- (ash 1 8)))) 112 | (float (/ value uint8-size) 0f0))) 113 | 114 | 115 | (defun normalize-int16 (float) 116 | (let ((int16-size (1- (ash 1 15)))) 117 | (round (* int16-size (rem float 1f0))))) 118 | 119 | 120 | (defun normalize-uint16 (float) 121 | (let ((int16-size (1- (ash 1 16)))) 122 | (round (* int16-size (rem float 1f0))))) 123 | 124 | 125 | (defun calc-alignment-padding (bytes) 126 | (let* ((offset (mod bytes +attribute-alignment+))) 127 | (if (zerop offset) 128 | 0 129 | (- +attribute-alignment+ offset)))) 130 | 131 | 132 | (defun align-buffer (buffer) 133 | (let* ((address (cffi:pointer-address buffer)) 134 | (shift (calc-alignment-padding address))) 135 | (values (cffi:inc-pointer buffer shift) shift))) 136 | 137 | 138 | (defmacro dry-run (&body body) 139 | `(let ((*dry-run* t)) 140 | ,@body)) 141 | 142 | 143 | (defun make-simple-array (size type) 144 | #+lispworks 145 | (make-array size :element-type type :allocation :static) 146 | #+(or sbcl ccl ecl) 147 | (make-array size :element-type type) 148 | #-(or sbcl ccl ecl lispworks) 149 | (error "make-simple-array is not implemented for ~A" (lisp-implementation-type))) 150 | 151 | 152 | (defmacro with-simple-array-pointer ((pointer-var simple-array) &body body) 153 | (a:once-only (simple-array) 154 | #+sbcl 155 | `(sb-sys:with-pinned-objects (,simple-array) 156 | (let ((,pointer-var (sb-sys:vector-sap (sb-ext:array-storage-vector ,simple-array)))) 157 | ,@body)) 158 | #+ccl 159 | `(ccl:with-pointer-to-ivector (,pointer-var ,simple-array) 160 | ,@body) 161 | #+ecl 162 | `(let ((,pointer-var (si:make-foreign-data-from-array ,simple-array))) 163 | ,@body) 164 | #+lispworks 165 | `(fli:with-dynamic-lisp-array-pointer (,pointer-var ,simple-array) 166 | ,@body) 167 | #-(or sbcl ccl ecl lispworks) 168 | (error "with-simple-array-pointer is not implemented for ~A" (lisp-implementation-type)))) 169 | -------------------------------------------------------------------------------- /src/graphics/filament/light.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.filament) 2 | 3 | 4 | ;;; 5 | ;;; DIRECT 6 | ;;; 7 | (u:define-enumval-extractor light-type-enum %filament:light-manager+type) 8 | 9 | (warp-intricate-builder-option light-builder :cast-shadows 10 | %filament:cast-shadows 11 | '(claw-utils:claw-pointer %filament:light-manager+builder) 12 | ':bool) 13 | 14 | (warp-intricate-builder-option light-builder :shadow-options 15 | %filament:shadow-options 16 | '(claw-utils:claw-pointer %filament:light-manager+builder) 17 | '(claw-utils:claw-pointer %filament:light-manager+shadow-options)) 18 | 19 | (warp-intricate-builder-option light-builder :cast-light 20 | %filament:cast-light 21 | '(claw-utils:claw-pointer %filament:light-manager+builder) 22 | ':bool) 23 | 24 | (warp-intricate-builder-option light-builder :position 25 | %filament:position 26 | '(claw-utils:claw-pointer %filament:light-manager+builder) 27 | '(claw-utils:claw-pointer %filament:math+float3)) 28 | 29 | (warp-intricate-builder-option light-builder :direction 30 | %filament:direction 31 | '(claw-utils:claw-pointer %filament:light-manager+builder) 32 | '(claw-utils:claw-pointer %filament:math+float3)) 33 | 34 | (warp-intricate-builder-option light-builder :color 35 | %filament:color 36 | '(claw-utils:claw-pointer %filament:light-manager+builder) 37 | '(claw-utils:claw-pointer %filament:linear-color)) 38 | 39 | (warp-intricate-builder-option light-builder :intensity 40 | %filament:intensity-candela 41 | '(claw-utils:claw-pointer %filament:light-manager+builder) 42 | ':float) 43 | 44 | (warp-intricate-builder-option light-builder :intensity-efficiency 45 | %filament:intensity 46 | '(claw-utils:claw-pointer %filament:light-manager+builder) 47 | ':float 48 | ':float) 49 | 50 | (warp-intricate-builder-option light-builder :falloff 51 | %filament:falloff 52 | '(claw-utils:claw-pointer %filament:light-manager+builder) 53 | ':float) 54 | 55 | (warp-intricate-builder-option light-builder :spot-light-cone 56 | %filament:spot-light-cone 57 | '(claw-utils:claw-pointer %filament:light-manager+builder) 58 | ':float 59 | ':float) 60 | 61 | (warp-intricate-builder-option light-builder :sun-angular-radius 62 | %filament:sun-angular-radius 63 | '(claw-utils:claw-pointer %filament:light-manager+builder) 64 | ':float) 65 | 66 | (warp-intricate-builder-option light-builder :sun-halo-size 67 | %filament:sun-halo-size 68 | '(claw-utils:claw-pointer %filament:light-manager+builder) 69 | ':float) 70 | 71 | (warp-intricate-builder-option light-builder :sun-halo-falloff 72 | %filament:sun-halo-falloff 73 | '(claw-utils:claw-pointer %filament:light-manager+builder) 74 | ':float) 75 | 76 | 77 | (defmacro with-light-builder ((name (type) &body steps) &body body) 78 | (flet ((ctor-expander () 79 | `(%filament:light-manager+builder '%filament:light-manager+type 80 | (light-type-enum ,type))) 81 | (build-expander (builder) 82 | `(%filament:build 83 | '(claw-utils:claw-pointer %filament:light-manager+builder) ,builder 84 | '(claw-utils:claw-pointer %filament:engine) !::engine 85 | '(claw-utils:claw-pointer %filament:utils+entity) !::entity))) 86 | (explode-builder name 87 | 'light-builder 88 | #'ctor-expander 89 | #'build-expander 90 | '(!::engine !::entity) 91 | steps 92 | body))) 93 | 94 | ;;; 95 | ;;; INDIRECT 96 | ;;; 97 | (warp-intricate-builder-option indirect-light :reflections 98 | %filament:reflections 99 | '(claw-utils:claw-pointer %filament:indirect-light+builder) 100 | '(claw-utils:claw-pointer %filament:texture)) 101 | 102 | (warp-intricate-builder-option indirect-light :radiance 103 | %filament:radiance 104 | '(claw-utils:claw-pointer %filament:indirect-light+builder) 105 | '%filament:uint8-t 106 | '(claw-utils:claw-pointer %filament:math+float3)) 107 | 108 | (warp-intricate-builder-option indirect-light :irradiance 109 | %filament:irradiance 110 | '(claw-utils:claw-pointer %filament:indirect-light+builder) 111 | '%filament:uint8-t 112 | '(claw-utils:claw-pointer %filament:math+float3)) 113 | 114 | (warp-intricate-builder-option indirect-light :cubemap-irradiance 115 | %filament:irradiance 116 | '(claw-utils:claw-pointer %filament:indirect-light+builder) 117 | '(claw-utils:claw-pointer %filament:texture)) 118 | 119 | (warp-intricate-builder-option indirect-light :intensity 120 | %filament:intensity 121 | '(claw-utils:claw-pointer %filament:indirect-light+builder) 122 | ':float) 123 | 124 | (warp-intricate-builder-option indirect-light :rotation 125 | %filament:rotation 126 | '(claw-utils:claw-pointer %filament:indirect-light+builder) 127 | '(claw-utils:claw-pointer %filament:math+mat3f)) 128 | 129 | (defmacro with-indirect-light-builder ((name &body steps) &body body) 130 | (flet ((ctor-expander () 131 | `(%filament:indirect-light+builder)) 132 | (build-expander (builder) 133 | `(%filament:build 134 | '(claw-utils:claw-pointer %filament:indirect-light+builder) ,builder 135 | '(claw-utils:claw-pointer %filament:engine) !::engine))) 136 | (explode-builder name 137 | 'indirect-light 138 | #'ctor-expander 139 | #'build-expander 140 | '(!::engine) 141 | steps 142 | body))) 143 | 144 | 145 | (defun destroy-indirect-light (engine light) 146 | (%filament:destroy 147 | '(claw-utils:claw-pointer %filament::engine) engine 148 | '(claw-utils:claw-pointer %filament::indirect-light) light)) 149 | -------------------------------------------------------------------------------- /tools/ui/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage :%alien-works.tools.imgui 2 | (:use :cl) 3 | (:local-nicknames (:a :alexandria) 4 | (:u :alien-works.utils) 5 | (:math :alien-works.math) 6 | (:host :alien-works.host) 7 | (:%imgui :%filament.imgui) 8 | (:cref :cffi-c-ref) 9 | (:%host :%alien-works.host)) 10 | (:export #:make-imgui-helper 11 | #:destroy-imgui-helper 12 | #:render-imgui 13 | #:update-font-atlas 14 | #:update-display-size 15 | #:define-ui-callback 16 | #:make-ui-callback 17 | #:destroy-ui-callback 18 | 19 | #:make-context 20 | #:destroy-context 21 | #:initialize-context 22 | #:with-bound-context 23 | #:update-mouse-position 24 | #:update-keyboard-buttons 25 | #:update-mouse-buttons 26 | #:update-mouse-wheel 27 | #:add-input-characters 28 | #:mouse-dragging-p 29 | #:mouse-drag-delta 30 | 31 | #:font-scale 32 | #:add-default-font 33 | #:add-font 34 | #:add-font-from-foreign 35 | #:with-font 36 | #:font-atlas-width 37 | #:desired-font-atlas-width 38 | 39 | #:framebuffer-scale 40 | 41 | #:with-style 42 | #:style 43 | #:style-window-rounding 44 | #:style-window-border 45 | #:update-touch-padding 46 | #:scale-style 47 | 48 | #:with-panel 49 | #:with-child-panel 50 | #:with-popup 51 | #:popup-open-p 52 | #:open-popup 53 | #:close-current-popup 54 | 55 | #:button 56 | #:checkbox 57 | #:text 58 | #:collapsing-header 59 | #:tree-node 60 | #:tree-pop 61 | #:with-tree-node 62 | #:selectable 63 | #:progress-bar 64 | #:same-line 65 | #:float-slider 66 | #:indent 67 | #:unindent 68 | #:with-indent 69 | #:item-active-p 70 | #:item-clicked-p 71 | #:with-combo 72 | 73 | #:text-input 74 | #:float-input 75 | #:color-input 76 | #:text-area 77 | 78 | #:with-menu-bar 79 | #:with-menu 80 | #:menu-item 81 | 82 | #:columns 83 | #:next-column 84 | 85 | #:focus-window 86 | #:focus-previous-item-by-default 87 | #:focus-keyboard)) 88 | 89 | 90 | (cl:defpackage :alien-works.tools.ui 91 | (:local-nicknames (:a :alexandria) 92 | (:u :alien-works.utils) 93 | (:math :alien-works.math) 94 | (:host :alien-works.host) 95 | (:%gx :%alien-works.graphics) 96 | (:%fm :%alien-works.filament) 97 | (:%ui :%alien-works.tools.imgui) 98 | (:%mem :%alien-works.memory)) 99 | (:use :cl) 100 | (:import-from :%alien-works.tools.imgui 101 | #:mouse-dragging-p 102 | #:mouse-drag-delta 103 | 104 | #:with-panel 105 | #:with-child-panel 106 | 107 | #:with-popup 108 | #:popup-open-p 109 | #:open-popup 110 | #:close-current-popup 111 | 112 | #:button 113 | #:checkbox 114 | #:text 115 | #:collapsing-header 116 | #:tree-node 117 | #:tree-pop 118 | #:with-tree-node 119 | #:selectable 120 | #:progress-bar 121 | #:same-line 122 | #:float-slider 123 | #:indent 124 | #:unindent 125 | #:with-indent 126 | #:item-active-p 127 | #:item-clicked-p 128 | #:with-combo 129 | 130 | #:float-input 131 | #:text-input 132 | #:color-input 133 | #:text-area 134 | 135 | #:with-style 136 | #:style-window-rounding 137 | #:style-window-border 138 | 139 | #:with-menu-bar 140 | #:with-menu 141 | #:menu-item 142 | 143 | #:focus-window 144 | #:focus-previous-item-by-default 145 | #:focus-keyboard 146 | 147 | #:with-font) 148 | (:export #:make-ui 149 | #:destroy-ui 150 | #:update-ui-input 151 | #:update-ui-size 152 | #:handle-ui-event 153 | #:render-ui 154 | #:ui 155 | 156 | #:mouse-dragging-p 157 | #:mouse-drag-delta 158 | 159 | #:with-panel 160 | #:with-child-panel 161 | 162 | #:with-popup 163 | #:popup-open-p 164 | #:open-popup 165 | #:close-current-popup 166 | 167 | #:button 168 | #:checkbox 169 | #:text 170 | #:collapsing-header 171 | #:tree-node 172 | #:tree-pop 173 | #:with-tree-node 174 | #:selectable 175 | #:progress-bar 176 | #:same-line 177 | #:float-slider 178 | #:indent 179 | #:unindent 180 | #:with-indent 181 | #:item-active-p 182 | #:item-clicked-p 183 | #:with-combo 184 | 185 | #:float-input 186 | #:text-input 187 | #:color-input 188 | #:text-area 189 | 190 | #:with-style 191 | #:style-window-rounding 192 | #:style-window-border 193 | 194 | #:with-menu-bar 195 | #:with-menu 196 | #:menu-item 197 | 198 | #:rows 199 | 200 | #:focus-window 201 | #:focus-previous-item-by-default 202 | #:focus-keyboard 203 | 204 | #:add-font 205 | #:use-memory-vector-font 206 | #:with-font 207 | 208 | #:skip-ui-processing)) 209 | -------------------------------------------------------------------------------- /src/graphics/filament/renderable.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.filament) 2 | 3 | 4 | (defun renderable-manager (engine) 5 | (%filament:get-renderable-manager 6 | '(claw-utils:claw-pointer %filament::engine) engine)) 7 | 8 | ;;; 9 | ;;; RENDERABLE 10 | ;;; 11 | (u:define-enumval-extractor renderable-primitive-type-enum 12 | %filament:renderable-manager+primitive-type) 13 | 14 | (warp-intricate-builder-option renderable-builder :index-bound-geometry 15 | %filament:geometry 16 | '(claw-utils:claw-pointer %filament:renderable-manager+builder) 17 | '%filament:size-t 18 | '%filament:renderable-manager+primitive-type 19 | '(claw-utils:claw-pointer %filament:vertex-buffer) 20 | '(claw-utils:claw-pointer %filament:index-buffer) 21 | '%filament:size-t 22 | '%filament:size-t 23 | '%filament:size-t 24 | '%filament:size-t) 25 | 26 | (warp-intricate-builder-option renderable-builder :count-bound-geometry 27 | %filament:geometry 28 | '(claw-utils:claw-pointer %filament:renderable-manager+builder) 29 | '%filament:size-t 30 | '%filament:renderable-manager+primitive-type 31 | '(claw-utils:claw-pointer %filament:vertex-buffer) 32 | '(claw-utils:claw-pointer %filament:index-buffer) 33 | '%filament:size-t 34 | '%filament:size-t) 35 | 36 | (warp-intricate-builder-option renderable-builder :geometry 37 | %filament:geometry 38 | '(claw-utils:claw-pointer %filament:renderable-manager+builder) 39 | '%filament:size-t 40 | '%filament:renderable-manager+primitive-type 41 | '(claw-utils:claw-pointer %filament:vertex-buffer) 42 | '(claw-utils:claw-pointer %filament:index-buffer)) 43 | 44 | (warp-intricate-builder-option renderable-builder :material 45 | %filament:material 46 | '(claw-utils:claw-pointer %filament:renderable-manager+builder) 47 | '%filament:size-t 48 | '(claw-utils:claw-pointer %filament:material-instance)) 49 | 50 | (warp-intricate-builder-option renderable-builder :bounding-box 51 | %filament:bounding-box 52 | '(claw-utils:claw-pointer %filament:renderable-manager+builder) 53 | '(claw-utils:claw-pointer %filament:box)) 54 | 55 | (warp-intricate-builder-option renderable-builder :layer-mask 56 | %filament:layer-mask 57 | '(claw-utils:claw-pointer %filament:renderable-manager+builder) 58 | '%filament:uint8-t 59 | '%filament:uint8-t) 60 | 61 | (warp-intricate-builder-option renderable-builder :priority 62 | %filament:priority 63 | '(claw-utils:claw-pointer %filament:renderable-manager+builder) 64 | '%filament:uint8-t) 65 | 66 | (warp-intricate-builder-option renderable-builder :culling 67 | %filament:culling 68 | '(claw-utils:claw-pointer %filament:renderable-manager+builder) 69 | ':bool) 70 | 71 | (warp-intricate-builder-option renderable-builder :cast-shadows 72 | %filament:cast-shadows 73 | '(claw-utils:claw-pointer %filament:renderable-manager+builder) 74 | ':bool) 75 | 76 | (warp-intricate-builder-option renderable-builder :receive-shadows 77 | %filament:receive-shadows 78 | '(claw-utils:claw-pointer %filament:renderable-manager+builder) 79 | ':bool) 80 | 81 | (warp-intricate-builder-option renderable-builder :screen-space-contact-shadows 82 | %filament:screen-space-contact-shadows 83 | '(claw-utils:claw-pointer %filament:renderable-manager+builder) 84 | ':bool) 85 | 86 | (warp-intricate-builder-option renderable-builder :transform-skinning 87 | %filament:skinning 88 | '(claw-utils:claw-pointer %filament:renderable-manager+builder) 89 | '%filament:size-t 90 | '(claw-utils:claw-pointer %filament:math+mat4f)) 91 | 92 | (warp-intricate-builder-option renderable-builder :bone-skinning 93 | %filament:skinning 94 | '(claw-utils:claw-pointer %filament:renderable-manager+builder) 95 | '%filament:size-t 96 | '(claw-utils:claw-pointer %filament:renderable-manager+bone)) 97 | 98 | (warp-intricate-builder-option renderable-builder :skinning 99 | %filament:skinning 100 | '(claw-utils:claw-pointer %filament:renderable-manager+builder) 101 | '%filament:size-t) 102 | 103 | (warp-intricate-builder-option renderable-builder :blend-order 104 | %filament:blend-order 105 | '(claw-utils:claw-pointer %filament:renderable-manager+builder) 106 | '%filament:size-t 107 | '%filament:uint16-t) 108 | 109 | 110 | (defmacro with-renderable-builder ((name (&optional count) &body steps) &body body) 111 | (flet ((ctor-expander () 112 | `(%filament:renderable-manager+builder '%filament:size-t ,count)) 113 | (build-expander (builder) 114 | `(%filament:build 115 | '(claw-utils:claw-pointer %filament:renderable-manager+builder) ,builder 116 | '(claw-utils:claw-pointer %filament:engine) !::engine 117 | '(claw-utils:claw-pointer %filament:utils+entity) !::entity))) 118 | (explode-builder name 119 | 'renderable-builder 120 | #'ctor-expander 121 | #'build-expander 122 | '(!::engine !::entity) 123 | steps 124 | body))) 125 | 126 | 127 | (defmacro with-renderable-instance ((instance entity) renderable-manager &body body) 128 | `(iffi:with-intricate-instance (,instance %filament::renderable-manager+instance) 129 | (%filament:get-instance 130 | :const 131 | '(claw-utils:claw-pointer %filament::renderable-manager+instance) ,instance 132 | '(claw-utils:claw-pointer %filament::renderable-manager) ,renderable-manager 133 | '(claw-utils:claw-pointer %filament::utils+entity) ,entity) 134 | ,@body)) 135 | 136 | 137 | (defun renderable-material-instance (renderable-manager instance layer) 138 | (%filament:get-material-instance-at 139 | :const 140 | '(claw-utils:claw-pointer %filament::renderable-manager) renderable-manager 141 | '(claw-utils:claw-pointer %filament::renderable-manager+instance) instance 142 | '%filament::size-t layer)) 143 | 144 | 145 | (defun (setf renderable-material-instance) (material-instance 146 | renderable-manager 147 | instance 148 | layer) 149 | (%filament:set-material-instance-at 150 | '(claw-utils:claw-pointer %filament::renderable-manager) renderable-manager 151 | '(claw-utils:claw-pointer %filament::renderable-manager+instance) instance 152 | '%filament::size-t layer 153 | '(claw-utils:claw-pointer %filament::material-instance) material-instance) 154 | material-instance) 155 | -------------------------------------------------------------------------------- /src/memory/allocator.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.memory) 2 | 3 | (defvar iffi:*allocator* #'aligned-alloc) 4 | (defvar iffi:*extricator* #'aligned-free) 5 | 6 | ;;; 7 | ;;; SYSTEM ALLOCATOR 8 | ;;; 9 | (defun system-allocator-expander (align-var size-var) 10 | `(aligned-alloc ,align-var ,size-var)) 11 | 12 | 13 | (defun system-extricator-expander (ptr-var) 14 | `(aligned-free ,ptr-var)) 15 | 16 | (setf iffi:*allocator-expander* 'system-allocator-expander 17 | iffi:*extricator-expander* 'system-extricator-expander) 18 | 19 | 20 | (defmacro with-system-allocator (() &body body) 21 | (cltl2:compiler-let (iffi:*allocator-expander* 22 | iffi:*extricator-expander*) 23 | (flet ((%allocator-expander (align-var size-var) 24 | `(aligned-alloc ,align-var ,size-var)) 25 | (%extricator-expander (ptr-var) 26 | `(aligned-free ,ptr-var))) 27 | (setf iffi:*allocator-expander* #'%allocator-expander 28 | iffi:*extricator-expander* #'%extricator-expander)) 29 | `(let ((iffi:*allocator* #'aligned-alloc) 30 | (iffi:*extricator* #'aligned-free)) 31 | ,@body))) 32 | 33 | ;;; 34 | ;;; STACK ALLOCATOR 35 | ;;; 36 | (defun align-address (address alignment) 37 | (let ((misaligned (mod address alignment))) 38 | (if (zerop misaligned) 39 | address 40 | (+ address ( - alignment misaligned))))) 41 | 42 | 43 | (defun align-pointer (ptr alignment) 44 | (cffi:make-pointer (align-address (cffi:pointer-address ptr) alignment))) 45 | 46 | 47 | (defstruct (stack-chunk 48 | (:constructor %make-stack-chunk)) 49 | (memory nil :type (simple-array (unsigned-byte 8) *) :read-only t) 50 | (head nil :type (unsigned-byte 64)) 51 | (tail nil :type (unsigned-byte 64))) 52 | 53 | 54 | (defun make-stack-chunk (chunk-size) 55 | (let* ((mem (sv:make-static-vector chunk-size 56 | :element-type '(unsigned-byte 8))) 57 | (mem-address (cffi:pointer-address (sv:static-vector-pointer mem)))) 58 | (%make-stack-chunk :memory mem 59 | :head mem-address 60 | :tail mem-address))) 61 | 62 | 63 | (defun destroy-stack-chunk (chunk) 64 | (sv:free-static-vector (stack-chunk-memory chunk))) 65 | 66 | 67 | (defun stack-chunk-allocate (chunk alignment size) 68 | (let* ((mem (stack-chunk-memory chunk)) 69 | (head-address (stack-chunk-head chunk)) 70 | (tail-address (stack-chunk-tail chunk)) 71 | (data-address (align-address head-address alignment)) 72 | (next-head-address (+ data-address size))) 73 | (unless (> next-head-address 74 | (+ (cffi:pointer-address (sv:static-vector-pointer mem)) (length mem))) 75 | (when (= tail-address head-address) 76 | (setf (stack-chunk-tail chunk) data-address)) 77 | (setf (stack-chunk-head chunk) next-head-address) 78 | (cffi:make-pointer data-address)))) 79 | 80 | 81 | (defun stack-chunk-free (chunk ptr) 82 | (let ((head-address (stack-chunk-head chunk)) 83 | (tail-address (stack-chunk-head chunk)) 84 | (mem-address (cffi:pointer-address 85 | (sv:static-vector-pointer (stack-chunk-memory chunk)))) 86 | (ptr-address (cffi:pointer-address ptr))) 87 | (when (> ptr-address head-address) 88 | (error "Pointer address is higher than stack head address (pointer: ~A, head: ~A" 89 | ptr-address head-address)) 90 | (when (< ptr-address tail-address) 91 | (error "Pointer address is lower than stack tail address (pointer: ~A, tail: ~A" 92 | ptr-address tail-address)) 93 | (if (= ptr-address tail-address) 94 | (setf (stack-chunk-tail chunk) mem-address 95 | (stack-chunk-head chunk) mem-address) 96 | (setf (stack-chunk-head chunk) (cffi:pointer-address ptr)))) 97 | (values)) 98 | 99 | 100 | (defun stack-chunk-empty-p (chunk) 101 | (= (stack-chunk-tail chunk) (stack-chunk-head chunk))) 102 | 103 | 104 | (defstruct (stack-allocator 105 | (:constructor %make-stack-allocator)) 106 | (chunk-size 0 :type (unsigned-byte 32) :read-only t) 107 | (chunks nil :type list)) 108 | 109 | 110 | (defun make-stack-allocator (&key chunk-size initial-chunk-size) 111 | (let ((chunk-size (or chunk-size (* 16 1024 1024)))) 112 | (%make-stack-allocator :chunk-size chunk-size 113 | :chunks (list (make-stack-chunk (or initial-chunk-size 114 | chunk-size)))))) 115 | 116 | 117 | (defun destroy-stack-allocator (allocator) 118 | (mapc #'destroy-stack-chunk (stack-allocator-chunks allocator)) 119 | (values)) 120 | 121 | 122 | (defun stack-alloc (allocator alignment size) 123 | (let ((current-chunk (first (stack-allocator-chunks allocator)))) 124 | (a:if-let ((ptr (stack-chunk-allocate current-chunk alignment size))) 125 | ptr 126 | (let ((new-chunk (make-stack-chunk (stack-allocator-chunk-size allocator)))) 127 | (a:if-let ((ptr (stack-chunk-allocate new-chunk alignment size))) 128 | (prog1 ptr (push new-chunk (stack-allocator-chunks allocator))) 129 | (progn 130 | (destroy-stack-chunk new-chunk) 131 | (error "Cannot fit data of size ~A with alignment ~A" size alignment))))))) 132 | 133 | 134 | (defun stack-free (allocator ptr) 135 | (let ((current-chunk (first (stack-allocator-chunks allocator)))) 136 | (stack-chunk-free current-chunk ptr) 137 | (when (and (stack-chunk-empty-p current-chunk) 138 | (rest (stack-allocator-chunks allocator))) 139 | (pop (stack-allocator-chunks allocator)) 140 | (destroy-stack-chunk current-chunk)) 141 | (values))) 142 | 143 | 144 | (defmacro with-stack-allocator ((allocator) &body body) 145 | (a:once-only (allocator) 146 | (a:with-gensyms (%allocate %free) 147 | (cltl2:compiler-let (iffi:*allocator-expander* 148 | iffi:*extricator-expander*) 149 | (flet ((%allocator-expander (align-var size-var) 150 | `(stack-alloc ,allocator ,align-var ,size-var)) 151 | (%extricator-expander (ptr-var) 152 | `(stack-free ,allocator ,ptr-var))) 153 | (setf iffi:*allocator-expander* #'%allocator-expander 154 | iffi:*extricator-expander* #'%extricator-expander)) 155 | `(flet ((,%allocate (alignment size) 156 | (stack-alloc ,allocator alignment size)) 157 | (,%free (ptr) 158 | (stack-free ,allocator ptr))) 159 | (let ((iffi:*allocator* #',%allocate) 160 | (iffi:*extricator* #',%free)) 161 | ,@body)))))) 162 | -------------------------------------------------------------------------------- /tools/graphics/filament/image.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.tools.filament) 2 | 3 | 4 | (defun make-image (width height channels) 5 | (let ((image (iffi:intricate-alloc '%filament.util::image+linear-image))) 6 | (handler-bind ((serious-condition (lambda (c) 7 | (declare (ignore c)) 8 | (iffi:intricate-free image) 9 | (setf image nil)))) 10 | (%filament.util:image+linear-image 11 | '(claw-utils:claw-pointer %filament.util::image+linear-image) image 12 | '%filament.util::uint32-t width 13 | '%filament.util::uint32-t height 14 | '%filament.util::uint32-t channels) 15 | image))) 16 | 17 | 18 | (defun image-width (image) 19 | (%filament.util:image+get-width 20 | :const 21 | '(claw-utils:claw-pointer %filament.util:image+linear-image) image)) 22 | 23 | 24 | (defun image-height (image) 25 | (%filament.util:image+get-height 26 | :const 27 | '(claw-utils:claw-pointer %filament.util:image+linear-image) image)) 28 | 29 | 30 | (defun image-channels (image) 31 | (%filament.util:image+get-channels 32 | :const 33 | '(claw-utils:claw-pointer %filament.util:image+linear-image) image)) 34 | 35 | 36 | (defun destroy-image (image) 37 | (unwind-protect 38 | (%filament.util:image+~linear-image 39 | '(claw-utils:claw-pointer %filament.util:image+linear-image) image) 40 | (iffi:intricate-free image))) 41 | 42 | 43 | (defun image-data-ptr (image) 44 | (%filament.util:image+get-pixel-ref 45 | :const 46 | '(claw-utils:claw-pointer %filament.util:image+linear-image) image)) 47 | 48 | 49 | (defun image-data-size (image) 50 | (* (image-width image) 51 | (image-height image) 52 | (image-channels image) 53 | (iffi:intricate-size :float))) 54 | 55 | 56 | (defun decode-image (byte-vector &key (color-space :srgb)) 57 | (u:with-pinned-array-pointer (data-ptr byte-vector) 58 | (let ((image (iffi:intricate-alloc '%filament.util:image+linear-image))) 59 | (%filament.util:aw+filament+tools+util+decode-image 60 | '(claw-utils:claw-pointer %filament.util:image+linear-image) image 61 | '(claw-utils:claw-pointer %filament.util:uint8-t) data-ptr 62 | '%filament.util:size-t (length byte-vector) 63 | '%filament.util:image+image-decoder+color-space color-space) 64 | (if (zerop (image-data-size image)) 65 | (prog1 nil 66 | (destroy-image image)) 67 | image)))) 68 | 69 | 70 | (defun encode-image (image byte-vector &key (format :png)) 71 | (u:with-pinned-array-pointer (data-ptr byte-vector) 72 | (let ((written (%filament.util:aw+filament+tools+util+encode-image 73 | '(claw-utils:claw-pointer %filament.util:uint8-t) data-ptr 74 | '%filament.util:size-t (length byte-vector) 75 | '%filament.util:image+image-encoder+format format 76 | '(claw-utils:claw-pointer %filament.util:image+linear-image) image))) 77 | (when (> written 0) 78 | written)))) 79 | 80 | 81 | (%aw.fm:warp-intricate-builder-option compressed-texture-encoder-builder :linear 82 | %filament.util:image+linear 83 | '(claw-utils:claw-pointer %filament.util:image+basis-encoder+builder) 84 | :bool) 85 | 86 | 87 | (%aw.fm:warp-intricate-builder-option compressed-texture-encoder-builder :cubemap 88 | %filament.util:image+cubemap 89 | '(claw-utils:claw-pointer %filament.util:image+basis-encoder+builder) 90 | :bool) 91 | 92 | 93 | (%aw.fm:warp-intricate-builder-option compressed-texture-encoder-builder :intermediate-format 94 | %filament.util:image+intermediate-format 95 | '(claw-utils:claw-pointer %filament.util:image+basis-encoder+builder) 96 | '%filament.util:image+basis-encoder+intermediate-format) 97 | 98 | 99 | (%aw.fm:warp-intricate-builder-option compressed-texture-encoder-builder :grayscale 100 | %filament.util:image+grayscale 101 | '(claw-utils:claw-pointer %filament.util:image+basis-encoder+builder) 102 | :bool) 103 | 104 | 105 | (%aw.fm:warp-intricate-builder-option compressed-texture-encoder-builder :normals 106 | %filament.util:image+normals 107 | '(claw-utils:claw-pointer %filament.util:image+basis-encoder+builder) 108 | :bool) 109 | 110 | 111 | (%aw.fm:warp-intricate-builder-option compressed-texture-encoder-builder :jobs 112 | %filament.util:image+jobs 113 | '(claw-utils:claw-pointer %filament.util:image+basis-encoder+builder) 114 | '%filament.util:size-t) 115 | 116 | 117 | (%aw.fm:warp-intricate-builder-option compressed-texture-encoder-builder :quiet 118 | %filament.util:image+quiet 119 | '(claw-utils:claw-pointer %filament.util:image+basis-encoder+builder) 120 | :bool) 121 | 122 | 123 | (%aw.fm:warp-intricate-builder-option compressed-texture-encoder-builder :mip-level 124 | %filament.util:image+miplevel 125 | '(claw-utils:claw-pointer %filament.util:image+basis-encoder+builder) 126 | '%filament.util:size-t 127 | '%filament.util:size-t 128 | '(claw-utils:claw-pointer %filament.util:image+linear-image)) 129 | 130 | 131 | (defmacro with-compressed-texture-encoder-builder (((name mip-count layer-count) &body steps) &body body) 132 | (flet ((ctor-expander () 133 | `(%filament.util:image+basis-encoder+builder 134 | '%filament.util:size-t ,mip-count 135 | '%filament.util:size-t ,layer-count)) 136 | (build-expander (builder) 137 | `(%filament.util:image+build 138 | '(claw-utils:claw-pointer %filament.util:image+basis-encoder+builder) ,builder))) 139 | (%aw.fm:explode-builder name 140 | 'compressed-texture-encoder-builder 141 | #'ctor-expander 142 | #'build-expander 143 | '() 144 | ;; we hardcode number of jobs 145 | ;; making encoding single-threaded 146 | ;; due to the SBCL problems with SIGFPE 147 | (append steps 148 | '((:jobs 1))) 149 | body))) 150 | 151 | 152 | (defun encode-compressed-texture (encoder) 153 | (u:without-float-traps 154 | (when (%filament.util:image+encode 155 | '(claw-utils:claw-pointer %filament.util:image+basis-encoder) encoder) 156 | (values (%filament.util:image+get-ktx2data 157 | :const 158 | '(claw-utils:claw-pointer %filament.util:image+basis-encoder) encoder) 159 | (%filament.util:image+get-ktx2byte-count 160 | :const 161 | '(claw-utils:claw-pointer %filament.util:image+basis-encoder) encoder))))) 162 | -------------------------------------------------------------------------------- /src/graphics/filament/buffer.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.filament) 2 | 3 | ;;; 4 | ;;; VERTEX BUFFER 5 | ;;; 6 | (u:define-enumval-extractor vertex-attribute-enum %filament:vertex-attribute) 7 | (u:define-enumval-extractor vertex-attribute-type-enum %filament:vertex-buffer+attribute-type) 8 | 9 | (warp-intricate-builder-option vertex-buffer-builder :buffer-count 10 | %filament:buffer-count 11 | '(claw-utils:claw-pointer %filament:vertex-buffer+builder) 12 | '%filament:uint8-t) 13 | 14 | 15 | (warp-intricate-builder-option vertex-buffer-builder :vertex-count 16 | %filament:vertex-count 17 | '(claw-utils:claw-pointer %filament:vertex-buffer+builder) 18 | '%filament:uint32-t) 19 | 20 | 21 | (warp-intricate-builder-option vertex-buffer-builder :attribute 22 | %filament:attribute 23 | '(claw-utils:claw-pointer %filament:vertex-buffer+builder) 24 | '%filament:vertex-attribute 25 | '%filament:uint8-t 26 | '%filament:vertex-buffer+attribute-type 27 | '%filament:uint32-t 28 | '%filament:uint8-t) 29 | 30 | 31 | (warp-intricate-builder-option vertex-buffer-builder :normalized 32 | %filament:normalized 33 | '(claw-utils:claw-pointer %filament:vertex-buffer+builder) 34 | '%filament:vertex-attribute 35 | ':bool) 36 | 37 | 38 | (defmacro with-vertex-buffer-builder ((name &rest steps) &body body) 39 | (flet ((ctor-expander () 40 | '(%filament:vertex-buffer+builder)) 41 | (build-expander (builder) 42 | `(%filament:build 43 | '(claw-utils:claw-pointer %filament:vertex-buffer+builder) ,builder 44 | '(claw-utils:claw-pointer %filament:engine) !::engine))) 45 | (explode-builder name 46 | 'vertex-buffer-builder 47 | #'ctor-expander 48 | #'build-expander 49 | '(!::engine) 50 | steps 51 | body))) 52 | 53 | 54 | (defun destroy-vertex-buffer (engine buffer) 55 | (%filament:destroy 56 | '(claw-utils:claw-pointer %filament:engine) engine 57 | '(claw-utils:claw-pointer %filament:vertex-buffer) buffer)) 58 | 59 | 60 | (cffi:defcallback buffer-descriptor-release :void ((buffer-ptr :pointer) 61 | (buffer-size :size) 62 | (user-data :pointer)) 63 | (declare (ignore buffer-ptr buffer-size)) 64 | (u:perform-foreign-callback (cffi:pointer-address user-data))) 65 | 66 | 67 | (defun update-vertex-buffer (buffer engine index data size 68 | &optional (offset 0) done-callback) 69 | (iffi:with-intricate-instance 70 | (descriptor %filament:backend+buffer-descriptor 71 | '(claw-utils:claw-pointer :void) data 72 | '%filament:size-t size 73 | '%filament:backend+buffer-descriptor+callback (cffi:null-pointer) 74 | '(claw-utils:claw-pointer :void) (cffi:null-pointer)) 75 | 76 | (when done-callback 77 | (let ((id (u:register-foreign-callback done-callback))) 78 | (%filament:backend+set-callback 79 | '(claw-utils:claw-pointer %filament::backend+buffer-descriptor) descriptor 80 | '%filament::backend+buffer-descriptor+callback (cffi:callback 81 | buffer-descriptor-release) 82 | '(claw-utils:claw-pointer :void) (cffi:make-pointer id)))) 83 | 84 | (%filament:set-buffer-at 85 | '(claw-utils:claw-pointer %filament:vertex-buffer) buffer 86 | '(claw-utils:claw-pointer %filament:engine) engine 87 | '%filament:uint8-t index 88 | '(claw-utils:claw-pointer %filament:vertex-buffer+buffer-descriptor) descriptor 89 | '%filament:uint32-t offset))) 90 | 91 | 92 | ;;; 93 | ;;; INDEX BUFFER 94 | ;;; 95 | (u:define-enumval-extractor index-type-enum %filament:index-buffer+index-type) 96 | 97 | (defun expand-index-buffer-builder-function (name) 98 | (ecase name 99 | (:index-count 100 | '(%filament:index-count 101 | '(claw-utils:claw-pointer %filament:index-buffer+builder) 102 | '%filament:uint32-t)) 103 | (:buffer-type 104 | '(%filament:buffer-type 105 | '(claw-utils:claw-pointer %filament:index-buffer+builder) 106 | '%filament:index-buffer+index-type)))) 107 | 108 | 109 | (warp-intricate-builder-option index-buffer-builder :index-count 110 | %filament:index-count 111 | '(claw-utils:claw-pointer %filament:index-buffer+builder) 112 | '%filament:uint32-t) 113 | 114 | 115 | (warp-intricate-builder-option index-buffer-builder :buffer-type 116 | %filament:buffer-type 117 | '(claw-utils:claw-pointer %filament:index-buffer+builder) 118 | '%filament:index-buffer+index-type) 119 | 120 | 121 | (defmacro with-index-buffer-builder ((name &rest steps) &body body) 122 | (flet ((ctor-expander () 123 | '(%filament:index-buffer+builder)) 124 | (build-expander (builder) 125 | `(%filament:build 126 | '(claw-utils:claw-pointer %filament:index-buffer+builder) ,builder 127 | '(claw-utils:claw-pointer %filament:engine) !::engine))) 128 | (explode-builder name 129 | 'index-buffer-builder 130 | #'ctor-expander 131 | #'build-expander 132 | '(!::engine) 133 | steps 134 | body))) 135 | 136 | 137 | (defun destroy-index-buffer (engine buffer) 138 | (%filament:destroy 139 | '(claw-utils:claw-pointer %filament:engine) engine 140 | '(claw-utils:claw-pointer %filament:index-buffer) buffer)) 141 | 142 | 143 | (defun update-index-buffer (buffer engine data size &optional (offset 0) done-callback) 144 | (iffi:with-intricate-instance 145 | (descriptor %filament:backend+buffer-descriptor 146 | '(claw-utils:claw-pointer :void) data 147 | '%filament:size-t size 148 | '%filament:backend+buffer-descriptor+callback (cffi:null-pointer) 149 | '(claw-utils:claw-pointer :void) (cffi:null-pointer)) 150 | 151 | (when done-callback 152 | (let ((id (u:register-foreign-callback done-callback))) 153 | (%filament:backend+set-callback 154 | '(claw-utils:claw-pointer %filament::backend+buffer-descriptor) descriptor 155 | '%filament::backend+buffer-descriptor+callback (cffi:callback 156 | buffer-descriptor-release) 157 | '(claw-utils:claw-pointer :void) (cffi:make-pointer id)))) 158 | 159 | (%filament:set-buffer 160 | '(claw-utils:claw-pointer %filament:index-buffer) buffer 161 | '(claw-utils:claw-pointer %filament:engine) engine 162 | '(claw-utils:claw-pointer %filament:index-buffer+buffer-descriptor) descriptor 163 | '%filament:uint32-t offset))) 164 | -------------------------------------------------------------------------------- /src/graphics/filament/math.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.filament) 2 | 3 | ;;; 4 | ;;; VEC4 5 | ;;; 6 | (defun vec4f (vec idx) 7 | (cffi:mem-ref (%filament::math+details+operator[] 8 | '(claw-utils:claw-pointer %filament::math+details+t-vec4) vec 9 | '%filament::size-t idx) 10 | :float)) 11 | 12 | 13 | (defun (setf vec4f) (value vec idx) 14 | (let ((mem (%filament::math+details+operator[] 15 | '(claw-utils:claw-pointer %filament::math+details+t-vec4) vec 16 | '%filament::size-t idx))) 17 | (setf (cffi:mem-ref mem :float) 18 | (float value 0f0)))) 19 | 20 | 21 | (defun create-vec4f (x y z w) 22 | (let ((vec (iffi:make-intricate-instance '%filament:math+details+t-vec4))) 23 | (setf (vec4f vec 0) x 24 | (vec4f vec 1) y 25 | (vec4f vec 2) z 26 | (vec4f vec 3) w) 27 | vec)) 28 | 29 | 30 | (defun destroy-vec4f (vec) 31 | (iffi:destroy-intricate-instance '%filament:math+details+t-vec4 vec)) 32 | 33 | 34 | (defmacro with-vec4f ((vec &optional (x 0f0) (y 0f0) (z 0f0) (w 1f0)) &body body) 35 | `(let ((,vec (create-vec4f ,x ,y ,z ,w))) 36 | (unwind-protect 37 | (progn ,@body) 38 | (destroy-vec4f ,vec)))) 39 | 40 | 41 | ;;; 42 | ;;; VEC3 43 | ;;; 44 | (defun vec3f (vec idx) 45 | (cffi:mem-ref (%filament::math+details+operator[] 46 | '(claw-utils:claw-pointer %filament::math+details+t-vec3) vec 47 | '%filament::size-t idx) 48 | :float)) 49 | 50 | 51 | (defun (setf vec3f) (value vec idx) 52 | (let ((mem (%filament::math+details+operator[] 53 | '(claw-utils:claw-pointer %filament::math+details+t-vec3) vec 54 | '%filament::size-t idx))) 55 | (setf (cffi:mem-ref mem :float) (float value 0f0)))) 56 | 57 | 58 | (defun create-vec3f (x y z) 59 | (let ((vec (iffi:make-intricate-instance '%filament:math+details+t-vec3))) 60 | (setf (vec3f vec 0) x 61 | (vec3f vec 1) y 62 | (vec3f vec 2) z) 63 | vec)) 64 | 65 | 66 | (defun destroy-vec3f (vec) 67 | (iffi:destroy-intricate-instance '%filament:math+details+t-vec3 vec)) 68 | 69 | 70 | (defmacro with-vec3f ((vec &optional (x 0f0) (y 0f0) (z 0f0)) &body body) 71 | `(let ((,vec (create-vec3f ,x ,y ,z))) 72 | (unwind-protect 73 | (progn ,@body) 74 | (destroy-vec3f ,vec)))) 75 | 76 | 77 | ;;; 78 | ;;; VEC2 79 | ;;; 80 | (defun vec2f (vec idx) 81 | (cffi:mem-ref (%filament::math+details+operator[] 82 | '(claw-utils:claw-pointer %filament::math+details+t-vec2) vec 83 | '%filament::size-t idx) 84 | :float)) 85 | 86 | 87 | (defun (setf vec2f) (value vec idx) 88 | (let ((mem (%filament::math+details+operator[] 89 | '(claw-utils:claw-pointer %filament::math+details+t-vec2) vec 90 | '%filament::size-t idx))) 91 | (setf (cffi:mem-ref mem :float) (float value 0f0)))) 92 | 93 | 94 | (defun create-vec2f (x y) 95 | (let ((vec (iffi:make-intricate-instance '%filament:math+details+t-vec2))) 96 | (setf (vec2f vec 0) x 97 | (vec2f vec 1) y) 98 | vec)) 99 | 100 | 101 | (defun destroy-vec2f (vec) 102 | (iffi:destroy-intricate-instance '%filament:math+details+t-vec2 vec)) 103 | 104 | 105 | (defmacro with-vec2f ((vec &optional (x 0f0) (y 0f0)) &body body) 106 | `(let ((,vec (create-vec2f ,x ,y))) 107 | (unwind-protect 108 | (progn ,@body) 109 | (destroy-vec2f ,vec)))) 110 | 111 | ;;; 112 | ;;; MAT4 113 | ;;; 114 | (defun mat4f (mat row col) 115 | (let ((column (%filament::math+details+operator[] 116 | '(claw-utils:claw-pointer %filament::math+details+t-mat44) mat 117 | '%filament::size-t col))) 118 | (vec4f column row))) 119 | 120 | 121 | (defun (setf mat4f) (value mat row col) 122 | (let ((column (%filament::math+details+operator[] 123 | '(claw-utils:claw-pointer %filament::math+details+t-mat44) mat 124 | '%filament::size-t col))) 125 | (setf (vec4f column row) value))) 126 | 127 | 128 | (defun create-mat4f (source) 129 | (let ((mat (iffi:make-intricate-instance '%filament:math+mat4f))) 130 | (setf (mat4f mat 0 0) (m:mat4 source 0 0) 131 | (mat4f mat 0 1) (m:mat4 source 1 0) 132 | (mat4f mat 0 2) (m:mat4 source 2 0) 133 | (mat4f mat 0 3) (m:mat4 source 3 0) 134 | 135 | (mat4f mat 1 0) (m:mat4 source 0 1) 136 | (mat4f mat 1 1) (m:mat4 source 1 1) 137 | (mat4f mat 1 2) (m:mat4 source 2 1) 138 | (mat4f mat 1 3) (m:mat4 source 3 1) 139 | 140 | (mat4f mat 2 0) (m:mat4 source 0 2) 141 | (mat4f mat 2 1) (m:mat4 source 1 2) 142 | (mat4f mat 2 2) (m:mat4 source 2 2) 143 | (mat4f mat 2 3) (m:mat4 source 3 2) 144 | 145 | (mat4f mat 3 0) (m:mat4 source 0 3) 146 | (mat4f mat 3 1) (m:mat4 source 1 3) 147 | (mat4f mat 3 2) (m:mat4 source 2 3) 148 | (mat4f mat 3 3) (m:mat4 source 3 3)) 149 | mat)) 150 | 151 | 152 | (defun destroy-mat4f (mat) 153 | (iffi:destroy-intricate-instance '%filament:math+mat4f mat)) 154 | 155 | 156 | (defmacro with-mat4f ((mat source) &body body) 157 | `(let ((,mat (create-mat4f ,source))) 158 | (unwind-protect 159 | (progn ,@body) 160 | (destroy-mat4f ,mat)))) 161 | 162 | 163 | ;;; 164 | ;;; MAT3 165 | ;;; 166 | (defun mat3f (mat row col) 167 | (let ((column (%filament::math+details+operator[] 168 | '(claw-utils:claw-pointer %filament::math+details+t-mat33) mat 169 | '%filament::size-t col))) 170 | (vec4f column row))) 171 | 172 | 173 | (defun (setf mat3f) (value mat row col) 174 | (let ((column (%filament::math+details+operator[] 175 | '(claw-utils:claw-pointer %filament::math+details+t-mat33) mat 176 | '%filament::size-t col))) 177 | (setf (vec4f column row) value))) 178 | 179 | 180 | (defun create-mat3f (source) 181 | (let ((mat (iffi:make-intricate-instance '%filament:math+mat3f))) 182 | (setf (mat3f mat 0 0) (m:mat3 source 0 0) 183 | (mat3f mat 0 1) (m:mat3 source 1 0) 184 | (mat3f mat 0 2) (m:mat3 source 2 0) 185 | 186 | (mat3f mat 1 0) (m:mat3 source 0 1) 187 | (mat3f mat 1 1) (m:mat3 source 1 1) 188 | (mat3f mat 1 2) (m:mat3 source 2 1) 189 | 190 | (mat3f mat 2 0) (m:mat3 source 0 2) 191 | (mat3f mat 2 1) (m:mat3 source 1 2) 192 | (mat3f mat 2 2) (m:mat3 source 2 2)) 193 | mat)) 194 | 195 | 196 | (defun destroy-mat3f (mat) 197 | (iffi:destroy-intricate-instance '%filament:math+mat3f mat)) 198 | 199 | 200 | (defmacro with-mat3f ((mat source) &body body) 201 | `(let ((,mat (create-mat3f ,source))) 202 | (unwind-protect 203 | (progn ,@body) 204 | (destroy-mat3f ,mat)))) 205 | -------------------------------------------------------------------------------- /src/graphics/surface.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.graphics) 2 | 3 | 4 | (atomics:defstruct (triple-buffered-value 5 | (:constructor %make-triple-buffered-value)) 6 | (updating-p nil :type boolean) 7 | (prepared-p nil :type boolean) 8 | (front nil :type t) 9 | (prepared nil :type t) 10 | (back nil :type t)) 11 | 12 | 13 | (defun make-triple-buffered-value (front prepared back) 14 | (%make-triple-buffered-value :front front :prepared prepared :back back)) 15 | 16 | 17 | (defun lock-triple-buffered-value (vessel) 18 | (loop until (atomics:cas (triple-buffered-value-updating-p vessel) nil t))) 19 | 20 | 21 | (defun unlock-triple-buffered-value (vessel) 22 | (setf (triple-buffered-value-updating-p vessel) nil)) 23 | 24 | 25 | (defmacro with-locked-triple-buffered-value ((vessel) &body body) 26 | (a:once-only (vessel) 27 | `(progn 28 | (lock-triple-buffered-value ,vessel) 29 | (unwind-protect 30 | (progn ,@body) 31 | (unlock-triple-buffered-value ,vessel))))) 32 | 33 | 34 | (defun swap-triple-buffered-value (vessel) 35 | (with-locked-triple-buffered-value (vessel) 36 | (when (triple-buffered-value-prepared-p vessel) 37 | (rotatef (triple-buffered-value-front vessel) 38 | (triple-buffered-value-prepared vessel)) 39 | (setf (triple-buffered-value-prepared-p vessel) nil)) 40 | (triple-buffered-value-front vessel))) 41 | 42 | 43 | (defun prepare-triple-buffered-value (vessel) 44 | (with-locked-triple-buffered-value (vessel) 45 | (rotatef (triple-buffered-value-back vessel) 46 | (triple-buffered-value-prepared vessel)) 47 | (setf (triple-buffered-value-prepared-p vessel) t))) 48 | 49 | 50 | ;;; 51 | ;;; 52 | ;;; 53 | (defstruct (buffered-surface-framebuffer 54 | (:constructor %make-buffered-surface-framebuffer)) 55 | (id -1 :type fixnum :read-only t) 56 | (depth-stencil-buffer-id -1 :type fixnum :read-only t)) 57 | 58 | 59 | (defun make-buffered-surface-framebuffer (width height) 60 | (let ((fbo (gl:gen-framebuffer)) 61 | (rbo (gl:gen-renderbuffer))) 62 | (gl:bind-framebuffer :framebuffer fbo) 63 | (gl:bind-renderbuffer :renderbuffer rbo) 64 | (gl:renderbuffer-storage :renderbuffer :depth24-stencil8 width height) 65 | (gl:framebuffer-renderbuffer :framebuffer :depth-stencil-attachment :renderbuffer rbo) 66 | (%make-buffered-surface-framebuffer :id fbo 67 | :depth-stencil-buffer-id rbo))) 68 | 69 | 70 | (defun destroy-buffered-surface-framebuffer (instance) 71 | (gl:delete-renderbuffers (list (buffered-surface-framebuffer-depth-stencil-buffer-id instance))) 72 | (gl:delete-framebuffers (list (buffered-surface-framebuffer-id instance)))) 73 | 74 | 75 | (defun prepare-framebuffer (framebuffer texture-id viewport-width viewport-height) 76 | (gl:bind-framebuffer :framebuffer (buffered-surface-framebuffer-id framebuffer)) 77 | ;; FIXME: attach texture only when needed 78 | (%gl:framebuffer-texture :framebuffer :color-attachment0 texture-id 0) 79 | (%gl:viewport 0 0 viewport-width viewport-height) 80 | (gl:clear-color 0f0 0f0 0f0 0f0) 81 | (gl:clear :color-buffer :depth-buffer :stencil-buffer)) 82 | 83 | 84 | (defun flush-framebuffer (framebuffer) 85 | (gl:bind-framebuffer :framebuffer (buffered-surface-framebuffer-id framebuffer)) 86 | ;; FIXME: detach texture only when needed 87 | (%gl:framebuffer-texture :framebuffer :color-attachment0 0 0)) 88 | 89 | ;;; 90 | ;;; 91 | ;;; 92 | (defstruct (buffered-surface-texture 93 | (:constructor %make-buffered-surface-texture)) 94 | (id -1 :type fixnum :read-only t) 95 | (filatex nil :read-only t)) 96 | 97 | 98 | (defun make-buffered-surface-texture (engine width height) 99 | (let ((tex-id (gl:gen-texture))) 100 | (gl:bind-texture :texture-2d tex-id) 101 | (gl:tex-image-2d :texture-2d 0 :rgba8 width height 0 102 | :rgba :unsigned-byte (cffi:null-pointer) :raw t) 103 | (gl:tex-parameter :texture-2d :texture-mag-filter :nearest) 104 | (gl:tex-parameter :texture-2d :texture-min-filter :nearest) 105 | (gl:tex-parameter :texture-2d :texture-base-level 0) 106 | (gl:tex-parameter :texture-2d :texture-max-level 0) 107 | (%make-buffered-surface-texture 108 | :id tex-id 109 | :filatex (make-texture engine 110 | (.import tex-id) 111 | (.sampler :2d) 112 | (.width width) 113 | (.height height) 114 | (.format :rgba8) 115 | (.levels 1))))) 116 | 117 | 118 | (defun destroy-buffered-surface-texture (engine instance) 119 | (destroy-texture engine (buffered-surface-texture-filatex instance)) 120 | (gl:delete-texture (buffered-surface-texture-id instance))) 121 | 122 | 123 | (atomics:defstruct (buffered-surface 124 | (:constructor %make-buffered-surface)) 125 | (width 1 :type fixnum :read-only t) 126 | (height 1 :type fixnum :read-only t) 127 | (prepared-p nil :type boolean) 128 | (front -1 :type (or buffered-surface-texture null)) 129 | (prepared -1 :type (or buffered-surface-texture null)) 130 | (back -1 :type (or buffered-surface-texture null)) 131 | (updating-p nil)) 132 | 133 | 134 | (defun make-buffered-surface (engine width height) 135 | (flet ((%make-texture () 136 | (make-buffered-surface-texture engine width height))) 137 | (%make-buffered-surface 138 | :width width 139 | :height height 140 | :front (%make-texture) 141 | :prepared (%make-texture) 142 | :back (%make-texture)))) 143 | 144 | 145 | (defun destroy-buffered-surface (engine instance) 146 | (destroy-buffered-surface-texture engine (buffered-surface-front instance)) 147 | (destroy-buffered-surface-texture engine (buffered-surface-back instance)) 148 | (destroy-buffered-surface-texture engine (buffered-surface-prepared instance))) 149 | 150 | 151 | (defun lock-buffered-surface (buffered-surface) 152 | (loop until (atomics:cas (buffered-surface-updating-p buffered-surface) nil t))) 153 | 154 | 155 | (defun unlock-buffered-surface (buffered-surface) 156 | (setf (buffered-surface-updating-p buffered-surface) nil)) 157 | 158 | 159 | (defmacro with-locked-buffered-surface ((surface) &body body) 160 | (a:once-only (surface) 161 | `(progn 162 | (lock-buffered-surface ,surface) 163 | (unwind-protect 164 | (progn ,@body) 165 | (unlock-buffered-surface ,surface))))) 166 | 167 | 168 | (defun buffered-surface-acquire (buffered-surface) 169 | (buffered-surface-texture-filatex (buffered-surface-front buffered-surface))) 170 | 171 | 172 | (defun buffered-surface-release (buffered-surface) 173 | (with-locked-buffered-surface (buffered-surface) 174 | (when (buffered-surface-prepared-p buffered-surface) 175 | (rotatef (buffered-surface-front buffered-surface) 176 | (buffered-surface-prepared buffered-surface)) 177 | (setf (buffered-surface-prepared-p buffered-surface) nil)))) 178 | 179 | 180 | (defun swap-buffered-surface (buffered-surface) 181 | (with-locked-buffered-surface (buffered-surface) 182 | (rotatef (buffered-surface-back buffered-surface) 183 | (buffered-surface-prepared buffered-surface)) 184 | (setf (buffered-surface-prepared-p buffered-surface) t))) 185 | -------------------------------------------------------------------------------- /alien-works.asd: -------------------------------------------------------------------------------- 1 | (cl:pushnew :cl-opengl-no-preload cl:*features*) 2 | (cl:pushnew :iffi-custom-allocation cl:*features*) 3 | 4 | (asdf:defsystem :alien-works 5 | :description "High-performance game foundation framework" 6 | :version "0.0.0" 7 | :license "MIT" 8 | :author "Pavel Korolev" 9 | :mailto "dev@borodust.org" 10 | :pathname "src/" 11 | :depends-on (;; foreign api 12 | #:alien-works-foundation 13 | #:aw-sdl 14 | #:aw-glm 15 | #:aw-filament/runtime 16 | #:aw-physx 17 | #:aw-chipmunk 18 | #:aw-skia 19 | #:aw-openal 20 | #:aw-opus 21 | (:feature :android #:cl-opengl/es2) 22 | (:feature (:not :android) #:cl-opengl) 23 | ;; ffi 24 | #:static-vectors 25 | #:claw-utils 26 | #:cffi 27 | #:cffi-c-ref 28 | ;; generic utility 29 | #:uiop 30 | #:alexandria 31 | #:trivial-main-thread 32 | #:trivial-gray-streams 33 | #:flexi-streams 34 | #:bordeaux-threads 35 | #:atomics 36 | #:cl-muth 37 | #:varjo) 38 | :serial t 39 | :components ((:module "utils" 40 | :serial t 41 | :components ((:file "utils"))) 42 | (:module "memory" 43 | :serial t 44 | :components ((:file "packages") 45 | (:file "system") 46 | (:file "memory") 47 | (:file "allocator"))) 48 | (:module "math" 49 | :serial t 50 | :components ((:file "packages") 51 | (:file "common") 52 | (:file "vec2") 53 | (:file "vec3") 54 | (:file "vec4") 55 | (:file "quat") 56 | (:file "mat3") 57 | (:file "mat4") 58 | (:file "math"))) 59 | (:module "host" 60 | :serial t 61 | :components ((:file "packages") 62 | (:file "system/linux" :if-feature (:and :linux (:not :android))) 63 | (:file "system/android" :if-feature :android) 64 | (:file "system/windows" :if-feature :windows) 65 | (:file "host"))) 66 | (:module "audio" 67 | :serial t 68 | :components ((:file "packages") 69 | (:module "openal" 70 | :components ((:file "openal"))) 71 | (:module "opus" 72 | :components ((:file "opus"))) 73 | (:file "audio"))) 74 | (:module "graphics" 75 | :serial t 76 | :components ((:file "packages") 77 | (:file "surface") 78 | (:module "varjo" 79 | :serial t 80 | :components ((:file "varjo"))) 81 | (:module "filament" 82 | :serial t 83 | :components ((:file "utils") 84 | (:file "math") 85 | (:file "box") 86 | (:file "engine") 87 | (:file "material") 88 | (:file "transform") 89 | (:file "buffer") 90 | (:file "entity") 91 | (:file "renderable") 92 | (:file "renderer") 93 | (:file "swap-chain") 94 | (:file "view") 95 | (:file "scene") 96 | (:file "camera") 97 | (:file "skybox") 98 | (:file "texture") 99 | (:file "light") 100 | (:file "image"))) 101 | (:module "skia" 102 | :serial t 103 | :components ((:file "skia"))) 104 | (:file "canvas") 105 | (:file "material") 106 | (:file "engine"))) 107 | (:module "physics" 108 | :serial t 109 | :components ((:file "packages") 110 | (:module "physx" 111 | :serial t 112 | :components ((:file "math") 113 | (:file "foundation") 114 | (:file "vdb") 115 | (:file "physics") 116 | (:file "dispatcher") 117 | (:file "material") 118 | (:file "scene") 119 | (:file "actor"))) 120 | (:file "physics"))) 121 | (:module "framework" 122 | :serial t 123 | :components ((:file "packages") 124 | (:file "framework"))) 125 | (:file "packages"))) 126 | 127 | 128 | (asdf:defsystem :alien-works/tools 129 | :description "High-performance game foundation framework" 130 | :version "0.0.0" 131 | :license "MIT" 132 | :author "Pavel Korolev" 133 | :mailto "dev@borodust.org" 134 | :depends-on (#:alien-works 135 | #:alien-works-foundation/tools 136 | #:aw-filament/tools 137 | #:aw-assimp) 138 | :serial t 139 | :pathname "tools/" 140 | :components ((:module "graphics" 141 | :serial t 142 | :components ((:file "packages") 143 | (:module "filament" 144 | :components ((:file "image") 145 | (:file "material"))) 146 | (:file "graphics"))) 147 | (:module "resources" 148 | :serial t 149 | :components ((:file "packages") 150 | (:file "image") 151 | (:file "resources") 152 | (:module "scene" 153 | :serial t 154 | :components ((:file "utils") 155 | (:file "material") 156 | (:file "mesh") 157 | (:file "scene"))) 158 | (:file "gltf"))) 159 | (:module "ui" 160 | :serial t 161 | :components ((:file "packages") 162 | (:module "imgui" 163 | :serial t 164 | :components ((:file "imgui"))) 165 | (:file "ui"))) 166 | (:file "packages"))) 167 | -------------------------------------------------------------------------------- /src/audio/openal/openal.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.audio.openal) 2 | 3 | 4 | (defmacro with-context (() &body body) 5 | (alexandria:with-gensyms (dev ctx) 6 | `(float-features:with-float-traps-masked () 7 | ;; Open default sound device 8 | (let ((,dev (%alc:open-device nil))) 9 | (when (cffi:null-pointer-p ,dev) 10 | (error "Couldn't open sound device")) 11 | ;; Create OpenAL context for opened device 12 | (let ((,ctx (%alc:create-context ,dev nil))) 13 | (when (cffi:null-pointer-p ,ctx) 14 | (error "Failed to create OpenAL context")) 15 | ;; Assign OpenAL context to the application 16 | (%alc:make-context-current ,ctx) 17 | (%al:distance-model %al:+inverse-distance-clamped+) 18 | (unwind-protect 19 | (progn ,@body) 20 | (%alc:destroy-context ,ctx) 21 | (%alc:close-device ,dev))))))) 22 | 23 | 24 | (defun extension-supported-p (name &optional device) 25 | (/= 0 (%alc:is-extension-present device name))) 26 | 27 | 28 | ;;; 29 | ;;; AUDIO DEVICE 30 | ;;; 31 | (defun all-output-audio-devices () 32 | (if (extension-supported-p "ALC_enumeration_EXT") 33 | (cref:c-let ((str :char :from (%alc:get-string nil %alc:+all-devices-specifier+))) 34 | (loop with start = 0 35 | for i from 0 36 | for char = (str i) 37 | until (and (= char 0) (= start i)) 38 | when (= char 0) 39 | collect (prog1 (cffi:foreign-string-to-lisp (str start &) :count (- i start)) 40 | (setf start (1+ i))))) 41 | (list (%alc:get-string nil %alc:+device-specifier+)))) 42 | 43 | 44 | (defmacro do-output-audio-devices ((device-name) &body body) 45 | `(loop for ,device-name in (all-output-audio-devices) 46 | do (progn ,@body))) 47 | 48 | ;;; 49 | ;;; LISTENER 50 | ;;; 51 | (defun audio-listener-gain () 52 | (cref:c-with ((value :float)) 53 | (%al:get-listenerf %al:+gain+ (value &)) 54 | value)) 55 | 56 | 57 | (defun (setf audio-listener-gain) (value) 58 | (%al:listenerf %al:+gain+ (float value 0f0)) 59 | value) 60 | 61 | 62 | (defun audio-listener-position (result-vec3) 63 | (%al:get-listenerfv %al:+position+ (%math:vec3-ptr result-vec3)) 64 | result-vec3) 65 | 66 | 67 | (defun (setf audio-listener-position) (value-vec3) 68 | (%al:listenerfv %al:+position+ (%math:vec3-ptr value-vec3)) 69 | value-vec3) 70 | 71 | 72 | (defun audio-listener-velocity (result-vec3) 73 | (%al:get-listenerfv %al:+velocity+ (%math:vec3-ptr result-vec3)) 74 | result-vec3) 75 | 76 | 77 | (defun (setf audio-listener-velocity) (value-vec3) 78 | (%al:listenerfv %al:+velocity+ (%math:vec3-ptr value-vec3)) 79 | value-vec3) 80 | 81 | 82 | (defun audio-listener-orientation (at-result-vec3 up-result-vec3) 83 | (cref:c-with ((orientation %al:float :count 6)) 84 | (%al:get-listenerfv %al:+orientation+ (orientation &)) 85 | (setf (math:vec3 at-result-vec3 0) (orientation 0) 86 | (math:vec3 at-result-vec3 1) (orientation 1) 87 | (math:vec3 at-result-vec3 2) (orientation 2) 88 | 89 | (math:vec3 up-result-vec3 0) (orientation 3) 90 | (math:vec3 up-result-vec3 1) (orientation 4) 91 | (math:vec3 up-result-vec3 2) (orientation 5))) 92 | (values at-result-vec3 up-result-vec3)) 93 | 94 | 95 | (defun (setf audio-listener-orientation) (at-result-vec3 up-result-vec3) 96 | (cref:c-with ((orientation %al:float :count 6)) 97 | (setf (orientation 0) (math:vec3 at-result-vec3 0) 98 | (orientation 1) (math:vec3 at-result-vec3 1) 99 | (orientation 2) (math:vec3 at-result-vec3 2) 100 | 101 | (orientation 3) (math:vec3 up-result-vec3 0) 102 | (orientation 4) (math:vec3 up-result-vec3 1) 103 | (orientation 5) (math:vec3 up-result-vec3 2)) 104 | (%al:listenerfv %al:+orientation+ (orientation &))) 105 | (values at-result-vec3 up-result-vec3)) 106 | 107 | 108 | ;;; 109 | ;;; BUFFER 110 | ;;; 111 | (defun make-audio-buffer () 112 | (cref:c-with ((buf %al:uint)) 113 | (setf buf 0) 114 | (%al:gen-buffers 1 (buf &)) 115 | buf)) 116 | 117 | 118 | (defun (setf audio-buffer-data) (s16-48k-pcm-data buffer &key (channels 1)) 119 | (sv:with-static-vector (foreign-data (length s16-48k-pcm-data) 120 | :element-type '(signed-byte 16) 121 | :initial-contents s16-48k-pcm-data) 122 | ;; Load sample data into the buffer 123 | (%al:buffer-data buffer (ecase channels 124 | (1 %al:+format-mono16+) 125 | (2 %al:+format-stereo16+)) 126 | (static-vectors:static-vector-pointer foreign-data) 127 | (* (length foreign-data) 2) 128 | 48000))) 129 | 130 | 131 | (defun destroy-audio-buffer (buffer) 132 | (cref:c-with ((buf %al:uint)) 133 | (setf buf buffer) 134 | (%al:delete-buffers 1 (buf &))) 135 | (values)) 136 | 137 | 138 | ;;; 139 | ;;; SOURCE 140 | ;;; 141 | (defun make-audio-source () 142 | (cref:c-with ((source %al:uint)) 143 | (setf source 0) 144 | (%al:gen-sources 1 (source &)) 145 | source)) 146 | 147 | 148 | (defun destroy-audio-source (source) 149 | (cref:c-with ((src %al:uint)) 150 | (setf src source) 151 | (%al:delete-sources 1 (src &))) 152 | (values)) 153 | 154 | 155 | (defun audio-source-state (source) 156 | (cref:c-with ((state %al:int)) 157 | (%al:get-sourcei source %al:+source-state+ (state &)) 158 | (case state 159 | (#.%al:+initial+ :initial) 160 | (#.%al:+playing+ :playing) 161 | (#.%al:+paused+ :paused) 162 | (#.%al:+stopped+ :stopped)))) 163 | 164 | 165 | (defun audio-source-buffer (source) 166 | (cref:c-with ((buf %al:uint)) 167 | (%al:get-sourcei source %al:+buffer+ (buf &)) 168 | buf)) 169 | 170 | 171 | (defun (setf audio-source-buffer) (buffer source) 172 | (%al:sourcei source %al:+buffer+ buffer) 173 | buffer) 174 | 175 | 176 | (defun play-audio-source (source) 177 | (%al:source-play source)) 178 | 179 | 180 | (defun pause-audio-source (source) 181 | (%al:source-pause source)) 182 | 183 | 184 | (defun stop-audio-source (source) 185 | (%al:source-stop source)) 186 | 187 | 188 | (defun audio-source-pitch (source) 189 | (cref:c-with ((val %al:float)) 190 | (%al:get-sourcef source %al:+pitch+ (val &)) 191 | val)) 192 | 193 | 194 | (defun (setf audio-source-pitch) (value source) 195 | (%al:sourcef source %al:+pitch+ (float (max 0 value) 0f0)) 196 | value) 197 | 198 | 199 | (defun audio-source-looping-p (source) 200 | (cref:c-with ((val %al:int)) 201 | (%al:get-sourcei source %al:+looping+ (val &)) 202 | (/= val %al:+false+))) 203 | 204 | 205 | (defun (setf audio-source-looping-p) (value source) 206 | (%al:sourcei source %al:+looping+ (if value %al:+true+ %al:+false+)) 207 | value) 208 | 209 | 210 | (defun audio-source-gain (source) 211 | (cref:c-with ((val %al:float)) 212 | (%al:get-sourcef source %al:+gain+ (val &)) 213 | val)) 214 | 215 | 216 | (defun (setf audio-source-gain) (value source) 217 | (%al:sourcef source %al:+gain+ (float (max 0 value) 0f0)) 218 | value) 219 | 220 | 221 | (defun audio-source-reference-distance (source) 222 | (cref:c-with ((val %al:float)) 223 | (%al:get-sourcef source %al:+reference-distance+ (val &)) 224 | val)) 225 | 226 | 227 | (defun (setf audio-source-reference-distance) (value source) 228 | (%al:sourcef source %al:+reference-distance+ (float (max 0 value) 0f0)) 229 | value) 230 | 231 | 232 | (defun audio-source-max-distance (source) 233 | (cref:c-with ((val %al:float)) 234 | (%al:get-sourcef source %al:+max-distance+ (val &)) 235 | val)) 236 | 237 | 238 | (defun (setf audio-source-max-distance) (value source) 239 | (%al:sourcef source %al:+max-distance+ (float (max 0 value) 0f0)) 240 | value) 241 | 242 | 243 | (defun audio-source-rolloff (source) 244 | (cref:c-with ((value %al:float)) 245 | (%al:get-sourcef source %al:+rolloff-factor+ (value &)) 246 | value)) 247 | 248 | 249 | (defun (setf audio-source-rolloff) (value source) 250 | (%al:sourcef source %al:+rolloff-factor+ (float (max 0 value) 0f0)) 251 | value) 252 | 253 | 254 | (defun audio-source-position (source result-vec3) 255 | (%al:get-sourcefv source %al:+position+ (%math:vec3-ptr result-vec3)) 256 | result-vec3) 257 | 258 | 259 | (defun (setf audio-source-position) (vec3 source) 260 | (%al:sourcefv source %al:+position+ (%math:vec3-ptr vec3)) 261 | vec3) 262 | 263 | 264 | (defun audio-source-velocity (source result-vec3) 265 | (%al:get-sourcefv source %al:+velocity+ (%math:vec3-ptr result-vec3)) 266 | result-vec3) 267 | 268 | 269 | (defun (setf audio-source-velocity) (vec3 source) 270 | (%al:sourcefv source %al:+velocity+ (%math:vec3-ptr vec3)) 271 | vec3) 272 | 273 | 274 | (defun audio-source-direction (source result-vec3) 275 | (%al:get-sourcefv source %al:+direction+ (%math:vec3-ptr result-vec3)) 276 | result-vec3) 277 | 278 | 279 | (defun (setf audio-source-direction) (vec3 source) 280 | (%al:sourcefv source %al:+direction+ (%math:vec3-ptr vec3)) 281 | vec3) 282 | 283 | 284 | (defun audio-source-offset (source &optional (type :seconds)) 285 | (if (eq type :seconds) 286 | (cref:c-with ((value %al:float)) 287 | (%al:get-sourcef source %al:+sec-offset+ (value &)) 288 | value) 289 | (cref:c-with ((value %al:uint)) 290 | (%al:get-sourcei source 291 | (ecase type 292 | (:samples %al:+sample-offset+) 293 | (:bytes %al:+byte-offset+)) 294 | (value &)) 295 | value))) 296 | 297 | 298 | ;;; 299 | ;;; MISC 300 | ;;; 301 | (defun wait-for-source (source) 302 | "Wait until provided source is not in AL_PLAYING state" 303 | (loop while (eq (audio-source-state source) :playing) 304 | do (sleep 0.1))) 305 | 306 | 307 | (defun play-pcm-s16-mono (pcm-data) 308 | (let ((buffer (make-audio-buffer)) 309 | (source (make-audio-source))) 310 | (unwind-protect 311 | (progn 312 | (setf (audio-buffer-data buffer) pcm-data 313 | (audio-source-buffer source) buffer) 314 | (play-audio-source source) 315 | (wait-for-source source)) 316 | (destroy-audio-buffer buffer) 317 | (destroy-audio-source source)))) 318 | -------------------------------------------------------------------------------- /src/graphics/filament/texture.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.filament) 2 | 3 | 4 | (u:define-enumval-extractor texture-sampler-type-enum %filament:backend+sampler-type) 5 | (u:define-enumval-extractor texture-internal-format-enum %filament:texture+internal-format) 6 | (u:define-enumval-extractor texture-cubemap-face-enum %filament:texture+cubemap-face) 7 | (u:define-enumval-extractor texture-usage-enum %filament:texture+usage) 8 | (u:define-enumval-extractor texture-swizzle-enum %filament:texture+swizzle) 9 | 10 | (u:define-enumval-extractor pixel-format-enum %filament:backend+pixel-data-format) 11 | (u:define-enumval-extractor pixel-type-enum %filament:backend+pixel-data-type) 12 | (u:define-enumval-extractor pixel-compressed-type-enum 13 | %filament:backend+compressed-pixel-data-type) 14 | 15 | 16 | (warp-intricate-builder-option texture-builder :width 17 | %filament:width 18 | '(claw-utils:claw-pointer %filament:texture+builder) 19 | '%filament:uint32-t) 20 | 21 | (warp-intricate-builder-option texture-builder :height 22 | %filament:height 23 | '(claw-utils:claw-pointer %filament:texture+builder) 24 | '%filament:uint32-t) 25 | 26 | (warp-intricate-builder-option texture-builder :depth 27 | %filament:depth 28 | '(claw-utils:claw-pointer %filament:texture+builder) 29 | '%filament:uint32-t) 30 | 31 | (warp-intricate-builder-option texture-builder :levels 32 | %filament:levels 33 | '(claw-utils:claw-pointer %filament:texture+builder) 34 | '%filament:uint8-t) 35 | 36 | (warp-intricate-builder-option texture-builder :sampler 37 | %filament:sampler 38 | '(claw-utils:claw-pointer %filament:texture+builder) 39 | '%filament:texture+sampler) 40 | 41 | (warp-intricate-builder-option texture-builder :format 42 | %filament:format 43 | '(claw-utils:claw-pointer %filament:texture+builder) 44 | '%filament:texture+internal-format) 45 | 46 | (warp-intricate-builder-option texture-builder :usage 47 | %filament:usage 48 | '(claw-utils:claw-pointer %filament:texture+builder) 49 | '%filament:texture+usage) 50 | 51 | (warp-intricate-builder-option texture-builder :swizzle 52 | %filament:swizzle 53 | '(claw-utils:claw-pointer %filament:texture+builder) 54 | '%filament:texture+swizzle 55 | '%filament:texture+swizzle 56 | '%filament:texture+swizzle 57 | '%filament:texture+swizzle) 58 | 59 | (warp-intricate-builder-option texture-builder :import 60 | %filament:import 61 | '(claw-utils:claw-pointer %filament:texture+builder) 62 | '%filament:intptr-t) 63 | 64 | 65 | (defmacro with-texture-builder ((name &body steps) &body body) 66 | (flet ((ctor-expander () 67 | `(%filament:texture+builder)) 68 | (build-expander (builder) 69 | `(%filament:build 70 | '(claw-utils:claw-pointer %filament:texture+builder) ,builder 71 | '(claw-utils:claw-pointer %filament:engine) !::engine))) 72 | (explode-builder name 73 | 'texture-builder 74 | #'ctor-expander 75 | #'build-expander 76 | '(!::engine) 77 | steps 78 | body))) 79 | 80 | 81 | (defun destroy-texture (engine texture) 82 | (%filament:destroy 83 | '(claw-utils:claw-pointer %filament::engine) engine 84 | '(claw-utils:claw-pointer %filament::texture) texture)) 85 | 86 | 87 | (defun update-texture-image (engine texture level pixel-buffer) 88 | (%filament:set-image 89 | :const 90 | '(claw-utils:claw-pointer %filament:texture) texture 91 | '(claw-utils:claw-pointer %filament:engine) engine 92 | '%filament:size-t level 93 | '(claw-utils:claw-pointer %filament:texture+pixel-buffer-descriptor) pixel-buffer)) 94 | 95 | 96 | (defun update-texture-subimage (engine texture level x-offset y-offset width height pixel-buffer) 97 | (%filament:set-image 98 | :const 99 | '(claw-utils:claw-pointer %filament:texture) texture 100 | '(claw-utils:claw-pointer %filament:engine) engine 101 | '%filament:size-t level 102 | '%filament:uint32-t x-offset 103 | '%filament:uint32-t y-offset 104 | '%filament:uint32-t width 105 | '%filament:uint32-t height 106 | '(claw-utils:claw-pointer %filament:texture+pixel-buffer-descriptor) pixel-buffer)) 107 | 108 | 109 | (defun update-texture-array-subimage (engine texture level x-offset y-offset z-offset 110 | width height depth 111 | pixel-buffer) 112 | (%filament:set-image 113 | :const 114 | '(claw-utils:claw-pointer %filament:texture) texture 115 | '(claw-utils:claw-pointer %filament:engine) engine 116 | '%filament:size-t level 117 | '%filament:uint32-t x-offset 118 | '%filament:uint32-t y-offset 119 | '%filament:uint32-t z-offset 120 | '%filament:uint32-t width 121 | '%filament:uint32-t height 122 | '%filament:uint32-t depth 123 | '(claw-utils:claw-pointer %filament:texture+pixel-buffer-descriptor) pixel-buffer)) 124 | 125 | 126 | (defmacro with-face-offsets ((val) &body body) 127 | `(iffi:with-intricate-instance (,val %filament:texture+face-offsets) 128 | ,@body)) 129 | 130 | 131 | (defun face-offset (offsets idx) 132 | (%filament:operator[] 133 | :const 134 | '(claw-utils:claw-pointer %filament:texture+face-offsets) offsets 135 | '%filament::size-t idx)) 136 | 137 | 138 | (defun (setf face-offset) (value offsets idx) 139 | (let ((ptr (%filament:operator[] 140 | '(claw-utils:claw-pointer %filament:texture+face-offsets) offsets 141 | '%filament::size-t idx))) 142 | (setf (cffi:mem-ref ptr '%filament:texture+face-offsets+size-type) value))) 143 | 144 | 145 | (defun update-cubemap-images (engine texture level pixel-buffer face-offsets) 146 | (%filament:set-image 147 | :const 148 | '(claw-utils:claw-pointer %filament:texture) texture 149 | '(claw-utils:claw-pointer %filament:engine) engine 150 | '%filament:size-t level 151 | '(claw-utils:claw-pointer %filament:texture+pixel-buffer-descriptor) pixel-buffer 152 | '(claw-utils:claw-pointer %filament:texture+face-offsets) face-offsets)) 153 | 154 | 155 | (defun generate-texture-mipmaps (engine texture) 156 | (%filament:generate-mipmaps 157 | :const 158 | '(claw-utils:claw-pointer %filament:texture) texture 159 | '(claw-utils:claw-pointer %filament:engine) engine)) 160 | 161 | 162 | (defun generate-texture-prefilter-mipmaps (engine texture pixel-buffer face-offsets 163 | &optional prefilter-options) 164 | (%filament:generate-prefilter-mipmap 165 | '(claw-utils:claw-pointer %filament:texture) texture 166 | '(claw-utils:claw-pointer %filament:engine) engine 167 | '(claw-utils:claw-pointer %filament:texture+pixel-buffer-descriptor) pixel-buffer 168 | '(claw-utils:claw-pointer %filament:texture+face-offsets) face-offsets 169 | '(claw-utils:claw-pointer %filament:texture+prefilter-options) prefilter-options)) 170 | 171 | 172 | ;;; 173 | ;;; PIXEL BUFFER 174 | ;;; 175 | (defvar *buffer-release-callback-table* (make-hash-table)) 176 | 177 | 178 | (defun register-release-buffer-callback (release-callback) 179 | (if release-callback 180 | (let ((identity-byte (cffi:foreign-alloc :char))) 181 | (setf 182 | (gethash (cffi:pointer-address identity-byte) *buffer-release-callback-table*) 183 | release-callback) 184 | identity-byte) 185 | (cffi:null-pointer))) 186 | 187 | 188 | (cffi:defcallback release-buffer-callback claw-utils:claw-pointer ((data claw-utils:claw-pointer) 189 | (size %filament:size-t) 190 | (user claw-utils:claw-pointer)) 191 | (declare (ignore data size)) 192 | (a:when-let (callback (gethash (cffi:pointer-address user) *buffer-release-callback-table*)) 193 | (unwind-protect 194 | (funcall callback) 195 | (cffi:foreign-free user) 196 | (remhash (cffi:pointer-address user) *buffer-release-callback-table*))) 197 | (cffi:null-pointer)) 198 | 199 | 200 | (defun make-pixel-buffer (data-ptr data-size pixel-format pixel-type &optional release-callback) 201 | (iffi:make-intricate-instance 202 | '%filament:backend+pixel-buffer-descriptor 203 | '(claw-utils:claw-pointer :void) data-ptr 204 | '%filament:size-t data-size 205 | '%filament:backend+pixel-buffer-descriptor+pixel-data-format pixel-format 206 | '%filament:backend+pixel-buffer-descriptor+pixel-data-type pixel-type 207 | '%filament:backend+buffer-descriptor+callback (cffi:callback release-buffer-callback) 208 | '(claw-utils:claw-pointer :void) (register-release-buffer-callback release-callback))) 209 | 210 | 211 | (defun make-compressed-pixel-buffer (data-ptr data-size compressed-size compressed-pixel-type 212 | &optional release-callback) 213 | (iffi:make-intricate-instance 214 | '%filament:backend+pixel-buffer-descriptor 215 | '(claw-utils:claw-pointer :void) data-ptr 216 | '%filament:size-t data-size 217 | '%filament:backend+compressed-pixel-data-type compressed-pixel-type 218 | '%filament:uint32-t compressed-size 219 | '%filament:backend+buffer-descriptor+callback (cffi:callback release-buffer-callback) 220 | '(claw-utils:claw-pointer :void) (register-release-buffer-callback release-callback))) 221 | 222 | 223 | (defun destory-pixel-buffer (buffer) 224 | (iffi:destroy-intricate-instance '%filament:backend+pixel-buffer-descriptor buffer)) 225 | 226 | ;;; 227 | ;;; SAMPLER 228 | ;;; 229 | (u:define-enumval-extractor min-filter-enum %filament:backend+sampler-min-filter) 230 | (u:define-enumval-extractor mag-filter-enum %filament:backend+sampler-mag-filter) 231 | (u:define-enumval-extractor wrap-mode-enum %filament:backend+sampler-wrap-mode) 232 | (u:define-enumval-extractor compare-mode-enum %filament:backend+sampler-compare-mode) 233 | (u:define-enumval-extractor compare-func-enum %filament:backend+sampler-compare-func) 234 | 235 | 236 | (defun make-sampler (min mag s-wrap r-wrap t-wrap compare-mode compare-func) 237 | (let ((instance (iffi:make-intricate-instance 238 | '%filament:texture-sampler 239 | '%filament::texture-sampler+min-filter min 240 | '%filament::texture-sampler+mag-filter mag 241 | '%filament::texture-sampler+wrap-mode s-wrap 242 | '%filament::texture-sampler+wrap-mode r-wrap 243 | '%filament::texture-sampler+wrap-mode t-wrap))) 244 | (%filament:set-compare-mode 245 | '(claw-utils:claw-pointer %filament::texture-sampler) instance 246 | '%filament::texture-sampler+compare-mode compare-mode 247 | '%filament::texture-sampler+compare-func compare-func) 248 | instance)) 249 | 250 | 251 | (defun destroy-sampler (sampler) 252 | (iffi:destroy-intricate-instance '%filament:texture-sampler sampler)) 253 | -------------------------------------------------------------------------------- /src/audio/opus/opus.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :alien-works.audio.opus) 2 | 3 | 4 | (declaim (special *length-buffer*)) 5 | 6 | (a:define-constant +recommended-packet-byte-size+ 4095) 7 | 8 | (a:define-constant +max-samples-per-channel+ (* (/ 48000 ;; 48KHz sample rate 9 | 1000) ;; per ms 10 | 60)) ;; 60ms frame duration 11 | 12 | 13 | (defun decode-packet-length (stream) 14 | (a:when-let (byte (read-byte stream nil nil)) 15 | (if (< byte #b10000000) 16 | byte 17 | (let ((next-bytes (1+ (logand (ash byte -4) #b0111)))) 18 | (read-sequence *length-buffer* stream :end next-bytes) 19 | (loop with length = (logand byte #b00001111) 20 | for i from 0 below next-bytes 21 | for byte = (aref *length-buffer* i) 22 | do (setf length (logior (ash length 8) byte)) 23 | finally (return length)))))) 24 | 25 | 26 | (defun encode-packet-length (stream length) 27 | (if (< length #b10000000) 28 | (write-byte length stream) 29 | (flet ((write-len-bytes (len-bytes value) 30 | (loop for i from (1- len-bytes) downto 0 31 | do (write-byte (ldb (byte 8 (* i 8)) value) stream))) 32 | (write-len-size (len-byte-size &optional (tail-value 0)) 33 | (write-byte (logior #b10000000 34 | (ash (1- len-byte-size) 4) 35 | tail-value) 36 | stream))) 37 | (let* ((bit-len (integer-length length)) 38 | (tail-bits (mod bit-len 8)) 39 | (len-bytes (floor (/ bit-len 8)))) 40 | (when (> bit-len 68) 41 | (error "Cannot encode length ~A: max integer length is 68 bits" length)) 42 | (cond 43 | ((zerop tail-bits) 44 | (write-len-size len-bytes) 45 | (write-len-bytes len-bytes length)) 46 | ((<= tail-bits 4) 47 | (let ((tail-value (ldb (byte 8 (* 8 len-bytes)) length))) 48 | (write-len-size len-bytes tail-value) 49 | (write-len-bytes len-bytes (logxor length 50 | (ash tail-value (* 8 len-bytes)) 51 | (ash #b00001111 (* 8 len-bytes)))))) 52 | (t (write-len-size (1+ len-bytes)) 53 | (write-len-bytes (1+ len-bytes) length))))))) 54 | 55 | 56 | (defun encode-packet (packet-stream packet &key start end) 57 | (let ((end (or end (length packet))) 58 | (start (or start 0))) 59 | (encode-packet-length packet-stream (- end start)) 60 | (write-sequence packet packet-stream :start start :end end) 61 | (values))) 62 | 63 | 64 | (define-condition packet-overflow (serious-condition) 65 | ((required-size :initarg :size :reader packet-required-size))) 66 | 67 | 68 | (defun try-different-array (new-array &key ((:start new-start) nil start-provided-p) 69 | ((:end new-end) nil end-provided-p)) 70 | (a:if-let (restart (find-restart 'try-different-array)) 71 | (apply #'invoke-restart 72 | restart 73 | new-array 74 | (nconc (when start-provided-p 75 | (list :start new-start)) 76 | (when end-provided-p 77 | (list :end new-end)))) 78 | (warn "~A restart not found" 'try-different-array))) 79 | 80 | 81 | (defun decode-packet (packet-stream packet &key start end) 82 | (a:if-let (packet-len (decode-packet-length packet-stream)) 83 | (tagbody retry 84 | (restart-case 85 | (let ((end (or end (length packet))) 86 | (start (or start 0))) 87 | (when (< (- end start) packet-len) 88 | (error (make-condition 'packet-overflow :size packet-len))) 89 | (let* ((bytes-read (read-sequence packet 90 | packet-stream 91 | :start start 92 | :end (+ start packet-len)))) 93 | (unless (= bytes-read packet-len) 94 | (error "Malformed packet: expected size ~A, but got ~A" 95 | packet-len bytes-read)) 96 | (return-from decode-packet (values packet bytes-read)))) 97 | (try-different-array (new-array &key ((:start new-start) nil start-provided-p) 98 | ((:end new-end) nil end-provided-p)) 99 | (when new-array 100 | (setf packet new-array)) 101 | (when start-provided-p 102 | (setf start new-start)) 103 | (when end-provided-p 104 | (setf end new-end)) 105 | (go retry)))) 106 | (values packet 0))) 107 | 108 | 109 | (defun update-encoder (encoder &key bitrate signal) 110 | (cref:c-with ((err :int)) 111 | (macrolet ((%update-encoder (request-code &rest values) 112 | `(unless (= (%opus:encoder-ctl encoder ,request-code ,@values) 0) 113 | (error "Failed to fulfill encoder request: ~A" 114 | (cffi:foreign-string-to-lisp (%opus:strerror err)))))) 115 | (when bitrate 116 | (%update-encoder %opus:+set-bitrate-request+ :int bitrate)) 117 | (when signal 118 | (%update-encoder %opus:+set-signal-request+ 119 | :int (ecase signal 120 | (:auto %opus:+auto+) 121 | (:voice %opus:+signal-voice+) 122 | (:music %opus:+signal-music+))))))) 123 | 124 | (defun encode-frame (stream 125 | encoder 126 | frame 127 | samples-per-channel 128 | &key packet-buffer) 129 | " 130 | * FRAME '(signed-byte 16) static-vector with samples for duration of 2.5, 5, 10, 20, 40 or 60 ms. 131 | * PACKET-BUFFER '(unsigned-byte 8) static-vector. Recommended size is 4KiB-1. 132 | " 133 | (let* ((bytes-written (%opus:encode encoder 134 | (sv:static-vector-pointer frame) 135 | samples-per-channel 136 | (sv:static-vector-pointer packet-buffer) 137 | (length packet-buffer)))) 138 | (when (< bytes-written 0) 139 | (error "Failed to encode audio: ~A" 140 | (cffi:foreign-string-to-lisp (%opus:strerror bytes-written)))) 141 | (encode-packet stream packet-buffer :end bytes-written)) 142 | (values)) 143 | 144 | 145 | (defun clean-frame-buffer-tail (frame-buffer head-sample-count) 146 | (host:memset (cffi:inc-pointer (sv:static-vector-pointer frame-buffer) 147 | (* 2 head-sample-count)) 148 | 0 149 | (* 2 (- (length frame-buffer) head-sample-count)))) 150 | 151 | 152 | (defun encode-audio (frame-stream-in packet-stream-out 153 | frame-size 154 | sample-rate 155 | channels 156 | &key (application :auto) 157 | ((:signal signal) :auto) 158 | (bitrate 96000)) 159 | " 160 | * FRAME-SIZE - number of samples in the whole frame (all channels). 161 | " 162 | (cref:c-with ((err :int)) 163 | (let* ((*length-buffer* (make-array 8 :element-type '(unsigned-byte 8))) 164 | (application (ecase application 165 | ((:auto :audio) %opus:+application-audio+) 166 | (:voice %opus:+application-voip+))) 167 | (encoder (%opus:encoder-create sample-rate channels application (err &))) 168 | (samples-per-channel (/ frame-size channels))) 169 | (unless (= err 0) 170 | (error "Failed to create encoder (~A): ~A" err 171 | (cffi:foreign-string-to-lisp (%opus:strerror err)))) 172 | (unwind-protect 173 | (sv:with-static-vectors ((frame-buffer frame-size 174 | :element-type '(signed-byte 16)) 175 | (packet-buffer +recommended-packet-byte-size+ 176 | :element-type '(unsigned-byte 8))) 177 | (update-encoder encoder 178 | :bitrate bitrate 179 | :signal signal) 180 | (loop for samples-read = (read-sequence frame-buffer frame-stream-in) 181 | when (< samples-read frame-size) 182 | do (clean-frame-buffer-tail frame-buffer samples-read) 183 | do (encode-frame packet-stream-out 184 | encoder 185 | frame-buffer 186 | samples-per-channel 187 | :packet-buffer packet-buffer) 188 | while (= samples-read frame-size))) 189 | (%opus:encoder-destroy encoder))))) 190 | 191 | 192 | (defun decode-frame (packet-stream 193 | decoder 194 | samples-per-channel 195 | &key frame-buffer 196 | packet-buffer) 197 | (multiple-value-bind (packet packet-size) 198 | (decode-packet packet-stream packet-buffer) 199 | (if (zerop packet-size) 200 | 0 201 | (%opus:decode decoder 202 | (sv:static-vector-pointer packet) 203 | packet-size 204 | (sv:static-vector-pointer frame-buffer) 205 | samples-per-channel 206 | 0)))) 207 | 208 | 209 | (defun decode-audio (packet-stream-in frame-stream-out 210 | sample-rate 211 | channels) 212 | " 213 | * PACKET-STREAM-IN - input stream of type (UNSIGNED-BYTE 8) 214 | * FRAME-STREAM-OUT - output stream of type (SIGNED-BYTE 16) 215 | " 216 | (cref:c-with ((err :int)) 217 | (let ((decoder (%opus:decoder-create sample-rate channels (err &))) 218 | (*length-buffer* (make-array 8 :element-type '(unsigned-byte 8)))) 219 | (unless (= err 0) 220 | (error "Failed to create decoder (~A): ~A" err 221 | (cffi:foreign-string-to-lisp (%opus:strerror err)))) 222 | 223 | (unwind-protect 224 | (let ((max-samples-per-channel (* (/ sample-rate 1000) 60))) 225 | (sv:with-static-vectors ((frame-buffer (* max-samples-per-channel 226 | channels) 227 | :element-type '(signed-byte 16)) 228 | (packet-buffer +recommended-packet-byte-size+ 229 | :element-type '(unsigned-byte 8))) 230 | (loop for samples-per-channel = (decode-frame packet-stream-in 231 | decoder 232 | max-samples-per-channel 233 | :frame-buffer frame-buffer 234 | :packet-buffer packet-buffer) 235 | until (zerop samples-per-channel) 236 | do (write-sequence frame-buffer frame-stream-out 237 | :end (* samples-per-channel channels))))) 238 | (%opus:decoder-destroy decoder))))) 239 | 240 | 241 | (defun encode (source destination &key 242 | (sample-rate 48000) 243 | (channels 1)) 244 | (with-open-file (in source :element-type '(signed-byte 16) :direction :input) 245 | (with-open-file (out destination :element-type '(unsigned-byte 8) :direction :output) 246 | (let ((frame-duration 20)) ;; msec 247 | (encode-audio in out (* (/ sample-rate 1000) frame-duration channels) 248 | sample-rate 249 | channels))))) 250 | 251 | 252 | (defun decode (location &key 253 | (sample-rate 48000) 254 | (channels 1)) 255 | (with-open-file (in location :element-type '(unsigned-byte 8) :direction :input) 256 | (flexi-streams:with-output-to-sequence (out :element-type '(signed-byte 16)) 257 | (decode-audio in out sample-rate channels)))) 258 | -------------------------------------------------------------------------------- /src/graphics/skia/skia.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :%alien-works.skia) 2 | 3 | 4 | (declaim (special *canvas* 5 | *paint* 6 | *font*)) 7 | 8 | (u:define-enumval-extractor color-type-enum %skia:sk-color-type) 9 | (u:define-enumval-extractor surface-origin-enum %skia:gr-surface-origin) 10 | (u:define-enumval-extractor clip-op-enum %skia:sk-clip-op) 11 | 12 | 13 | (defun make-surface-from-backend-render-target (context render-target surface-props) 14 | (iffi:with-intricate-instance (color-space-sp %skia:sk-sp) 15 | (%skia:sk-surface+make-from-backend-render-target 16 | '(:pointer %skia:sk-sp) (iffi:intricate-alloc '%skia:sk-sp) 17 | '(:pointer %skia:gr-recording-context) context 18 | '(:pointer %skia:gr-backend-render-target) render-target 19 | '%skia:gr-surface-origin (surface-origin-enum :bottom-left-gr-surface-origin) 20 | '%skia:sk-color-type (color-type-enum :rgba-8888-sk-color-type) 21 | '(:pointer %skia:sk-sp) color-space-sp 22 | '(:pointer %skia:sk-surface-props) surface-props 23 | '%skia:sk-surface+render-target-release-proc (cffi:null-pointer) 24 | '%skia:sk-surface+release-context (cffi:null-pointer)))) 25 | 26 | 27 | (defun make-native-gl-interface () 28 | (%skia:gr-gl-make-native-interface 29 | '(:pointer %skia:sk-sp) 30 | (iffi:intricate-alloc '%skia:sk-sp))) 31 | 32 | 33 | (defun make-gl-context (gl-interface-sp) 34 | (%skia:gr-direct-context+make-gl 35 | '(:pointer %skia:sk-sp) (iffi:intricate-alloc 36 | '%skia:sk-sp) 37 | '(:pointer %skia:sk-sp) gl-interface-sp)) 38 | 39 | 40 | ;;; 41 | ;;; SKIA 42 | ;;; 43 | (defstruct (skia-context 44 | (:constructor %make-context) 45 | (:conc-name %context-)) 46 | interface 47 | handle 48 | framebuffer) 49 | 50 | 51 | (defun context-interface (skia) 52 | (%skia:get :const '(:pointer %skia:sk-sp) (%context-interface skia))) 53 | 54 | 55 | (defun context-handle (skia) 56 | (%skia:get :const '(:pointer %skia:sk-sp) (%context-handle skia))) 57 | 58 | 59 | (defun make-context (framebuffer-id) 60 | (let* ((interface-sp (make-native-gl-interface)) 61 | (context-sp (make-gl-context interface-sp)) 62 | (framebuffer (iffi:make-intricate-instance '%skia:gr-gl-framebuffer-info))) 63 | (iffi:with-intricate-slots %skia:gr-gl-framebuffer-info 64 | ((fbo-id %skia:f-fboid) 65 | (format %skia:f-format)) 66 | framebuffer 67 | (setf fbo-id framebuffer-id 68 | format #x8058)) ;; #define GR_GL_RGBA8 0x8058 69 | 70 | (%make-context :interface interface-sp 71 | :handle context-sp 72 | :framebuffer framebuffer))) 73 | 74 | 75 | (defun flush-context (skia) 76 | (%skia:flush 77 | '(claw-utils:claw-pointer %skia:gr-direct-context) (context-handle skia))) 78 | 79 | 80 | (defun destroy-context (skia) 81 | ;; FIXME: do things 82 | ) 83 | 84 | 85 | 86 | ;;; 87 | ;;; CANVAS 88 | ;;; 89 | (defstruct (skia-canvas 90 | (:constructor %make-canvas) 91 | (:conc-name %canvas-)) 92 | render-target 93 | surface 94 | handle) 95 | 96 | 97 | (defun make-canvas (skia width height) 98 | (let* ((render-target (iffi:make-intricate-instance 99 | '%skia:gr-backend-render-target 100 | :int width 101 | :int height 102 | :int 0 103 | :int 8 104 | '(:pointer %skia:gr-gl-framebuffer-info) (%context-framebuffer skia))) 105 | (surface-sp (iffi:with-intricate-instances ((surface-props %skia:sk-surface-props)) 106 | (make-surface-from-backend-render-target (context-handle skia) 107 | render-target 108 | surface-props))) 109 | (surface (%skia:get :const '(:pointer %skia:sk-sp) surface-sp)) 110 | (canvas (%skia:get-canvas '(:pointer %skia:sk-surface) surface))) 111 | (%make-canvas :surface surface-sp 112 | :handle canvas 113 | :render-target render-target))) 114 | 115 | 116 | (defun update-canvas-clip (canvas x y width height &key (mode :intersect)) 117 | (iffi:with-intricate-instance (irect %skia:sk-i-rect) 118 | (%skia:set-xywh 119 | '(claw-utils:claw-pointer %skia:sk-i-rect) irect 120 | '%skia:int32-t (floor x) 121 | '%skia:int32-t (floor y) 122 | '%skia:int32-t (floor width) 123 | '%skia:int32-t (floor height)) 124 | (%skia:clip-i-rect 125 | '(claw-utils:claw-pointer %skia:sk-canvas) (%canvas-handle canvas) 126 | '(claw-utils:claw-pointer %skia:sk-i-rect) irect 127 | '%skia:sk-clip-op mode)) 128 | canvas) 129 | 130 | 131 | (defun destroy-canvas (canvas) 132 | ;; FIXME: do it 133 | ) 134 | 135 | 136 | ;;; 137 | ;;; DRAWING 138 | ;;; 139 | (defun make-paint () 140 | (iffi:make-intricate-instance '%skia:sk-paint)) 141 | 142 | 143 | (defun destroy-paint (paint) 144 | (iffi:destroy-intricate-instance '%skia:sk-paint paint)) 145 | 146 | 147 | (defun clear-canvas (&optional (canvas *canvas*)) 148 | (%skia:clear '(:pointer %skia:sk-canvas) (%canvas-handle canvas) 149 | '%skia:sk-color %skia:+sk-color-transparent+)) 150 | 151 | 152 | (defun discard-canvas (&optional (canvas *canvas*)) 153 | (%skia:discard '(:pointer %skia:sk-canvas) (%canvas-handle canvas))) 154 | 155 | 156 | (defun flush-canvas (&optional (canvas *canvas*)) 157 | (%skia:flush '(:pointer %skia:sk-canvas) (%canvas-handle canvas))) 158 | 159 | 160 | (defun paint-color (r g b a) 161 | (iffi:with-intricate-instance (color %skia:sk-color4f) 162 | (iffi:with-intricate-slots %skia:sk-color4f ((cr %skia:f-r) 163 | (cg %skia:f-g) 164 | (cb %skia:f-b) 165 | (ca %skia:f-a)) 166 | color 167 | (setf cr (float r 0f0) 168 | cg (float g 0f0) 169 | cb (float b 0f0) 170 | ca (float a 0f0)) 171 | (%skia:set-color 172 | '(claw-utils:claw-pointer %skia:sk-paint) *paint* 173 | '(claw-utils:claw-pointer %skia:sk-color4f) color 174 | '(claw-utils:claw-pointer %skia:sk-color-space) (cffi:null-pointer))))) 175 | 176 | 177 | (defun font-size (size) 178 | (when *font* 179 | (%skia:set-size 180 | '(claw-utils:claw-pointer %skia:sk-font) *font* 181 | '%skia:sk-scalar (float size 0f0)))) 182 | 183 | 184 | (defun font-baseline-snap (snapped) 185 | (when *font* 186 | (%skia:set-baseline-snap 187 | '(claw-utils:claw-pointer %skia:sk-font) *font* 188 | :bool (and snapped t)))) 189 | 190 | 191 | (defun font-edging (mode) 192 | (when *font* 193 | (%skia:set-edging 194 | '(claw-utils:claw-pointer %skia:sk-font) *font* 195 | '%skia::sk-font+edging mode))) 196 | 197 | 198 | (defun font-subpixel (subpixeled) 199 | (when *font* 200 | (%skia:set-subpixel 201 | '(claw-utils:claw-pointer %skia:sk-font) *font* 202 | :bool (and subpixeled t)))) 203 | 204 | 205 | (defun rectangle (x y width height) 206 | (iffi:with-intricate-alloc (rect %skia:sk-rect) 207 | (%skia:sk-rect+make-xywh 208 | '(:pointer %skia:sk-rect) rect 209 | '%skia:sk-scalar (float x 0f0) 210 | '%skia:sk-scalar (float y 0f0) 211 | '%skia:sk-scalar (float width 0f0) 212 | '%skia:sk-scalar (float height 0f0)) 213 | (%skia:draw-rect 214 | '(:pointer %skia:sk-canvas) (%canvas-handle *canvas*) 215 | '(:pointer %skia:sk-rect) rect 216 | '(:pointer %skia:sk-paint) *paint*))) 217 | 218 | 219 | (defun circle (x y radius) 220 | (%skia:draw-circle 221 | '(:pointer %skia:sk-canvas) (%canvas-handle *canvas*) 222 | '%skia:sk-scalar (float x 0f0) 223 | '%skia:sk-scalar (float y 0f0) 224 | '%skia:sk-scalar (float radius 0f0) 225 | '(:pointer %skia:sk-paint) *paint*)) 226 | 227 | 228 | (defun text (text x y) 229 | (when *font* 230 | (cffi:with-foreign-string ((ftext byte-size) text :encoding :utf-8) 231 | (%skia:draw-simple-text 232 | '(claw-utils:claw-pointer %skia:sk-canvas) (%canvas-handle *canvas*) 233 | '(claw-utils:claw-pointer :void) ftext 234 | '%skia:size-t (1- byte-size) 235 | '%skia:sk-text-encoding :utf8 236 | '%skia:sk-scalar (float x 0f0) 237 | '%skia:sk-scalar (float y 0f0) 238 | '(claw-utils:claw-pointer %skia:sk-font) *font* 239 | '(claw-utils:claw-pointer %skia:sk-paint) *paint*)))) 240 | 241 | 242 | (defun save-transform () 243 | (%skia:save '(claw-utils:claw-pointer %skia:sk-canvas) (%canvas-handle *canvas*))) 244 | 245 | 246 | (defun restore-transform () 247 | (%skia:restore '(claw-utils:claw-pointer %skia:sk-canvas) (%canvas-handle *canvas*))) 248 | 249 | 250 | (defun reset-transform () 251 | (%skia:restore-to-count 252 | '(claw-utils:claw-pointer %skia:sk-canvas) (%canvas-handle *canvas*) 253 | :int 1)) 254 | 255 | 256 | (defun translate (x y) 257 | (%skia:translate 258 | '(claw-utils:claw-pointer %skia:sk-canvas) (%canvas-handle *canvas*) 259 | '%skia:sk-scalar (float x 0f0) 260 | '%skia:sk-scalar (float y 0f0))) 261 | 262 | 263 | (defun rotate (degrees) 264 | (%skia:rotate 265 | '(claw-utils:claw-pointer %skia:sk-canvas) (%canvas-handle *canvas*) 266 | '%skia:sk-scalar (float degrees 0f0))) 267 | 268 | 269 | (defun rotate-around (x y degrees) 270 | (%skia:rotate 271 | '(claw-utils:claw-pointer %skia:sk-canvas) (%canvas-handle *canvas*) 272 | '%skia:sk-scalar (float degrees 0f0) 273 | '%skia:sk-scalar (float x 0f0) 274 | '%skia:sk-scalar (float y 0f0))) 275 | 276 | 277 | (defun scale (x y) 278 | (%skia:scale 279 | '(claw-utils:claw-pointer %skia:sk-canvas) (%canvas-handle *canvas*) 280 | '%skia:sk-scalar (float x 0f0) 281 | '%skia:sk-scalar (float y 0f0))) 282 | 283 | ;;; 284 | ;;; FONTS 285 | ;;; 286 | (defun make-typeface (font-data-ub8-array) 287 | (assert (or (subtypep (array-element-type font-data-ub8-array) '(unsigned-byte 8)) 288 | (subtypep (array-element-type font-data-ub8-array) '(signed-byte 8)))) 289 | (let ((typeface (iffi:intricate-alloc '%skia:sk-sp))) 290 | (u:with-pinned-array-pointer (font-data-ptr font-data-ub8-array) 291 | (iffi:with-intricate-alloc (data %skia:sk-sp) 292 | (%skia:sk-data+make-with-copy 293 | '(claw-utils:claw-pointer %skia:sk-sp) data 294 | '(claw-utils:claw-pointer :void) font-data-ptr 295 | '%skia:size-t (length font-data-ub8-array)) 296 | (unwind-protect 297 | (progn 298 | (%skia:sk-typeface+make-from-data 299 | '(claw-utils:claw-pointer %skia:sk-sp) typeface 300 | '(claw-utils:claw-pointer %skia:sk-sp) data 301 | :int 0)) 302 | (%skia:~sk-sp 303 | '(claw-utils:claw-pointer %skia:sk-sp) data)))) 304 | typeface)) 305 | 306 | 307 | (defun destroy-typeface (typeface) 308 | (%skia:~sk-sp 309 | '(claw-utils:claw-pointer %skia:sk-sp) typeface) 310 | (iffi:intricate-free typeface) 311 | (values)) 312 | 313 | 314 | (defun %typeface-family-name (typeface-ptr) 315 | (unless (cffi:null-pointer-p typeface-ptr) 316 | (iffi:with-intricate-instance (sk-str %skia:sk-string) 317 | (%skia:get-family-name 318 | :const 319 | '(claw-utils:claw-pointer %skia:sk-typeface) typeface-ptr 320 | '(claw-utils:claw-pointer %skia:sk-string) sk-str) 321 | (cffi:foreign-string-to-lisp 322 | (%skia:c-str :const '(claw-utils:claw-pointer %skia:sk-string) sk-str) 323 | :encoding :utf-8)))) 324 | 325 | 326 | (defun typeface-family-name (typeface) 327 | (%typeface-family-name (%skia:get 328 | :const 329 | '(claw-utils:claw-pointer %skia:sk-sp) typeface))) 330 | 331 | 332 | (defun make-default-font () 333 | (iffi:make-intricate-instance '%skia:sk-font)) 334 | 335 | 336 | (defun make-font (typeface) 337 | (iffi:make-intricate-instance '%skia:sk-font 338 | '(claw-utils:claw-pointer %skia:sk-sp) typeface)) 339 | 340 | 341 | (defun destroy-font (font) 342 | (iffi:destroy-intricate-instance '%skia:sk-font font)) 343 | 344 | 345 | (defun font-family-name (font) 346 | (%typeface-family-name 347 | (%skia:get-typeface-or-default :const '(claw-utils:claw-pointer %skia:sk-font) font))) 348 | --------------------------------------------------------------------------------