extra/euler/modeling/modeling.factor

   1 ! Copyright (C) 2010 Slava Pestov.\r
   2 USING: accessors combinators fry kernel locals math.vectors\r
   3 namespaces sets sequences game.models.half-edge euler.b-rep\r
   4 euler.operators math ;\r
   5 IN: euler.modeling\r
   6 \r
   7 : (polygon>double-face) ( polygon -- edge )\r
   8     [ first2 make-vefs ] keep\r
   9     [ drop opposite-edge>> ] [ 2 tail-slice [ make-ev-one ] each ] 2bi\r
  10     make-ef face-ccw ;\r
  11 \r
  12 SYMBOLS: smooth-smooth\r
  13 sharp-smooth\r
  14 smooth-sharp\r
  15 sharp-sharp\r
  16 smooth-like-vertex\r
  17 sharp-like-vertex\r
  18 smooth-continue\r
  19 sharp-continue ;\r
  20 \r
  21 : polygon>double-face ( polygon mode -- edge )\r
  22     ! This only handles the simple case with no repeating vertices\r
  23     drop\r
  24     dup all-unique? [ "polygon>double-face doesn't support repeating vertices yet" throw ] unless\r
  25     (polygon>double-face) ;\r
  26 \r
  27 :: extrude-simple ( edge dist sharp? -- edge )\r
  28     edge face-normal dist v*n :> vec\r
  29     edge vertex-pos vec v+ :> pos\r
  30     edge pos make-ev-one :> e0!\r
  31     e0 opposite-edge>> :> e-end\r
  32     edge face-ccw :> edge!\r
  33 \r
  34     [ edge e-end eq? not ] [\r
  35         edge vertex-pos vec v+ :> pos\r
  36         edge pos make-ev-one :> e1\r
  37         e0 e1 make-ef drop\r
  38         e1 e0!\r
  39         edge face-ccw edge!\r
  40     ] do while\r
  41     \r
  42     e-end face-ccw :> e-end\r
  43     e0 e-end make-ef drop\r
  44 \r
  45     e-end ;\r
  46 \r
  47 : check-bridge-rings ( e1 e2 -- )\r
  48     {\r
  49         [ [ face>> assert-no-rings ] bi@ ]\r
  50         [ [ face>> assert-base-face ] bi@ ]\r
  51         [ assert-different-faces ]\r
  52         [ [ face-sides ] bi@ assert= ]\r
  53     } 2cleave ;\r
  54 \r
  55 :: bridge-rings-simple ( e1 e2 sharp? -- edge )\r
  56     e1 e2 check-bridge-rings\r
  57     e1 e2 kill-f-make-rh\r
  58     e1 e2 make-e-kill-r face-cw :> ea!\r
  59     e2 face-ccw :> eb!\r
  60     [ ea e1 eq? not ] [\r
  61         ea eb make-ef opposite-edge>> face-cw ea!\r
  62         eb face-ccw eb!\r
  63     ] while\r
  64     eb ;\r
  65 \r
  66 :: project-pt-line ( p p0 p1 -- q )\r
  67     p1 p0 v- :> vt\r
  68     p p0 v- vt v* sum\r
  69     vt norm-sq /\r
  70     vt n*v p0 v+ ; inline\r
  71 \r
  72 :: project-pt-plane ( line-p0 line-vt plane-n plane-d -- q )\r
  73     plane-d neg plane-n line-p0 v. -\r
  74     line-vt plane-n v. /\r
  75     line-vt n*v line-p0 v+ ; inline\r
  76 \r
  77 : project-poly-plane ( poly vdir plane-n plane-d -- qoly )\r
  78     '[ _ _ _ project-pt-plane ] map ; inline\r