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