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

   1 ! Copyright (C) 2010 Slava Pestov.
   2 USING: accessors arrays assocs combinators
   3 combinators.short-circuit game.models.half-edge kernel math
   4 math.vectors namespaces sequences sets ;
   5 FROM: namespaces => set ;
   6 IN: euler.b-rep
   7
   8 : >index-hash ( seq -- hash ) H{ } zip-index-as ; inline
   9
  10 TUPLE: b-edge < edge sharpness macro ;
  11
  12 TUPLE: vertex < identity-tuple position edge ;
  13
  14 TUPLE: face < identity-tuple edge next-ring base-face ;
  15
  16 :: (opposite) ( e1 e2 quot: ( edge -- edge' ) -- edge )
  17     e1 quot call :> e0
  18     e0 e2 eq? [ e1 ] [ e0 e2 quot (opposite) ] if ;
  19     inline recursive
  20
  21 : opposite ( edge quot: ( edge -- edge' ) -- edge )
  22     dupd (opposite) ; inline
  23
  24 : face-ccw ( edge -- edge ) next-edge>> ; inline
  25
  26 : face-cw ( edge -- edge ) [ face-ccw ] opposite ; inline
  27
  28 : vertex-cw ( edge -- edge ) opposite-edge>> next-edge>> ; inline
  29
  30 : vertex-ccw ( edge -- edge ) [ vertex-cw ] opposite ; inline
  31
  32 : base-face? ( face -- ? ) dup base-face>> eq? ; inline
  33
  34 : has-rings? ( face -- ? ) next-ring>> >boolean ; inline
  35
  36 : incident? ( e1 e2 -- ? ) [ vertex>> ] bi@ eq? ; inline
  37
  38 TUPLE: b-rep < identity-tuple faces edges vertices ;
  39
  40 : <b-rep> ( -- b-rep )
  41     V{ } clone V{ } clone V{ } clone b-rep boa ;
  42
  43 SYMBOL: sharpness-stack
  44 sharpness-stack [ V{ t } ] initialize
  45
  46 : set-sharpness ( sharp? -- ) >boolean sharpness-stack get set-last ;
  47 : get-sharpness ( -- sharp? ) sharpness-stack get last ;
  48
  49 : push-sharpness ( sharp? -- ) >boolean sharpness-stack get push ;
  50 : pop-sharpness ( -- sharp? )
  51     sharpness-stack get
  52     dup length 1 = [ first ] [ pop ] if ;
  53
  54 : new-vertex ( position b-rep -- vertex )
  55     [ f vertex boa dup ] dip vertices>> push ; inline
  56
  57 : new-edge ( b-rep -- edge )
  58     [ b-edge new get-sharpness >>sharpness dup ] dip edges>> push ; inline
  59
  60 : new-face ( b-rep -- face )
  61     [ face new dup ] dip faces>> push ; inline
  62
  63 : delete-vertex ( vertex b-rep -- )
  64     vertices>> remove! drop ; inline
  65
  66 : delete-edge ( edge b-rep -- )
  67     edges>> remove! drop ; inline
  68
  69 : delete-face ( face b-rep -- )
  70     faces>> remove! drop ; inline
  71
  72 : add-ring ( ring base-face -- )
  73     [ >>base-face drop ]
  74     [ next-ring>> >>next-ring drop ]
  75     [ swap >>next-ring drop ]
  76     2tri ;
  77
  78 : delete-ring ( ring base-face -- )
  79     2dup next-ring>> eq?
  80     [ [ next-ring>> ] dip next-ring<< ]
  81     [ next-ring>> delete-ring ]
  82     if ;
  83
  84 : vertex-pos ( edge -- pos )
  85     vertex>> position>> ; inline
  86
  87 : same-edge? ( e1 e2 -- ? )
  88     { [ eq? ] [ opposite-edge>> eq? ] } 2|| ;
  89
  90 : same-face? ( e1 e2 -- ? )
  91     [ face>> ] bi@ eq? ;
  92
  93 : edge-direction ( edge -- v )
  94     [ face-ccw ] keep [ vertex-pos ] bi@ v- ;
  95
  96 : normal ( v0 v1 v2 -- v )
  97     [ drop v- ] [ nipd v- ] 3bi cross ;
  98
  99 ERROR: all-points-colinear ;
 100
 101 : face-normal ( edge -- n )
 102     face-edges
 103     [
 104         dup face-ccw dup face-ccw
 105         [ vertex-pos ] tri@ normal
 106     ] map
 107     [ [ zero? ] all? not ] find nip
 108     [ normalize ] [ all-points-colinear ] if* ;
 109
 110 : (face-plane-dist) ( normal edge -- d )
 111     vertex-pos vdot neg ; inline
 112
 113 : face-plane-dist ( edge -- d )
 114     [ face-normal ] [ (face-plane-dist) ] bi ; inline
 115
 116 : face-plane ( edge -- n d )
 117     [ face-normal dup ] [ (face-plane-dist) ] bi ; inline
 118
 119 : face-midpoint ( edge -- v )
 120     face-edges
 121     [ [ vertex-pos ] [ v+ ] map-reduce ] [ length ] bi v/n ;
 122
 123 : clear-b-rep ( b-rep -- )
 124     [ faces>> delete-all ]
 125     [ edges>> delete-all ]
 126     [ vertices>> delete-all ]
 127     tri ;
 128
 129 : connect-opposite-edges ( b-rep -- )
 130     edges>>
 131     [ [ [ next-edge>> vertex>> ] [ vertex>> 2array ] [ ] tri ] H{ } map>assoc ]
 132     [ swap '[ [ vertex>> ] [ next-edge>> vertex>> 2array _ at ] [ opposite-edge<< ] tri ] each ] bi ;
 133
 134 : connect-faces ( b-rep -- )
 135     edges>> [ dup face>> edge<< ] each ;
 136
 137 : connect-vertices ( b-rep -- )
 138     edges>> [ dup vertex>> edge<< ] each ;
 139
 140 : finish-b-rep ( b-rep -- )
 141     [ connect-faces ] [ connect-vertices ] bi ;
 142
 143 : characteristic ( b-rep -- n )
 144     ! Assumes b-rep is connected and all faces are convex
 145     [ vertices>> length ]
 146     [ edges>> length 2 / ]
 147     [ faces>> [ base-face? ] count ] tri
 148     [ - ] dip + ;
 149
 150 : genus ( b-rep -- n )
 151     ! Assumes b-rep is connected and all faces are convex
 152     characteristic 2 swap - 2 / ;
 153
 154 SYMBOLS: live-vertices live-edges live-faces ;
 155
 156 ERROR: dead-vertex vertex ;
 157
 158 : check-live-vertex ( vertex -- )
 159     dup live-vertices get in? [ drop ] [ dead-vertex ] if ;
 160
 161 ERROR: dead-edge edge ;
 162
 163 : check-live-edge ( edge -- )
 164     dup live-edges get in? [ drop ] [ dead-edge ] if ;
 165
 166 ERROR: dead-face face ;
 167
 168 : check-live-face ( face -- )
 169     dup live-faces get in? [ drop ] [ dead-face ] if ;
 170
 171 : check-vertex ( vertex -- )
 172     [ edge>> check-live-edge ]
 173     [ dup edge>> [ vertex>> assert= ] with each-vertex-edge ]
 174     bi ;
 175
 176 : check-edge ( edge -- )
 177     {
 178         [ vertex>> check-live-vertex ]
 179         [ opposite-edge>> check-live-edge ]
 180         [ face>> check-live-face ]
 181         [ dup opposite-edge>> opposite-edge>> assert= ]
 182     } cleave ;
 183
 184 : check-face ( face -- )
 185     [ edge>> check-live-edge ]
 186     [ dup edge>> [ face>> assert= ] with each-face-edge ]
 187     bi ;
 188
 189 : check-ring ( base-face face -- )
 190     [ check-face ] [ base-face>> assert= ] bi ;
 191
 192 : check-base-face ( face -- )
 193     [ check-face ]
 194     [ dup [ next-ring>> ] follow rest [ check-ring ] with each ] bi ;
 195
 196 : check-b-rep ( b-rep -- )
 197     [
 198         [
 199             [ vertices>> fast-set live-vertices set ]
 200             [ edges>> fast-set live-edges set ]
 201             [ faces>> fast-set live-faces set ] tri
 202         ]
 203         [
 204             [ vertices>> [ check-vertex ] each ]
 205             [ edges>> [ check-edge ] each ]
 206             [ faces>> [ base-face? ] filter [ check-base-face ] each ] tri
 207         ] bi
 208     ] with-scope ;
 209
 210 : empty-b-rep? ( b-rep -- ? )
 211     [ faces>> ] [ edges>> ] [ vertices>> ] tri
 212     [ empty? ] tri@ and and ;
 213
 214 ERROR: b-rep-not-empty b-rep ;
 215
 216 : assert-empty-b-rep ( b-rep -- )
 217     dup empty-b-rep? [ drop ] [ b-rep-not-empty ] if ;
 218
 219 : is-valid-edge? ( e brep -- ? )
 220     edges>> member? ; inline
 221
 222 : edge-endpoints ( edge -- from to )
 223     [ vertex>> position>> ]
 224     [ opposite-edge>> vertex>> position>> ] bi ; inline
 225
 226 :: connecting-edge ( e0 e1 -- edge/f )
 227     e1 vertex>> :> target-vertex
 228     e0 vertex>> target-vertex eq? [ f ] [
 229         f e0 [| ret edge |
 230             edge opposite-edge>> vertex>> target-vertex eq?
 231             [ edge edge f ]
 232             [ f edge vertex-cw dup e0 eq? not ] if
 233         ] loop drop
 234     ] if ;