From: Javier Sancho Date: Thu, 7 Aug 2014 11:18:28 +0000 (+0200) Subject: Praparing for autoconf X-Git-Url: https://git.jsancho.org/?a=commitdiff_plain;h=9c753299c5306a5f896a2ec582221b341fc80a93;p=guile-assimp.git Praparing for autoconf --- diff --git a/Makefile.am b/Makefile.am new file mode 100644 index 0000000..a9dc6ef --- /dev/null +++ b/Makefile.am @@ -0,0 +1,39 @@ +## Process this file with automake to produce Makefile.in. +## +## guile-assimp, foreign interface to libassimp +## Copyright (C) 2014 by Javier Sancho Fernandez +## +## This program is free software: you can redistribute it and/or modify +## it under the terms of the GNU General Public License as published by +## the Free Software Foundation, either version 3 of the License, or +## (at your option) any later version. +## +## This program 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 General Public License +## along with this program. If not, see . + +include guile.am + +moddir=$(prefix)/share/guile/site/$(GUILE_EFFECTIVE_VERSION) +godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/ccache + +SOURCES = \ + assimp.scm \ + assimp/low-level.scm \ + assimp/low-level/cimport.scm \ + assimp/low-level/color.scm \ + assimp/low-level/material.scm \ + assimp/low-level/matrix.scm \ + assimp/low-level/mesh.scm \ + assimp/low-level/postprocess.scm \ + assimp/low-level/scene.scm \ + assimp/low-level/types.scm \ + assimp/low-level/vector.scm + +EXTRA_DIST += env.in COPYING examples README + +TESTS_ENVIRONMENT = $(top_builddir)/env $(GUILE) --no-auto-compile diff --git a/acinclude.m4 b/acinclude.m4 new file mode 100644 index 0000000..441dcd4 --- /dev/null +++ b/acinclude.m4 @@ -0,0 +1,341 @@ +## Autoconf macros for working with Guile. +## +## Copyright (C) 1998,2001, 2006, 2010, 2012, 2013, 2014 Free Software Foundation, Inc. +## +## This library 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. +## +## This library 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 +## Lesser General Public License for more details. +## +## You should have received a copy of the GNU Lesser General Public +## License along with this library; if not, write to the Free Software +## Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +## 02110-1301 USA + +# serial 10 + +## Index +## ----- +## +## GUILE_PKG -- find Guile development files +## GUILE_PROGS -- set paths to Guile interpreter, config and tool programs +## GUILE_FLAGS -- set flags for compiling and linking with Guile +## GUILE_SITE_DIR -- find path to Guile "site" directory +## GUILE_CHECK -- evaluate Guile Scheme code and capture the return value +## GUILE_MODULE_CHECK -- check feature of a Guile Scheme module +## GUILE_MODULE_AVAILABLE -- check availability of a Guile Scheme module +## GUILE_MODULE_REQUIRED -- fail if a Guile Scheme module is unavailable +## GUILE_MODULE_EXPORTS -- check if a module exports a variable +## GUILE_MODULE_REQUIRED_EXPORT -- fail if a module doesn't export a variable + +## Code +## ---- + +## NOTE: Comments preceding an AC_DEFUN (starting from "Usage:") are massaged +## into doc/ref/autoconf-macros.texi (see Makefile.am in that directory). + +# GUILE_PKG -- find Guile development files +# +# Usage: GUILE_PKG([VERSIONS]) +# +# This macro runs the @code{pkg-config} tool to find development files +# for an available version of Guile. +# +# By default, this macro will search for the latest stable version of +# Guile (e.g. 2.0), falling back to the previous stable version +# (e.g. 1.8) if it is available. If no guile-@var{VERSION}.pc file is +# found, an error is signalled. The found version is stored in +# @var{GUILE_EFFECTIVE_VERSION}. +# +# If @code{GUILE_PROGS} was already invoked, this macro ensures that the +# development files have the same effective version as the Guile +# program. +# +# @var{GUILE_EFFECTIVE_VERSION} is marked for substitution, as by +# @code{AC_SUBST}. +# +AC_DEFUN([GUILE_PKG], + [PKG_PROG_PKG_CONFIG + _guile_versions_to_search="m4_default([$1], [2.0 1.8])" + if test -n "$GUILE_EFFECTIVE_VERSION"; then + _guile_tmp="" + for v in $_guile_versions_to_search; do + if test "$v" = "$GUILE_EFFECTIVE_VERSION"; then + _guile_tmp=$v + fi + done + if test -z "$_guile_tmp"; then + AC_MSG_FAILURE([searching for guile development files for versions $_guile_versions_to_search, but previously found $GUILE version $GUILE_EFFECTIVE_VERSION]) + fi + _guile_versions_to_search=$GUILE_EFFECTIVE_VERSION + fi + GUILE_EFFECTIVE_VERSION="" + _guile_errors="" + for v in $_guile_versions_to_search; do + if test -z "$GUILE_EFFECTIVE_VERSION"; then + AC_MSG_NOTICE([checking for guile $v]) + PKG_CHECK_EXISTS([guile-$v], [GUILE_EFFECTIVE_VERSION=$v], []) + fi + done + + if test -z "$GUILE_EFFECTIVE_VERSION"; then + AC_MSG_ERROR([ +No Guile development packages were found. + +Please verify that you have Guile installed. If you installed Guile +from a binary distribution, please verify that you have also installed +the development packages. If you installed it yourself, you might need +to adjust your PKG_CONFIG_PATH; see the pkg-config man page for more. +]) + fi + AC_MSG_NOTICE([found guile $GUILE_EFFECTIVE_VERSION]) + AC_SUBST([GUILE_EFFECTIVE_VERSION]) + ]) + +# GUILE_FLAGS -- set flags for compiling and linking with Guile +# +# Usage: GUILE_FLAGS +# +# This macro runs the @code{pkg-config} tool to find out how to compile +# and link programs against Guile. It sets four variables: +# @var{GUILE_CFLAGS}, @var{GUILE_LDFLAGS}, @var{GUILE_LIBS}, and +# @var{GUILE_LTLIBS}. +# +# @var{GUILE_CFLAGS}: flags to pass to a C or C++ compiler to build code that +# uses Guile header files. This is almost always just one or more @code{-I} +# flags. +# +# @var{GUILE_LDFLAGS}: flags to pass to the compiler to link a program +# against Guile. This includes @code{-lguile-@var{VERSION}} for the +# Guile library itself, and may also include one or more @code{-L} flag +# to tell the compiler where to find the libraries. But it does not +# include flags that influence the program's runtime search path for +# libraries, and will therefore lead to a program that fails to start, +# unless all necessary libraries are installed in a standard location +# such as @file{/usr/lib}. +# +# @var{GUILE_LIBS} and @var{GUILE_LTLIBS}: flags to pass to the compiler or to +# libtool, respectively, to link a program against Guile. It includes flags +# that augment the program's runtime search path for libraries, so that shared +# libraries will be found at the location where they were during linking, even +# in non-standard locations. @var{GUILE_LIBS} is to be used when linking the +# program directly with the compiler, whereas @var{GUILE_LTLIBS} is to be used +# when linking the program is done through libtool. +# +# The variables are marked for substitution, as by @code{AC_SUBST}. +# +AC_DEFUN([GUILE_FLAGS], + [AC_REQUIRE([GUILE_PKG]) + PKG_CHECK_MODULES(GUILE, [guile-$GUILE_EFFECTIVE_VERSION]) + + dnl GUILE_CFLAGS and GUILE_LIBS are already defined and AC_SUBST'd by + dnl PKG_CHECK_MODULES. But GUILE_LIBS to pkg-config is GUILE_LDFLAGS + dnl to us. + + GUILE_LDFLAGS=$GUILE_LIBS + + dnl Determine the platform dependent parameters needed to use rpath. + dnl AC_LIB_LINKFLAGS_FROM_LIBS is defined in gnulib/m4/lib-link.m4 and needs + dnl the file gnulib/build-aux/config.rpath. + AC_LIB_LINKFLAGS_FROM_LIBS([GUILE_LIBS], [$GUILE_LDFLAGS], []) + GUILE_LIBS="$GUILE_LDFLAGS $GUILE_LIBS" + AC_LIB_LINKFLAGS_FROM_LIBS([GUILE_LTLIBS], [$GUILE_LDFLAGS], [yes]) + GUILE_LTLIBS="$GUILE_LDFLAGS $GUILE_LTLIBS" + + AC_SUBST([GUILE_EFFECTIVE_VERSION]) + AC_SUBST([GUILE_CFLAGS]) + AC_SUBST([GUILE_LDFLAGS]) + AC_SUBST([GUILE_LIBS]) + AC_SUBST([GUILE_LTLIBS]) + ]) + +# GUILE_SITE_DIR -- find path to Guile "site" directory +# +# Usage: GUILE_SITE_DIR +# +# This looks for Guile's "site" directory, usually something like +# PREFIX/share/guile/site, and sets var @var{GUILE_SITE} to the path. +# Note that the var name is different from the macro name. +# +# The variable is marked for substitution, as by @code{AC_SUBST}. +# +AC_DEFUN([GUILE_SITE_DIR], + [AC_REQUIRE([GUILE_PKG]) + AC_MSG_CHECKING(for Guile site directory) + GUILE_SITE=`$PKG_CONFIG --print-errors --variable=sitedir guile-$GUILE_EFFECTIVE_VERSION` + AC_MSG_RESULT($GUILE_SITE) + if test "$GUILE_SITE" = ""; then + AC_MSG_FAILURE(sitedir not found) + fi + AC_SUBST(GUILE_SITE) + ]) + +# GUILE_PROGS -- set paths to Guile interpreter, config and tool programs +# +# Usage: GUILE_PROGS([VERSION]) +# +# This macro looks for programs @code{guile} and @code{guild}, setting +# variables @var{GUILE} and @var{GUILD} to their paths, respectively. +# If @code{guile} is not found, signal an error. +# +# By default, this macro will search for the latest stable version of +# Guile (e.g. 2.0). x.y or x.y.z versions can be specified. If an older +# version is found, the macro will signal an error. +# +# The effective version of the found @code{guile} is set to +# @var{GUILE_EFFECTIVE_VERSION}. This macro ensures that the effective +# version is compatible with the result of a previous invocation of +# @code{GUILE_FLAGS}, if any. +# +# As a legacy interface, it also looks for @code{guile-config} and +# @code{guile-tools}, setting @var{GUILE_CONFIG} and @var{GUILE_TOOLS}. +# +# The variables are marked for substitution, as by @code{AC_SUBST}. +# +AC_DEFUN([GUILE_PROGS], + [AC_PATH_PROG(GUILE,guile) + _guile_required_version="m4_default([$1], [$GUILE_EFFECTIVE_VERSION])" + if test -z "$_guile_required_version"; then + _guile_required_version=2.0 + fi + if test "$GUILE" = "" ; then + AC_MSG_ERROR([guile required but not found]) + fi + AC_SUBST(GUILE) + + _guile_effective_version=`$GUILE -c "(display (effective-version))"` + if test -z "$GUILE_EFFECTIVE_VERSION"; then + GUILE_EFFECTIVE_VERSION=$_guile_effective_version + elif test "$GUILE_EFFECTIVE_VERSION" != "$_guile_effective_version"; then + AC_MSG_ERROR([found development files for Guile $GUILE_EFFECTIVE_VERSION, but $GUILE has effective version $_guile_effective_version]) + fi + + _guile_major_version=`$GUILE -c "(display (major-version))"` + _guile_minor_version=`$GUILE -c "(display (minor-version))"` + _guile_micro_version=`$GUILE -c "(display (micro-version))"` + _guile_prog_version="$_guile_major_version.$_guile_minor_version.$_guile_micro_version" + + AC_MSG_CHECKING([for Guile version >= $_guile_required_version]) + _major_version=`echo $_guile_required_version | cut -d . -f 1` + _minor_version=`echo $_guile_required_version | cut -d . -f 2` + _micro_version=`echo $_guile_required_version | cut -d . -f 3` + if test "$_guile_major_version" -ge "$_major_version"; then + if test "$_guile_minor_version" -ge "$_minor_version"; then + if test -n "$_micro_version"; then + if test "$_guile_micro_version" -lt "$_micro_version"; then + AC_MSG_ERROR([Guile $_guile_required_version required, but $_guile_prog_version found]) + fi + fi + elif test "$GUILE_EFFECTIVE_VERSION" == "$_major_version.$_minor_version" -a -z "$_micro_version"; then + # Allow prereleases that have the right effective version. + true + else + as_fn_error $? "Guile $_guile_required_version required, but $_guile_prog_version found" "$LINENO" 5 + fi + else + AC_MSG_ERROR([Guile $_guile_required_version required, but $_guile_prog_version found]) + fi + AC_MSG_RESULT([$_guile_prog_version]) + + AC_PATH_PROG(GUILD,guild) + AC_SUBST(GUILD) + + AC_PATH_PROG(GUILE_CONFIG,guile-config) + AC_SUBST(GUILE_CONFIG) + if test -n "$GUILD"; then + GUILE_TOOLS=$GUILD + else + AC_PATH_PROG(GUILE_TOOLS,guile-tools) + fi + AC_SUBST(GUILE_TOOLS) + ]) + +# GUILE_CHECK -- evaluate Guile Scheme code and capture the return value +# +# Usage: GUILE_CHECK_RETVAL(var,check) +# +# @var{var} is a shell variable name to be set to the return value. +# @var{check} is a Guile Scheme expression, evaluated with "$GUILE -c", and +# returning either 0 or non-#f to indicate the check passed. +# Non-0 number or #f indicates failure. +# Avoid using the character "#" since that confuses autoconf. +# +AC_DEFUN([GUILE_CHECK], + [AC_REQUIRE([GUILE_PROGS]) + $GUILE -c "$2" > /dev/null 2>&1 + $1=$? + ]) + +# GUILE_MODULE_CHECK -- check feature of a Guile Scheme module +# +# Usage: GUILE_MODULE_CHECK(var,module,featuretest,description) +# +# @var{var} is a shell variable name to be set to "yes" or "no". +# @var{module} is a list of symbols, like: (ice-9 common-list). +# @var{featuretest} is an expression acceptable to GUILE_CHECK, q.v. +# @var{description} is a present-tense verb phrase (passed to AC_MSG_CHECKING). +# +AC_DEFUN([GUILE_MODULE_CHECK], + [AC_MSG_CHECKING([if $2 $4]) + GUILE_CHECK($1,(use-modules $2) (exit ((lambda () $3)))) + if test "$$1" = "0" ; then $1=yes ; else $1=no ; fi + AC_MSG_RESULT($$1) + ]) + +# GUILE_MODULE_AVAILABLE -- check availability of a Guile Scheme module +# +# Usage: GUILE_MODULE_AVAILABLE(var,module) +# +# @var{var} is a shell variable name to be set to "yes" or "no". +# @var{module} is a list of symbols, like: (ice-9 common-list). +# +AC_DEFUN([GUILE_MODULE_AVAILABLE], + [GUILE_MODULE_CHECK($1,$2,0,is available) + ]) + +# GUILE_MODULE_REQUIRED -- fail if a Guile Scheme module is unavailable +# +# Usage: GUILE_MODULE_REQUIRED(symlist) +# +# @var{symlist} is a list of symbols, WITHOUT surrounding parens, +# like: ice-9 common-list. +# +AC_DEFUN([GUILE_MODULE_REQUIRED], + [GUILE_MODULE_AVAILABLE(ac_guile_module_required, ($1)) + if test "$ac_guile_module_required" = "no" ; then + AC_MSG_ERROR([required guile module not found: ($1)]) + fi + ]) + +# GUILE_MODULE_EXPORTS -- check if a module exports a variable +# +# Usage: GUILE_MODULE_EXPORTS(var,module,modvar) +# +# @var{var} is a shell variable to be set to "yes" or "no". +# @var{module} is a list of symbols, like: (ice-9 common-list). +# @var{modvar} is the Guile Scheme variable to check. +# +AC_DEFUN([GUILE_MODULE_EXPORTS], + [GUILE_MODULE_CHECK($1,$2,$3,exports `$3') + ]) + +# GUILE_MODULE_REQUIRED_EXPORT -- fail if a module doesn't export a variable +# +# Usage: GUILE_MODULE_REQUIRED_EXPORT(module,modvar) +# +# @var{module} is a list of symbols, like: (ice-9 common-list). +# @var{modvar} is the Guile Scheme variable to check. +# +AC_DEFUN([GUILE_MODULE_REQUIRED_EXPORT], + [GUILE_MODULE_EXPORTS(guile_module_required_export,$1,$2) + if test "$guile_module_required_export" = "no" ; then + AC_MSG_ERROR([module $1 does not export $2; required]) + fi + ]) + +## guile.m4 ends here diff --git a/assimp.scm b/assimp.scm new file mode 100644 index 0000000..11a3d09 --- /dev/null +++ b/assimp.scm @@ -0,0 +1,386 @@ +;;; guile-assimp, foreign interface to libassimp +;;; Copyright (C) 2014 by Javier Sancho Fernandez +;;; +;;; This program is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; This program 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 General Public License +;;; along with this program. If not, see . + + +(define-module (assimp) + #:use-module (assimp low-level) + #:use-module (assimp low-level cimport) + #:use-module (assimp low-level color) + #:use-module (assimp low-level material) + #:use-module (assimp low-level matrix) + #:use-module (assimp low-level mesh) + #:use-module (assimp low-level postprocess) + #:use-module (assimp low-level scene) + #:use-module (assimp low-level types) + #:use-module (assimp low-level vector) + #:use-module (system foreign) + #:export (ai-import-file + ai-release-import + ai-attach-predefined-log-stream + ai-transform-vec-by-matrix4 + ai-multiply-matrix3 + ai-multiply-matrix4 + ai-identity-matrix3 + ai-identity-matrix4 + ai-transpose-matrix3 + ai-transpose-matrix4) + #:re-export (ai-material-key + ai-process-steps + ai-process-convert-to-left-handed + ai-process-preset-target-realtime-fast + ai-process-preset-target-realtime-quality + ai-process-preset-target-realtime-max-quality + ai-default-log-stream + (aiDetachAllLogStreams . ai-detach-all-log-streams))) + + +;;; Scenes + +(define-conversion-type parse-aiScene -> ai-scene + (flags (field 'mFlags)) + (root-node (wrap (field 'mRootNode) wrap-ai-node)) + (meshes (wrap (array (field 'mNumMeshes) (field 'mMeshes)) wrap-ai-mesh)) + (materials (wrap (array (field 'mNumMaterials) (field 'mMaterials)) wrap-ai-material)) + (animations (array (field 'mNumAnimations) (field 'mAnimations))) + (textures (array (field 'mNumTextures) (field 'mTextures))) + (lights (array (field 'mNumLights) (field 'mLights))) + (cameras (array (field 'mNumCameras) (field 'mCameras)))) + +(export ai-scene? + ai-scene-contents + ai-scene-flags + ai-scene-root-node + ai-scene-meshes + ai-scene-materials + ai-scene-animations + ai-scene-textures + ai-scene-lights + ai-scene-cameras) + + +;;; Nodes + +(define-conversion-type parse-aiNode -> ai-node + (name (sized-string (field 'mName))) + (transformation (wrap (parse-aiMatrix4x4 (field 'mTransformation) #:reverse #t) wrap-ai-matrix4x4)) + (parent (wrap (field 'mParent) wrap-ai-node)) + (children (wrap (array (field 'mNumChildren) (field 'mChildren)) wrap-ai-node)) + (meshes (array (field 'mNumMeshes) (field 'mMeshes)))) + +(export ai-node? + ai-node-contents + ai-node-name + ai-node-transformation + ai-node-parent + ai-node-children + ai-node-meshes) + + +;;; Meshes + +(define-conversion-type parse-aiMesh -> ai-mesh + (name (sized-string (field 'mName))) + (primitive-types (field 'mPrimitiveTypes)) + (vertices (wrap + (array (field 'mNumVertices) (field 'mVertices) #:element-size 12 #:element-proc get-element-address) + wrap-ai-vector3d)) + (faces (wrap + (array (field 'mNumFaces) (field 'mFaces) #:element-size 8 #:element-proc get-element-address) + wrap-ai-face)) + (normals (wrap + (array (field 'mNumVertices) (field 'mNormals) #:element-size 12 #:element-proc get-element-address) + wrap-ai-vector3d)) + (tangents (wrap + (array (field 'mNumVertices) (field 'mTangents) #:element-size 12 #:element-proc get-element-address) + wrap-ai-vector3d)) + (bitangents (wrap + (array (field 'mNumVertices) (field 'mBitangents) #:element-size 12 #:element-proc get-element-address) + wrap-ai-vector3d)) + (colors (map + (lambda (c) + (wrap + (array (field 'mNumVertices) c #:element-size 16 #:element-proc get-element-address) + wrap-ai-color4d)) + (field 'mColors))) + (texture-coords (map + (lambda (tc) + (wrap + (array (field 'mNumVertices) tc #:element-size 12 #:element-proc get-element-address) + wrap-ai-vector3d)) + (field 'mTextureCoords))) + (num-uv-components (field 'mNumUVComponents)) + (bones (wrap (array (field 'mNumBones) (field 'mBones)) wrap-ai-bone)) + (material-index (field 'mMaterialIndex))) + +(export ai-mesh? + ai-mesh-contents + ai-mesh-name + ai-mesh-primitive-types + ai-mesh-vertices + ai-mesh-faces + ai-mesh-normals + ai-mesh-tangents + ai-mesh-bitangents + ai-mesh-colors + ai-mesh-texture-coords + ai-mesh-num-uv-components + ai-mesh-bones + ai-mesh-material-index) + + +;;; Materials + +(define-conversion-type parse-aiMaterial -> ai-material + (properties (array (field 'mNumProperties) (field 'mProperties))) + (num-allocated (field 'mNumAllocated))) + +(export ai-material? + ai-material-contents + ai-material-properties + ai-material-num-allocated) + + +(define-public (ai-get-material-color mat color-type) + (let ((pmat (unwrap-ai-material mat)) + (pkey (string->pointer (car color-type))) + (type (cadr color-type)) + (index (caddr color-type)) + (pout (parse-aiColor4D (make-list 4 0) #:reverse #t))) + (let ((res (aiGetMaterialColor pmat pkey type index pout))) + (if (< res 0) + res + (wrap-ai-color4d pout))))) + +(define-public (ai-get-material-float-array mat color-type max) + (let ((pmat (unwrap-ai-material mat)) + (pkey (string->pointer (car color-type))) + (type (cadr color-type)) + (index (caddr color-type)) + (pout (bytevector->pointer (list->f32vector (make-list max 0)))) + (pmax (bytevector->pointer (list->u32vector (list max))))) + (let ((res (aiGetMaterialFloatArray pmat pkey type index pout pmax))) + (if (< res 0) + res + (f32vector->list (pointer->bytevector pout max 0 'f32)))))) + +(define-public (ai-get-material-integer-array mat color-type max) + (let ((pmat (unwrap-ai-material mat)) + (pkey (string->pointer (car color-type))) + (type (cadr color-type)) + (index (caddr color-type)) + (pout (bytevector->pointer (list->s32vector (make-list max 0)))) + (pmax (bytevector->pointer (list->u32vector (list max))))) + (let ((res (aiGetMaterialIntegerArray pmat pkey type index pout pmax))) + (if (< res 0) + res + (s32vector->list (pointer->bytevector pout max 0 's32)))))) + + +;;; Faces + +(define-conversion-type parse-aiFace -> ai-face + (indices (array (field 'mNumIndices) (field 'mIndices)))) + +(export ai-face? + ai-face-contents + ai-face-indices) + + +;;; Vectors + +(define-conversion-type parse-aiVector2D -> ai-vector2d + (x (field 'x)) + (y (field 'y))) + +(export ai-vector2d? + ai-vector2d-contents + ai-vector2d-x + ai-vector2d-y) + +(define-conversion-type parse-aiVector3D -> ai-vector3d + (x (field 'x)) + (y (field 'y)) + (z (field 'z))) + +(export ai-vector3d? + ai-vector3d-contents + ai-vector3d-x + ai-vector3d-y + ai-vector3d-z) + + +;;; Matrixes + +(define-conversion-type parse-aiMatrix3x3 -> ai-matrix3x3 + (a1 (field 'a1)) + (a2 (field 'a2)) + (a3 (field 'a3)) + (b1 (field 'b1)) + (b2 (field 'b2)) + (b3 (field 'b3)) + (c1 (field 'c1)) + (c2 (field 'c2)) + (c3 (field 'c3))) + +(export ai-matrix3x3? + ai-matrix3x3-contents + ai-matrix3x3-a1 + ai-matrix3x3-a2 + ai-matrix3x3-a3 + ai-matrix3x3-b1 + ai-matrix3x3-b2 + ai-matrix3x3-b3 + ai-matrix3x3-c1 + ai-matrix3x3-c2 + ai-matrix3x3-c3) + +(define-conversion-type parse-aiMatrix4x4 -> ai-matrix4x4 + (a1 (field 'a1)) + (a2 (field 'a2)) + (a3 (field 'a3)) + (a4 (field 'a4)) + (b1 (field 'b1)) + (b2 (field 'b2)) + (b3 (field 'b3)) + (b4 (field 'b4)) + (c1 (field 'c1)) + (c2 (field 'c2)) + (c3 (field 'c3)) + (c4 (field 'c4)) + (d1 (field 'd1)) + (d2 (field 'd2)) + (d3 (field 'd3)) + (d4 (field 'd4))) + +(export ai-matrix4x4? + ai-matrix4x4-contents + ai-matrix4x4-a1 + ai-matrix4x4-a2 + ai-matrix4x4-a3 + ai-matrix4x4-a4 + ai-matrix4x4-b1 + ai-matrix4x4-b2 + ai-matrix4x4-b3 + ai-matrix4x4-b4 + ai-matrix4x4-c1 + ai-matrix4x4-c2 + ai-matrix4x4-c3 + ai-matrix4x4-c4 + ai-matrix4x4-d1 + ai-matrix4x4-d2 + ai-matrix4x4-d3 + ai-matrix4x4-d4) + + +;;; Colors + +(define-conversion-type parse-aiColor4D -> ai-color4d + (r (field 'r)) + (g (field 'g)) + (b (field 'b)) + (a (field 'a))) + +(export ai-color4d? + ai-color4d-contents + ai-color4d-r + ai-color4d-g + ai-color4d-b + ai-color4d-a) + + +;;; Bones + +(define-conversion-type parse-aiBone -> ai-bone + (name (sized-string (field 'mName))) + (weights (wrap + (array (field 'mNumWeights) (field 'mWeights) #:element-size 8 #:element-proc get-element-address) + wrap-ai-vertex-weight)) + (offset-matrix (wrap (parse-aiMatrix4x4 (field 'mOffsetMatrix) #:reverse #t) wrap-ai-matrix4x4))) + +(export ai-bone? + ai-bone-contents + ai-bone-name + ai-bone-weights + ai-bone-offset-matrix) + + +;;; Weights + +(define-conversion-type parse-aiVertexWeight -> ai-vertex-weight + (vertex-id (field 'mVertexId)) + (weight (field 'mWeight))) + +(export ai-vertex-weight? + ai-vertex-weight-contents + ai-vertex-weight-vertex-id + ai-vertex-weight-weight) + + +;;; Functions + +(define (ai-import-file filename flags) + (wrap-ai-scene + (aiImportFile (string->pointer filename) + flags))) + +(define (ai-release-import scene) + (aiReleaseImport (unwrap-ai-scene scene))) + +(define* (ai-attach-predefined-log-stream type #:optional file) + (aiAttachLogStream + (aiGetPredefinedLogStream + type + (if file + (string->pointer file) + %null-pointer)))) + +(define (ai-transform-vec-by-matrix4 vec mat) + (let ((cvec (parse-aiVector3D (map cdr (ai-vector3d-contents vec)) #:reverse #t)) + (cmat (parse-aiMatrix4x4 (map cdr (ai-matrix4x4-contents mat)) #:reverse #t))) + (aiTransformVecByMatrix4 cvec cmat) + (wrap-ai-vector3d cvec))) + +(define (ai-multiply-matrix3 m1 m2) + (let ((cm1 (parse-aiMatrix3x3 (map cdr (ai-matrix3x3-contents m1)) #:reverse #t)) + (cm2 (parse-aiMatrix3x3 (map cdr (ai-matrix3x3-contents m2)) #:reverse #t))) + (aiMultiplyMatrix3 cm1 cm2) + (wrap-ai-matrix3x3 cm1))) + +(define (ai-multiply-matrix4 m1 m2) + (let ((cm1 (parse-aiMatrix4x4 (map cdr (ai-matrix4x4-contents m1)) #:reverse #t)) + (cm2 (parse-aiMatrix4x4 (map cdr (ai-matrix4x4-contents m2)) #:reverse #t))) + (aiMultiplyMatrix4 cm1 cm2) + (wrap-ai-matrix4x4 cm1))) + +(define (ai-identity-matrix3) + (let ((cmat (parse-aiMatrix3x3 (make-list 9 0) #:reverse #t))) + (aiIdentityMatrix3 cmat) + (wrap-ai-matrix3x3 cmat))) + +(define (ai-identity-matrix4) + (let ((cmat (parse-aiMatrix4x4 (make-list 16 0) #:reverse #t))) + (aiIdentityMatrix4 cmat) + (wrap-ai-matrix4x4 cmat))) + +(define (ai-transpose-matrix3 mat) + (let ((cmat (parse-aiMatrix3x3 (map cdr (ai-matrix3x3-contents mat)) #:reverse #t))) + (aiTransposeMatrix3 cmat) + (wrap-ai-matrix3x3 cmat))) + +(define (ai-transpose-matrix4 mat) + (let ((cmat (parse-aiMatrix4x4 (map cdr (ai-matrix4x4-contents mat)) #:reverse #t))) + (aiTransposeMatrix4 cmat) + (wrap-ai-matrix4x4 cmat))) diff --git a/assimp/low-level.scm b/assimp/low-level.scm new file mode 100644 index 0000000..148b26d --- /dev/null +++ b/assimp/low-level.scm @@ -0,0 +1,230 @@ +;;; guile-assimp, foreign interface to libassimp +;;; Copyright (C) 2014 by Javier Sancho Fernandez +;;; +;;; This program is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; This program 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 General Public License +;;; along with this program. If not, see . + + +(define-module (assimp low-level) + #:use-module (ice-9 iconv) + #:use-module (rnrs bytevectors) + #:use-module (system foreign)) + + +;;; Generic Functions + +(define (mk-string . args) + (string-concatenate + (map (lambda (a) + (if (string? a) + a + (symbol->string (syntax->datum a)))) + args))) + +(define (lambda-mk-symbol x) + (lambda args + (datum->syntax x + (string->symbol + (apply mk-string args))))) + + +;;; Parsers Definition + +(define-syntax define-struct-parser + (lambda (x) + (syntax-case x () + ((_ name (field type) ...) + (with-syntax (((field-name ...) (map car #'((field type) ...))) + ((field-type ...) (map cadr #'((field type) ...)))) + #'(define* (name pointer-or-data #:key (reverse #f)) + (cond (reverse + (make-c-struct + (list field-type ...) + pointer-or-data)) + (else + (map cons + '(field-name ...) + (parse-c-struct pointer-or-data (list field-type ...))))))))))) + +(export-syntax define-struct-parser) + + +;;; Type Generation + +(define-syntax define-conversion-type + (lambda (x) + (define mk-symbol (lambda-mk-symbol x)) + (syntax-case x (->) + ((_ parser -> name (field-name field-proc) ...) + (with-syntax ((type? (mk-symbol #'name "?")) + (wrap-type (mk-symbol "wrap-" #'name)) + (unwrap-type (mk-symbol "unwrap-" #'name)) + (output-string (mk-string "#<" #'name " ~x>")) + (type-contents (mk-symbol #'name "-contents")) + (type-parse (mk-symbol #'name "-parse")) + ((field-reader ...) (map (lambda (f) (mk-symbol #'name "-" (car f))) #'((field-name field-proc) ...)))) + #'(begin + (define-wrapped-pointer-type name + type? + wrap-type unwrap-type + (lambda (x p) + (format p output-string + (pointer-address (unwrap-type x))))) + (define (type-parse wrapped) + (let ((unwrapped (unwrap-type wrapped))) + (cond ((= (pointer-address unwrapped) 0) + '()) + (else + (parser unwrapped))))) + (define-type-contents type-contents type-parse (field-name field-proc) ...) + (define-field-reader field-reader type-parse field-proc) + ... + )))))) + +(define-macro (define-type-contents type-contents type-parse . fields) + `(define (,type-contents wrapped) + (let ((alist (,type-parse wrapped))) + (list ,@(map (lambda (f) + `(cons ',(car f) ,(cadr f))) + fields))))) + +(define-macro (define-field-reader field-reader type-parse body) + `(define (,field-reader wrapped) + (let ((alist (,type-parse wrapped))) + ,body))) + +(define-macro (field name) + `(assoc-ref alist ,name)) + +(export-syntax define-conversion-type + field) + + +;;; Support functions for type generation + +(define (bv-uint-ref pointer index) + (bytevector-uint-ref + (pointer->bytevector pointer 4 index) + 0 + (native-endianness) + 4)) + +(define* (array size root #:key (element-size 4) (element-proc bv-uint-ref)) + (cond ((= (pointer-address root) 0) + '()) + (else + (reverse + (let loop ((i 0) (res '())) + (cond ((= i size) + res) + (else + (loop (+ i 1) (cons (element-proc root (* element-size i)) res))))))))) + +(define (get-element-address root-pointer offset) + (make-pointer (+ (pointer-address root-pointer) offset))) + +(define (sized-string s) + (cond (s + (bytevector->string + (u8-list->bytevector (list-head (cadr s) (car s))) + (fluid-ref %default-port-encoding))) + (else + #f))) + +(define (wrap pointers wrap-proc) + (define (make-wrap element) + (let ((pointer + (cond ((pointer? element) + (if (= (pointer-address element) 0) + #f + element)) + ((= element 0) + #f) + (else + (make-pointer element))))) + (cond (pointer + (wrap-proc pointer)) + (else + #f)))) + (cond ((list? pointers) + (map make-wrap pointers)) + (else + (make-wrap pointers)))) + +(export array + get-element-address + sized-string + wrap) + + +;;; Function Mappers + +(define-syntax define-foreign-function + (lambda (x) + (syntax-case x (->) + ((_ ((foreign-lib name) arg-type ...) -> return-type) + (with-syntax ((name-string (datum->syntax x (symbol->string (syntax->datum #'name))))) + #'(define name + (pointer->procedure return-type + (dynamic-func name-string foreign-lib) + (list arg-type ...)))))))) + + +(define libassimp (dynamic-link "libassimp")) + +(define-syntax define-assimp-function + (syntax-rules (->) + ((_ (name arg-type ...) -> return-type) + (define-foreign-function ((libassimp name) arg-type ...) -> return-type)))) + + +(export-syntax define-foreign-function + define-assimp-function) + + +;;; Enumerators and bitfields (copìed from figl code, thanks to Andy Wingo + +(define-syntax-rule (define-enumeration enumerator (name value) ...) + (define-syntax enumerator + (lambda (x) + (syntax-case x () + ((_) + #''(name ...)) + ((_ enum) (number? (syntax->datum #'enum)) + #'enum) + ((_ enum) + #'(or (assq-ref `((name . ,(syntax->datum value)) ...) + (syntax->datum #'enum)) + (syntax-violation 'enumerator "invalid enumerated value" + #'enum))))))) + +(define-syntax-rule (define-bitfield bitfield (name value) ...) + (define-syntax bitfield + (lambda (x) + (syntax-case x () + ((_) + #''(name ...)) + ((_ bit (... ...)) + #`(logior + #,@(map + (lambda (bit) + (let ((datum (syntax->datum bit))) + (if (number? datum) + datum + (or (assq-ref '((name . value) ...) datum) + (syntax-violation 'bitfield "invalid bitfield value" + bit))))) + #'(bit (... ...))))))))) + +(export-syntax define-enumeration + define-bitfield) diff --git a/assimp/low-level/cimport.scm b/assimp/low-level/cimport.scm new file mode 100644 index 0000000..7f0f259 --- /dev/null +++ b/assimp/low-level/cimport.scm @@ -0,0 +1,46 @@ +;;; guile-assimp, foreign interface to libassimp +;;; Copyright (C) 2014 by Javier Sancho Fernandez +;;; +;;; This program is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; This program 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 General Public License +;;; along with this program. If not, see . + + +(define-module (assimp low-level cimport) + #:use-module (assimp low-level) + #:use-module (system foreign) + #:export (aiImportFile + aiReleaseImport + aiGetPredefinedLogStream + aiAttachLogStream + aiDetachAllLogStreams + aiTransformVecByMatrix4 + aiMultiplyMatrix3 + aiMultiplyMatrix4 + aiIdentityMatrix3 + aiIdentityMatrix4 + aiTransposeMatrix3 + aiTransposeMatrix4)) + +(define-assimp-function (aiImportFile '* unsigned-int) -> '*) +(define-assimp-function (aiReleaseImport '*) -> void) +(define-assimp-function (aiGetPredefinedLogStream unsigned-int '*) -> (list '* '* '*)) +(define-assimp-function (aiAttachLogStream '*) -> void) +(define-assimp-function (aiDetachAllLogStreams) -> void) + +(define-assimp-function (aiTransformVecByMatrix4 '* '*) -> void) +(define-assimp-function (aiMultiplyMatrix3 '* '*) -> void) +(define-assimp-function (aiMultiplyMatrix4 '* '*) -> void) +(define-assimp-function (aiIdentityMatrix3 '*) -> void) +(define-assimp-function (aiIdentityMatrix4 '*) -> void) +(define-assimp-function (aiTransposeMatrix3 '*) -> void) +(define-assimp-function (aiTransposeMatrix4 '*) -> void) diff --git a/assimp/low-level/color.scm b/assimp/low-level/color.scm new file mode 100644 index 0000000..bc13274 --- /dev/null +++ b/assimp/low-level/color.scm @@ -0,0 +1,29 @@ +;;; guile-assimp, foreign interface to libassimp +;;; Copyright (C) 2014 by Javier Sancho Fernandez +;;; +;;; This program is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; This program 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 General Public License +;;; along with this program. If not, see . + + +(define-module (assimp low-level color) + #:use-module (assimp low-level) + #:use-module (system foreign)) + + +(define-struct-parser parse-aiColor4D + (r float) + (g float) + (b float) + (a float)) + +(export parse-aiColor4D) diff --git a/assimp/low-level/material.scm b/assimp/low-level/material.scm new file mode 100644 index 0000000..2b3ade1 --- /dev/null +++ b/assimp/low-level/material.scm @@ -0,0 +1,68 @@ +;;; guile-assimp, foreign interface to libassimp +;;; Copyright (C) 2014 by Javier Sancho Fernandez +;;; +;;; This program is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; This program 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 General Public License +;;; along with this program. If not, see . + + +(define-module (assimp low-level material) + #:use-module (assimp low-level) + #:use-module (assimp low-level types) + #:use-module (system foreign) + #:export (parse-aiMaterial + parse-aiMaterialProperty + ai-material-key + aiGetMaterialColor + aiGetMaterialFloatArray + aiGetMaterialIntegerArray)) + + +(define-struct-parser parse-aiMaterialProperty + (mKey aiString-type) + (mSemantic unsigned-int) + (mIndex unsigned-int) + (mDataLength unsigned-int) + (mType unsigned-int) + (mData '*)) + +(define-struct-parser parse-aiMaterial + (mProperties '*) + (mNumProperties unsigned-int) + (mNumAllocated unsigned-int)) + + +(define-enumeration + ai-material-key + (name '("?mat.name" 0 0)) + (twosided '("$mat.twosided" 0 0)) + (shading-model '("$mat.shadingm" 0 0)) + (enable-wireframe '("$mat.wireframe" 0 0)) + (blend-func '("$mat.blend" 0 0)) + (opacity '("$mat.opacity" 0 0)) + (bumpscaling '("$mat.bumpscaling" 0 0)) + (shininess '("$mat.shininess" 0 0)) + (reflectivity '("$mat.reflectivity" 0 0)) + (shininess-strength '("$mat.shinpercent" 0 0)) + (refracti '("$mat.refracti" 0 0)) + (color-diffuse '("$clr.diffuse" 0 0)) + (color-ambient '("$clr.ambient" 0 0)) + (color-specular '("$clr.specular" 0 0)) + (color-emissive '("$clr.emissive" 0 0)) + (color-transparent '("$clr.transparent" 0 0)) + (color-reflective '("$clr.reflective" 0 0)) + (global-background-image '("?bg.global" 0 0))) + + +(define-assimp-function (aiGetMaterialColor '* '* unsigned-int unsigned-int '*) -> int) +(define-assimp-function (aiGetMaterialFloatArray '* '* unsigned-int unsigned-int '* '*) -> int) +(define-assimp-function (aiGetMaterialIntegerArray '* '* unsigned-int unsigned-int '* '*) -> int) diff --git a/assimp/low-level/matrix.scm b/assimp/low-level/matrix.scm new file mode 100644 index 0000000..416b4d0 --- /dev/null +++ b/assimp/low-level/matrix.scm @@ -0,0 +1,53 @@ +;;; guile-assimp, foreign interface to libassimp +;;; Copyright (C) 2014 by Javier Sancho Fernandez +;;; +;;; This program is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; This program 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 General Public License +;;; along with this program. If not, see . + + +(define-module (assimp low-level matrix) + #:use-module (assimp low-level) + #:use-module (system foreign)) + + +(define-struct-parser parse-aiMatrix3x3 + (a1 float) + (a2 float) + (a3 float) + (b1 float) + (b2 float) + (b3 float) + (c1 float) + (c2 float) + (c3 float)) + +(define-struct-parser parse-aiMatrix4x4 + (a1 float) + (a2 float) + (a3 float) + (a4 float) + (b1 float) + (b2 float) + (b3 float) + (b4 float) + (c1 float) + (c2 float) + (c3 float) + (c4 float) + (d1 float) + (d2 float) + (d3 float) + (d4 float)) + +(export parse-aiMatrix3x3 + parse-aiMatrix4x4) diff --git a/assimp/low-level/mesh.scm b/assimp/low-level/mesh.scm new file mode 100644 index 0000000..50d0bb8 --- /dev/null +++ b/assimp/low-level/mesh.scm @@ -0,0 +1,69 @@ +;;; guile-assimp, foreign interface to libassimp +;;; Copyright (C) 2014 by Javier Sancho Fernandez +;;; +;;; This program is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; This program 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 General Public License +;;; along with this program. If not, see . + + +(define-module (assimp low-level mesh) + #:use-module (assimp low-level) + #:use-module (assimp low-level types) + #:use-module (system foreign)) + + +(define-struct-parser parse-aiFace + (mNumIndices unsigned-int) + (mIndices '*)) + +(export parse-aiFace) + + +(define-struct-parser parser-aiVertexWeight + (mVertexId unsigned-int) + (mWeight float)) + +(export parse-aiVertexWeight) + + +(define-struct-parser parse-aiBone + (mName aiString-type) + (mNumWeights unsigned-int) + (mWeights '*) + (mOffsetMatrix aiMatrix4x4-type)) + +(export parse-aiBone) + + +(define AI_MAX_NUMBER_OF_COLOR_SETS #x8) +(define AI_MAX_NUMBER_OF_TEXTURECOORDS #x8) + +(define-struct-parser parse-aiMesh + (mPrimitiveTypes unsigned-int) + (mNumVertices unsigned-int) + (mNumFaces unsigned-int) + (mVertices '*) + (mNormals '*) + (mTangents '*) + (mBitangents '*) + (mColors (make-list AI_MAX_NUMBER_OF_COLOR_SETS '*)) + (mTextureCoords (make-list AI_MAX_NUMBER_OF_TEXTURECOORDS '*)) + (mNumUVComponents (make-list AI_MAX_NUMBER_OF_TEXTURECOORDS unsigned-int)) + (mFaces '*) + (mNumBones unsigned-int) + (mBones '*) + (mMaterialIndex unsigned-int) + (mName aiString-type) + (mNumAnimMeshes unsigned-int) + (mAnimMeshes '*)) + +(export parse-aiMesh) diff --git a/assimp/low-level/postprocess.scm b/assimp/low-level/postprocess.scm new file mode 100644 index 0000000..20ca550 --- /dev/null +++ b/assimp/low-level/postprocess.scm @@ -0,0 +1,92 @@ +;;; guile-assimp, foreign interface to libassimp +;;; Copyright (C) 2014 by Javier Sancho Fernandez +;;; +;;; This program is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; This program 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 General Public License +;;; along with this program. If not, see . + + +(define-module (assimp low-level postprocess) + #:use-module (assimp low-level) + #:export (ai-process-steps + ai-process-convert-to-left-handed + ai-process-preset-target-realtime-fast + ai-process-preset-target-realtime-quality + ai-process-preset-target-realtime-max-quality)) + + +(define-bitfield + ai-process-steps + (calc-tangent-space #x1) + (join-identical-vertices #x2) + (make-left-handed #x4) + (triangulate #x8) + (remove-component #x10) + (gen-normals #x20) + (gen-smooth-normals #x40) + (split-large-meshes #x80) + (pretransform-vertices #x100) + (limit-bone-weights #x200) + (validate-data-structure #x400) + (improve-cache-locality #x800) + (remove-redundant-materials #x1000) + (fix-infacing-normals #x2000) + (sort-by-ptype #x8000) + (find-degenerates #x10000) + (find-invalid-data #x20000) + (gen-UV-coords #x40000) + (transform-UV-coords #x80000) + (find-instances #x100000) + (optimize-meshes #x200000) + (optimize-graph #x400000) + (flip-UVs #x800000) + (flip-winding-order #x1000000) + (split-by-bone-count #x2000000) + (debone #x4000000)) + +(define ai-process-convert-to-left-handed + (ai-process-steps + make-left-handed + flip-UVs + flip-winding-order)) + +(define ai-process-preset-target-realtime-fast + (ai-process-steps + calc-tangent-space + gen-normals + join-identical-vertices + triangulate + gen-UV-coords + sort-by-ptype)) + +(define ai-process-preset-target-realtime-quality + (ai-process-steps + calc-tangent-space + gen-smooth-normals + join-identical-vertices + improve-cache-locality + limit-bone-weights + remove-redundant-materials + split-large-meshes + triangulate + gen-UV-coords + sort-by-ptype + find-degenerates + find-invalid-data)) + +(define ai-process-preset-target-realtime-max-quality + (+ ai-process-preset-target-realtime-quality + (ai-process-steps + find-instances + validate-data-structure + optimize-meshes + debone))) diff --git a/assimp/low-level/scene.scm b/assimp/low-level/scene.scm new file mode 100644 index 0000000..651ea3a --- /dev/null +++ b/assimp/low-level/scene.scm @@ -0,0 +1,53 @@ +;;; guile-assimp, foreign interface to libassimp +;;; Copyright (C) 2014 by Javier Sancho Fernandez +;;; +;;; This program is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; This program 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 General Public License +;;; along with this program. If not, see . + + +(define-module (assimp low-level scene) + #:use-module (assimp low-level) + #:use-module (assimp low-level types) + #:use-module (system foreign)) + + +(define-struct-parser parse-aiNode + (mName aiString-type) + (mTransformation aiMatrix4x4-type) + (mParent '*) + (mNumChildren unsigned-int) + (mChildren '*) + (mNumMeshes unsigned-int) + (mMeshes '*)) + +(export parse-aiNode) + + +(define-struct-parser parse-aiScene + (mFlags unsigned-int) + (mRootNode '*) + (mNumMeshes unsigned-int) + (mMeshes '*) + (mNumMaterials unsigned-int) + (mMaterials '*) + (mNumAnimations unsigned-int) + (mAnimations '*) + (mNumTextures unsigned-int) + (mTextures '*) + (mNumLights unsigned-int) + (mLights '*) + (mNumCameras unsigned-int) + (mCameras '*) + (mPrivate '*)) + +(export parse-aiScene) diff --git a/assimp/low-level/types.scm b/assimp/low-level/types.scm new file mode 100644 index 0000000..20e2281 --- /dev/null +++ b/assimp/low-level/types.scm @@ -0,0 +1,38 @@ +;;; guile-assimp, foreign interface to libassimp +;;; Copyright (C) 2014 by Javier Sancho Fernandez +;;; +;;; This program is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; This program 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 General Public License +;;; along with this program. If not, see . + + +(define-module (assimp low-level types) + #:use-module (assimp low-level) + #:use-module (system foreign) + #:export (aiString-type + aiMatrix4x4-type + ai-default-log-stream)) + + +(define aiString-type + (list size_t (make-list 1024 int8))) + +(define aiMatrix4x4-type + (make-list 16 float)) + +(define-enumeration + ai-default-log-stream + (file #x1) + (stdout #x2) + (stderr #x4) + (debugger #x8) + (ai-dls-enforce-enum-size #x7fffffff)) diff --git a/assimp/low-level/vector.scm b/assimp/low-level/vector.scm new file mode 100644 index 0000000..49b9916 --- /dev/null +++ b/assimp/low-level/vector.scm @@ -0,0 +1,33 @@ +;;; guile-assimp, foreign interface to libassimp +;;; Copyright (C) 2014 by Javier Sancho Fernandez +;;; +;;; This program is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; This program 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 General Public License +;;; along with this program. If not, see . + + +(define-module (assimp low-level vector) + #:use-module (assimp low-level) + #:use-module (system foreign)) + + +(define-struct-parser parse-aiVector2D + (x float) + (y float)) + +(define-struct-parser parse-aiVector3D + (x float) + (y float) + (z float)) + +(export parse-aiVector2D + parse-aiVector3D) diff --git a/configure.ac b/configure.ac new file mode 100644 index 0000000..a84de55 --- /dev/null +++ b/configure.ac @@ -0,0 +1,35 @@ +dnl -*- Autoconf -*- + +AC_INIT(guile-assimp, 0.1.0) +AC_COPYRIGHT([ + +guile-assimp, foreign interface to libassimp +Copyright (C) 2014 by Javier Sancho Fernandez + +This program is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +This program 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 General Public License +along with this program. If not, see . + +]) + +AC_CONFIG_SRCDIR(assimp.scm) +AC_CONFIG_AUX_DIR([build-aux]) +AM_INIT_AUTOMAKE([color-tests -Wall -Wno-portability foreign]) +AM_SILENT_RULES([yes]) + +GUILE_PKG([2.2 2.0]) +GUILE_PROGS + +AC_CONFIG_FILES([Makefile]) +AC_CONFIG_FILES([env], [chmod +x env]) + +AC_OUTPUT diff --git a/env.in b/env.in new file mode 100644 index 0000000..db507ca --- /dev/null +++ b/env.in @@ -0,0 +1,14 @@ +#!/bin/sh + +GUILE_LOAD_PATH=@abs_top_srcdir@:$GUILE_LOAD_PATH +if test "@abs_top_srcdir@" != "@abs_top_builddir@"; then + GUILE_LOAD_PATH=@abs_top_builddir@:$GUILE_LOAD_PATH +fi +GUILE_LOAD_COMPILED_PATH=@abs_top_builddir@:$GUILE_LOAD_PATH +PATH=@abs_top_builddir@/bin:$PATH + +export GUILE_LOAD_PATH +export GUILE_LOAD_COMPILED_PATH +export PATH + +exec "$@" diff --git a/examples/sample-figl/sample-figl.scm b/examples/sample-figl/sample-figl.scm index b0b9623..871184c 100755 --- a/examples/sample-figl/sample-figl.scm +++ b/examples/sample-figl/sample-figl.scm @@ -18,7 +18,7 @@ ;;; along with this program. If not, see . -(use-modules (assimp assimp) +(use-modules (assimp) (figl gl) (figl gl low-level) (figl glu) diff --git a/guile.am b/guile.am new file mode 100644 index 0000000..dc1e63f --- /dev/null +++ b/guile.am @@ -0,0 +1,19 @@ +GOBJECTS = $(SOURCES:%.scm=%.go) + +nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES) +nobase_go_DATA = $(GOBJECTS) + +# Make sure source files are installed first, so that the mtime of +# installed compiled files is greater than that of installed source +# files. See +# +# for details. +guile_install_go_files = install-nobase_goDATA +$(guile_install_go_files): install-nobase_modDATA + +CLEANFILES = $(GOBJECTS) +EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES) +GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat +SUFFIXES = .scm .go +.scm.go: + $(AM_V_GEN)$(top_builddir)/env $(GUILE_TOOLS) compile $(GUILE_WARNINGS) -o "$@" "$<" diff --git a/src/assimp.scm b/src/assimp.scm deleted file mode 100644 index 3925805..0000000 --- a/src/assimp.scm +++ /dev/null @@ -1,386 +0,0 @@ -;;; guile-assimp, foreign interface to libassimp -;;; Copyright (C) 2014 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program 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 General Public License -;;; along with this program. If not, see . - - -(define-module (assimp assimp) - #:use-module (assimp low-level) - #:use-module (assimp low-level cimport) - #:use-module (assimp low-level color) - #:use-module (assimp low-level material) - #:use-module (assimp low-level matrix) - #:use-module (assimp low-level mesh) - #:use-module (assimp low-level postprocess) - #:use-module (assimp low-level scene) - #:use-module (assimp low-level types) - #:use-module (assimp low-level vector) - #:use-module (system foreign) - #:export (ai-import-file - ai-release-import - ai-attach-predefined-log-stream - ai-transform-vec-by-matrix4 - ai-multiply-matrix3 - ai-multiply-matrix4 - ai-identity-matrix3 - ai-identity-matrix4 - ai-transpose-matrix3 - ai-transpose-matrix4) - #:re-export (ai-material-key - ai-process-steps - ai-process-convert-to-left-handed - ai-process-preset-target-realtime-fast - ai-process-preset-target-realtime-quality - ai-process-preset-target-realtime-max-quality - ai-default-log-stream - (aiDetachAllLogStreams . ai-detach-all-log-streams))) - - -;;; Scenes - -(define-conversion-type parse-aiScene -> ai-scene - (flags (field 'mFlags)) - (root-node (wrap (field 'mRootNode) wrap-ai-node)) - (meshes (wrap (array (field 'mNumMeshes) (field 'mMeshes)) wrap-ai-mesh)) - (materials (wrap (array (field 'mNumMaterials) (field 'mMaterials)) wrap-ai-material)) - (animations (array (field 'mNumAnimations) (field 'mAnimations))) - (textures (array (field 'mNumTextures) (field 'mTextures))) - (lights (array (field 'mNumLights) (field 'mLights))) - (cameras (array (field 'mNumCameras) (field 'mCameras)))) - -(export ai-scene? - ai-scene-contents - ai-scene-flags - ai-scene-root-node - ai-scene-meshes - ai-scene-materials - ai-scene-animations - ai-scene-textures - ai-scene-lights - ai-scene-cameras) - - -;;; Nodes - -(define-conversion-type parse-aiNode -> ai-node - (name (sized-string (field 'mName))) - (transformation (wrap (parse-aiMatrix4x4 (field 'mTransformation) #:reverse #t) wrap-ai-matrix4x4)) - (parent (wrap (field 'mParent) wrap-ai-node)) - (children (wrap (array (field 'mNumChildren) (field 'mChildren)) wrap-ai-node)) - (meshes (array (field 'mNumMeshes) (field 'mMeshes)))) - -(export ai-node? - ai-node-contents - ai-node-name - ai-node-transformation - ai-node-parent - ai-node-children - ai-node-meshes) - - -;;; Meshes - -(define-conversion-type parse-aiMesh -> ai-mesh - (name (sized-string (field 'mName))) - (primitive-types (field 'mPrimitiveTypes)) - (vertices (wrap - (array (field 'mNumVertices) (field 'mVertices) #:element-size 12 #:element-proc get-element-address) - wrap-ai-vector3d)) - (faces (wrap - (array (field 'mNumFaces) (field 'mFaces) #:element-size 8 #:element-proc get-element-address) - wrap-ai-face)) - (normals (wrap - (array (field 'mNumVertices) (field 'mNormals) #:element-size 12 #:element-proc get-element-address) - wrap-ai-vector3d)) - (tangents (wrap - (array (field 'mNumVertices) (field 'mTangents) #:element-size 12 #:element-proc get-element-address) - wrap-ai-vector3d)) - (bitangents (wrap - (array (field 'mNumVertices) (field 'mBitangents) #:element-size 12 #:element-proc get-element-address) - wrap-ai-vector3d)) - (colors (map - (lambda (c) - (wrap - (array (field 'mNumVertices) c #:element-size 16 #:element-proc get-element-address) - wrap-ai-color4d)) - (field 'mColors))) - (texture-coords (map - (lambda (tc) - (wrap - (array (field 'mNumVertices) tc #:element-size 12 #:element-proc get-element-address) - wrap-ai-vector3d)) - (field 'mTextureCoords))) - (num-uv-components (field 'mNumUVComponents)) - (bones (wrap (array (field 'mNumBones) (field 'mBones)) wrap-ai-bone)) - (material-index (field 'mMaterialIndex))) - -(export ai-mesh? - ai-mesh-contents - ai-mesh-name - ai-mesh-primitive-types - ai-mesh-vertices - ai-mesh-faces - ai-mesh-normals - ai-mesh-tangents - ai-mesh-bitangents - ai-mesh-colors - ai-mesh-texture-coords - ai-mesh-num-uv-components - ai-mesh-bones - ai-mesh-material-index) - - -;;; Materials - -(define-conversion-type parse-aiMaterial -> ai-material - (properties (array (field 'mNumProperties) (field 'mProperties))) - (num-allocated (field 'mNumAllocated))) - -(export ai-material? - ai-material-contents - ai-material-properties - ai-material-num-allocated) - - -(define-public (ai-get-material-color mat color-type) - (let ((pmat (unwrap-ai-material mat)) - (pkey (string->pointer (car color-type))) - (type (cadr color-type)) - (index (caddr color-type)) - (pout (parse-aiColor4D (make-list 4 0) #:reverse #t))) - (let ((res (aiGetMaterialColor pmat pkey type index pout))) - (if (< res 0) - res - (wrap-ai-color4d pout))))) - -(define-public (ai-get-material-float-array mat color-type max) - (let ((pmat (unwrap-ai-material mat)) - (pkey (string->pointer (car color-type))) - (type (cadr color-type)) - (index (caddr color-type)) - (pout (bytevector->pointer (list->f32vector (make-list max 0)))) - (pmax (bytevector->pointer (list->u32vector (list max))))) - (let ((res (aiGetMaterialFloatArray pmat pkey type index pout pmax))) - (if (< res 0) - res - (f32vector->list (pointer->bytevector pout max 0 'f32)))))) - -(define-public (ai-get-material-integer-array mat color-type max) - (let ((pmat (unwrap-ai-material mat)) - (pkey (string->pointer (car color-type))) - (type (cadr color-type)) - (index (caddr color-type)) - (pout (bytevector->pointer (list->s32vector (make-list max 0)))) - (pmax (bytevector->pointer (list->u32vector (list max))))) - (let ((res (aiGetMaterialIntegerArray pmat pkey type index pout pmax))) - (if (< res 0) - res - (s32vector->list (pointer->bytevector pout max 0 's32)))))) - - -;;; Faces - -(define-conversion-type parse-aiFace -> ai-face - (indices (array (field 'mNumIndices) (field 'mIndices)))) - -(export ai-face? - ai-face-contents - ai-face-indices) - - -;;; Vectors - -(define-conversion-type parse-aiVector2D -> ai-vector2d - (x (field 'x)) - (y (field 'y))) - -(export ai-vector2d? - ai-vector2d-contents - ai-vector2d-x - ai-vector2d-y) - -(define-conversion-type parse-aiVector3D -> ai-vector3d - (x (field 'x)) - (y (field 'y)) - (z (field 'z))) - -(export ai-vector3d? - ai-vector3d-contents - ai-vector3d-x - ai-vector3d-y - ai-vector3d-z) - - -;;; Matrixes - -(define-conversion-type parse-aiMatrix3x3 -> ai-matrix3x3 - (a1 (field 'a1)) - (a2 (field 'a2)) - (a3 (field 'a3)) - (b1 (field 'b1)) - (b2 (field 'b2)) - (b3 (field 'b3)) - (c1 (field 'c1)) - (c2 (field 'c2)) - (c3 (field 'c3))) - -(export ai-matrix3x3? - ai-matrix3x3-contents - ai-matrix3x3-a1 - ai-matrix3x3-a2 - ai-matrix3x3-a3 - ai-matrix3x3-b1 - ai-matrix3x3-b2 - ai-matrix3x3-b3 - ai-matrix3x3-c1 - ai-matrix3x3-c2 - ai-matrix3x3-c3) - -(define-conversion-type parse-aiMatrix4x4 -> ai-matrix4x4 - (a1 (field 'a1)) - (a2 (field 'a2)) - (a3 (field 'a3)) - (a4 (field 'a4)) - (b1 (field 'b1)) - (b2 (field 'b2)) - (b3 (field 'b3)) - (b4 (field 'b4)) - (c1 (field 'c1)) - (c2 (field 'c2)) - (c3 (field 'c3)) - (c4 (field 'c4)) - (d1 (field 'd1)) - (d2 (field 'd2)) - (d3 (field 'd3)) - (d4 (field 'd4))) - -(export ai-matrix4x4? - ai-matrix4x4-contents - ai-matrix4x4-a1 - ai-matrix4x4-a2 - ai-matrix4x4-a3 - ai-matrix4x4-a4 - ai-matrix4x4-b1 - ai-matrix4x4-b2 - ai-matrix4x4-b3 - ai-matrix4x4-b4 - ai-matrix4x4-c1 - ai-matrix4x4-c2 - ai-matrix4x4-c3 - ai-matrix4x4-c4 - ai-matrix4x4-d1 - ai-matrix4x4-d2 - ai-matrix4x4-d3 - ai-matrix4x4-d4) - - -;;; Colors - -(define-conversion-type parse-aiColor4D -> ai-color4d - (r (field 'r)) - (g (field 'g)) - (b (field 'b)) - (a (field 'a))) - -(export ai-color4d? - ai-color4d-contents - ai-color4d-r - ai-color4d-g - ai-color4d-b - ai-color4d-a) - - -;;; Bones - -(define-conversion-type parse-aiBone -> ai-bone - (name (sized-string (field 'mName))) - (weights (wrap - (array (field 'mNumWeights) (field 'mWeights) #:element-size 8 #:element-proc get-element-address) - wrap-ai-vertex-weight)) - (offset-matrix (wrap (parse-aiMatrix4x4 (field 'mOffsetMatrix) #:reverse #t) wrap-ai-matrix4x4))) - -(export ai-bone? - ai-bone-contents - ai-bone-name - ai-bone-weights - ai-bone-offset-matrix) - - -;;; Weights - -(define-conversion-type parse-aiVertexWeight -> ai-vertex-weight - (vertex-id (field 'mVertexId)) - (weight (field 'mWeight))) - -(export ai-vertex-weight? - ai-vertex-weight-contents - ai-vertex-weight-vertex-id - ai-vertex-weight-weight) - - -;;; Functions - -(define (ai-import-file filename flags) - (wrap-ai-scene - (aiImportFile (string->pointer filename) - flags))) - -(define (ai-release-import scene) - (aiReleaseImport (unwrap-ai-scene scene))) - -(define* (ai-attach-predefined-log-stream type #:optional file) - (aiAttachLogStream - (aiGetPredefinedLogStream - type - (if file - (string->pointer file) - %null-pointer)))) - -(define (ai-transform-vec-by-matrix4 vec mat) - (let ((cvec (parse-aiVector3D (map cdr (ai-vector3d-contents vec)) #:reverse #t)) - (cmat (parse-aiMatrix4x4 (map cdr (ai-matrix4x4-contents mat)) #:reverse #t))) - (aiTransformVecByMatrix4 cvec cmat) - (wrap-ai-vector3d cvec))) - -(define (ai-multiply-matrix3 m1 m2) - (let ((cm1 (parse-aiMatrix3x3 (map cdr (ai-matrix3x3-contents m1)) #:reverse #t)) - (cm2 (parse-aiMatrix3x3 (map cdr (ai-matrix3x3-contents m2)) #:reverse #t))) - (aiMultiplyMatrix3 cm1 cm2) - (wrap-ai-matrix3x3 cm1))) - -(define (ai-multiply-matrix4 m1 m2) - (let ((cm1 (parse-aiMatrix4x4 (map cdr (ai-matrix4x4-contents m1)) #:reverse #t)) - (cm2 (parse-aiMatrix4x4 (map cdr (ai-matrix4x4-contents m2)) #:reverse #t))) - (aiMultiplyMatrix4 cm1 cm2) - (wrap-ai-matrix4x4 cm1))) - -(define (ai-identity-matrix3) - (let ((cmat (parse-aiMatrix3x3 (make-list 9 0) #:reverse #t))) - (aiIdentityMatrix3 cmat) - (wrap-ai-matrix3x3 cmat))) - -(define (ai-identity-matrix4) - (let ((cmat (parse-aiMatrix4x4 (make-list 16 0) #:reverse #t))) - (aiIdentityMatrix4 cmat) - (wrap-ai-matrix4x4 cmat))) - -(define (ai-transpose-matrix3 mat) - (let ((cmat (parse-aiMatrix3x3 (map cdr (ai-matrix3x3-contents mat)) #:reverse #t))) - (aiTransposeMatrix3 cmat) - (wrap-ai-matrix3x3 cmat))) - -(define (ai-transpose-matrix4 mat) - (let ((cmat (parse-aiMatrix4x4 (map cdr (ai-matrix4x4-contents mat)) #:reverse #t))) - (aiTransposeMatrix4 cmat) - (wrap-ai-matrix4x4 cmat))) diff --git a/src/low-level.scm b/src/low-level.scm deleted file mode 100644 index 148b26d..0000000 --- a/src/low-level.scm +++ /dev/null @@ -1,230 +0,0 @@ -;;; guile-assimp, foreign interface to libassimp -;;; Copyright (C) 2014 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program 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 General Public License -;;; along with this program. If not, see . - - -(define-module (assimp low-level) - #:use-module (ice-9 iconv) - #:use-module (rnrs bytevectors) - #:use-module (system foreign)) - - -;;; Generic Functions - -(define (mk-string . args) - (string-concatenate - (map (lambda (a) - (if (string? a) - a - (symbol->string (syntax->datum a)))) - args))) - -(define (lambda-mk-symbol x) - (lambda args - (datum->syntax x - (string->symbol - (apply mk-string args))))) - - -;;; Parsers Definition - -(define-syntax define-struct-parser - (lambda (x) - (syntax-case x () - ((_ name (field type) ...) - (with-syntax (((field-name ...) (map car #'((field type) ...))) - ((field-type ...) (map cadr #'((field type) ...)))) - #'(define* (name pointer-or-data #:key (reverse #f)) - (cond (reverse - (make-c-struct - (list field-type ...) - pointer-or-data)) - (else - (map cons - '(field-name ...) - (parse-c-struct pointer-or-data (list field-type ...))))))))))) - -(export-syntax define-struct-parser) - - -;;; Type Generation - -(define-syntax define-conversion-type - (lambda (x) - (define mk-symbol (lambda-mk-symbol x)) - (syntax-case x (->) - ((_ parser -> name (field-name field-proc) ...) - (with-syntax ((type? (mk-symbol #'name "?")) - (wrap-type (mk-symbol "wrap-" #'name)) - (unwrap-type (mk-symbol "unwrap-" #'name)) - (output-string (mk-string "#<" #'name " ~x>")) - (type-contents (mk-symbol #'name "-contents")) - (type-parse (mk-symbol #'name "-parse")) - ((field-reader ...) (map (lambda (f) (mk-symbol #'name "-" (car f))) #'((field-name field-proc) ...)))) - #'(begin - (define-wrapped-pointer-type name - type? - wrap-type unwrap-type - (lambda (x p) - (format p output-string - (pointer-address (unwrap-type x))))) - (define (type-parse wrapped) - (let ((unwrapped (unwrap-type wrapped))) - (cond ((= (pointer-address unwrapped) 0) - '()) - (else - (parser unwrapped))))) - (define-type-contents type-contents type-parse (field-name field-proc) ...) - (define-field-reader field-reader type-parse field-proc) - ... - )))))) - -(define-macro (define-type-contents type-contents type-parse . fields) - `(define (,type-contents wrapped) - (let ((alist (,type-parse wrapped))) - (list ,@(map (lambda (f) - `(cons ',(car f) ,(cadr f))) - fields))))) - -(define-macro (define-field-reader field-reader type-parse body) - `(define (,field-reader wrapped) - (let ((alist (,type-parse wrapped))) - ,body))) - -(define-macro (field name) - `(assoc-ref alist ,name)) - -(export-syntax define-conversion-type - field) - - -;;; Support functions for type generation - -(define (bv-uint-ref pointer index) - (bytevector-uint-ref - (pointer->bytevector pointer 4 index) - 0 - (native-endianness) - 4)) - -(define* (array size root #:key (element-size 4) (element-proc bv-uint-ref)) - (cond ((= (pointer-address root) 0) - '()) - (else - (reverse - (let loop ((i 0) (res '())) - (cond ((= i size) - res) - (else - (loop (+ i 1) (cons (element-proc root (* element-size i)) res))))))))) - -(define (get-element-address root-pointer offset) - (make-pointer (+ (pointer-address root-pointer) offset))) - -(define (sized-string s) - (cond (s - (bytevector->string - (u8-list->bytevector (list-head (cadr s) (car s))) - (fluid-ref %default-port-encoding))) - (else - #f))) - -(define (wrap pointers wrap-proc) - (define (make-wrap element) - (let ((pointer - (cond ((pointer? element) - (if (= (pointer-address element) 0) - #f - element)) - ((= element 0) - #f) - (else - (make-pointer element))))) - (cond (pointer - (wrap-proc pointer)) - (else - #f)))) - (cond ((list? pointers) - (map make-wrap pointers)) - (else - (make-wrap pointers)))) - -(export array - get-element-address - sized-string - wrap) - - -;;; Function Mappers - -(define-syntax define-foreign-function - (lambda (x) - (syntax-case x (->) - ((_ ((foreign-lib name) arg-type ...) -> return-type) - (with-syntax ((name-string (datum->syntax x (symbol->string (syntax->datum #'name))))) - #'(define name - (pointer->procedure return-type - (dynamic-func name-string foreign-lib) - (list arg-type ...)))))))) - - -(define libassimp (dynamic-link "libassimp")) - -(define-syntax define-assimp-function - (syntax-rules (->) - ((_ (name arg-type ...) -> return-type) - (define-foreign-function ((libassimp name) arg-type ...) -> return-type)))) - - -(export-syntax define-foreign-function - define-assimp-function) - - -;;; Enumerators and bitfields (copìed from figl code, thanks to Andy Wingo - -(define-syntax-rule (define-enumeration enumerator (name value) ...) - (define-syntax enumerator - (lambda (x) - (syntax-case x () - ((_) - #''(name ...)) - ((_ enum) (number? (syntax->datum #'enum)) - #'enum) - ((_ enum) - #'(or (assq-ref `((name . ,(syntax->datum value)) ...) - (syntax->datum #'enum)) - (syntax-violation 'enumerator "invalid enumerated value" - #'enum))))))) - -(define-syntax-rule (define-bitfield bitfield (name value) ...) - (define-syntax bitfield - (lambda (x) - (syntax-case x () - ((_) - #''(name ...)) - ((_ bit (... ...)) - #`(logior - #,@(map - (lambda (bit) - (let ((datum (syntax->datum bit))) - (if (number? datum) - datum - (or (assq-ref '((name . value) ...) datum) - (syntax-violation 'bitfield "invalid bitfield value" - bit))))) - #'(bit (... ...))))))))) - -(export-syntax define-enumeration - define-bitfield) diff --git a/src/low-level/cimport.scm b/src/low-level/cimport.scm deleted file mode 100644 index 7f0f259..0000000 --- a/src/low-level/cimport.scm +++ /dev/null @@ -1,46 +0,0 @@ -;;; guile-assimp, foreign interface to libassimp -;;; Copyright (C) 2014 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program 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 General Public License -;;; along with this program. If not, see . - - -(define-module (assimp low-level cimport) - #:use-module (assimp low-level) - #:use-module (system foreign) - #:export (aiImportFile - aiReleaseImport - aiGetPredefinedLogStream - aiAttachLogStream - aiDetachAllLogStreams - aiTransformVecByMatrix4 - aiMultiplyMatrix3 - aiMultiplyMatrix4 - aiIdentityMatrix3 - aiIdentityMatrix4 - aiTransposeMatrix3 - aiTransposeMatrix4)) - -(define-assimp-function (aiImportFile '* unsigned-int) -> '*) -(define-assimp-function (aiReleaseImport '*) -> void) -(define-assimp-function (aiGetPredefinedLogStream unsigned-int '*) -> (list '* '* '*)) -(define-assimp-function (aiAttachLogStream '*) -> void) -(define-assimp-function (aiDetachAllLogStreams) -> void) - -(define-assimp-function (aiTransformVecByMatrix4 '* '*) -> void) -(define-assimp-function (aiMultiplyMatrix3 '* '*) -> void) -(define-assimp-function (aiMultiplyMatrix4 '* '*) -> void) -(define-assimp-function (aiIdentityMatrix3 '*) -> void) -(define-assimp-function (aiIdentityMatrix4 '*) -> void) -(define-assimp-function (aiTransposeMatrix3 '*) -> void) -(define-assimp-function (aiTransposeMatrix4 '*) -> void) diff --git a/src/low-level/color.scm b/src/low-level/color.scm deleted file mode 100644 index bc13274..0000000 --- a/src/low-level/color.scm +++ /dev/null @@ -1,29 +0,0 @@ -;;; guile-assimp, foreign interface to libassimp -;;; Copyright (C) 2014 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program 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 General Public License -;;; along with this program. If not, see . - - -(define-module (assimp low-level color) - #:use-module (assimp low-level) - #:use-module (system foreign)) - - -(define-struct-parser parse-aiColor4D - (r float) - (g float) - (b float) - (a float)) - -(export parse-aiColor4D) diff --git a/src/low-level/material.scm b/src/low-level/material.scm deleted file mode 100644 index 2b3ade1..0000000 --- a/src/low-level/material.scm +++ /dev/null @@ -1,68 +0,0 @@ -;;; guile-assimp, foreign interface to libassimp -;;; Copyright (C) 2014 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program 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 General Public License -;;; along with this program. If not, see . - - -(define-module (assimp low-level material) - #:use-module (assimp low-level) - #:use-module (assimp low-level types) - #:use-module (system foreign) - #:export (parse-aiMaterial - parse-aiMaterialProperty - ai-material-key - aiGetMaterialColor - aiGetMaterialFloatArray - aiGetMaterialIntegerArray)) - - -(define-struct-parser parse-aiMaterialProperty - (mKey aiString-type) - (mSemantic unsigned-int) - (mIndex unsigned-int) - (mDataLength unsigned-int) - (mType unsigned-int) - (mData '*)) - -(define-struct-parser parse-aiMaterial - (mProperties '*) - (mNumProperties unsigned-int) - (mNumAllocated unsigned-int)) - - -(define-enumeration - ai-material-key - (name '("?mat.name" 0 0)) - (twosided '("$mat.twosided" 0 0)) - (shading-model '("$mat.shadingm" 0 0)) - (enable-wireframe '("$mat.wireframe" 0 0)) - (blend-func '("$mat.blend" 0 0)) - (opacity '("$mat.opacity" 0 0)) - (bumpscaling '("$mat.bumpscaling" 0 0)) - (shininess '("$mat.shininess" 0 0)) - (reflectivity '("$mat.reflectivity" 0 0)) - (shininess-strength '("$mat.shinpercent" 0 0)) - (refracti '("$mat.refracti" 0 0)) - (color-diffuse '("$clr.diffuse" 0 0)) - (color-ambient '("$clr.ambient" 0 0)) - (color-specular '("$clr.specular" 0 0)) - (color-emissive '("$clr.emissive" 0 0)) - (color-transparent '("$clr.transparent" 0 0)) - (color-reflective '("$clr.reflective" 0 0)) - (global-background-image '("?bg.global" 0 0))) - - -(define-assimp-function (aiGetMaterialColor '* '* unsigned-int unsigned-int '*) -> int) -(define-assimp-function (aiGetMaterialFloatArray '* '* unsigned-int unsigned-int '* '*) -> int) -(define-assimp-function (aiGetMaterialIntegerArray '* '* unsigned-int unsigned-int '* '*) -> int) diff --git a/src/low-level/matrix.scm b/src/low-level/matrix.scm deleted file mode 100644 index 416b4d0..0000000 --- a/src/low-level/matrix.scm +++ /dev/null @@ -1,53 +0,0 @@ -;;; guile-assimp, foreign interface to libassimp -;;; Copyright (C) 2014 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program 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 General Public License -;;; along with this program. If not, see . - - -(define-module (assimp low-level matrix) - #:use-module (assimp low-level) - #:use-module (system foreign)) - - -(define-struct-parser parse-aiMatrix3x3 - (a1 float) - (a2 float) - (a3 float) - (b1 float) - (b2 float) - (b3 float) - (c1 float) - (c2 float) - (c3 float)) - -(define-struct-parser parse-aiMatrix4x4 - (a1 float) - (a2 float) - (a3 float) - (a4 float) - (b1 float) - (b2 float) - (b3 float) - (b4 float) - (c1 float) - (c2 float) - (c3 float) - (c4 float) - (d1 float) - (d2 float) - (d3 float) - (d4 float)) - -(export parse-aiMatrix3x3 - parse-aiMatrix4x4) diff --git a/src/low-level/mesh.scm b/src/low-level/mesh.scm deleted file mode 100644 index 50d0bb8..0000000 --- a/src/low-level/mesh.scm +++ /dev/null @@ -1,69 +0,0 @@ -;;; guile-assimp, foreign interface to libassimp -;;; Copyright (C) 2014 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program 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 General Public License -;;; along with this program. If not, see . - - -(define-module (assimp low-level mesh) - #:use-module (assimp low-level) - #:use-module (assimp low-level types) - #:use-module (system foreign)) - - -(define-struct-parser parse-aiFace - (mNumIndices unsigned-int) - (mIndices '*)) - -(export parse-aiFace) - - -(define-struct-parser parser-aiVertexWeight - (mVertexId unsigned-int) - (mWeight float)) - -(export parse-aiVertexWeight) - - -(define-struct-parser parse-aiBone - (mName aiString-type) - (mNumWeights unsigned-int) - (mWeights '*) - (mOffsetMatrix aiMatrix4x4-type)) - -(export parse-aiBone) - - -(define AI_MAX_NUMBER_OF_COLOR_SETS #x8) -(define AI_MAX_NUMBER_OF_TEXTURECOORDS #x8) - -(define-struct-parser parse-aiMesh - (mPrimitiveTypes unsigned-int) - (mNumVertices unsigned-int) - (mNumFaces unsigned-int) - (mVertices '*) - (mNormals '*) - (mTangents '*) - (mBitangents '*) - (mColors (make-list AI_MAX_NUMBER_OF_COLOR_SETS '*)) - (mTextureCoords (make-list AI_MAX_NUMBER_OF_TEXTURECOORDS '*)) - (mNumUVComponents (make-list AI_MAX_NUMBER_OF_TEXTURECOORDS unsigned-int)) - (mFaces '*) - (mNumBones unsigned-int) - (mBones '*) - (mMaterialIndex unsigned-int) - (mName aiString-type) - (mNumAnimMeshes unsigned-int) - (mAnimMeshes '*)) - -(export parse-aiMesh) diff --git a/src/low-level/postprocess.scm b/src/low-level/postprocess.scm deleted file mode 100644 index 20ca550..0000000 --- a/src/low-level/postprocess.scm +++ /dev/null @@ -1,92 +0,0 @@ -;;; guile-assimp, foreign interface to libassimp -;;; Copyright (C) 2014 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program 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 General Public License -;;; along with this program. If not, see . - - -(define-module (assimp low-level postprocess) - #:use-module (assimp low-level) - #:export (ai-process-steps - ai-process-convert-to-left-handed - ai-process-preset-target-realtime-fast - ai-process-preset-target-realtime-quality - ai-process-preset-target-realtime-max-quality)) - - -(define-bitfield - ai-process-steps - (calc-tangent-space #x1) - (join-identical-vertices #x2) - (make-left-handed #x4) - (triangulate #x8) - (remove-component #x10) - (gen-normals #x20) - (gen-smooth-normals #x40) - (split-large-meshes #x80) - (pretransform-vertices #x100) - (limit-bone-weights #x200) - (validate-data-structure #x400) - (improve-cache-locality #x800) - (remove-redundant-materials #x1000) - (fix-infacing-normals #x2000) - (sort-by-ptype #x8000) - (find-degenerates #x10000) - (find-invalid-data #x20000) - (gen-UV-coords #x40000) - (transform-UV-coords #x80000) - (find-instances #x100000) - (optimize-meshes #x200000) - (optimize-graph #x400000) - (flip-UVs #x800000) - (flip-winding-order #x1000000) - (split-by-bone-count #x2000000) - (debone #x4000000)) - -(define ai-process-convert-to-left-handed - (ai-process-steps - make-left-handed - flip-UVs - flip-winding-order)) - -(define ai-process-preset-target-realtime-fast - (ai-process-steps - calc-tangent-space - gen-normals - join-identical-vertices - triangulate - gen-UV-coords - sort-by-ptype)) - -(define ai-process-preset-target-realtime-quality - (ai-process-steps - calc-tangent-space - gen-smooth-normals - join-identical-vertices - improve-cache-locality - limit-bone-weights - remove-redundant-materials - split-large-meshes - triangulate - gen-UV-coords - sort-by-ptype - find-degenerates - find-invalid-data)) - -(define ai-process-preset-target-realtime-max-quality - (+ ai-process-preset-target-realtime-quality - (ai-process-steps - find-instances - validate-data-structure - optimize-meshes - debone))) diff --git a/src/low-level/scene.scm b/src/low-level/scene.scm deleted file mode 100644 index 651ea3a..0000000 --- a/src/low-level/scene.scm +++ /dev/null @@ -1,53 +0,0 @@ -;;; guile-assimp, foreign interface to libassimp -;;; Copyright (C) 2014 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program 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 General Public License -;;; along with this program. If not, see . - - -(define-module (assimp low-level scene) - #:use-module (assimp low-level) - #:use-module (assimp low-level types) - #:use-module (system foreign)) - - -(define-struct-parser parse-aiNode - (mName aiString-type) - (mTransformation aiMatrix4x4-type) - (mParent '*) - (mNumChildren unsigned-int) - (mChildren '*) - (mNumMeshes unsigned-int) - (mMeshes '*)) - -(export parse-aiNode) - - -(define-struct-parser parse-aiScene - (mFlags unsigned-int) - (mRootNode '*) - (mNumMeshes unsigned-int) - (mMeshes '*) - (mNumMaterials unsigned-int) - (mMaterials '*) - (mNumAnimations unsigned-int) - (mAnimations '*) - (mNumTextures unsigned-int) - (mTextures '*) - (mNumLights unsigned-int) - (mLights '*) - (mNumCameras unsigned-int) - (mCameras '*) - (mPrivate '*)) - -(export parse-aiScene) diff --git a/src/low-level/types.scm b/src/low-level/types.scm deleted file mode 100644 index 20e2281..0000000 --- a/src/low-level/types.scm +++ /dev/null @@ -1,38 +0,0 @@ -;;; guile-assimp, foreign interface to libassimp -;;; Copyright (C) 2014 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program 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 General Public License -;;; along with this program. If not, see . - - -(define-module (assimp low-level types) - #:use-module (assimp low-level) - #:use-module (system foreign) - #:export (aiString-type - aiMatrix4x4-type - ai-default-log-stream)) - - -(define aiString-type - (list size_t (make-list 1024 int8))) - -(define aiMatrix4x4-type - (make-list 16 float)) - -(define-enumeration - ai-default-log-stream - (file #x1) - (stdout #x2) - (stderr #x4) - (debugger #x8) - (ai-dls-enforce-enum-size #x7fffffff)) diff --git a/src/low-level/vector.scm b/src/low-level/vector.scm deleted file mode 100644 index 49b9916..0000000 --- a/src/low-level/vector.scm +++ /dev/null @@ -1,33 +0,0 @@ -;;; guile-assimp, foreign interface to libassimp -;;; Copyright (C) 2014 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program 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 General Public License -;;; along with this program. If not, see . - - -(define-module (assimp low-level vector) - #:use-module (assimp low-level) - #:use-module (system foreign)) - - -(define-struct-parser parse-aiVector2D - (x float) - (y float)) - -(define-struct-parser parse-aiVector3D - (x float) - (y float) - (z float)) - -(export parse-aiVector2D - parse-aiVector3D)