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
(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
+++ /dev/null
-;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
-;;; Copyright (C) 2019 Javier Sancho <jsf@jsancho.org>
-;;;
-;;; 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
-;;; <http://www.gnu.org/licenses/>.
-
-
-(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 '*))
+++ /dev/null
-;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
-;;; Copyright (C) 2019 Javier Sancho <jsf@jsancho.org>
-;;;
-;;; 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
-;;; <http://www.gnu.org/licenses/>.
-
-
-(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 "#<aabbox3df ~x>"
- (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 '* '*))
+++ /dev/null
-;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
-;;; Copyright (C) 2019 Javier Sancho <jsf@jsancho.org>
-;;;
-;;; 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
-;;; <http://www.gnu.org/licenses/>.
-
-
-(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))
+++ /dev/null
-;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
-;;; Copyright (C) 2019 Javier Sancho <jsf@jsancho.org>
-;;;
-;;; 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
-;;; <http://www.gnu.org/licenses/>.
-
-
-(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 '* '*))
+++ /dev/null
-;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
-;;; Copyright (C) 2019 Javier Sancho <jsf@jsancho.org>
-;;;
-;;; 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
-;;; <http://www.gnu.org/licenses/>.
-
-
-(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 '* '*))
+++ /dev/null
-;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
-;;; Copyright (C) 2019 Javier Sancho <jsf@jsancho.org>
-;;;
-;;; 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
-;;; <http://www.gnu.org/licenses/>.
-
-
-(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 "#<s3dvertex ~x>"
- (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 "#<smaterial ~x>"
- (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))
+++ /dev/null
-;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
-;;; Copyright (C) 2019 Javier Sancho <jsf@jsancho.org>
-;;;
-;;; 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
-;;; <http://www.gnu.org/licenses/>.
-
-
-(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)))
(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))
+++ /dev/null
-;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
-;;; Copyright (C) 2019 Javier Sancho <jsf@jsancho.org>
-;;;
-;;; 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
-;;; <http://www.gnu.org/licenses/>.
-
-
-(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)))
+++ /dev/null
-;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
-;;; Copyright (C) 2019 Javier Sancho <jsf@jsancho.org>
-;;;
-;;; 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
-;;; <http://www.gnu.org/licenses/>.
-
-
-(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)))
+++ /dev/null
-;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
-;;; Copyright (C) 2019 Javier Sancho <jsf@jsancho.org>
-;;;
-;;; 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
-;;; <http://www.gnu.org/licenses/>.
-
-
-(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)))
+++ /dev/null
-;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
-;;; Copyright (C) 2019 Javier Sancho <jsf@jsancho.org>
-;;;
-;;; 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
-;;; <http://www.gnu.org/licenses/>.
-
-
-(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))
+++ /dev/null
-;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
-;;; Copyright (C) 2019 Javier Sancho <jsf@jsancho.org>
-;;;
-;;; 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
-;;; <http://www.gnu.org/licenses/>.
-
-
-(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))
+++ /dev/null
-;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
-;;; Copyright (C) 2019 Javier Sancho <jsf@jsancho.org>
-;;;
-;;; 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
-;;; <http://www.gnu.org/licenses/>.
-
-
-(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))
{
return irr::video::EDT_OPENGL;
}
- else if (!strcmp(driverType, "count"))
- {
- return irr::video::EDT_COUNT;
- }
else
{
return irr::video::EDT_NULL;
#include <libguile.h>
#include "EDriverTypes.h"
#include "Irrlicht.h"
+#include "dimension2d.h"
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
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);
}
--- /dev/null
+/* guile-irrlicht --- GNU Guile bindings for Irrlicht Engine
+
+ Copyright (C) 2020 Javier Sancho <jsf@jsancho.org>
+
+ 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
+ <http://www.gnu.org/licenses/>.
+*/
+
+#include <irrlicht/irrlicht.h>
+#include <libguile.h>
+#include "dimension2d.h"
+
+extern "C" {
+
+ irr::core::dimension2d<irr::u32>
+ scm_to_dimension2d_u32 (SCM dimension2d)
+ {
+ return irr::core::dimension2d<irr::u32>
+ (scm_to_uint32 (scm_car (dimension2d)),
+ scm_to_uint32 (scm_cadr (dimension2d)));
+ }
+
+}
--- /dev/null
+/* guile-irrlicht --- GNU Guile bindings for Irrlicht Engine
+
+ Copyright (C) 2020 Javier Sancho <jsf@jsancho.org>
+
+ 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
+ <http://www.gnu.org/licenses/>.
+*/
+
+#ifndef __GUILE_IRRLICHT_DIMENSION_2D_INCLUDED__
+#define __GUILE_IRRLICHT_DIMENSION_2D_INCLUDED__
+
+#include <irrlicht/irrlicht.h>
+#include <libguile.h>
+
+extern "C" {
+
+ irr::core::dimension2d<irr::u32>
+ scm_to_dimension2d_u32 (SCM dimension2d);
+
+}
+
+#endif
projects / guile-irrlicht.git / commitdiff