unmaintained/euler/b-rep/triangulation/triangulation.factor

   1 USING: accessors alien.c-types alien.handles euler.b-rep
   2 game.models.half-edge grouping kernel locals opengl.gl
   3 opengl.glu sequences specialized-arrays specialized-vectors
   4 libc destructors alien.data ;
   5 IN: euler.b-rep.triangulation
   6
   7 SPECIALIZED-ARRAY: double
   8
   9 ERROR: triangulated-face-must-be-base ;
  10
  11 <PRIVATE
  12
  13 : tess-begin ( -- callback )
  14     [| primitive-type vertices-h |
  15         primitive-type GL_TRIANGLES =
  16         [ "unexpected primitive type" throw ] unless
  17     ] GLUtessBeginDataCallback ;
  18
  19 : tess-end ( -- callback )
  20     [| vertices-h |
  21         ! nop
  22     ] GLUtessEndDataCallback ;
  23
  24 : tess-vertex ( -- callback )
  25     [| vertex-h vertices-h |
  26         vertex-h alien-handle-ptr>
  27         vertices-h alien-handle-ptr> push
  28     ] GLUtessVertexDataCallback ;
  29
  30 : tess-edge-flag ( -- callback )
  31     [| flag vertices-h |
  32         ! nop
  33     ] GLUtessEdgeFlagDataCallback ;
  34
  35 PRIVATE>
  36
  37 :: triangulate-face ( face -- triangles )
  38     [
  39         face dup base-face>> eq? [ triangulated-face-must-be-base ] unless
  40
  41         gluNewTess &gluDeleteTess :> tess
  42         V{ } clone :> vertices
  43         vertices <alien-handle-ptr> &release-alien-handle-ptr :> vertices-h
  44
  45         tess GLU_TESS_BEGIN_DATA     tess-begin     gluTessCallback
  46         tess GLU_TESS_END_DATA       tess-end       gluTessCallback
  47         tess GLU_TESS_VERTEX_DATA    tess-vertex    gluTessCallback
  48         tess GLU_TESS_EDGE_FLAG_DATA tess-edge-flag gluTessCallback
  49
  50         tess vertices-h gluTessBeginPolygon
  51
  52         4 double malloc-array &free :> vertex-buf
  53
  54         face [| ring |
  55             tess gluTessBeginContour
  56
  57             ring edge>> [
  58                 tess swap vertex>>
  59                 [ position>> double >c-array ]
  60                 [ <alien-handle-ptr> &release-alien-handle-ptr ] bi gluTessVertex
  61             ] each-face-edge
  62
  63             tess gluTessEndContour
  64
  65             ring next-ring>> dup
  66         ] loop drop
  67         tess gluTessEndPolygon
  68
  69         vertices { } like 3 <groups>
  70     ] with-destructors ;