;;
;; Bindings for the Gnu Triangulated Surface Library
;;
;; Based on the Haskell and Python GTS bindings.
;;
;; Copyright 2011 Ivan Raikov and the Okinawa Institute of Science and Technology.
;;
;; 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.
;;
;; A full copy of the GPL license can be found at
;; .
#>
#define USE_SURFACE_BTREE
#include
#include
<#
(define-foreign-type FILE "FILE")
;; (compose list->string vector->list)
;; (compose list->vector string->list) )
(define-foreign-type GtsObjectClass "GtsObjectClass")
(define-foreign-type GtsObject "GtsObject")
(define-foreign-type GtsMatrix "GtsMatrix")
;; Type for an (r,g,b) triple in GTS (floating point)
(define-foreign-type GtsColor "GtsColor")
;; GTS formatted data file
(define-foreign-type GtsFile "GtsFile")
;; A GTS formatted data file variable
(define-foreign-type GtsFileVariable "GtsFileVariable")
(define-foreign-type GtsObjectClassInfo "GtsObjectClassInfo")
(define-foreign-type GtsObjectClass "GtsObjectClass")
(define-foreign-type GtsObject "GtsObject")
(define-foreign-type GtsPointClass "GtsPointClass")
(define-foreign-type GtsPoint "GtsPoint")
(define-foreign-type GtsRange "GtsRange")
(define-foreign-type GtsSegment "GtsSegment")
(define-foreign-type GtsTriangleClass "GtsTriangleClass")
(define-foreign-type GtsTriangle "GtsTriangle")
(define-foreign-type GtsVertex "GtsVertex")
(define-foreign-type GtsVertexClass "GtsVertexClass")
(define-foreign-type GtsVertexNormal "GtsVertexNormal")
(define-foreign-type GtsColorVertex "GtsColorVertex")
(define-foreign-type GtsSurface "GtsSurface")
(define-foreign-type GtsSurfaceClass "GtsSurfaceClass")
(define-foreign-type GtsEdgeClass "GtsEdgeClass")
(define-foreign-type GtsEdge "GtsEdge")
(define-foreign-type GtsFaceClass "GtsFaceClass")
(define-foreign-type GtsFace "GtsFace")
(define-foreign-type GtsSurfaceStats "GtsSurfaceStats")
(define-foreign-type GtsSurfaceQualityStats "GtsSurfaceQualityStats")
(define-foreign-type GtsSurfaceInterClass "GtsSurfaceInterClass")
(define-foreign-type GtsSurfaceInter "GtsSurfaceInter")
(define-foreign-type GtsSurfaceTraverse "GtsSurfaceTraverse")
(define-foreign-type GtsConstraintClass "GtsConstraintClass")
(define-foreign-type GtsConstraint "GtsConstraint")
(define-foreign-type GtsBBoxClass "GtsBBoxClass")
(define-foreign-type GtsBBox "GtsBBox")
(define-foreign-type GtsBBoxClass "GtsBBoxClass")
;; callback types
(define-foreign-type GtsFunc "GtsFunc")
(define-foreign-type GtsEncroachFunc "GtsEncroachFunc")
(define-foreign-type GtsKeyFunc "GtsKeyFunc")
(define-foreign-type GtsRefineFunc "GtsRefineFunc")
(define-foreign-type GtsStopFunc "GtsStopFunc")
(define check-version
(foreign-lambda bool "GTS_CHECK_VERSION" unsigned-int unsigned-int unsigned-int))
(define class-name-length (foreign-value "GTS_CLASS_NAME_LENGTH" unsigned-int))
(define-foreign-variable allow-floating-vertices
bool "gts_allow_floating_vertices" )
;; Create a new GTS Matrix 4x4 object and return the pointer to it.
(define matrix-new
(foreign-lambda (nonnull-c-pointer GtsMatrix) "gts_matrix_new"
double double double double double double double double double
double double double double double double double))
;; Set the fields of an existing GTS Matrix object
(define matrix-assign
(foreign-lambda void "gts_matrix_assign"
(nonnull-c-pointer GtsMatrix)
double double double double double double double double
double double double double double double double double))
;; Destroy a GTS matrix and free the associated memory
(define matrix-destroy
(foreign-lambda void "gts_matrix_destroy" (nonnull-c-pointer GtsMatrix)))
;; Set a GTS matrix to the Zero matrix (if the matrix is NULL a new one is allocated)
(define matrix-zero
(foreign-lambda (nonnull-c-pointer GtsMatrix) "gts_matrix_zero" (c-pointer GtsMatrix)))
;; Set a GTS matrix to the Identity matrix (if the matrix is NULL a new one is allocated)
(define matrix-identity
(foreign-lambda (nonnull-c-pointer GtsMatrix) "gts_matrix_identity" (c-pointer GtsMatrix)))
;; Transpose a GTS Matrix and return the newly allocated matrix
(define matrix-transpose
(foreign-lambda (nonnull-c-pointer GtsMatrix) "gts_matrix_transpose" (nonnull-c-pointer GtsMatrix)))
;; Invert a GTS Matrix and return the newly allocated matrix or NULL if the matrix can't be inverted
(define matrix-inverse
(foreign-lambda (c-pointer GtsMatrix) "gts_matrix_inverse" (nonnull-c-pointer GtsMatrix)))
;; Calculate the product of two matrices and return the newly allocated matrix
(define matrix-product
(foreign-lambda (nonnull-c-pointer GtsMatrix) "gts_matrix_product" (nonnull-c-pointer GtsMatrix) (nonnull-c-pointer GtsMatrix)))
;; Scale a GTS Matrix in place
(define matrix-scale
(foreign-lambda (nonnull-c-pointer GtsMatrix) "gts_matrix_scale" (c-pointer GtsMatrix) f64vector))
;; Translate the GTS Matrix by the GTS Vector (if the Matrix is NULL a new one is allocated and translated)
(define matrix-translate
(foreign-lambda (nonnull-c-pointer GtsMatrix) "gts_matrix_translate" (c-pointer GtsMatrix) f64vector))
;; Rotate the GTS Matrix around the vector by the given angle (if the Matrix is NULL a new one is allocated and translated)
(define matrix-rotate
(foreign-lambda (nonnull-c-pointer GtsMatrix) "gts_matrix_rotate" (c-pointer GtsMatrix) f64vector double))
;; Open a file
(define fopen
(foreign-lambda (c-pointer FILE) "fopen" c-string c-string))
;; Close a file
(define fclose
(foreign-lambda int "fclose" (nonnull-c-pointer FILE)))
;; Create a new GTS file handle from a file
(define file-new
(foreign-lambda (nonnull-c-pointer GtsFile) "gts_file_new" (nonnull-c-pointer FILE)))
;; Create a new GTS file handle from a C String.
(define file-new-from-string
(foreign-lambda (nonnull-c-pointer GtsFile) "gts_file_new_from_string" c-string))
;; Destroy a GTS file handle and free the memory
(define file-destroy
(foreign-lambda void "gts_file_destroy" (nonnull-c-pointer GtsFile)))
(define object-class
(foreign-lambda nonnull-c-pointer "gts_object_class" ))
(define object-class-new
(foreign-lambda nonnull-c-pointer "gts_object_class_new"
(nonnull-c-pointer GtsObjectClass)
(nonnull-c-pointer GtsObjectClassInfo) ))
(define object-check-cast
(foreign-lambda nonnull-c-pointer "gts_object_check_cast"
nonnull-c-pointer nonnull-c-pointer ))
(define object-class-check-cast
(foreign-lambda nonnull-c-pointer "gts_object_class_check_cast"
nonnull-c-pointer nonnull-c-pointer ))
(define object-class-from-name
(foreign-lambda (nonnull-c-pointer GtsObjectClass) "gts_object_class_from_name" c-string ))
;; Create a triangle which is guaranteed to enclose all the points in the list
(define triangle-enclosing
(foreign-lambda (nonnull-c-pointer GtsTriangle) "gts_triangle_enclosing"
(nonnull-c-pointer GtsTriangleClass)
(nonnull-c-pointer g_slist)
double ))
;; Get the class descriptor for the GTS Triangle class
(define default-triangle-class
(foreign-lambda (nonnull-c-pointer GtsTriangleClass) "gts_triangle_class" ))
;; Create a new triangle from 3 edges
(define gts_triangle_new
(foreign-lambda (nonnull-c-pointer GtsTriangle) "gts_triangle_new"
(nonnull-c-pointer GtsTriangleClass)
(nonnull-c-pointer GtsEdge)
(nonnull-c-pointer GtsEdge)
(nonnull-c-pointer GtsEdge) ))
(define (triangle-new e1 e2 e3 #!key (triangle-class (default-triangle-class)))
(gts_triangle_new triangle-class e1 e2 e3))
;; Discard the existing edges of the triangle and replace with the new ones
(define triangle-set
(foreign-lambda void "gts_triangle_set"
(nonnull-c-pointer GtsTriangle)
(nonnull-c-pointer GtsEdge)
(nonnull-c-pointer GtsEdge)
(nonnull-c-pointer GtsEdge) ))
;; Get the area of this triangle
(define triangle-area
(foreign-lambda double "gts_triangle_area" (nonnull-c-pointer GtsTriangle)))
;; Get the perimeter of this triangle
(define triangle-perimeter
(foreign-lambda double "gts_triangle_perimeter" (nonnull-c-pointer GtsTriangle)))
;; Get a measure of the quality of this triangle (how close to equilateral it is?)
(define triangle-quality
(foreign-lambda double "gts_triangle_quality" (nonnull-c-pointer GtsTriangle)))
;; Get the normal to the plane of this triangle
(define gts_triangle_normal
(foreign-lambda void "gts_triangle_normal" (nonnull-c-pointer GtsTriangle) f64vector f64vector f64vector))
(define (triangle-normal t)
(let ((x (make-f64vector 1))
(y (make-f64vector 1))
(z (make-f64vector 1)))
(gts_triangle_normal t x y z)
(f64vector (f64vector-ref x 0) (f64vector-ref y 0) (f64vector-ref z 0))))
;; Change the orientation of triangle t, turning it inside out
(define triangle-revert
(foreign-lambda void "gts_triangle_revert" (nonnull-c-pointer GtsTriangle)))
(define triangle-orientation
(foreign-lambda double "gts_triangle_orientation" (nonnull-c-pointer GtsTriangle)))
(define triangle-neighbors
(foreign-lambda (nonnull-c-pointer g_slist) "gts_triangle_neighbors" (nonnull-c-pointer GtsTriangle)))
(define gts_triangle_vertices_edges
(foreign-lambda void "gts_triangle_vertices_edges"
(nonnull-c-pointer GtsTriangle)
(c-pointer GtsEdge)
(nonnull-c-pointer (c-pointer GtsVertex))
(nonnull-c-pointer (c-pointer GtsVertex))
(nonnull-c-pointer (c-pointer GtsVertex))
(nonnull-c-pointer (c-pointer GtsEdge))
(nonnull-c-pointer (c-pointer GtsEdge))
(nonnull-c-pointer (c-pointer GtsEdge))
))
(define (triangle-vertices-edges t e)
(let-location ((v1 (c-pointer GtsVertex))
(v2 (c-pointer GtsVertex))
(v3 (c-pointer GtsVertex))
(e1 (c-pointer GtsEdge))
(e2 (c-pointer GtsEdge))
(e3 (c-pointer GtsEdge)))
(gts_triangle_vertices_edges t e
(location v1) (location v2) (location v3)
(location e1) (location e2) (location e3))
(list (vector v1 v2 v3)
(vector e1 e2 e3))))
(define gts_triangle_vertices
(foreign-lambda void "gts_triangle_vertices"
(nonnull-c-pointer GtsTriangle)
(nonnull-c-pointer (c-pointer GtsVertex))
(nonnull-c-pointer (c-pointer GtsVertex))
(nonnull-c-pointer (c-pointer GtsVertex))
))
(define (triangle-vertices t e)
(let-location ((v1 (c-pointer GtsVertex))
(v2 (c-pointer GtsVertex))
(v3 (c-pointer GtsVertex)))
(gts_triangle_vertices t e
(location v1) (location v2) (location v3))
(vector v1 v2 v3)))
(define triangle-vertex-opposite
(foreign-lambda (nonnull-c-pointer GtsVertex) "gts_triangle_vertex_opposite"
(nonnull-c-pointer GtsTriangle)
(nonnull-c-pointer GtsEdge)))
(define triangle-edge-opposite
(foreign-lambda (nonnull-c-pointer GtsEdge) "gts_triangle_edge_opposite"
(nonnull-c-pointer GtsTriangle)
(nonnull-c-pointer GtsVertex)))
(define triangle-is-ok
(foreign-lambda bool "gts_triangle_is_ok"
(nonnull-c-pointer GtsTriangle)))
(define triangle-circumcircle-center
(foreign-lambda (nonnull-c-pointer GtsPoint) "gts_triangle_circumcircle_center"
(nonnull-c-pointer GtsTriangle)
(nonnull-c-pointer GtsPointClass)))
(define triangle-interpolate-height
(foreign-lambda void "gts_triangle_interpolate_height"
(nonnull-c-pointer GtsTriangle)
(nonnull-c-pointer GtsPoint)))
(define triangles-from-edges
(foreign-lambda (nonnull-c-pointer g_slist) "gts_triangles_from_edges"
(nonnull-c-pointer g_slist)))
;; Clear a range
(define range-init
(foreign-lambda void "gts_range_init" (nonnull-c-pointer GtsRange)))
(define range-reset
(foreign-lambda void "gts_range_reset" (nonnull-c-pointer GtsRange)))
(define range-add-value
(foreign-lambda void "gts_range_add_value" (nonnull-c-pointer GtsRange) double))
(define range-add-update
(foreign-lambda void "gts_range_update" (nonnull-c-pointer GtsRange)))
;; Get class descriptor for the GTS point class
(define default-point-class
(foreign-lambda (nonnull-c-pointer GtsPointClass) "gts_point_class" ))
;; Create a new GTS point in 3d space
(define gts_point_new
(foreign-lambda (nonnull-c-pointer GtsPoint) "gts_point_new"
(nonnull-c-pointer GtsPointClass)
double double double))
(define (point-new x y z #!key (point-class (default-point-class)))
(gts_point_new point-class x y z))
;; Set the value of a GTS point in 3d space
(define point-set
(foreign-lambda void "gts_point_set"
(nonnull-c-pointer GtsPoint)
double double double))
;; True iff the point is within or on the boundary of the box defined by the two other points
(define point-is-in-rectangle
(foreign-lambda bool "gts_point_is_in_rectangle"
(nonnull-c-pointer GtsPoint)
(nonnull-c-pointer GtsPoint)
(nonnull-c-pointer GtsPoint) ))
;; Transform the coordinates of p according to m.
(define point-transform
(foreign-lambda void "gts_point_transform"
(nonnull-c-pointer GtsPoint)
(nonnull-c-pointer GtsMatrix)))
;; Get class descriptor for the GTS vertex class
(define default-vertex-class
(foreign-lambda (nonnull-c-pointer GtsVertexClass) "gts_vertex_class" ))
;; Create a new GTS vertex in 3d space
(define gts_vertex_new
(foreign-lambda (nonnull-c-pointer GtsVertex) "gts_vertex_new"
(nonnull-c-pointer GtsVertexClass)
double double double))
(define (vertex-new x y z #!key (vertex-class (default-vertex-class)))
(gts_vertex_new vertex-class x y z))
;; True if this vertex is not part of a GTS segment
(define vertex-is-unattached
(foreign-lambda bool "gts_vertex_is_unattached"
(nonnull-c-pointer GtsVertex) ))
;; Return the number of connected triangles sharing the vertex, if
;; second parameter is true then sever the connection
(define vertex-is-contact
(foreign-lambda unsigned-int "gts_vertex_is_contact"
(nonnull-c-pointer GtsVertex)
bool))
;; Null unless two vertices are the endpoints of the same segment, in
;; which case return the segment
(define vertices-are-connected
(foreign-lambda (c-pointer GtsSegment) "gts_vertices_are_connected"
(nonnull-c-pointer GtsVertex)
(nonnull-c-pointer GtsVertex) ))
;; Replace a vertex with another vertex and update all objects using it
(define vertex-replace
(foreign-lambda void "gts_vertex_replace"
(nonnull-c-pointer GtsVertex)
(nonnull-c-pointer GtsVertex) ))
;; Adds to list all the GtsVertex connected to v by a GtsSegment and
;; not already in list. If surface is not NULL only the vertices
;; connected to v by an edge belonging to surface are considered.
(define vertex-neighbors
(foreign-lambda (nonnull-c-pointer g_slist) "gts_vertex_neighbors"
(nonnull-c-pointer GtsVertex)
(nonnull-c-pointer g_slist)
(c-pointer GtsSurface) ))
;; Adds all the GtsTriangle which share v as a vertex and do not
;; already belong to list.
(define vertex-triangles
(foreign-lambda (nonnull-c-pointer g_slist) "gts_vertex_triangles"
(nonnull-c-pointer GtsVertex)
(nonnull-c-pointer g_slist) ))
;; Adds all the GtsFace belonging to surface (if not NULL) which share
;; v as a vertex and do not already belong to list.
(define vertex-faces
(foreign-lambda (nonnull-c-pointer g_slist) "gts_vertex_faces"
(nonnull-c-pointer GtsVertex)
(nonnull-c-pointer GtsSurface)
(nonnull-c-pointer g_slist) ))
;; A list of GtsEdge describing in counterclockwise order the boundary
;; of the fan of summit v, the faces of the fan belonging to surface
(define vertex-fan-oriented
(foreign-lambda (nonnull-c-pointer g_slist) "gts_vertex_fan_oriented"
(nonnull-c-pointer GtsVertex)
(nonnull-c-pointer GtsSurface) ))
;; TRUE if v is strictly contained in the diametral circle of e, FALSE otherwise
(define vertex-enroaches-edge
(foreign-lambda bool "gts_vertex_encroaches_edge"
(nonnull-c-pointer GtsVertex)
(nonnull-c-pointer GtsEdge) ))
;; For each vertex v in vertices look if there are any vertex of
;; vertices contained in a box centered on v of size 2*epsilon. If
;; there are and if check is not NULL and returns TRUE, replace them
;; with v (using gts_vertex_replace()), destroy them and remove them
;; from list. This is done efficiently using Kd-Trees.
(define vertices-merge
(foreign-lambda (nonnull-c-pointer g_list) "gts_vertices_merge"
(nonnull-c-pointer g_list)
double
c-pointer))
(define default-vertex-class
(foreign-lambda (nonnull-c-pointer GtsVertexClass) "gts_vertex_class" ))
(define default-face-class
(foreign-lambda (nonnull-c-pointer GtsFaceClass) "gts_face_class" ))
(define default-edge-class
(foreign-lambda (nonnull-c-pointer GtsEdgeClass) "gts_edge_class" ))
(define default-surface-class
(foreign-lambda (nonnull-c-pointer GtsSurfaceClass) "gts_surface_class" ))
(define default-vertex-normal-class
(foreign-lambda (nonnull-c-pointer GtsVertexClass) "gts_vertex_normal_class" ))
(define default-color-vertex-class
(foreign-lambda (nonnull-c-pointer GtsVertexClass) "gts_color_vertex_class" ))
;; Create a new empty surface which uses the specified types of sub-object
(define gts_surface_new
(foreign-lambda (nonnull-c-pointer GtsSurface) "gts_surface_new"
(nonnull-c-pointer GtsSurfaceClass)
(nonnull-c-pointer GtsFaceClass)
(nonnull-c-pointer GtsEdgeClass)
(nonnull-c-pointer GtsVertexClass) ))
(define (surface-new #!key
(surface-class (default-surface-class))
(face-class (default-face-class))
(edge-class (default-edge-class))
(vertex-class (default-vertex-class)))
(gts_surface_new surface-class face-class edge-class vertex-class))
;; Add a face to a surface
(define surface-add-face
(foreign-lambda void "gts_surface_add_face"
(nonnull-c-pointer GtsSurface)
(nonnull-c-pointer GtsFace) ))
;; Read a surface from a GTS formatted file
(define surface-read
(foreign-lambda unsigned-int "gts_surface_read"
(nonnull-c-pointer GtsSurface)
(nonnull-c-pointer GtsFile) ))
;; Remove a face from a surface
(define surface-remove-face
(foreign-lambda void "gts_surface_remove_face"
(nonnull-c-pointer GtsSurface)
(nonnull-c-pointer GtsFace) ))
;; Get the surface area of all triangles in the surface
(define surface-area
(foreign-lambda double "gts_surface_area"
(nonnull-c-pointer GtsSurface) ))
;; Get some statistics on the surface
;; FIXME: instead of void this should return GtsSurfaceStats
(define gts_surface_stats
(foreign-lambda void "gts_surface_stats"
(nonnull-c-pointer GtsSurface)
(nonnull-c-pointer GtsSurfaceStats)))
;; Get some statistics on the quality of the triangles making up the surface
;; FIXME: instead of void this should return GtsSurfaceQualityStats
(define gts_surface_quality_stats
(foreign-lambda void "gts_surface_quality_stats"
(nonnull-c-pointer GtsSurface)
(nonnull-c-pointer GtsSurfaceQualityStats)))
;; Invoke a function for each vertex in the surface
(define surface-foreach-vertex
(foreign-lambda void "gts_surface_foreach_vertex"
(nonnull-c-pointer GtsSurface)
nonnull-c-pointer ;; GtsFunc
scheme-object))
;; Invoke a function for each edge in the surface
(define surface-foreach-edge
(foreign-lambda void "gts_surface_foreach_edge"
(nonnull-c-pointer GtsSurface)
nonnull-c-pointer ;; GtsFunc
scheme-object))
;; Invoke a function for each face in the surface
(define surface-foreach-face
(foreign-lambda void "gts_surface_foreach_face"
(nonnull-c-pointer GtsSurface)
nonnull-c-pointer ;; GtsFunc
scheme-object))
;; Invoke a function for each face in the surface and remove the face afterwards
(define gts-surface-foreach-face-remove
(foreign-lambda void "gts_surface_foreach_face_remove"
(nonnull-c-pointer GtsSurface)
nonnull-c-pointer ;; GtsFunc
scheme-object))
;; Generate a surface which is a tesselated model of a sphere
(define surface-generate-sphere
(foreign-lambda (nonnull-c-pointer GtsSurface) "gts_surface_generate_sphere"
(nonnull-c-pointer GtsSurface)
unsigned-int))
;; Add a copy of all the faces, edges and vertices of s2 to s1.
(define surface-copy
(foreign-lambda (nonnull-c-pointer GtsSurface) "gts_surface_copy"
(nonnull-c-pointer GtsSurface)
(nonnull-c-pointer GtsSurface)))
;; Adds all the faces of with which do not already belong to s to s.
(define surface-merge
(foreign-lambda void "gts_surface_merge"
(nonnull-c-pointer GtsSurface)
(nonnull-c-pointer GtsSurface)))
;; True iff the surface describes a manifold
(define surface-is-manifold
(foreign-lambda bool "gts_surface_is_manifold"
(nonnull-c-pointer GtsSurface)))
;; True iff the surface is closed
(define surface-is-closed
(foreign-lambda bool "gts_surface_is_closed"
(nonnull-c-pointer GtsSurface)))
;; True iff all the faces of the surface have a compatible orientation
(define surface-is-orientable
(foreign-lambda bool "gts_surface_is_orientable"
(nonnull-c-pointer GtsSurface)))
;; Return the volume of the domain bounded by the surface, only valid
;; if the surface is closed and orientable
(define surface-volume
(foreign-lambda double "gts_surface_volume"
(nonnull-c-pointer GtsSurface)))
;; Return the center of mass of the domain bounded by the surface s,
;; only valid if the surface is closed and orientable
(define gts_surface_center_of_mass
(foreign-lambda double "gts_surface_center_of_mass"
(nonnull-c-pointer GtsSurface)
(nonnull-c-pointer double)))
(define (surface-center-of-mass s)
(let ((d (make-f64vector 3)))
(list (gts_surface_center_of_mass s d) d)))
;; Return the center of area of the surface (all faces should be co-planar)
(define gts_surface_center_of_area
(foreign-lambda double "gts_surface_center_of_area"
(nonnull-c-pointer GtsSurface)
(nonnull-c-pointer double)))
(define (surface-center-of-area s)
(let ((d (make-f64vector 3)))
(list (gts_surface_center_of_area s d) d)))
(define surface-vertex-number
(foreign-lambda unsigned-int "gts_surface_vertex_number"
(nonnull-c-pointer GtsSurface)))
(define surface-edge-number
(foreign-lambda unsigned-int "gts_surface_edge_number"
(nonnull-c-pointer GtsSurface)))
(define surface-face-number
(foreign-lambda unsigned-int "gts_surface_face_number"
(nonnull-c-pointer GtsSurface)))
(define surface-boundary
(foreign-lambda (nonnull-c-pointer g_slist) "gts_surface_boundary"
(nonnull-c-pointer GtsSurface)))
(define surface-split
(foreign-lambda (nonnull-c-pointer g_slist) "gts_surface_split"
(nonnull-c-pointer GtsSurface)))
(define surface-write
(foreign-lambda void "gts_surface_write"
(nonnull-c-pointer GtsSurface)
(nonnull-c-pointer FILE )))
;; Create a new GTS Face from the 3 edges
(define gts_face_new
(foreign-lambda (nonnull-c-pointer GtsFace) "gts_face_new"
(nonnull-c-pointer GtsFaceClass)
(nonnull-c-pointer GtsEdge)
(nonnull-c-pointer GtsEdge)
(nonnull-c-pointer GtsEdge)))
(define (face-new e1 e2 e3 #!key (face-class (default-face-class)))
(gts_face_new face-class e1 e2 e3))
;; Check if the face compatible with all its neighbors belonging to the surface
(define face-is-compatible
(foreign-lambda bool "gts_face_is_compatible"
(nonnull-c-pointer GtsFace)
(nonnull-c-pointer GtsSurface)))
;; Get the class for a surface intersection
(define surface-inter-class
(foreign-lambda (nonnull-c-pointer GtsSurfaceInterClass) "gts_surface_inter_class"))
;; Create a new surface intersection from the two surfaces and the precomputed face bounding box trees
(define surface-inter-new
(foreign-lambda (nonnull-c-pointer GtsSurfaceInter) "gts_surface_inter_new"
(nonnull-c-pointer GtsSurfaceInterClass)
(nonnull-c-pointer GtsSurface)
(nonnull-c-pointer GtsSurface)
(nonnull-c-pointer g_node)
(nonnull-c-pointer g_node)
bool bool))
;; True iff the edges in the intersection form a closed curve
(define gts_surface_inter_check
(foreign-lambda bool "gts_surface_inter_check"
(nonnull-c-pointer GtsSurfaceInter)
s32vector))
(define (surface-inter-check s)
(let ((closed (s32vector 0)))
(gts_surface_inter_check s closed)
(positive? (s32vector-ref closed 0) )))
;; Adds to surface the part of the surface described by si and op.
(define surface-inter-boolean
(foreign-lambda void "gts_surface_inter_boolean"
(nonnull-c-pointer GtsSurfaceInter)
(nonnull-c-pointer GtsSurface)
unsigned-int))
;; A new GtsSurface containing the faces of s which are self-intersecting or NULL if no faces of s are self-intersecting.
(define surface-is-self-intersecting
(foreign-lambda (c-pointer GtsSurface) "gts_surface_is_self_intersecting"
(nonnull-c-pointer GtsSurface)))
#>
void isosurface_function (gdouble **a, GtsCartesianGrid g, guint k, gpointer data)
{
double x, y, z, v; unsigned int i,j;
C_word f, res, sx, sy, sz; C_word *ptr;
z = g.z;
f = (C_word)data;
for (i = 0, x = g.x; i < g.nx; i++, x += g.dx)
{
for (j = 0, y = g.y; j < g.ny; j++, y += g.dy)
{
ptr = C_alloc (C_SIZEOF_FLONUM);
sx = C_flonum(&ptr, x);
C_save (sx);
ptr = C_alloc (C_SIZEOF_FLONUM);
sy = C_flonum(&ptr, y);
C_save (sy);
ptr = C_alloc (C_SIZEOF_FLONUM);
sz = C_flonum(&ptr, z);
C_save (sz);
res = C_callback (f, 3);
if (C_truep (C_i_numberp(res)) )
{
v = C_c_double(res);
a[i][j] = v;
}
}
}
}
<#
(define isosurface-cartesian
(foreign-safe-lambda* (nonnull-c-pointer GtsSurface)
(((nonnull-c-pointer GtsSurface) s)
(double iso)
(unsigned-int nx) (unsigned-int ny) (unsigned-int nz)
(double dx) (double dy) (double dz)
(double x) (double y) (double z)
(scheme-object f))
#< y, p-> z) intersects with bb, FALSE otherwise.
(define bb-tree-stabbed
(foreign-lambda (nonnull-c-pointer g_slist) "gts_bb_tree_stabbed"
(nonnull-c-pointer g_node)
(nonnull-c-pointer GtsPoint)
))
;; Destroy a GTS object and free the associated memory. This is the generic version, see the typed helper functions
(define object-destroy
(foreign-lambda void "gts_object_destroy"
(nonnull-c-pointer GtsObject)))
(define constraint-class
(foreign-lambda (nonnull-c-pointer GtsEdgeClass) "gts_constraint_class"))
(define point-locate
(foreign-lambda (nonnull-c-pointer GtsFace) "gts_point_locate"
(nonnull-c-pointer GtsPoint)
(nonnull-c-pointer GtsSurface)
(nonnull-c-pointer GtsFace)
))
;; Create a new edge from a pair of vertices
(define gts_edge_new
(foreign-lambda (nonnull-c-pointer GtsEdge) "gts_edge_new"
(nonnull-c-pointer GtsEdgeClass)
(nonnull-c-pointer GtsVertex)
(nonnull-c-pointer GtsVertex)
))
(define (edge-new v1 v2 #!key (edge-class (default-edge-class)))
(gts_edge_new edge-class v1 v2))
;; Replaces e with with. For each triangle which uses e as an edge, e
;; is replaced with with. The with-> triangles list is updated
;; appropriately and the e-> triangles list is freed and set to NULL
(define edge-replace
(foreign-lambda void "gts_edge_replace"
(nonnull-c-pointer GtsEdge)
(nonnull-c-pointer GtsEdge)
))
;; Performs an "edge swap" on the two triangles sharing e and belonging to s.
(define edge-swap
(foreign-lambda void "gts_edge_swap"
(nonnull-c-pointer GtsEdge)
(nonnull-c-pointer GtsSurface)
))
(define segment-triangle-intersection
(foreign-lambda (nonnull-c-pointer GtsPoint) "gts_segment_triangle_intersection"
(nonnull-c-pointer GtsSegment)
(nonnull-c-pointer GtsTriangle)
bool
(nonnull-c-pointer GtsPointClass)
))
;; Tests if the planar projection (x, y) of p is inside or outside the
;; circumcircle of the planar projection of t. This function is
;; geometrically robust.
(define point-in-triangle-circle
(foreign-lambda double "gts_point_in_triangle_circle"
(nonnull-c-pointer GtsPoint)
(nonnull-c-pointer GtsTriangle)
))
;; Checks for orientation of the projection of three points on the
;; (x,y) plane. The result is also an approximation of twice the
;; signed area of the triangle defined by the three points. This
;; function uses adaptive floating point arithmetic and is
;; consequently geometrically robust.
(define point-orientation
(foreign-lambda double "gts_point_orientation"
(nonnull-c-pointer GtsPoint)
(nonnull-c-pointer GtsPoint)
(nonnull-c-pointer GtsPoint)
))
;; TRUE if p is inside the surface defined by tree, FALSE otherwise.
(define point-is-inside-surface
(foreign-lambda bool "gts_point_is_inside_surface"
(nonnull-c-pointer GtsPoint)
(nonnull-c-pointer g_node)
bool
))
;; Tests if the planar projection (x, y) of p is inside or outside the
;; circle defined by the planar projection of p1, p2 and p3.
(define point-in-circle
(foreign-lambda double "gts_point_in_circle"
(nonnull-c-pointer GtsPoint)
(nonnull-c-pointer GtsPoint)
(nonnull-c-pointer GtsPoint)
(nonnull-c-pointer GtsPoint)
))
;; Checks if p4 lies above, below or on the plane passing through the
;; points p1, p2 and p3. Below is defined so that p1, p2 and p3 appear
;; in counterclockwise order when viewed from above the plane. The
;; returned value is an approximation of six times the signed volume
;; of the tetrahedron defined by the four points. This function uses
;; adaptive floating point arithmetic and is consequently
;; geometrically robust.
(define point-orientation-3d
(foreign-lambda double "gts_point_orientation_3d"
(nonnull-c-pointer GtsPoint)
(nonnull-c-pointer GtsPoint)
(nonnull-c-pointer GtsPoint)
(nonnull-c-pointer GtsPoint)
))
;; A list of triangle strips containing all the triangles of s. A
;; triangle strip is itself a list of successive triangles having one
;; edge in common.
(define surface-strip
(foreign-lambda (nonnull-c-pointer g_slist) "gts_surface_strip"
(nonnull-c-pointer GtsSurface)
))
;; Using the gts_bb_tree_surface_distance() and
;; gts_bb_tree_surface_boundary_distance() functions fills face_range
;; and boundary_range with the min, max and average Euclidean
;; (minimum) distances between the faces of s1 and the faces of s2 and
;; between the boundary edges of s1 and s2.
(define surface-distance
(foreign-lambda void "gts_surface_distance"
(nonnull-c-pointer GtsSurface)
(nonnull-c-pointer GtsSurface)
double
(nonnull-c-pointer GtsRange)
(nonnull-c-pointer GtsRange)
))
;; Get the class descriptor for the GTS BBox class
(define default-bbox-class
(foreign-lambda (nonnull-c-pointer GtsBBoxClass) "gts_bbox_class" ))
;; A new GtsBBox bounding box of surface.
(define gts_bbox_surface
(foreign-lambda (nonnull-c-pointer GtsRange) "gts_bbox_surface"
(nonnull-c-pointer GtsBBoxClass)
(nonnull-c-pointer GtsSurface)
))
(define (bbox-surface s #!key (bbox-class (default-bbox-class)))
(gts_bbox_surface bbox-class s))
(define bbox-x1
(foreign-safe-lambda* double
(((nonnull-c-pointer GtsBBox) bbox))
#<x1);
EOF
))
(define bbox-x2
(foreign-safe-lambda* double
(((nonnull-c-pointer GtsBBox) bbox))
#<x2);
EOF
))
(define bbox-y1
(foreign-safe-lambda* double
(((nonnull-c-pointer GtsBBox) bbox))
#<y1);
EOF
))
(define bbox-y2
(foreign-safe-lambda* double
(((nonnull-c-pointer GtsBBox) bbox))
#<y2);
EOF
))
(define bbox-z1
(foreign-safe-lambda* double
(((nonnull-c-pointer GtsBBox) bbox))
#<z1);
EOF
))
(define bbox-z2
(foreign-safe-lambda* double
(((nonnull-c-pointer GtsBBox) bbox))
#<z2);
EOF
))
;; TRUE if the bounding boxes bb1 and bb2 are overlapping (including
;; just touching), FALSE otherwise.
(define bboxes-are-overlapping
(foreign-lambda bool "gts_bboxes_are_overlapping"
(nonnull-c-pointer GtsBBox)
(nonnull-c-pointer GtsBBox)
))
;; Add a constraint edge to a Delaunay surface
(define delaunay_add_constraint
(foreign-lambda (nonnull-c-pointer g_slist) "gts_delaunay_add_constraint"
(nonnull-c-pointer GtsSurface)
(nonnull-c-pointer GtsConstraint)
))
;; NULL if the planar projection of surface is a Delaunay
;; triangulation (unconstrained), a GtsFace violating the Delaunay
;; property otherwise.
(define delaunay-check
(foreign-lambda (nonnull-c-pointer GtsFace) "gts_delaunay_check"
(nonnull-c-pointer GtsSurface)
))
;; Removes all the edges of the boundary of surface which are not constraints.
(define delaunay-check-remove-hull
(foreign-lambda void "gts_delaunay_check_remove_hull"
(nonnull-c-pointer GtsSurface)
))
;; Recursively split constraints of surface which are encroached by
;; vertices of surface (see Shewchuk 96 for details). The split
;; constraints are destroyed and replaced by a set of new constraints
;; of the same class. If gts_vertex_encroaches_edge() is used for
;; encroaches, the resulting surface will be Delaunay conforming. If
;; steiner_max is positive or nul, the recursive splitting procedure
;; will stop when this maximum number of Steiner points is reached. In
;; that case the resulting surface will not necessarily be Delaunay
;; conforming.
(define delaunay-conform
(foreign-lambda unsigned-int "gts_delaunay_conform"
(nonnull-c-pointer GtsSurface)
int
nonnull-c-pointer ;; GtsEncroachFunc
nonnull-c-pointer
))
;; An implementation of the refinement algorithm described in Ruppert
;; (1995) and Shewchuk (1996).
(define delaunay-refine
(foreign-lambda unsigned-int "gts_delaunay_refine"
(nonnull-c-pointer GtsSurface)
int
nonnull-c-pointer ;; GtsEncroachFunc
nonnull-c-pointer
nonnull-c-pointer ;; GtsKeyFunc
nonnull-c-pointer
))
;; Add one vertex to a Delaunay triangulation preserving the Delaunay
;; property
(define delaunay-add-vertex
(foreign-lambda (nonnull-c-pointer GtsVertex) "gts_delaunay_add_vertex"
(nonnull-c-pointer GtsSurface)
(nonnull-c-pointer GtsVertex)
(nonnull-c-pointer GtsFace)
))
;; Add one vertex to a face of a Delaunay triangulation preserving the
;; Delaunay property
(define delaunay-add-vertex-to-face
(foreign-lambda (nonnull-c-pointer GtsVertex) "gts_delaunay_add_vertex_to_face"
(nonnull-c-pointer GtsSurface)
(nonnull-c-pointer GtsVertex)
(nonnull-c-pointer GtsFace)
))
;; Removes v from the Delaunay triangulation defined by surface and
;; restores the Delaunay property. Vertex v must not be used by any
;; constrained edge otherwise the triangulation is not guaranteed to
;; be Delaunay.
(define delaunay-remove-vertex
(foreign-lambda void "gts_delaunay_remove_vertex"
(nonnull-c-pointer GtsSurface)
(nonnull-c-pointer GtsVertex)
))
;; Typed helper functions
(define surface-destroy
(foreign-lambda void "surface_destroy"
(nonnull-c-pointer GtsSurface)
))
(define triangle-destroy
(foreign-lambda void "triangle_destroy"
(nonnull-c-pointer GtsTriangle)
))
(define vertex-destroy
(foreign-lambda void "vertex_destroy"
(nonnull-c-pointer GtsVertex)
))
(define surface-traverse-new
(foreign-lambda (nonnull-c-pointer GtsSurfaceTraverse) "gts_surface_traverse_new"
(nonnull-c-pointer GtsSurface)
(nonnull-c-pointer GtsFace)
))
(define gts_surface_traverse_next
(foreign-lambda (c-pointer GtsFace) "gts_surface_traverse_next"
(nonnull-c-pointer GtsSurfaceTraverse)
(nonnull-c-pointer unsigned-int)
))
(define (surface-traverse-next t level)
(let ((level (f64vector level)))
(gts_surface_traverse_next t level)
(f64vector-ref level 0)))
(define surface-traverse-destroy
(foreign-lambda void "gts_surface_traverse_destroy"
(nonnull-c-pointer GtsSurfaceTraverse)
))
(define surface-tessellate
(foreign-lambda void "gts_surface_tessellate"
(nonnull-c-pointer GtsSurface)
nonnull-c-pointer ;; GtsRefineFunc
nonnull-c-pointer
))
(define surface-refine
(foreign-lambda void "gts_surface_refine"
(nonnull-c-pointer GtsSurface)
nonnull-c-pointer ;; GtsKeyFunc
nonnull-c-pointer
nonnull-c-pointer ;; GtsRefineFunc
nonnull-c-pointer
nonnull-c-pointer ;; GtsStopFunc
nonnull-c-pointer
))
(define edge-face-number
(foreign-lambda unsigned-int "gts_edge_face_number"
(nonnull-c-pointer GtsEdge)
(nonnull-c-pointer GtsSurface)))
(define edge-face-manifold-faces
(foreign-lambda bool "gts_edge_manifold_faces"
(nonnull-c-pointer GtsEdge)
(nonnull-c-pointer GtsSurface)
(nonnull-c-pointer (nonnull-c-pointer GtsFace))
(nonnull-c-pointer (nonnull-c-pointer GtsFace))))
(define edge-belongs-to-tetrahedron
(foreign-lambda bool "gts_edge_belongs_to_tetrahedron"
(nonnull-c-pointer GtsEdge)))
(define edges-from-vertices
(foreign-lambda (nonnull-c-pointer g_slist) "gts_edges_from_vertices"
(nonnull-c-pointer g_slist)
(nonnull-c-pointer GtsSurface)))
(define edges-merge
(foreign-lambda (nonnull-c-pointer g_list) "gts_edges_merge"
(nonnull-c-pointer g_list) ))
(define edge-is-contact
(foreign-lambda unsigned-int "gts_edge_is_contact"
(nonnull-c-pointer GtsEdge) ))
(define edge-is-boundary
(foreign-lambda (nonnull-c-pointer GtsFace) "gts_edge_is_boundary"
(nonnull-c-pointer GtsEdge)
(nonnull-c-pointer GtsSurface)
))
(define edge-has-any-parent-surface
(foreign-lambda (nonnull-c-pointer GtsFace) "gts_has_any_parent_surface"
(nonnull-c-pointer GtsEdge)
))
(define edge-has-parent-surface
(foreign-lambda (nonnull-c-pointer GtsFace) "gts_has_parent_surface"
(nonnull-c-pointer GtsEdge)
(nonnull-c-pointer GtsSurface)
))
(define edge-is-duplicate
(foreign-lambda (nonnull-c-pointer GtsEdge) "gts_edge_is_duplicate"
(nonnull-c-pointer GtsEdge)
))
(define edge-is-unattached
(foreign-lambda bool "gts_edge_is_unattached"
(nonnull-c-pointer GtsEdge)
))
;; Shutdown GTS and free all memory.
;; After calling this method no other GTS functions may be called.
(define finalize
(foreign-lambda void "gts_finalize"
))
(define object-reset-reserved
(foreign-lambda void "object_reset_reserved"
(nonnull-c-pointer GtsObject)
))
(define object-attributes
(foreign-lambda void "gts_object_attributes"
(nonnull-c-pointer GtsObject)
(nonnull-c-pointer GtsObject)
))
(define object-clone
(foreign-lambda (nonnull-c-pointer GtsObject) "gts_object_clone"
(nonnull-c-pointer GtsObject)
))
(define surface_face_revert (foreign-value ">s_triangle_revert" c-pointer))
;; Callback interfaces
#|
;; Callback for the GTS Object class initialization - don't use this unless you know what you are doing
(define object-class-init-callback
(foreign-lambda void "GtsObjectClassInitFunc" (nonnull-c-pointer GtsObjectClass)))
;; Callback for the GTS Object initialization - don't use this unless you know what you are doing
(define object-init-callback
(foreign-lambda void "GtsObjectInitFunc" (nonnull-c-pointer GtsObject)))
;; Callback for the GTS argument set method - don't use this unless you know what you are doing
(define arg-set-callback
(foreign-lambda void "GtsArgSetFunc" (nonnull-c-pointer GtsObject)))
;; Callback for the GTS argument get method - don't use this unless you know what you are doing
(define arg-get-callback
(foreign-lambda void "GtsArgGetFunc" (nonnull-c-pointer GtsObject)))
|#
;; Callback for most GTS visitors
(define-syntax define-visitor-callback
(syntax-rules ()
((_ (name arg1 arg2) body)
(define-external (name (c-pointer arg1) (c-pointer arg2)) int
body))))
;; Callback for gts_vertices_merge
(define-syntax define-merge-callback
(syntax-rules ()
((_ (name v1 v2) body)
(define-external (name ((nonnull-c-pointer GtsVertex) v1) ((nonnull-c-pointer GtsVertex) v2)) bool
body))))
(define-syntax define-encroach-callback
(syntax-rules ()
((_ (name x1 x2 x3 x4) body)
(define-external (name ((nonnull-c-pointer GtsVertex) x1) ((nonnull-c-pointer GtsEdge) x2)
((nonnull-c-pointer GtsSurface) x3) (c-pointer x4)) bool
body))))
(define-syntax define-key-callback
(syntax-rules ()
((_ (name arg1 arg2) body)
(define-external (name (c-pointer arg1) (c-pointer arg2)) double
body))))
(define-syntax define-refine-callback
(syntax-rules ()
((_ (name x1 x2 x3) body)
(define-external (name ((nonnull-c-pointer GtsEdge) x1) ((nonnull-c-pointer GtsVertexClass) x2)
(c-pointer x3)) (nonnull-c-pointer GtsVertex)
body))))
(define-syntax define-stop-callback
(syntax-rules ()
((_ (name x1 x2 x3) body)
(define-external (name (double x1) (unsigned-int x2) (c-pointer x3)) bool
body))))