From 6e3f5a53745ccdc3d03a5f1fa95899adbba562b3 Mon Sep 17 00:00:00 2001 From: Javier Sancho Date: Wed, 4 Mar 2020 10:53:05 +0100 Subject: [PATCH] create-device --- Makefile.am | 1 + irrlicht.scm | 7 +- irrlicht/bindings.scm | 53 ------ irrlicht/bindings/core.scm | 71 ------- irrlicht/bindings/gui.scm | 32 ---- irrlicht/bindings/io.scm | 55 ------ irrlicht/bindings/scene.scm | 106 ----------- irrlicht/bindings/video.scm | 255 ------------------------- irrlicht/core.scm | 40 ---- irrlicht/device.scm | 72 ++----- irrlicht/gui.scm | 53 ------ irrlicht/io.scm | 50 ----- irrlicht/scene.scm | 232 ----------------------- irrlicht/util.scm | 29 --- irrlicht/util/foreign.scm | 361 ------------------------------------ irrlicht/video.scm | 199 -------------------- src/EDriverTypes.cpp | 4 - src/Irrlicht.cpp | 11 +- src/dimension2d.cpp | 36 ++++ src/dimension2d.h | 35 ++++ 20 files changed, 95 insertions(+), 1607 deletions(-) delete mode 100644 irrlicht/bindings.scm delete mode 100644 irrlicht/bindings/core.scm delete mode 100644 irrlicht/bindings/gui.scm delete mode 100644 irrlicht/bindings/io.scm delete mode 100644 irrlicht/bindings/scene.scm delete mode 100644 irrlicht/bindings/video.scm delete mode 100644 irrlicht/core.scm delete mode 100644 irrlicht/gui.scm delete mode 100644 irrlicht/io.scm delete mode 100644 irrlicht/scene.scm delete mode 100644 irrlicht/util.scm delete mode 100644 irrlicht/util/foreign.scm delete mode 100644 irrlicht/video.scm create mode 100644 src/dimension2d.cpp create mode 100644 src/dimension2d.h diff --git a/Makefile.am b/Makefile.am index ead6dfc..f9c9ed9 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,6 +1,7 @@ ACLOCAL_AMFLAGS = -I m4 lib_LTLIBRARIES = libguile-irrlicht.la libguile_irrlicht_la_SOURCES = \ + src/dimension2d.cpp \ src/EDriverTypes.cpp \ src/GuileIrrlicht.cpp \ src/Irrlicht.cpp diff --git a/irrlicht.scm b/irrlicht.scm index 5db57e9..97bad7e 100644 --- a/irrlicht.scm +++ b/irrlicht.scm @@ -23,12 +23,7 @@ (eval-when (eval load compile) ;; load public symbols into current module (let ((public-modules - '((irrlicht core) - (irrlicht device) - (irrlicht gui) - (irrlicht io) - (irrlicht scene) - (irrlicht video))) + '((irrlicht device))) (current-interface (module-public-interface (current-module)))) (for-each diff --git a/irrlicht/bindings.scm b/irrlicht/bindings.scm deleted file mode 100644 index 2592e59..0000000 --- a/irrlicht/bindings.scm +++ /dev/null @@ -1,53 +0,0 @@ -;;; guile-irrlicht --- FFI bindings for Irrlicht Engine -;;; Copyright (C) 2019 Javier Sancho -;;; -;;; This file is part of guile-irrlicht. -;;; -;;; Guile-irrlicht is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU Lesser General Public License as -;;; published by the Free Software Foundation; either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; Guile-irrlicht is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with guile-irrlicht. If not, see -;;; . - - -(define-module (irrlicht bindings) - #:use-module (system foreign) - #:use-module (irrlicht util foreign)) - -(define-foreign create-device - '* "irr_createDevice" (list int '* uint32 int int int)) - -(define-foreign get-cursor-control - '* "irr_getCursorControl" (list '*)) - -(define-foreign get-file-system - '* "irr_getFileSystem" (list '*)) - -(define-foreign get-video-driver - '* "irr_getVideoDriver" (list '*)) - -(define-foreign get-gui-environment - '* "irr_getGUIEnvironment" (list '*)) - -(define-foreign get-scene-manager - '* "irr_getSceneManager" (list '*)) - -(define-foreign is-window-active - int "irr_isWindowActive" (list '*)) - -(define-foreign set-window-caption - void "irr_setWindowCaption" (list '* '*)) - -(define-foreign run - int "irr_run" (list '*)) - -(define-foreign drop - int "irr_drop" (list '*)) diff --git a/irrlicht/bindings/core.scm b/irrlicht/bindings/core.scm deleted file mode 100644 index a5f06fd..0000000 --- a/irrlicht/bindings/core.scm +++ /dev/null @@ -1,71 +0,0 @@ -;;; guile-irrlicht --- FFI bindings for Irrlicht Engine -;;; Copyright (C) 2019 Javier Sancho -;;; -;;; This file is part of guile-irrlicht. -;;; -;;; Guile-irrlicht is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU Lesser General Public License as -;;; published by the Free Software Foundation; either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; Guile-irrlicht is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with guile-irrlicht. If not, see -;;; . - - -(define-module (irrlicht bindings core) - #:use-module (system foreign) - #:use-module (irrlicht util foreign)) - -;; dimension2d struct -(define-public dimension2d - (list uint32 uint32)) - -(define-public (dimension2d->pointer data) - (make-c-struct dimension2d data)) - -;; rect struct -(define-public rect - (list int32 int32 int32 int32)) - -(define-public (rect->pointer data) - (make-c-struct rect data)) - -;; vector2df struct -(define-public vector2df - (list float float)) - -(define-public (vector2df->pointer data) - (make-c-struct vector2df data)) - -;; vector3df struct -(define-public vector3df - (list float float float)) - -(define-public (vector3df->pointer data) - (make-c-struct vector3df data)) - -;; aabbox3df struct -(define-wrapped-pointer-type aabbox3df-type - aabbox3df? - pointer->aabbox3df aabbox3df->pointer - (lambda (box port) - (format port "#" - (pointer-address (aabbox3df->pointer box))))) - -(export pointer->aabbox3df - aabbox3df->pointer) - -(define-public aabbox3df - (list vector3df vector3df)) - -(define-foreign aabbox3d-add-internal-point - void "irr_core_aabbox3d_addInternalPoint" (list '* '*)) - -(define-foreign aabbox3d-reset - void "irr_core_aabbox3d_reset" (list '* '*)) diff --git a/irrlicht/bindings/gui.scm b/irrlicht/bindings/gui.scm deleted file mode 100644 index 9aac7ca..0000000 --- a/irrlicht/bindings/gui.scm +++ /dev/null @@ -1,32 +0,0 @@ -;;; guile-irrlicht --- FFI bindings for Irrlicht Engine -;;; Copyright (C) 2019 Javier Sancho -;;; -;;; This file is part of guile-irrlicht. -;;; -;;; Guile-irrlicht is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU Lesser General Public License as -;;; published by the Free Software Foundation; either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; Guile-irrlicht is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with guile-irrlicht. If not, see -;;; . - - -(define-module (irrlicht bindings gui) - #:use-module (system foreign) - #:use-module (irrlicht util foreign)) - -(define-foreign add-static-text - '* "irr_gui_addStaticText" (list '* '* '* int int '* int int)) - -(define-foreign draw-all - void "irr_gui_drawAll" (list '*)) - -(define-foreign set-visible-cursor - void "irr_gui_setVisibleCursor" (list '* int)) diff --git a/irrlicht/bindings/io.scm b/irrlicht/bindings/io.scm deleted file mode 100644 index aafbed6..0000000 --- a/irrlicht/bindings/io.scm +++ /dev/null @@ -1,55 +0,0 @@ -;;; guile-irrlicht --- FFI bindings for Irrlicht Engine -;;; Copyright (C) 2019 Javier Sancho -;;; -;;; This file is part of guile-irrlicht. -;;; -;;; Guile-irrlicht is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU Lesser General Public License as -;;; published by the Free Software Foundation; either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; Guile-irrlicht is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with guile-irrlicht. If not, see -;;; . - - -(define-module (irrlicht bindings io) - #:use-module (system foreign) - #:use-module (rnrs arithmetic bitwise) - #:use-module (irrlicht util foreign)) - -(define (make-cirr-id c0 c1 c2 c3) - (define (char->numeric c) - (if (char? c) (char->integer c) c)) - (logior - (char->numeric c0) - (bitwise-arithmetic-shift-left (char->numeric c1) 8) - (bitwise-arithmetic-shift-left (char->numeric c2) 16) - (bitwise-arithmetic-shift-left (char->numeric c3) 24))) - -;; irr_io_E_FILE_ARCHIVE_TYPE enum -;; A PKZIP archive -(define-public EFAT_ZIP (make-cirr-id #\Z #\I #\P 0)) -;; A gzip archive -(define-public EFAT_GZIP (make-cirr-id #\g #\z #\i #\p)) -;; A virtual directory -(define-public EFAT_FOLDER (make-cirr-id #\f #\l #\d #\r)) -;; An ID Software PAK archive -(define-public EFAT_PAK (make-cirr-id #\P #\A #\K 0)) -;; A Nebula Device archive -(define-public EFAT_NPK (make-cirr-id #\N #\P #\K 0)) -;; A Tape ARchive -(define-public EFAT_TAR (make-cirr-id #\T #\A #\R 0)) -;; A wad Archive, Quake2, Halflife -(define-public EFAT_WAD (make-cirr-id #\W #\A #\D 0)) -;; The type of this archive is unknown -(define-public EFAT_UNKNOWN (make-cirr-id #\u #\n #\k #\n)) - -;; IO functions -(define-foreign add-file-archive - int "irr_io_addFileArchive" (list '* '* int int int '* '*)) diff --git a/irrlicht/bindings/scene.scm b/irrlicht/bindings/scene.scm deleted file mode 100644 index ad2646b..0000000 --- a/irrlicht/bindings/scene.scm +++ /dev/null @@ -1,106 +0,0 @@ -;;; guile-irrlicht --- FFI bindings for Irrlicht Engine -;;; Copyright (C) 2019 Javier Sancho -;;; -;;; This file is part of guile-irrlicht. -;;; -;;; Guile-irrlicht is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU Lesser General Public License as -;;; published by the Free Software Foundation; either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; Guile-irrlicht is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with guile-irrlicht. If not, see -;;; . - - -(define-module (irrlicht bindings scene) - #:use-module (system foreign) - #:use-module (irrlicht util foreign)) - -;; irr_scene_EMD2_ANIMATION_TYPE enum -(define-public EMAT_STAND 0) -(define-public EMAT_RUN 1) -(define-public EMAT_ATTACK 2) -(define-public EMAT_PAIN_A 3) -(define-public EMAT_PAIN_B 4) -(define-public EMAT_PAIN_C 5) -(define-public EMAT_JUMP 6) -(define-public EMAT_FLIP 7) -(define-public EMAT_SALUTE 8) -(define-public EMAT_FALLBACK 9) -(define-public EMAT_WAVE 10) -(define-public EMAT_POINT 11) -(define-public EMAT_CROUCH_STAND 12) -(define-public EMAT_CROUCH_WALK 13) -(define-public EMAT_CROUCH_ATTACK 14) -(define-public EMAT_CROUCH_PAIN 15) -(define-public EMAT_CROUCH_DEATH 16) -(define-public EMAT_DEATH_FALLBACK 17) -(define-public EMAT_DEATH_FALLFORWARD 18) -(define-public EMAT_DEATH_FALLBACKSLOW 19) -(define-public EMAT_BOOM 20) -(define-public EMAT_COUNT 21) - -;; irr_scene_E_PRIMITIVE_TYPE enum -(define-public EPT_POINTS 0) -(define-public EPT_LINE_STRIP 1) -(define-public EPT_LINE_LOOP 2) -(define-public EPT_LINES 3) -(define-public EPT_TRIANGLE_STRIP 4) -(define-public EPT_TRIANGLE_FAN 5) -(define-public EPT_TRIANGLES 6) -(define-public EPT_QUAD_STRIP 7) -(define-public EPT_QUADS 8) -(define-public EPT_POLYGON 9) -(define-public EPT_POINT_SPRITES 10) - -;; Scene functions -(define-foreign add-animated-mesh-scene-node - '* "irr_scene_addAnimatedMeshSceneNode" (list '* '* '* int '* '* '* int)) - -(define-foreign add-animator - void "irr_scene_addAnimator" (list '* '*)) - -(define-foreign add-camera-scene-node - '* "irr_scene_addCameraSceneNode" (list '* '* '* '* int int)) - -(define-foreign add-camera-scene-node-fps - '* "irr_scene_addCameraSceneNodeFPS" (list '* '* float float int '* int int float int int)) - -(define-foreign add-custom-scene-node - '* "irr_scene_addCustomSceneNode" (list '* '* int '* '* '* '* '* '* '*)) - -(define-foreign add-octree-scene-node - '* "irr_scene_addOctreeSceneNode" (list '* '* '* int int int)) - -(define-foreign create-rotation-animator - '* "irr_scene_createRotationAnimator" (list '* '*)) - -(define-foreign draw-all - void "irr_scene_drawAll" (list '*)) - -(define-foreign get-absolute-transformation - '* "irr_scene_getAbsoluteTransformation" (list '*)) - -(define-foreign get-mesh - '* "irr_scene_getMesh" (list '* '*)) - -(define-foreign get-root-scene-node - '* "irr_scene_getRootSceneNode" (list '*)) - -(define-foreign set-material-flag - void "irr_scene_setMaterialFlag" (list '* int int)) - -(define-foreign set-material-texture - void "irr_scene_setMaterialTexture" (list '* int '*)) - -(define-foreign set-md2-animation - void "irr_scene_setMD2Animation" (list '* int)) - -(define-foreign set-position - void "irr_scene_setPosition" (list '* '*)) diff --git a/irrlicht/bindings/video.scm b/irrlicht/bindings/video.scm deleted file mode 100644 index de37133..0000000 --- a/irrlicht/bindings/video.scm +++ /dev/null @@ -1,255 +0,0 @@ -;;; guile-irrlicht --- FFI bindings for Irrlicht Engine -;;; Copyright (C) 2019 Javier Sancho -;;; -;;; This file is part of guile-irrlicht. -;;; -;;; Guile-irrlicht is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU Lesser General Public License as -;;; published by the Free Software Foundation; either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; Guile-irrlicht is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with guile-irrlicht. If not, see -;;; . - - -(define-module (irrlicht bindings video) - #:use-module (system foreign) - #:use-module ((irrlicht bindings core) #:prefix ffi-core:) - #:use-module (irrlicht util foreign)) - -;; irr_video_E_BLEND_OPERATION enum -(define-public EBO_NONE 0) -(define-public EBO_ADD 1) -(define-public EBO_SUBTRACT 2) -(define-public EBO_REVSUBTRACT 3) -(define-public EBO_MIN 4) -(define-public EBO_MAX 5) -(define-public EBO_MIN_FACTOR 6) -(define-public EBO_MAX_FACTOR 7) -(define-public EBO_MIN_ALPHA 8) -(define-public EBO_MAX_ALPHA 9) - -;; irr_video_E_COMPARISON_FUNC enum -(define-public ECFN_NEVER 0) -(define-public ECFN_LESSEQUAL 1) -(define-public ECFN_EQUAL 2) -(define-public ECFN_LESS 3) -(define-public ECFN_NOTEQUAL 4) -(define-public ECFN_GREATEREQUAL 5) -(define-public ECFN_GREATER 6) -(define-public ECFN_ALWAYS 7) - -;; irr_video_E_COLOR_PLANE enum -(define-public ECP_NONE 0) -(define-public ECP_ALPHA 1) -(define-public ECP_RED 2) -(define-public ECP_GREEN 4) -(define-public ECP_BLUE 8) -(define-public ECP_RGB 14) -(define-public ECP_ALL 15) - -;; irr_video_E_ANTI_ALIASING_MODE enum -(define-public EAAM_OFF 0) -(define-public EAAM_SIMPLE 1) -(define-public EAAM_QUALITY 3) -(define-public EAAM_LINE_SMOOTH 4) -(define-public EAAM_POINT_SMOOTH 8) -(define-public EAAM_FULL_BASIC 15) -(define-public EAAM_ALPHA_TO_COVERAGE 16) - -;; irr_video_E_COLOR_MATERIAL enum -(define-public ECM_NONE 0) -(define-public ECM_DIFFUSE 1) -(define-public ECM_AMBIENT 2) -(define-public ECM_EMISSIVE 3) -(define-public ECM_SPECULAR 4) -(define-public ECM_DIFFUSE_AND_AMBIENT 5) - -;; irr_video_E_DRIVER_TYPE enum -(define-public EDT_NULL 0) -(define-public EDT_SOFTWARE 1) -(define-public EDT_BURNINGSVIDEO 2) -(define-public EDT_DIRECT3D8 3) -(define-public EDT_DIRECT3D9 4) -(define-public EDT_OPENGL 5) -(define-public EDT_COUNT 6) - -;; irr_video_E_MATERIAL_FLAG enum -(define-public EMF_WIREFRAME #x1) -(define-public EMF_POINTCLOUD #x2) -(define-public EMF_GOURAUD_SHADING #x4) -(define-public EMF_LIGHTING #x8) -(define-public EMF_ZBUFFER #x10) -(define-public EMF_ZWRITE_ENABLE #x20) -(define-public EMF_BACK_FACE_CULLING #x40) -(define-public EMF_FRONT_FACE_CULLING #x80) -(define-public EMF_BILINEAR_FILTER #x100) -(define-public EMF_TRILINEAR_FILTER #x200) -(define-public EMF_ANISOTROPIC_FILTER #x400) -(define-public EMF_FOG_ENABLE #x800) -(define-public EMF_NORMALIZE_NORMALS #x1000) -(define-public EMF_TEXTURE_WRAP #x2000) -(define-public EMF_ANTI_ALIASING #x4000) -(define-public EMF_COLOR_MASK #x8000) -(define-public EMF_COLOR_MATERIAL #x10000) -(define-public EMF_USE_MIP_MAPS #x20000) -(define-public EMF_BLEND_OPERATION #x40000) -(define-public EMF_POLYGON_OFFSET #x80000) - -;; irr_video_E_POLYGON_OFFSET enum -(define-public EPO_BACK 0) -(define-public EPO_FRONT 1) - -;;irr_video_E_MATERIAL_TYPE enum -(define-public EMT_SOLID 0) -(define-public EMT_SOLID_2_LAYER 1) -(define-public EMT_LIGHTMAP 2) -(define-public EMT_LIGHTMAP_ADD 3) -(define-public EMT_LIGHTMAP_M2 4) -(define-public EMT_LIGHTMAP_M4 5) -(define-public EMT_LIGHTMAP_LIGHTING 6) -(define-public EMT_LIGHTMAP_LIGHTING_M2 7) -(define-public EMT_LIGHTMAP_LIGHTING_M4 8) -(define-public EMT_DETAIL_MAP 9) -(define-public EMT_SPHERE_MAP 10) -(define-public EMT_REFLECTION_2_LAYER 11) -(define-public EMT_TRANSPARENT_ADD_COLOR 12) -(define-public EMT_TRANSPARENT_ALPHA_CHANNEL 13) -(define-public EMT_TRANSPARENT_ALPHA_CHANNEL_REF 14) -(define-public EMT_TRANSPARENT_VERTEX_ALPHA 15) -(define-public EMT_TRANSPARENT_REFLECTION_2_LAYER 16) -(define-public EMT_NORMAL_MAP_SOLID 17) -(define-public EMT_NORMAL_MAP_TRANSPARENT_ADD_COLOR 18) -(define-public EMT_NORMAL_MAP_TRANSPARENT_VERTEX_ALPHA 19) -(define-public EMT_PARALLAX_MAP_SOLID 20) -(define-public EMT_PARALLAX_MAP_TRANSPARENT_ADD_COLOR 21) -(define-public EMT_PARALLAX_MAP_TRANSPARENT_VERTEX_ALPHA 22) -(define-public EMT_ONETEXTURE_BLEND 23) -(define-public EMT_FORCE_32BIT #x7fffffff) - -;; irr_video_E_TRANSFORMATION_STATE enum -(define-public ETS_VIEW 0) -(define-public ETS_WORLD 1) -(define-public ETS_PROJECTION 2) -(define-public ETS_TEXTURE_0 3) -(define-public ETS_TEXTURE_1 4) -(define-public ETS_TEXTURE_2 5) -(define-public ETS_TEXTURE_3 6) -(define-public ETS_TEXTURE_4 7) -(define-public ETS_TEXTURE_5 8) -(define-public ETS_TEXTURE_6 9) -(define-public ETS_TEXTURE_7 10) -(define-public ETS_COUNT 11) - -;; irr_video_E_VERTEX_TYPE enum -(define-public EVT_STANDARD 0) -(define-public EVT_2TCOORDS 1) -(define-public EVT_TANGENTS 2) - -;; irr_video_E_INDEX_TYPE enum -(define-public EIT_16BIT 0) -(define-public EIT_32BIT 1) - -;; scolor struct -(define-public scolor - (list uint8 uint8 uint8 uint8)) - -(define-public (scolor->pointer data) - (make-c-struct scolor (reverse data))) - -;; Driver functions -(define-foreign begin-scene - int "irr_video_beginScene" (list '* int int '* '* '*)) - -(define-foreign draw-vertex-primitive-list - void "irr_video_drawVertexPrimitiveList" (list '* '* int '* int int int int)) - -(define-foreign end-scene - int "irr_video_endScene" (list '*)) - -(define-foreign get-fps - int "irr_video_getFPS" (list '*)) - -(define-foreign get-texture - '* "irr_video_getTexture" (list '* '*)) - -(define-foreign get-video-driver-name - '* "irr_video_getName" (list '*)) - -(define-foreign set-material - void "irr_video_setMaterial" (list '* '*)) - -(define-foreign set-transform - void "irr_video_setTransform" (list '* int '*)) - -;; s3dvertex struct -(define-wrapped-pointer-type s3dvertex-type - s3dvertex? - pointer->s3dvertex s3dvertex->pointer - (lambda (vertex port) - (format port "#" - (pointer-address (s3dvertex->pointer vertex))))) - -(export pointer->s3dvertex - s3dvertex->pointer) - -(define-public s3dvertex - (list ffi-core:vector3df - ffi-core:vector3df - scolor - ffi-core:vector2df)) - -;; smateriallayer struct -(define-public smateriallayer - (list '* uint8 uint8 uint8 uint8 uint8 int8 '* '*)) - -;; smaterial struct -(define-wrapped-pointer-type smaterial-type - smaterial? - pointer->smaterial smaterial->pointer - (lambda (material port) - (format port "#" - (pointer-address (smaterial->pointer material))))) - -(export pointer->smaterial - smaterial->pointer) - -(define-public smaterial - (list smateriallayer smateriallayer smateriallayer smateriallayer ; textureLayer[4] - uint32 ; materialType - scolor ; ambientColor - scolor ; diffuseColor - scolor ; emissiveColor - scolor ; specularColor - float ; shininess - float ; materialTypeParam - float ; materialTypeParam2 - float ; thickness - uint8 ; zBuffer - uint8 ; antiAliasing - (bit-field-group - (uint8 4) ; colorMask:4 - (uint8 3) ; colorMaterial:3 - (uint16 4) ; blendOperation:4 - (uint8 3) ; polygonOffsetFactor:3 - (uint16 1) ; polygonOffsetDirection:1 - (uint8 1) ; wireframe:1 - (uint8 1) ; pointCloud:1 - (uint8 1) ; gouraudShading:1 - (uint8 1) ; lighting:1 - (uint8 1) ; zWriteEnable:1 - (uint8 1) ; backfaceCulling:1 - (uint8 1) ; frontfaceCulling:1 - (uint8 1) ; fogEnable:1 - (uint8 1) ; normalizeNormals:1 - (uint8 1) ; useMipMaps:1 - ))) - -(define-foreign make-c-material - '* "makeMaterial" (list)) diff --git a/irrlicht/core.scm b/irrlicht/core.scm deleted file mode 100644 index 683c89a..0000000 --- a/irrlicht/core.scm +++ /dev/null @@ -1,40 +0,0 @@ -;;; guile-irrlicht --- FFI bindings for Irrlicht Engine -;;; Copyright (C) 2019 Javier Sancho -;;; -;;; This file is part of guile-irrlicht. -;;; -;;; Guile-irrlicht is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU Lesser General Public License as -;;; published by the Free Software Foundation; either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; Guile-irrlicht is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with guile-irrlicht. If not, see -;;; . - - -(define-module (irrlicht core) - #:use-module (system foreign) - #:use-module ((irrlicht bindings core) #:prefix ffi-core:) - #:export (make-aabbox3df - aabbox3d-reset! - aabbox3d-add-internal-point!)) - -(define (make-aabbox3df) - (ffi-core:pointer->aabbox3df - (make-c-struct ffi-core:aabbox3df '((0 0 0) (0 0 0))))) - -(define (aabbox3d-reset! box init-value) - (ffi-core:aabbox3d-reset - (ffi-core:aabbox3df->pointer box) - (ffi-core:vector3df->pointer init-value))) - -(define (aabbox3d-add-internal-point! box point) - (ffi-core:aabbox3d-add-internal-point - (ffi-core:aabbox3df->pointer box) - (ffi-core:vector3df->pointer point))) diff --git a/irrlicht/device.scm b/irrlicht/device.scm index 8fcc652..b697c7f 100644 --- a/irrlicht/device.scm +++ b/irrlicht/device.scm @@ -19,69 +19,23 @@ (define-module (irrlicht device) - #:use-module (ice-9 match) - #:use-module (system foreign) - #:use-module ((irrlicht bindings) #:prefix ffi:) - #:use-module ((irrlicht bindings core) #:prefix ffi-core:) - #:use-module ((irrlicht bindings video) #:prefix ffi-video:) - #:use-module (irrlicht util) - #:export (create-device - get-cursor-control - get-file-system - get-video-driver - get-gui-environment - get-scene-manager - is-window-active? - set-window-caption! - device-run? - device-drop!)) + #:export (create-device)) +(load-extension "libguile-irrlicht" "init_guile_irrlicht") + +(define irrlicht-create-device create-device) (define* (create-device #:key (device-type 'software) (window-size '(640 480)) (bits 16) (fullscreen #f) (stencilbuffer #f) - (vsync #f)) - (let ((driver (match device-type - ('null ffi-video:EDT_NULL) - ('software ffi-video:EDT_SOFTWARE) - ('burnings ffi-video:EDT_BURNINGSVIDEO) - ('direct3d8 ffi-video:EDT_DIRECT3D8) - ('direct3d9 ffi-video:EDT_DIRECT3D9) - ('opengl ffi-video:EDT_OPENGL) - ('count ffi-video:EDT_COUNT)))) - (let ((device (ffi:create-device driver - (ffi-core:dimension2d->pointer window-size) - bits - (bool->integer fullscreen) - (bool->integer stencilbuffer) - (bool->integer vsync)))) - (if (null-pointer? device) #f device)))) - -(define (get-cursor-control device) - (ffi:get-cursor-control device)) - -(define (get-file-system device) - (ffi:get-file-system device)) - -(define (get-video-driver device) - (ffi:get-video-driver device)) - -(define (get-gui-environment device) - (ffi:get-gui-environment device)) - -(define (get-scene-manager device) - (ffi:get-scene-manager device)) - -(define (is-window-active? device) - (integer->bool (ffi:is-window-active device))) - -(define (set-window-caption! device text) - (ffi:set-window-caption device (string->pointer text))) - -(define (device-run? device) - (integer->bool (ffi:run device))) - -(define (device-drop! device) - (integer->bool (ffi:drop device))) + (vsync #f) + (receiver 0)) + (irrlicht-create-device device-type + window-size + bits + fullscreen + stencilbuffer + vsync + receiver)) diff --git a/irrlicht/gui.scm b/irrlicht/gui.scm deleted file mode 100644 index 8a4c97e..0000000 --- a/irrlicht/gui.scm +++ /dev/null @@ -1,53 +0,0 @@ -;;; guile-irrlicht --- FFI bindings for Irrlicht Engine -;;; Copyright (C) 2019 Javier Sancho -;;; -;;; This file is part of guile-irrlicht. -;;; -;;; Guile-irrlicht is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU Lesser General Public License as -;;; published by the Free Software Foundation; either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; Guile-irrlicht is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with guile-irrlicht. If not, see -;;; . - - -(define-module (irrlicht gui) - #:use-module (ice-9 match) - #:use-module (system foreign) - #:use-module ((irrlicht bindings core) #:prefix ffi-core:) - #:use-module ((irrlicht bindings gui) #:prefix ffi-gui:) - #:use-module (irrlicht util) - #:export (add-static-text! - gui-draw-all - set-visible-cursor!)) - -(define* (add-static-text! gui-env text rectangle - #:key - (border #f) - (word-wrap #t) - (parent %null-pointer) - (id -1) - (fill-background #f)) - (ffi-gui:add-static-text gui-env - (string->pointer text) - (ffi-core:rect->pointer rectangle) - (bool->integer border) - (bool->integer word-wrap) - parent - id - (bool->integer fill-background))) - -(define (gui-draw-all gui-env) - (ffi-gui:draw-all gui-env)) - -(define (set-visible-cursor! cursor-control visible) - (ffi-gui:set-visible-cursor - cursor-control - (bool->integer visible))) diff --git a/irrlicht/io.scm b/irrlicht/io.scm deleted file mode 100644 index 9aaf34c..0000000 --- a/irrlicht/io.scm +++ /dev/null @@ -1,50 +0,0 @@ -;;; guile-irrlicht --- FFI bindings for Irrlicht Engine -;;; Copyright (C) 2019 Javier Sancho -;;; -;;; This file is part of guile-irrlicht. -;;; -;;; Guile-irrlicht is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU Lesser General Public License as -;;; published by the Free Software Foundation; either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; Guile-irrlicht is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with guile-irrlicht. If not, see -;;; . - - -(define-module (irrlicht io) - #:use-module (ice-9 match) - #:use-module (system foreign) - #:use-module ((irrlicht bindings io) #:prefix ffi-io:) - #:use-module (irrlicht util) - #:export (add-file-archive!)) - -(define* (add-file-archive! file-system filename - #:key - (ignore-case #t) - (ignore-paths #t) - (archive-type 'unknown) - (password "") - (ret-archive %null-pointer)) - (let ((type (match archive-type - ('zip ffi-io:EFAT_ZIP) - ('gzip ffi-io:EFAT_GZIP) - ('folder ffi-io:EFAT_FOLDER) - ('pak ffi-io:EFAT_PAK) - ('npk ffi-io:EFAT_NPK) - ('tar ffi-io:EFAT_TAR) - ('wad ffi-io:EFAT_WAD) - ('unknown ffi-io:EFAT_UNKNOWN)))) - (ffi-io:add-file-archive file-system - (string->pointer filename) - (bool->integer ignore-case) - (bool->integer ignore-paths) - type - (string->pointer password) - ret-archive))) diff --git a/irrlicht/scene.scm b/irrlicht/scene.scm deleted file mode 100644 index 83eb9ba..0000000 --- a/irrlicht/scene.scm +++ /dev/null @@ -1,232 +0,0 @@ -;;; guile-irrlicht --- FFI bindings for Irrlicht Engine -;;; Copyright (C) 2019 Javier Sancho -;;; -;;; This file is part of guile-irrlicht. -;;; -;;; Guile-irrlicht is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU Lesser General Public License as -;;; published by the Free Software Foundation; either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; Guile-irrlicht is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with guile-irrlicht. If not, see -;;; . - - -(define-module (irrlicht scene) - #:use-module (ice-9 match) - #:use-module (system foreign) - #:use-module ((irrlicht bindings core) #:prefix ffi-core:) - #:use-module ((irrlicht bindings scene) #:prefix ffi-scene:) - #:use-module ((irrlicht bindings video) #:prefix ffi-video:) - #:use-module (irrlicht util) - #:export (add-animated-mesh-scene-node - add-animator! - add-camera-scene-node! - add-camera-scene-node-fps! - add-custom-scene-node! - add-octree-scene-node - create-rotation-animator - get-absolute-transformation - get-mesh - get-root-scene-node - scene-draw-all - set-material-flag! - set-material-texture! - set-md2-animation! - set-position!)) - -(define* (add-animated-mesh-scene-node scene-manager mesh - #:key - (parent %null-pointer) - (id -1) - (position '(0 0 0)) - (rotation '(0 0 0)) - (scale '(1 1 1)) - (also-add-if-mesh-pointer-zero #f)) - (let ((node (ffi-scene:add-animated-mesh-scene-node - scene-manager - mesh - parent - id - (ffi-core:vector3df->pointer position) - (ffi-core:vector3df->pointer rotation) - (ffi-core:vector3df->pointer scale) - (bool->integer also-add-if-mesh-pointer-zero)))) - (if (null-pointer? node) #f node))) - -(define (add-animator! node animator) - (ffi-scene:add-animator node animator)) - -(define* (add-camera-scene-node! scene-manager - #:key - (parent %null-pointer) - (position '(0 0 0)) - (lookat '(0 0 100)) - (id -1) - (make-active #t)) - (let ((camera (ffi-scene:add-camera-scene-node - scene-manager - parent - (ffi-core:vector3df->pointer position) - (ffi-core:vector3df->pointer lookat) - id - (bool->integer make-active)))) - (if (null-pointer? camera) #f camera))) - -(define* (add-camera-scene-node-fps! scene-manager - #:key - (parent %null-pointer) - (rotate-speed 100.0) - (move-speed 0.5) - (id -1) - (key-map-array %null-pointer) - (key-map-size 0) - (no-vertical-movement #f) - (jump-speed 0.0) - (invert-mouse #f) - (make-active #t)) - (ffi-scene:add-camera-scene-node-fps - scene-manager - parent - rotate-speed - move-speed - id - key-map-array - key-map-size - (bool->integer no-vertical-movement) - jump-speed - (bool->integer invert-mouse) - (bool->integer make-active))) - -(define* (add-custom-scene-node! scene-manager - render - get-bounding-box - get-material-count - get-material - #:key - (parent %null-pointer) - (id -1) - (position '(0 0 0)) - (rotation '(0 0 0)) - (scale '(1 1 1))) - (let ((c-get-bounding-box - (lambda () - (ffi-core:aabbox3df->pointer (get-bounding-box)))) - (c-get-material - (lambda (i) - (ffi-video:smaterial->pointer (get-material i))))) - (ffi-scene:add-custom-scene-node - scene-manager - parent - id - (ffi-core:vector3df->pointer position) - (ffi-core:vector3df->pointer rotation) - (ffi-core:vector3df->pointer scale) - (procedure->pointer void render '()) - (procedure->pointer '* c-get-bounding-box '()) - (procedure->pointer uint32 get-material-count '()) - (procedure->pointer '* c-get-material (list uint32))))) - -(define* (add-octree-scene-node scene-manager mesh - #:key - (parent %null-pointer) - (id -1) - (minimal-polys-per-node 512) - (also-add-if-mesh-pointer-zero #f)) - (ffi-scene:add-octree-scene-node - scene-manager - mesh - parent - id - minimal-polys-per-node - (bool->integer also-add-if-mesh-pointer-zero))) - -(define (create-rotation-animator scene-manager rotation-speed) - (let ((animator (ffi-scene:create-rotation-animator - scene-manager - (ffi-core:vector3df->pointer rotation-speed)))) - (if (null-pointer? animator) #f animator))) - -(define (get-absolute-transformation node) - (ffi-scene:get-absolute-transformation node)) - -(define (get-mesh scene-manager filename) - (let ((mesh (ffi-scene:get-mesh scene-manager (string->pointer filename)))) - (if (null-pointer? mesh) #f mesh))) - -(define (get-root-scene-node scene-manager) - (ffi-scene:get-root-scene-node scene-manager)) - -(define (scene-draw-all scene-manager) - (ffi-scene:draw-all scene-manager)) - -(define (set-material-flag! node flag newvalue) - (let ((material-flag - (match flag - ('wireframe ffi-video:EMF_WIREFRAME) - ('pointcloud ffi-video:EMF_POINTCLOUD) - ('gouraud-shading ffi-video:EMF_GOURAUD_SHADING) - ('lighting ffi-video:EMF_LIGHTING) - ('zbuffer ffi-video:EMF_ZBUFFER) - ('zwrite-enable ffi-video:EMF_ZWRITE_ENABLE) - ('back-face-culling ffi-video:EMF_BACK_FACE_CULLING) - ('front-face-culling ffi-video:EMF_FRONT_FACE_CULLING) - ('bilinear-filter ffi-video:EMF_BILINEAR_FILTER) - ('trilinear-filter ffi-video:EMF_TRILINEAR_FILTER) - ('anisotropic-filter ffi-video:EMF_ANISOTROPIC_FILTER) - ('fog-enable ffi-video:EMF_FOG_ENABLE) - ('normalize-normals ffi-video:EMF_NORMALIZE_NORMALS) - ('texture-wrap ffi-video:EMF_TEXTURE_WRAP) - ('anti-aliasing ffi-video:EMF_ANTI_ALIASING) - ('color-mask ffi-video:EMF_COLOR_MASK) - ('color-material ffi-video:EMF_COLOR_MATERIAL) - ('use-mip-maps ffi-video:EMF_USE_MIP_MAPS) - ('blend-operation ffi-video:EMF_BLEND_OPERATION) - ('polygon-offset ffi-video:EMF_POLYGON_OFFSET)))) - (ffi-scene:set-material-flag - node - material-flag - (bool->integer newvalue)))) - -(define (set-material-texture! node texture-layer texture) - (ffi-scene:set-material-texture node texture-layer texture)) - -(define (set-md2-animation! node anim) - (let ((animation-type - (match anim - ('stand ffi-scene:EMAT_STAND) - ('run ffi-scene:EMAT_RUN) - ('attack ffi-scene:EMAT_ATTACK) - ('pain-a ffi-scene:EMAT_PAIN_A) - ('pain-b ffi-scene:EMAT_PAIN_B) - ('pain-c ffi-scene:EMAT_PAIN_C) - ('jump ffi-scene:EMAT_JUMP) - ('flip ffi-scene:EMAT_FLIP) - ('salute ffi-scene:EMAT_SALUTE) - ('fallback ffi-scene:EMAT_FALLBACK) - ('wave ffi-scene:EMAT_WAVE) - ('point ffi-scene:EMAT_POINT) - ('crouch-stand ffi-scene:EMAT_CROUCH_STAND) - ('crouch-walk ffi-scene:EMAT_CROUCH_WALK) - ('crouch-attack ffi-scene:EMAT_CROUCH_ATTACK) - ('crouch-pain ffi-scene:EMAT_CROUCH_PAIN) - ('crouch-death ffi-scene:EMAT_CROUCH_DEATH) - ('death-fallback ffi-scene:EMAT_DEATH_FALLBACK) - ('death-fallforward ffi-scene:EMAT_DEATH_FALLFORWARD) - ('death-fallbackslow ffi-scene:EMAT_DEATH_FALLBACKSLOW) - ('boom ffi-scene:EMAT_BOOM) - ('count ffi-scene:EMAT_COUNT)))) - (ffi-scene:set-md2-animation - node - animation-type))) - -(define (set-position! node newpos) - (ffi-scene:set-position - node - (ffi-core:vector3df->pointer newpos))) diff --git a/irrlicht/util.scm b/irrlicht/util.scm deleted file mode 100644 index 8c5b9e4..0000000 --- a/irrlicht/util.scm +++ /dev/null @@ -1,29 +0,0 @@ -;;; guile-irrlicht --- FFI bindings for Irrlicht Engine -;;; Copyright (C) 2019 Javier Sancho -;;; -;;; This file is part of guile-irrlicht. -;;; -;;; Guile-irrlicht is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU Lesser General Public License as -;;; published by the Free Software Foundation; either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; Guile-irrlicht is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with guile-irrlicht. If not, see -;;; . - - -(define-module (irrlicht util) - #:export (bool->integer - integer->bool)) - -(define (bool->integer var) - (if var 1 0)) - -(define (integer->bool var) - (if (= var 0) #f #t)) diff --git a/irrlicht/util/foreign.scm b/irrlicht/util/foreign.scm deleted file mode 100644 index 1c54e12..0000000 --- a/irrlicht/util/foreign.scm +++ /dev/null @@ -1,361 +0,0 @@ -;;; guile-irrlicht --- FFI bindings for Irrlicht Engine -;;; Copyright (C) 2019 Javier Sancho -;;; -;;; This file is part of guile-irrlicht. -;;; -;;; Guile-irrlicht is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU Lesser General Public License as -;;; published by the Free Software Foundation; either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; Guile-irrlicht is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with guile-irrlicht. If not, see -;;; . - - -(define-module (irrlicht util foreign) - #:use-module (system foreign) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-9 gnu) - #:use-module (rnrs bytevectors) - #:export (define-foreign - define-foreign-record-type - foreign-record->pointer - bit-field - bit-field-group - get-bit-field-group-type - make-c-bit-field-group - parse-c-bit-field-group - sizeof+ - make-c-struct+ - parse-c-struct+)) - - -;; Based on guile-sdl2 function, thanks a lot -(define irrlicht-func - (let ((cirr (dynamic-link "libCIrrlicht"))) - (lambda (return-type function-name arg-types) - (pointer->procedure return-type - (dynamic-func function-name cirr) - arg-types)))) - -(define-syntax-rule (define-foreign name return-type func-name arg-types) - (define-public name - (irrlicht-func return-type func-name arg-types))) - - -;; foreign record type -(define-record-type standard-foreign-record-type - (make-foreign-record-type name types fields) - foreign-record-type? - (name foreign-record-type-name) - (types foreign-record-type-types) - (fields foreign-record-type-fields)) - -(define (foreign-record-type-basic-types record-type) - (map (lambda (type) - (if (foreign-record-type? type) - (foreign-record-type-basic-types type) - type)) - (foreign-record-type-types record-type))) - - -;; foreign record -(define-record-type foreign-record - (make-foreign-record type pointer) - foreign-record? - (type foreign-record-type) - (pointer foreign-record-pointer)) - -(set-record-type-printer! foreign-record - (lambda (record port) - (let* ((record-type (foreign-record-type record)) - (name (foreign-record-type-name record-type)) - (pointer (foreign-record-pointer record)) - (types (foreign-record-type-types record-type)) - (fields (foreign-record-type-fields record-type)) - (values (parse-c-struct pointer types))) - (format port "#<~a" name) - (for-each (lambda (field value) - (format port " ~a: ~a" field value)) - fields - values) - (format port ">")))) - -(define (foreign-record->pointer record) - (foreign-record-pointer record)) - - -;; define-foreign-record-type -(define-syntax define-foreign-record-type - (lambda (x) - (define (field-names field-specs) - (map (lambda (field-spec) - (syntax-case field-spec () - ((name type getter) #'name) - ((name type getter setter) #'name))) - field-specs)) - - (define (field-types field-specs) - (map (lambda (field-spec) - (syntax-case field-spec () - ((name type getter) #'type) - ((name type getter setter) #'type))) - field-specs)) - - (define (field-getters field-specs) - (map (lambda (field-spec field-id) - (syntax-case field-spec () - ((name type getter) (list #'getter field-id)) - ((name type getter setter) (list #'getter field-id)))) - field-specs - (iota (length field-specs)))) - - (define (field-setters field-specs) - (filter-map (lambda (field-spec field-id) - (syntax-case field-spec () - ((name type getter) #f) - ((name type getter setter) (list #'setter field-id)))) - field-specs - (iota (length field-specs)))) - - (syntax-case x () - ((_ name (make-name make-arg ...) predicate? field-spec ...) - (with-syntax (((type-id ...) (field-types #'(field-spec ...))) - ((field-name ...) (field-names #'(field-spec ...))) - (((getter getter-id) ...) (field-getters #'(field-spec ...))) - (((setter setter-id) ...) (field-setters #'(field-spec ...)))) - #'(begin - (define name - (make-foreign-record-type 'name (list type-id ...) (list 'field-name ...))) - - (define (make-name make-arg ...) - (let ((pointer (make-c-struct (list type-id ...) (list make-arg ...)))) - (make-foreign-record name pointer))) - - (define (predicate? record) - (and (foreign-record? record) - (equal? (foreign-record-type-name (foreign-record-type record)) 'name))) - - (define (getter record) - (let ((values (parse-c-struct (foreign-record-pointer record) (list type-id ...)))) - (list-ref values getter-id))) - ... - - (define (setter record new-value) - (let* ((types (list type-id ...)) - (type (list-ref types setter-id)) - (len (sizeof type)) - (offset (if (> setter-id 0) - (sizeof (list-head types setter-id)) - 0)) - (bv (pointer->bytevector (foreign-record-pointer record) len offset 'u32))) - (bytevector-set! bv new-value type) - new-value)) - ...)))))) - -(define (bytevector-set! bv value type) - (let ((procedure - (cond - ((= type int8) bytevector-s8-set!) - ((= type int16) bytevector-s16-native-set!) - ((= type int32) bytevector-s32-native-set!) - ((= type int64) bytevector-s64-native-set!) - ((= type uint8) bytevector-u8-set!) - ((= type uint16) bytevector-u16-native-set!) - ((= type uint32) bytevector-u32-native-set!) - ((= type uint64) bytevector-u64-native-set!) - ((= type float) bytevector-ieee-single-native-set!) - ((= type double) bytevector-ieee-double-native-set!) - (else #f)))) - (if procedure - (apply procedure bv 0 value '())))) - - -;; bit fields -(define-record-type bit-field-record - (bit-field type bits) - bit-field? - (type bit-field-type) - (bits bit-field-bits)) - -(define-record-type bit-field-group-subtype-record - (make-bit-field-group-subtype type arity maker parser) - bit-field-group-subtype? - (type bit-field-group-subtype-type) - (arity bit-field-group-subtype-arity) - (maker bit-field-group-subtype-maker) - (parser bit-field-group-subtype-parser)) - -(define-record-type bit-field-group-record - (make-bit-field-group subtypes) - bit-field-group? - (subtypes bit-field-group-subtypes)) - -(define (build-bit-field-group-subtype-maker bit-fields) - "Return a maker procedure for the bit field group" - (lambda (values) - (let loop ((fields bit-fields) - (vals values) - (res '()) - (bits 0)) - (cond ((null? fields) - (apply logior res)) - (else - (loop (cdr fields) - (cdr vals) - (cons (ash (car vals) bits) res) - (+ bits (bit-field-bits (car fields))))))))) - -(define (build-bit-field-group-subtype-parser bit-fields) - (lambda (value) - (let loop ((fields bit-fields) - (res '()) - (bits 0)) - (cond ((null? fields) - res) - (else - (let ((n-bits (+ bits (bit-field-bits (car fields))))) - (loop (cdr fields) - (append res (list (bit-extract value bits n-bits))) - n-bits))))))) - -(define (validate-bit-field-group bit-fields) - "Return a list with the calculated real types of the bit field group or error if overflow" - (let loop ((fields bit-fields) - (current-type 0) - (n-bits 0) - (subtypes '()) - (subtype-fields '())) - (cond ((null? fields) - (if (> current-type 0) - ;; Append last type processed to the result - (append subtypes - (list (make-bit-field-group-subtype - current-type - (length subtype-fields) - (build-bit-field-group-subtype-maker subtype-fields) - (build-bit-field-group-subtype-parser subtype-fields)))) - ;; We already have the result - subtypes)) - (else - (let* ((field (car fields)) - (type (max (bit-field-type field) current-type)) - (bits (+ (bit-field-bits field) n-bits))) - (cond ((> bits (* (sizeof type) 8)) - ;; Bits overflow - (if (> n-bits 0) - ;; Make a new subtype and continue - (loop fields 0 0 - (append subtypes - (list (make-bit-field-group-subtype - current-type - (length subtype-fields) - (build-bit-field-group-subtype-maker subtype-fields) - (build-bit-field-group-subtype-parser subtype-fields)))) - '()) - ;; Bits exceed type capacity - (error "Bit field group overflow"))) - (else - (loop (cdr fields) type bits subtypes - (append subtype-fields (list field)))))))))) - -(define-syntax-rule (bit-field-group (type bits) ...) - (let* ((bit-fields (list (bit-field type bits) ...)) - (subtypes (validate-bit-field-group bit-fields))) - (make-bit-field-group subtypes))) - -(define (get-bit-field-group-type group) - (map (lambda (subtype) - (bit-field-group-subtype-type subtype)) - (bit-field-group-subtypes group))) - -(define (make-c-bit-field-group group values) - (let make-c ((subtypes (bit-field-group-subtypes group)) - (vals values)) - (cond ((null? subtypes) - '()) - (else - (let* ((subtype (car subtypes)) - (arity (bit-field-group-subtype-arity subtype)) - (maker (bit-field-group-subtype-maker subtype))) - (cons (maker (list-head vals arity)) - (make-c (cdr subtypes) (list-tail vals arity)))))))) - -(define (parse-c-bit-field-group values group) - (apply append - (map (lambda (subtype value) - ((bit-field-group-subtype-parser subtype) value)) - (bit-field-group-subtypes group) - values))) - -(define (convert-struct types) - "Convert a struct type with bit fields in an ordinary struct type" - (cond ((null? types) - '()) - (else - (let ((type (car types))) - (cond ((list? type) - (cons (convert-struct type) - (convert-struct (cdr types)))) - ((bit-field-group? type) - (append (get-bit-field-group-type type) - (convert-struct (cdr types)))) - (else - (cons type - (convert-struct (cdr types))))))))) - -(define (convert-struct-values types vals) - "Convert struct values with bit fields in an ordinary struct" - (cond ((null? types) - '()) - (else - (let ((type (car types)) - (val (car vals))) - (cond ((list? type) - (cons (convert-struct-values type val) - (convert-struct-values (cdr types) (cdr vals)))) - ((bit-field-group? type) - (append (make-c-bit-field-group type val) - (convert-struct-values (cdr types) (cdr vals)))) - (else - (cons val - (convert-struct-values (cdr types) (cdr vals))))))))) - -(define (parse-struct-values vals types) - "Parse struct values with bit fields from an ordinary struct" - (cond ((null? types) - '()) - (else - (let ((type (car types)) - (val (car vals))) - (cond ((list? type) - (cons (parse-struct-values val type) - (parse-struct-values (cdr vals) (cdr types)))) - ((bit-field-group? type) - (let ((arity (length (bit-field-group-subtypes type)))) - (cons (parse-c-bit-field-group (list-head vals arity) type) - (parse-struct-values (list-tail vals arity) (cdr types))))) - (else - (cons val - (parse-struct-values (cdr vals) (cdr types))))))))) - -(define (sizeof+ type) - (if (list? type) - (sizeof (convert-struct type)) - (sizeof type))) - -(define (make-c-struct+ types vals) - (make-c-struct (convert-struct types) - (convert-struct-values types vals))) - -(define (parse-c-struct+ foreign types) - (parse-struct-values - (parse-c-struct foreign (convert-struct types)) - types)) diff --git a/irrlicht/video.scm b/irrlicht/video.scm deleted file mode 100644 index 0c334fe..0000000 --- a/irrlicht/video.scm +++ /dev/null @@ -1,199 +0,0 @@ -;;; guile-irrlicht --- FFI bindings for Irrlicht Engine -;;; Copyright (C) 2019 Javier Sancho -;;; -;;; This file is part of guile-irrlicht. -;;; -;;; Guile-irrlicht is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU Lesser General Public License as -;;; published by the Free Software Foundation; either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; Guile-irrlicht is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with guile-irrlicht. If not, see -;;; . - - -(define-module (irrlicht video) - #:use-module (ice-9 match) - #:use-module (system foreign) - #:use-module ((irrlicht bindings core) #:prefix ffi-core:) - #:use-module ((irrlicht bindings scene) #:prefix ffi-scene:) - #:use-module ((irrlicht bindings video) #:prefix ffi-video:) - #:use-module (irrlicht util) - #:use-module (irrlicht util foreign) - #:export (begin-scene - draw-vertex-primitive-list - end-scene - get-fps - get-texture - get-video-driver-name - set-material! - set-transform! - make-s3dvertex - vertex-position - make-material)) - -(define* (begin-scene driver - #:key - (back-buffer #t) - (z-buffer #t) - (color '(255 0 0 0)) - (video-data %null-pointer) - (source-rect '())) - (ffi-video:begin-scene driver - (bool->integer back-buffer) - (bool->integer z-buffer) - (ffi-video:scolor->pointer color) - video-data - (if (null? source-rect) - %null-pointer - (ffi-core:rect->pointer source-rect)))) - -(define* (draw-vertex-primitive-list driver vertices index-list - #:key - (v-type 'standard) - (p-type 'triangles)) - (define (make-c-vertices vertices) - (let ((vals (map (lambda (vertex) - (parse-c-struct (ffi-video:s3dvertex->pointer vertex) - ffi-video:s3dvertex)) - vertices)) - (types (make-list (length vertices) ffi-video:s3dvertex))) - (make-c-struct types vals))) - - (define (make-c-indices indices) - (let* ((vals (apply append indices)) - (types (make-list (length vals) int32))) - (make-c-struct types vals))) - - (let ((vertices-pointer (make-c-vertices vertices)) - (vertex-count (length vertices)) - (indices-pointer (make-c-indices index-list)) - (prim-count (length index-list)) - (vertex-type - (match v-type - ('standard ffi-video:EVT_STANDARD) - ('2tcoords ffi-video:EVT_2TCOORDS) - ('tangents ffi-video:EVT_TANGENTS))) - (primitive-type - (match p-type - ('points ffi-scene:EPT_POINTS) - ('strip ffi-scene:EPT_LINE_STRIP) - ('line-loop ffi-scene:EPT_LINE_LOOP) - ('lines ffi-scene:EPT_LINES) - ('triangle-strip ffi-scene:EPT_TRIANGLE_STRIP) - ('triangle-fan ffi-scene:EPT_TRIANGLE_FAN) - ('triangles ffi-scene:EPT_TRIANGLES) - ('quad-strip ffi-scene:EPT_QUAD_STRIP) - ('quads ffi-scene:EPT_QUADS) - ('polygon ffi-scene:EPT_POLYGON) - ('point-sprites ffi-scene:EPT_POINT_SPRITES)))) - - - (ffi-video:draw-vertex-primitive-list - driver - vertices-pointer - vertex-count - indices-pointer - prim-count - vertex-type - primitive-type - ffi-video:EIT_32BIT))) - -(define (end-scene driver) - (ffi-video:end-scene driver)) - -(define (get-fps driver) - (ffi-video:get-fps driver)) - -(define (get-texture driver filename) - (ffi-video:get-texture driver (string->pointer filename))) - -(define (get-video-driver-name driver) - (pointer->string - (ffi-video:get-video-driver-name driver))) - -(define (set-material! driver material) - (ffi-video:set-material - driver - (ffi-video:smaterial->pointer material))) - -(define (set-transform! driver state mat) - (let ((transform-state - (match state - ('view ffi-video:ETS_VIEW) - ('world ffi-video:ETS_WORLD) - ('projection ffi-video:ETS_PROJECTION) - ('texture0 ffi-video:ETS_TEXTURE_0) - ('texture1 ffi-video:ETS_TEXTURE_1) - ('texture2 ffi-video:ETS_TEXTURE_2) - ('texture3 ffi-video:ETS_TEXTURE_3) - ('texture4 ffi-video:ETS_TEXTURE_4) - ('texture5 ffi-video:ETS_TEXTURE_5) - ('texture6 ffi-video:ETS_TEXTURE_6) - ('texture7 ffi-video:ETS_TEXTURE_7) - ('count ffi-video:ETS_COUNT)))) - (ffi-video:set-transform - driver - transform-state - mat))) - -;; s3d vertices -(define (make-s3dvertex position normal color t-coords) - (ffi-video:pointer->s3dvertex - (make-c-struct ffi-video:s3dvertex - (list position normal color t-coords)))) - -(define (vertex-position vertex) - (let ((data (parse-c-struct (ffi-video:s3dvertex->pointer vertex) - ffi-video:s3dvertex))) - (car data))) - -;; smaterial -(define* (make-material #:key (wireframe #f) (lighting #t)) - (let ((material - (list - ;; textureLayer[4] - (list %null-pointer 0 0 0 0 0 0 %null-pointer %null-pointer) - (list %null-pointer 0 0 0 0 0 0 %null-pointer %null-pointer) - (list %null-pointer 0 0 0 0 0 0 %null-pointer %null-pointer) - (list %null-pointer 0 0 0 0 0 0 %null-pointer %null-pointer) - ffi-video:EMT_SOLID ; materialType - (list 255 255 255 255) ; ambientColor - (list 255 255 255 255) ; diffuseColor - (list 0 0 0 0) ; emissiveColor - (list 255 255 255 255) ; specularColor - 0 ; shininess - 0 ; materialTypeParam - 0 ; materialTypeParam2 - 1 ; thickness - ffi-video:ECFN_LESSEQUAL ; zBuffer - ffi-video:EAAM_SIMPLE ; antiAliasing - (list - ffi-video:ECP_ALL ; colorMask - ffi-video:ECM_DIFFUSE ; colorMaterial - ffi-video:EBO_NONE ; blendOperation - 0 ; polygonOffsetFactor - ffi-video:EPO_FRONT ; polygonOffsetDirection - (bool->integer wireframe) ; wireframe - (bool->integer #f) ; pointCloud - (bool->integer #t) ; gouraudShading - (bool->integer lighting) ; lighting - (bool->integer #t) ; zWriteEnable - (bool->integer #t) ; backfaceCulling - (bool->integer #f) ; frontfaceCulling - (bool->integer #f) ; fogEnable - (bool->integer #f) ; normalizeNormals - (bool->integer #t) ; useMipMaps - )))) - (ffi-video:pointer->smaterial - ;; (make-c-struct+ ffi-video:smaterial material)))) - (make-c-material)))) - -(define-public (make-c-material) - (ffi-video:make-c-material)) diff --git a/src/EDriverTypes.cpp b/src/EDriverTypes.cpp index 356af97..ec41fe9 100644 --- a/src/EDriverTypes.cpp +++ b/src/EDriverTypes.cpp @@ -53,10 +53,6 @@ extern "C" { { return irr::video::EDT_OPENGL; } - else if (!strcmp(driverType, "count")) - { - return irr::video::EDT_COUNT; - } else { return irr::video::EDT_NULL; diff --git a/src/Irrlicht.cpp b/src/Irrlicht.cpp index 2d4fd5c..fc42579 100644 --- a/src/Irrlicht.cpp +++ b/src/Irrlicht.cpp @@ -23,6 +23,7 @@ #include #include "EDriverTypes.h" #include "Irrlicht.h" +#include "dimension2d.h" extern "C" { @@ -32,7 +33,7 @@ extern "C" { init_irrlicht (void) { init_irrlicht_device (); - scm_c_define_gsubr ("irr_createDevice", 7, 0, 0, (scm_t_subr)irr_createDevice); + scm_c_define_gsubr ("create-device", 7, 0, 0, (scm_t_subr)irr_createDevice); } void @@ -58,7 +59,13 @@ extern "C" { SCM vsync, SCM receiver) { - irr::IrrlichtDevice* device = irr::createDevice (scm_to_driver_type (deviceType)); + irr::IrrlichtDevice* device = + irr::createDevice (scm_to_driver_type (deviceType), + scm_to_dimension2d_u32 (windowSize), + scm_to_uint32 (bits), + scm_to_bool (fullscreen), + scm_to_bool (stencilbuffer), + scm_to_bool (vsync)); return scm_make_foreign_object_1 (irrlicht_device, device); } diff --git a/src/dimension2d.cpp b/src/dimension2d.cpp new file mode 100644 index 0000000..cad023c --- /dev/null +++ b/src/dimension2d.cpp @@ -0,0 +1,36 @@ +/* guile-irrlicht --- GNU Guile bindings for Irrlicht Engine + + Copyright (C) 2020 Javier Sancho + + This file is part of guile-irrlicht. + + guile-irrlicht is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as + published by the Free Software Foundation; either version 3 of the + License, or (at your option) any later version. + + guile-irrlicht is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with guile-irrlicht. If not, see + . +*/ + +#include +#include +#include "dimension2d.h" + +extern "C" { + + irr::core::dimension2d + scm_to_dimension2d_u32 (SCM dimension2d) + { + return irr::core::dimension2d + (scm_to_uint32 (scm_car (dimension2d)), + scm_to_uint32 (scm_cadr (dimension2d))); + } + +} diff --git a/src/dimension2d.h b/src/dimension2d.h new file mode 100644 index 0000000..86336c6 --- /dev/null +++ b/src/dimension2d.h @@ -0,0 +1,35 @@ +/* guile-irrlicht --- GNU Guile bindings for Irrlicht Engine + + Copyright (C) 2020 Javier Sancho + + This file is part of guile-irrlicht. + + guile-irrlicht is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as + published by the Free Software Foundation; either version 3 of the + License, or (at your option) any later version. + + guile-irrlicht is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with guile-irrlicht. If not, see + . +*/ + +#ifndef __GUILE_IRRLICHT_DIMENSION_2D_INCLUDED__ +#define __GUILE_IRRLICHT_DIMENSION_2D_INCLUDED__ + +#include +#include + +extern "C" { + + irr::core::dimension2d + scm_to_dimension2d_u32 (SCM dimension2d); + +} + +#endif -- 2.39.5