79 lines
2.1 KiB
Factor
79 lines
2.1 KiB
Factor
! Copyright (C) 2010 Slava Pestov.
|
|
USING: accessors combinators fry kernel locals math.vectors
|
|
namespaces sets sequences game.models.half-edge euler.b-rep
|
|
euler.operators math ;
|
|
IN: euler.modeling
|
|
|
|
: (polygon>double-face) ( polygon -- edge )
|
|
[ first2 make-vefs ] keep
|
|
[ drop opposite-edge>> ] [ 2 tail-slice [ make-ev-one ] each ] 2bi
|
|
make-ef face-ccw ;
|
|
|
|
SYMBOLS: smooth-smooth
|
|
sharp-smooth
|
|
smooth-sharp
|
|
sharp-sharp
|
|
smooth-like-vertex
|
|
sharp-like-vertex
|
|
smooth-continue
|
|
sharp-continue ;
|
|
|
|
: polygon>double-face ( polygon mode -- edge )
|
|
! This only handles the simple case with no repeating vertices
|
|
drop
|
|
dup all-unique? [ "polygon>double-face doesn't support repeating vertices yet" throw ] unless
|
|
(polygon>double-face) ;
|
|
|
|
:: extrude-simple ( edge dist sharp? -- edge )
|
|
edge face-normal dist v*n :> vec
|
|
edge vertex-pos vec v+ :> pos
|
|
edge pos make-ev-one :> e0!
|
|
e0 opposite-edge>> :> e-end
|
|
edge face-ccw :> edge!
|
|
|
|
[ edge e-end eq? not ] [
|
|
edge vertex-pos vec v+ :> pos
|
|
edge pos make-ev-one :> e1
|
|
e0 e1 make-ef drop
|
|
e1 e0!
|
|
edge face-ccw edge!
|
|
] do while
|
|
|
|
e-end face-ccw :> e-end
|
|
e0 e-end make-ef drop
|
|
|
|
e-end ;
|
|
|
|
: check-bridge-rings ( e1 e2 -- )
|
|
{
|
|
[ [ face>> assert-no-rings ] bi@ ]
|
|
[ [ face>> assert-base-face ] bi@ ]
|
|
[ assert-different-faces ]
|
|
[ [ face-sides ] bi@ assert= ]
|
|
} 2cleave ;
|
|
|
|
:: bridge-rings-simple ( e1 e2 sharp? -- edge )
|
|
e1 e2 check-bridge-rings
|
|
e1 e2 kill-f-make-rh
|
|
e1 e2 make-e-kill-r face-cw :> ea!
|
|
e2 face-ccw :> eb!
|
|
[ ea e1 eq? not ] [
|
|
ea eb make-ef opposite-edge>> face-cw ea!
|
|
eb face-ccw eb!
|
|
] while
|
|
eb ;
|
|
|
|
:: project-pt-line ( p p0 p1 -- q )
|
|
p1 p0 v- :> vt
|
|
p p0 v- vt v* sum
|
|
vt norm-sq /
|
|
vt n*v p0 v+ ; inline
|
|
|
|
:: project-pt-plane ( line-p0 line-vt plane-n plane-d -- q )
|
|
plane-d neg plane-n line-p0 v. -
|
|
line-vt plane-n v. /
|
|
line-vt n*v line-p0 v+ ; inline
|
|
|
|
: project-poly-plane ( poly vdir plane-n plane-d -- qoly )
|
|
'[ _ _ _ project-pt-plane ] map ; inline
|