extra/euler/operators/operators.factor

   1 ! Copyright (C) 2010 Slava Pestov.
   2 USING: accessors combinators fry kernel locals namespaces
   3 game.models.half-edge euler.b-rep sequences typed math
   4 math.vectors ;
   5 IN: euler.operators
   6
   7 ERROR: edges-not-incident ;
   8
   9 : assert-incident ( e1 e2 -- )
  10     incident? [ edges-not-incident ] unless ;
  11
  12 ERROR: should-not-be-equal obj1 obj2 ;
  13
  14 : assert-not= ( obj1 obj2 -- )
  15     2dup eq? [ should-not-be-equal ] [ 2drop ] if ;
  16
  17 ERROR: edges-in-different-faces ;
  18
  19 : assert-same-face ( e1 e2 -- )
  20     same-face? [ edges-in-different-faces ] unless ;
  21
  22 ERROR: edges-in-same-face ;
  23
  24 : assert-different-faces ( e1 e2 -- )
  25     same-face? [ edges-in-same-face ] when ;
  26
  27 : assert-isolated-component ( edge -- )
  28     [ [ opposite-edge>> ] [ next-edge>> ] bi assert= ]
  29     [ dup opposite-edge>> assert-same-face ]
  30     bi ;
  31
  32 : assert-base-face ( face -- )
  33     base-face check-instance drop ;
  34
  35 ERROR: has-rings face ;
  36
  37 : assert-no-rings ( face -- )
  38     dup next-ring>> [ has-rings ] [ drop ] if ;
  39
  40 : assert-ring-of ( ring face -- )
  41     [ base-face>> ] dip assert= ;
  42
  43 : with-b-rep ( b-rep quot -- )
  44     [ b-rep ] dip with-variable ; inline
  45
  46 : make-b-rep ( quot -- b-rep )
  47     <b-rep> [ swap with-b-rep ] [ finish-b-rep ] [ ] tri ; inline
  48
  49 <PRIVATE
  50
  51 :: make-loop ( vertex face -- edge )
  52     b-rep get new-edge :> edge
  53     vertex edge vertex<<
  54     edge edge next-edge<<
  55     face edge face<<
  56
  57     edge ;
  58
  59 : make-loop-face ( vertex -- edge )
  60     b-rep get new-face
  61     dup >>base-face
  62     make-loop ;
  63
  64 :: make-edge ( vertex next-edge -- edge )
  65     b-rep get new-edge :> edge
  66     vertex edge vertex<<
  67     next-edge edge next-edge<<
  68     next-edge face>> edge face<<
  69
  70     edge ;
  71
  72 : opposite-edges ( e1 e2 -- )
  73     [ opposite-edge<< ] [ swap opposite-edge<< ] 2bi ;
  74
  75 PRIVATE>
  76
  77 MIXIN: point
  78 INSTANCE: sequence point
  79 INSTANCE: number point
  80
  81 TYPED:: make-vefs ( pos1: point pos2: point -- edge: b-edge )
  82     b-rep get :> b-rep
  83
  84     pos1 b-rep new-vertex :> v1
  85     v1 make-loop-face :> e1
  86
  87     pos2 b-rep new-vertex :> v2
  88     v2 e1 make-edge :> e2
  89
  90     e2 e1 next-edge<<
  91     e1 e2 opposite-edges
  92
  93     e2 ;
  94
  95 TYPED:: make-ev-one ( edge: b-edge point: point -- edge: b-edge )
  96     point b-rep get new-vertex :> v
  97     v edge make-edge :> e1'
  98
  99     edge vertex>> e1' make-edge :> e2'
 100
 101     e2' edge face-cw next-edge<<
 102     e1' e2' opposite-edges
 103
 104     e1' ;
 105
 106 <PRIVATE
 107
 108 :: subdivide-vertex-cycle ( e1 e2 v -- )
 109     e1 e2 eq? [
 110         v e1 vertex<<
 111         e1 vertex-cw e2 v subdivide-vertex-cycle
 112     ] unless ;
 113
 114 :: (make-ev) ( e1 e2 point -- edge )
 115     e1 e2 assert-incident
 116
 117     point b-rep get new-vertex :> v'
 118     v' e2 make-edge :> e1'
 119
 120     e1 vertex>> :> v
 121
 122     v e1 make-edge :> e2'
 123
 124     e1 e2 v' subdivide-vertex-cycle
 125
 126     e1 face-cw :> e1p
 127     e2 face-cw :> e2p
 128     e1 opposite-edge>> :> e1m
 129
 130     e1m e1p assert-not=
 131
 132     e1' e2p next-edge<<
 133     e2' e1p next-edge<<
 134
 135     e1' e2' opposite-edges
 136
 137     e1' ;
 138
 139 PRIVATE>
 140
 141 TYPED:: make-ev ( e1: b-edge e2: b-edge point: point -- edge: b-edge )
 142     e1 e2 eq?
 143     [ e1 point make-ev-one ] [ e1 e2 point (make-ev) ] if ;
 144
 145 <PRIVATE
 146
 147 : subdivide-edge-cycle ( face e1 e2 -- )
 148     2dup eq? [ 3drop ] [
 149         [ drop face<< ]
 150         [ [ next-edge>> ] dip subdivide-edge-cycle ] 3bi
 151     ] if ;
 152
 153 PRIVATE>
 154
 155 TYPED:: make-ef ( e1: b-edge e2: b-edge -- edge: b-edge )
 156     e1 e2 assert-same-face
 157
 158     e2 vertex>> make-loop-face :> e1'
 159     e1 vertex>> e2 make-edge :> e2'
 160     e1' e2' opposite-edges
 161
 162     e1 face-cw :> e1p
 163
 164     e1 e2 eq? [
 165         e2 face-cw :> e2p
 166
 167         e1' face>> e1 e2 subdivide-edge-cycle
 168
 169         e1' e2p next-edge<<
 170         e1 e1' next-edge<<
 171     ] unless
 172
 173     e2' e1p next-edge<<
 174     e1' ;
 175
 176 TYPED:: make-e-kill-r ( edge-ring: b-edge edge-face: b-edge -- edge: b-edge )
 177     edge-ring face>> :> ring
 178     edge-face face>> :> face
 179     ring face assert-ring-of
 180
 181     edge-ring [ face >>face drop ] each-face-edge
 182
 183     edge-ring vertex>> edge-face make-edge :> e1
 184     edge-face vertex>> edge-ring make-edge :> e2
 185
 186     ring face delete-ring
 187     ring b-rep get delete-face
 188
 189     e2 edge-face face-cw next-edge<<
 190     e1 edge-ring face-cw next-edge<<
 191
 192     e1 e2 opposite-edges
 193
 194     e1 ;
 195
 196 TYPED:: make-f-kill-rh ( edge-ring: b-edge -- )
 197     edge-ring face>> :> ring
 198     ring base-face>> :> base-face
 199     ring base-face delete-ring
 200     ring ring base-face<< ;
 201
 202 TYPED:: kill-vefs ( edge: b-edge -- )
 203     edge assert-isolated-component
 204
 205     b-rep get :> b-rep
 206     edge dup opposite-edge>> :> ( e2 e1 )
 207
 208     e1 vertex>> :> v1
 209     e2 vertex>> :> v2
 210
 211     e1 face>> b-rep delete-face
 212
 213     e1 b-rep delete-edge
 214     e2 b-rep delete-edge
 215     v1 b-rep delete-vertex
 216     v2 b-rep delete-vertex ;
 217
 218 TYPED:: kill-ev ( edge: b-edge -- )
 219     b-rep get :> b-rep
 220
 221     edge vertex>> :> v
 222     edge opposite-edge>> :> edge'
 223     edge' vertex>> :> v'
 224
 225     edge [ v' >>vertex drop ] each-vertex-edge
 226
 227     edge face-cw :> edgep
 228     edge' face-cw :> edge'p
 229
 230     edge next-edge>> edgep next-edge<<
 231     edge' next-edge>> edge'p next-edge<<
 232
 233     v b-rep delete-vertex
 234     edge b-rep delete-edge
 235     edge' b-rep delete-edge ;
 236
 237 TYPED:: kill-ef ( edge: b-edge -- )
 238     b-rep get :> b-rep
 239
 240     edge :> e1
 241     edge opposite-edge>> :> e2
 242
 243     e1 e2 assert-different-faces
 244
 245     e1 face-cw :> e1p
 246     e2 face-cw :> e2p
 247
 248     e1 face>> :> f1
 249     e2 face>> :> f2
 250
 251     e1 [ f2 >>face drop ] each-face-edge
 252     f1 b-rep delete-face
 253
 254     e1 e2 incident? [
 255         e2 next-edge>> e2p next-edge<<
 256
 257     ] [
 258         e2 next-edge>> e1p next-edge<<
 259         e1 next-edge>> e2p next-edge<<
 260     ] if
 261
 262     e1 b-rep delete-edge
 263     e2 b-rep delete-edge ;
 264
 265 TYPED:: kill-e-make-r ( edge: b-edge -- edge-ring: b-edge )
 266     b-rep get :> b-rep
 267
 268     edge opposite-edge>> :> edge'
 269     edge' next-edge>> :> edge-ring
 270     edge-ring opposite-edge>> :> edge-ring'
 271
 272     edge edge' assert-same-face
 273     edge edge-ring assert-same-face
 274     edge edge-ring' assert-different-faces
 275
 276     b-rep new-face :> ring
 277
 278     ring edge face>> base-face>> add-ring
 279     ring edge' edge subdivide-edge-cycle
 280
 281     edge b-rep delete-edge
 282     edge' b-rep delete-edge
 283
 284     edge-ring ;
 285
 286 TYPED:: kill-f-make-rh ( edge-face: b-edge edge-base-face: b-edge -- )
 287     edge-face face>> :> face
 288     edge-base-face face>> :> base-face
 289
 290     face assert-base-face
 291     base-face assert-base-face
 292     edge-face edge-base-face assert-different-faces
 293
 294     face base-face add-ring ;
 295
 296 TYPED: move-v ( edge: b-edge point: point -- )
 297     swap vertex>> position<< ;
 298
 299 TYPED: move-e ( edge: b-edge offset: point -- )
 300     [ dup opposite-edge>> ] dip
 301     '[ vertex>> [ _ v+ ] change-position drop ] bi@ ;
 302
 303 TYPED: move-f ( edge: b-edge offset: point -- )
 304     '[ vertex>> [ _ v+ ] change-position drop ] each-face-edge ;
 305
 306 TYPED: sharp-e ( edge: b-edge sharp?: boolean -- )
 307     >>sharpness drop ;
 308
 309 TYPED: sharp-f ( edge: b-edge sharp?: boolean -- )
 310     '[ _ sharp-e ] each-face-edge ;
 311
 312 TYPED: sharp-v ( edge: b-edge sharp?: boolean -- )
 313     '[ _ sharp-e ] each-vertex-edge ;
 314
 315 TYPED: material-f ( edge: b-edge material -- ) 2drop ;