1 ! Copyright (C) 2010 Slava Pestov.
2 USING: accessors fry kernel locals sequences sets namespaces
3 combinators combinators.short-circuit game.models.half-edge
4 math math.vectors math.matrices assocs arrays hashtables ;
5 FROM: namespaces => set ;
8 : >index-hash ( seq -- hash ) H{ } zip-index-as ; inline
10 TUPLE: b-edge < edge sharpness macro ;
12 TUPLE: vertex < identity-tuple position edge ;
14 TUPLE: face < identity-tuple edge next-ring base-face ;
16 :: (opposite) ( e1 e2 quot: ( edge -- edge' ) -- edge )
18 e0 e2 eq? [ e1 ] [ e0 e2 quot (opposite) ] if ;
21 : opposite ( edge quot: ( edge -- edge' ) -- edge )
22 dupd (opposite) ; inline
24 : face-ccw ( edge -- edge ) next-edge>> ; inline
26 : face-cw ( edge -- edge ) [ face-ccw ] opposite ; inline
28 : vertex-cw ( edge -- edge ) opposite-edge>> next-edge>> ; inline
30 : vertex-ccw ( edge -- edge ) [ vertex-cw ] opposite ; inline
32 : base-face? ( face -- ? ) dup base-face>> eq? ; inline
34 : has-rings? ( face -- ? ) next-ring>> >boolean ; inline
36 : incident? ( e1 e2 -- ? ) [ vertex>> ] bi@ eq? ; inline
38 TUPLE: b-rep < identity-tuple faces edges vertices ;
40 : <b-rep> ( -- b-rep )
41 V{ } clone V{ } clone V{ } clone b-rep boa ;
43 SYMBOL: sharpness-stack
44 sharpness-stack [ V{ t } ] initialize
46 : set-sharpness ( sharp? -- ) >boolean sharpness-stack get set-last ;
47 : get-sharpness ( -- sharp? ) sharpness-stack get last ;
49 : push-sharpness ( sharp? -- ) >boolean sharpness-stack get push ;
50 : pop-sharpness ( -- sharp? )
52 dup length 1 = [ first ] [ pop ] if ;
54 : new-vertex ( position b-rep -- vertex )
55 [ f vertex boa dup ] dip vertices>> push ; inline
57 : new-edge ( b-rep -- edge )
58 [ b-edge new get-sharpness >>sharpness dup ] dip edges>> push ; inline
60 : new-face ( b-rep -- face )
61 [ face new dup ] dip faces>> push ; inline
63 : delete-vertex ( vertex b-rep -- )
64 vertices>> remove! drop ; inline
66 : delete-edge ( edge b-rep -- )
67 edges>> remove! drop ; inline
69 : delete-face ( face b-rep -- )
70 faces>> remove! drop ; inline
72 : add-ring ( ring base-face -- )
74 [ next-ring>> >>next-ring drop ]
75 [ swap >>next-ring drop ]
78 : delete-ring ( ring base-face -- )
80 [ [ next-ring>> ] dip next-ring<< ]
81 [ next-ring>> delete-ring ]
84 : vertex-pos ( edge -- pos )
85 vertex>> position>> ; inline
87 : same-edge? ( e1 e2 -- ? )
88 { [ eq? ] [ opposite-edge>> eq? ] } 2|| ;
90 : same-face? ( e1 e2 -- ? )
93 : edge-direction ( edge -- v )
94 [ face-ccw ] keep [ vertex-pos ] bi@ v- ;
96 : normal ( v0 v1 v2 -- v )
97 [ drop v- ] [ [ drop ] 2dip v- ] 3bi cross ;
99 ERROR: all-points-colinear ;
101 : face-normal ( edge -- n )
104 dup face-ccw dup face-ccw
105 [ vertex-pos ] tri@ normal
107 [ [ zero? ] all? not ] find nip
108 [ normalize ] [ all-points-colinear ] if* ;
110 : (face-plane-dist) ( normal edge -- d )
111 vertex-pos v. neg ; inline
113 : face-plane-dist ( edge -- d )
114 [ face-normal ] [ (face-plane-dist) ] bi ; inline
116 : face-plane ( edge -- n d )
117 [ face-normal dup ] [ (face-plane-dist) ] bi ; inline
119 : face-midpoint ( edge -- v )
121 [ [ vertex-pos ] [ v+ ] map-reduce ] [ length ] bi v/n ;
123 : clear-b-rep ( b-rep -- )
124 [ faces>> delete-all ]
125 [ edges>> delete-all ]
126 [ vertices>> delete-all ]
129 : connect-opposite-edges ( b-rep -- )
131 [ [ [ next-edge>> vertex>> ] [ vertex>> 2array ] [ ] tri ] H{ } map>assoc ]
132 [ swap '[ [ vertex>> ] [ next-edge>> vertex>> 2array _ at ] [ opposite-edge<< ] tri ] each ] bi ;
134 : connect-faces ( b-rep -- )
135 edges>> [ dup face>> edge<< ] each ;
137 : connect-vertices ( b-rep -- )
138 edges>> [ dup vertex>> edge<< ] each ;
140 : finish-b-rep ( b-rep -- )
141 [ connect-faces ] [ connect-vertices ] bi ;
143 : characteristic ( b-rep -- n )
144 ! Assumes b-rep is connected and all faces are convex
145 [ vertices>> length ]
146 [ edges>> length 2 / ]
147 [ faces>> [ base-face? ] count ] tri
150 : genus ( b-rep -- n )
151 ! Assumes b-rep is connected and all faces are convex
152 characteristic 2 swap - 2 / ;
154 SYMBOLS: live-vertices live-edges live-faces ;
156 ERROR: dead-vertex vertex ;
158 : check-live-vertex ( vertex -- )
159 dup live-vertices get in? [ drop ] [ dead-vertex ] if ;
161 ERROR: dead-edge edge ;
163 : check-live-edge ( edge -- )
164 dup live-edges get in? [ drop ] [ dead-edge ] if ;
166 ERROR: dead-face face ;
168 : check-live-face ( face -- )
169 dup live-faces get in? [ drop ] [ dead-face ] if ;
171 : check-vertex ( vertex -- )
172 [ edge>> check-live-edge ]
173 [ dup edge>> [ vertex>> assert= ] with each-vertex-edge ]
176 : check-edge ( edge -- )
178 [ vertex>> check-live-vertex ]
179 [ opposite-edge>> check-live-edge ]
180 [ face>> check-live-face ]
181 [ dup opposite-edge>> opposite-edge>> assert= ]
184 : check-face ( face -- )
185 [ edge>> check-live-edge ]
186 [ dup edge>> [ face>> assert= ] with each-face-edge ]
189 : check-ring ( base-face face -- )
190 [ check-face ] [ base-face>> assert= ] bi ;
192 : check-base-face ( face -- )
194 [ dup [ next-ring>> ] follow rest [ check-ring ] with each ] bi ;
196 : check-b-rep ( b-rep -- )
199 [ vertices>> fast-set live-vertices set ]
200 [ edges>> fast-set live-edges set ]
201 [ faces>> fast-set live-faces set ] tri
204 [ vertices>> [ check-vertex ] each ]
205 [ edges>> [ check-edge ] each ]
206 [ faces>> [ base-face? ] filter [ check-base-face ] each ] tri
210 : empty-b-rep? ( b-rep -- ? )
211 [ faces>> ] [ edges>> ] [ vertices>> ] tri
212 [ empty? ] tri@ and and ;
214 ERROR: b-rep-not-empty b-rep ;
216 : assert-empty-b-rep ( b-rep -- )
217 dup empty-b-rep? [ drop ] [ b-rep-not-empty ] if ;
219 : is-valid-edge? ( e brep -- ? )
220 edges>> member? ; inline
222 : edge-endpoints ( edge -- from to )
223 [ vertex>> position>> ]
224 [ opposite-edge>> vertex>> position>> ] bi ; inline
226 :: connecting-edge ( e0 e1 -- edge/f )
227 e1 vertex>> :> target-vertex
228 e0 vertex>> target-vertex eq? [ f ] [
230 edge opposite-edge>> vertex>> target-vertex eq?
232 [ f edge vertex-cw dup e0 eq? not ] if