extra/euler/b-rep/subdivision/subdivision.factor

   1 USING: accessors arrays assocs euler.b-rep
   2 game.models.half-edge kernel locals math math.vectors
   3 math.vectors.simd.cords sequences sets typed fry ;
   4 FROM: sequences.private => nth-unsafe set-nth-unsafe ;
   5 IN: euler.b-rep.subdivision
   6
   7 : <vertex> ( position -- vertex ) vertex new swap >>position ; inline
   8
   9 : face-points ( faces -- face-pts )
  10     [ edge>> face-midpoint <vertex> ] map ; inline
  11
  12 :: edge-points ( edges edge-indices face-indices face-points -- edge-pts )
  13     edges length 0 <array> :> edge-pts
  14
  15     edges [| edge n |
  16         edge opposite-edge>> :> opposite-edge
  17         opposite-edge edge-indices at :> opposite-n
  18
  19         n opposite-n < [
  20             edge          vertex>> position>>
  21             opposite-edge vertex>> position>> v+
  22             edge          face>> face-indices at face-points nth position>> v+
  23             opposite-edge face>> face-indices at face-points nth position>> v+
  24             0.25 v*n
  25             <vertex>
  26             [ n edge-pts set-nth-unsafe ]
  27             [ opposite-n edge-pts set-nth-unsafe ] bi
  28         ] when
  29     ] each-index
  30
  31     edge-pts ; inline
  32
  33 :: vertex-points ( vertices edge-indices face-indices edge-pts face-points -- vertex-pts )
  34     vertices [| vertex |
  35         0 double-4{ 0 0 0 0 } double-4{ 0 0 0 0 }
  36         vertex edge>> [| valence face-sum edge-sum edge |
  37             valence 1 +
  38             face-sum edge face>> face-indices at face-points nth position>> v+
  39             edge-sum edge next-edge>> vertex>> position>> v+
  40         ] each-vertex-edge :> ( valence face-sum edge-sum )
  41         valence >float :> fvalence
  42         face-sum fvalence v/n :> face-avg
  43         edge-sum fvalence v/n :> edge-avg
  44         face-avg  edge-avg v+  vertex position>> fvalence 2.0 - v*n v+
  45         fvalence v/n
  46         <vertex>
  47     ] map ; inline
  48
  49 TYPED:: subdivide ( brep: b-rep -- brep': b-rep )
  50     brep vertices>> :> vertices
  51     brep edges>>    :> edges
  52     brep faces>>    :> faces
  53
  54     vertices >index-hash :> vertex-indices
  55     edges    >index-hash :> edge-indices
  56     faces    >index-hash :> face-indices
  57
  58     faces face-points :> face-pts
  59     edges edge-indices face-indices face-pts edge-points :> edge-pts
  60     vertices edge-indices face-indices edge-pts face-pts vertex-points :> vertex-pts
  61
  62     V{ } clone :> sub-edges
  63     V{ } clone :> sub-faces
  64
  65     vertices [
  66         edge>> [| edg |
  67             edg edge-indices at edge-pts nth :> point-a
  68             edg next-edge>> :> next-edg
  69             next-edg vertex>> :> next-vertex
  70             next-vertex vertex-indices at vertex-pts nth :> point-b
  71             next-edg edge-indices at edge-pts nth :> point-c
  72             edg face>> face-indices at face-pts nth :> point-d
  73
  74             face new
  75                 dup >>base-face :> fac
  76
  77             b-edge new
  78                 fac >>face
  79                 point-a >>vertex :> edg-a
  80             b-edge new
  81                 fac >>face
  82                 point-b >>vertex :> edg-b
  83             b-edge new
  84                 fac >>face
  85                 point-c >>vertex :> edg-c
  86             b-edge new
  87                 fac >>face
  88                 point-d >>vertex :> edg-d
  89             edg-a fac   edge<<
  90             edg-b edg-a next-edge<<
  91             edg-c edg-b next-edge<<
  92             edg-d edg-c next-edge<<
  93             edg-a edg-d next-edge<<
  94
  95             fac sub-faces push
  96             edg-a sub-edges push
  97             edg-b sub-edges push
  98             edg-c sub-edges push
  99             edg-d sub-edges push
 100
 101             point-a [ edg-a or ] change-edge drop
 102             point-b [ edg-b or ] change-edge drop
 103             point-c [ edg-c or ] change-edge drop
 104             point-d [ edg-d or ] change-edge drop
 105         ] each-vertex-edge
 106     ] each
 107
 108     b-rep new
 109         sub-faces { } like >>faces
 110         sub-edges { } like >>edges
 111         face-pts edge-pts vertex-pts 3append members { } like >>vertices
 112     [ connect-opposite-edges ] keep ;