extra/euler/modeling/modeling.factor

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