--- /dev/null
+USING: accessors euler.b-rep euler.modeling euler.operators\r
+euler.b-rep.examples kernel locals math.vectors.simd.cords\r
+namespaces sequences tools.test ;\r
+IN: euler.b-rep.tests\r
+\r
+[ double-4{ 0.0 0.0 -1.0 0.0 } ]\r
+[ valid-cube-b-rep edges>> first face-normal ] unit-test\r
+\r
+[ double-4{ 0.0 0.0 -1.0 0.0 } -1.0 ]\r
+[ valid-cube-b-rep edges>> first face-plane ] unit-test\r
+\r
+[ t ] [ 0 multi-ringed-face-cube-b-rep faces>> nth base-face? ] unit-test\r
+[ t ] [ 5 multi-ringed-face-cube-b-rep faces>> nth base-face? ] unit-test\r
+[ f ] [ 6 multi-ringed-face-cube-b-rep faces>> nth base-face? ] unit-test\r
+\r
+:: mock-face ( p0 p1 p2 -- edge )\r
+ b-edge new vertex new p0 >>position >>vertex :> e0\r
+ b-edge new vertex new p1 >>position >>vertex :> e1\r
+ b-edge new vertex new p2 >>position >>vertex :> e2\r
+\r
+ e1 e0 next-edge<<\r
+ e2 e1 next-edge<<\r
+ e0 e2 next-edge<<\r
+ \r
+ e0 ;\r
+\r
+[\r
+ double-4{\r
+ HEX: 1.279a74590331dp-1\r
+ HEX: 1.279a74590331dp-1\r
+ HEX: 1.279a74590331dp-1\r
+ 0.0\r
+ }\r
+ HEX: -1.bb67ae8584cabp1\r
+] [\r
+ double-4{ 1 0 5 0 }\r
+ double-4{ 0 1 5 0 }\r
+ double-4{ 0 0 6 0 } mock-face face-plane\r
+] unit-test\r
+\r
+V{ t } clone sharpness-stack [\r
+ [ t ] [ get-sharpness ] unit-test\r
+ [ V{ f } ] [ f set-sharpness sharpness-stack get ] unit-test\r
+ [ V{ f t } t ] [ t push-sharpness sharpness-stack get get-sharpness ] unit-test\r
+ [ t V{ f } f ] [ pop-sharpness sharpness-stack get get-sharpness ] unit-test\r
+] with-variable\r
+\r
+[ t ] [ valid-cube-b-rep [ edges>> first ] keep is-valid-edge? ] unit-test\r
+[ f ] [ b-edge new valid-cube-b-rep is-valid-edge? ] unit-test\r
+\r
+[ t ] [\r
+ valid-cube-b-rep edges>>\r
+ [ [ 0 swap nth ] [ 1 swap nth ] bi connecting-edge ]\r
+ [ 0 swap nth ] bi eq?\r
+] unit-test\r
+\r
+[ t ] [\r
+ valid-cube-b-rep edges>>\r
+ [ [ 1 swap nth ] [ 0 swap nth ] bi connecting-edge ]\r
+ [ 6 swap nth ] bi eq?\r
+] unit-test\r
+\r
+[ t ] [\r
+ valid-cube-b-rep edges>>\r
+ [ [ 0 swap nth ] [ 3 swap nth ] bi connecting-edge ]\r
+ [ 21 swap nth ] bi eq?\r
+] unit-test\r
+\r
+[ f ] [\r
+ valid-cube-b-rep edges>>\r
+ [ 0 swap nth ] [ 2 swap nth ] bi connecting-edge\r
+] unit-test\r
+\r
+[ double-4{ 0 0 -1 0 } ] [\r
+ [\r
+ { double-4{ 0 0 0 0 } double-4{ 0 1 0 0 } double-4{ 0 2 0 0 } double-4{ 1 1 0 0 } }\r
+ smooth-smooth polygon>double-face face-normal\r
+ ] make-b-rep drop\r
+] unit-test\r
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+USING: accessors fry kernel locals sequences sets namespaces
+combinators combinators.short-circuit game.models.half-edge
+math math.vectors math.matrices assocs arrays hashtables ;
+FROM: namespaces => set ;
+IN: euler.b-rep
+
+: >index-hash ( seq -- hash ) [ 2array ] map-index >hashtable ; inline
+
+TUPLE: b-edge < edge sharpness macro ;
+
+TUPLE: vertex < identity-tuple position edge ;
+
+TUPLE: face < identity-tuple edge next-ring base-face ;
+
+:: (opposite) ( e1 e2 quot: ( edge -- edge' ) -- edge )
+ e1 quot call :> e0
+ e0 e2 eq? [ e1 ] [ e0 e2 quot (opposite) ] if ;
+ inline recursive
+
+: opposite ( edge quot: ( edge -- edge' ) -- edge )
+ dupd (opposite) ; inline
+
+: face-ccw ( edge -- edge ) next-edge>> ; inline
+
+: face-cw ( edge -- edge ) [ face-ccw ] opposite ; inline
+
+: vertex-cw ( edge -- edge ) opposite-edge>> next-edge>> ; inline
+
+: vertex-ccw ( edge -- edge ) [ vertex-cw ] opposite ; inline
+
+: base-face? ( face -- ? ) dup base-face>> eq? ; inline
+
+: has-rings? ( face -- ? ) next-ring>> >boolean ; inline
+
+: incident? ( e1 e2 -- ? ) [ vertex>> ] bi@ eq? ; inline
+
+TUPLE: b-rep < identity-tuple faces edges vertices ;
+
+: <b-rep> ( -- b-rep )
+ V{ } clone V{ } clone V{ } clone b-rep boa ;
+
+SYMBOL: sharpness-stack
+sharpness-stack [ V{ t } ] initialize
+
+: set-sharpness ( sharp? -- ) >boolean sharpness-stack get set-last ;
+: get-sharpness ( -- sharp? ) sharpness-stack get last ;
+
+: push-sharpness ( sharp? -- ) >boolean sharpness-stack get push ;
+: pop-sharpness ( -- sharp? )
+ sharpness-stack get
+ dup length 1 = [ first ] [ pop ] if ;
+
+: new-vertex ( position b-rep -- vertex )
+ [ f vertex boa dup ] dip vertices>> push ; inline
+
+: new-edge ( b-rep -- edge )
+ [ b-edge new get-sharpness >>sharpness dup ] dip edges>> push ; inline
+
+: new-face ( b-rep -- face )
+ [ face new dup ] dip faces>> push ; inline
+
+: delete-vertex ( vertex b-rep -- )
+ vertices>> remove! drop ; inline
+
+: delete-edge ( edge b-rep -- )
+ edges>> remove! drop ; inline
+
+: delete-face ( face b-rep -- )
+ faces>> remove! drop ; inline
+
+: add-ring ( ring base-face -- )
+ [ >>base-face drop ]
+ [ next-ring>> >>next-ring drop ]
+ [ swap >>next-ring drop ]
+ 2tri ;
+
+: delete-ring ( ring base-face -- )
+ 2dup next-ring>> eq?
+ [ [ next-ring>> ] dip next-ring<< ]
+ [ next-ring>> delete-ring ]
+ if ;
+
+: vertex-pos ( edge -- pos )
+ vertex>> position>> ; inline
+
+: same-edge? ( e1 e2 -- ? )
+ { [ eq? ] [ opposite-edge>> eq? ] } 2|| ;
+
+: same-face? ( e1 e2 -- ? )
+ [ face>> ] bi@ eq? ;
+
+: edge-direction ( edge -- v )
+ [ face-ccw ] keep [ vertex-pos ] bi@ v- ;
+
+: normal ( v0 v1 v2 -- v )
+ [ drop v- ] [ [ drop ] 2dip v- ] 3bi cross ;
+
+ERROR: all-points-colinear ;
+
+: face-normal ( edge -- n )
+ face-edges
+ [
+ dup face-ccw dup face-ccw
+ [ vertex-pos ] tri@ normal
+ ] map
+ [ [ zero? ] all? not ] find nip
+ [ normalize ] [ all-points-colinear ] if* ;
+
+: (face-plane-dist) ( normal edge -- d )
+ vertex-pos v. neg ; inline
+
+: face-plane-dist ( edge -- d )
+ [ face-normal ] [ (face-plane-dist) ] bi ; inline
+
+: face-plane ( edge -- n d )
+ [ face-normal dup ] [ (face-plane-dist) ] bi ; inline
+
+: face-midpoint ( edge -- v )
+ face-edges
+ [ [ vertex-pos ] [ v+ ] map-reduce ] [ length ] bi v/n ;
+
+: clear-b-rep ( b-rep -- )
+ [ faces>> delete-all ]
+ [ edges>> delete-all ]
+ [ vertices>> delete-all ]
+ tri ;
+
+: connect-opposite-edges ( b-rep -- )
+ edges>>
+ [ [ [ next-edge>> vertex>> ] [ vertex>> 2array ] [ ] tri ] H{ } map>assoc ]
+ [ swap '[ [ vertex>> ] [ next-edge>> vertex>> 2array _ at ] [ opposite-edge<< ] tri ] each ] bi ;
+
+: connect-faces ( b-rep -- )
+ edges>> [ dup face>> edge<< ] each ;
+
+: connect-vertices ( b-rep -- )
+ edges>> [ dup vertex>> edge<< ] each ;
+
+: finish-b-rep ( b-rep -- )
+ [ connect-faces ] [ connect-vertices ] bi ;
+
+: characteristic ( b-rep -- n )
+ ! Assumes b-rep is connected and all faces are convex
+ [ vertices>> length ]
+ [ edges>> length 2 / ]
+ [ faces>> [ base-face? ] count ] tri
+ [ - ] dip + ;
+
+: genus ( b-rep -- n )
+ ! Assumes b-rep is connected and all faces are convex
+ characteristic 2 swap - 2 / ;
+
+SYMBOLS: live-vertices live-edges live-faces ;
+
+ERROR: dead-vertex vertex ;
+
+: check-live-vertex ( vertex -- )
+ dup live-vertices get in? [ drop ] [ dead-vertex ] if ;
+
+ERROR: dead-edge edge ;
+
+: check-live-edge ( edge -- )
+ dup live-edges get in? [ drop ] [ dead-edge ] if ;
+
+ERROR: dead-face face ;
+
+: check-live-face ( face -- )
+ dup live-faces get in? [ drop ] [ dead-face ] if ;
+
+: check-vertex ( vertex -- )
+ [ edge>> check-live-edge ]
+ [ dup edge>> [ vertex>> assert= ] with each-vertex-edge ]
+ bi ;
+
+: check-edge ( edge -- )
+ {
+ [ vertex>> check-live-vertex ]
+ [ opposite-edge>> check-live-edge ]
+ [ face>> check-live-face ]
+ [ dup opposite-edge>> opposite-edge>> assert= ]
+ } cleave ;
+
+: check-face ( face -- )
+ [ edge>> check-live-edge ]
+ [ dup edge>> [ face>> assert= ] with each-face-edge ]
+ bi ;
+
+: check-ring ( base-face face -- )
+ [ check-face ] [ base-face>> assert= ] bi ;
+
+: check-base-face ( face -- )
+ [ check-face ]
+ [ dup [ next-ring>> ] follow rest [ check-ring ] with each ] bi ;
+
+: check-b-rep ( b-rep -- )
+ [
+ [
+ [ vertices>> fast-set live-vertices set ]
+ [ edges>> fast-set live-edges set ]
+ [ faces>> fast-set live-faces set ] tri
+ ]
+ [
+ [ vertices>> [ check-vertex ] each ]
+ [ edges>> [ check-edge ] each ]
+ [ faces>> [ base-face? ] filter [ check-base-face ] each ] tri
+ ] bi
+ ] with-scope ;
+
+: empty-b-rep? ( b-rep -- ? )
+ [ faces>> ] [ edges>> ] [ vertices>> ] tri
+ [ empty? ] tri@ and and ;
+
+ERROR: b-rep-not-empty b-rep ;
+
+: assert-empty-b-rep ( b-rep -- )
+ dup empty-b-rep? [ drop ] [ b-rep-not-empty ] if ;
+
+: is-valid-edge? ( e brep -- ? )
+ edges>> member? ; inline
+
+: edge-endpoints ( edge -- from to )
+ [ vertex>> position>> ]
+ [ opposite-edge>> vertex>> position>> ] bi ; inline
+
+:: connecting-edge ( e0 e1 -- edge/f )
+ e1 vertex>> :> target-vertex
+ e0 vertex>> target-vertex eq? [ f ] [
+ f e0 [| ret edge |
+ edge opposite-edge>> vertex>> target-vertex eq?
+ [ edge edge f ]
+ [ f edge vertex-cw dup e0 eq? not ] if
+ ] loop drop
+ ] if ;
--- /dev/null
+USING: accessors assocs euler.b-rep game.models.half-edge
+kernel locals math.vectors.simd.cords sequences ;
+IN: euler.b-rep.examples
+
+CONSTANT: valid-cube-b-rep
+ T{ b-rep
+ { faces {
+ T{ face { edge 0 } { next-ring f } { base-face 0 } }
+ T{ face { edge 4 } { next-ring f } { base-face 1 } }
+ T{ face { edge 8 } { next-ring f } { base-face 2 } }
+ T{ face { edge 12 } { next-ring f } { base-face 3 } }
+ T{ face { edge 16 } { next-ring f } { base-face 4 } }
+ T{ face { edge 20 } { next-ring f } { base-face 5 } }
+ } }
+ { edges {
+ T{ b-edge { face 0 } { vertex 0 } { opposite-edge 6 } { next-edge 1 } }
+ T{ b-edge { face 0 } { vertex 1 } { opposite-edge 19 } { next-edge 2 } }
+ T{ b-edge { face 0 } { vertex 3 } { opposite-edge 12 } { next-edge 3 } }
+ T{ b-edge { face 0 } { vertex 2 } { opposite-edge 21 } { next-edge 0 } }
+
+ T{ b-edge { face 1 } { vertex 4 } { opposite-edge 10 } { next-edge 5 } }
+ T{ b-edge { face 1 } { vertex 5 } { opposite-edge 16 } { next-edge 6 } }
+ T{ b-edge { face 1 } { vertex 1 } { opposite-edge 0 } { next-edge 7 } }
+ T{ b-edge { face 1 } { vertex 0 } { opposite-edge 20 } { next-edge 4 } }
+
+ T{ b-edge { face 2 } { vertex 6 } { opposite-edge 14 } { next-edge 9 } }
+ T{ b-edge { face 2 } { vertex 7 } { opposite-edge 17 } { next-edge 10 } }
+ T{ b-edge { face 2 } { vertex 5 } { opposite-edge 4 } { next-edge 11 } }
+ T{ b-edge { face 2 } { vertex 4 } { opposite-edge 23 } { next-edge 8 } }
+
+ T{ b-edge { face 3 } { vertex 2 } { opposite-edge 2 } { next-edge 13 } }
+ T{ b-edge { face 3 } { vertex 3 } { opposite-edge 18 } { next-edge 14 } }
+ T{ b-edge { face 3 } { vertex 7 } { opposite-edge 8 } { next-edge 15 } }
+ T{ b-edge { face 3 } { vertex 6 } { opposite-edge 22 } { next-edge 12 } }
+
+ T{ b-edge { face 4 } { vertex 1 } { opposite-edge 5 } { next-edge 17 } }
+ T{ b-edge { face 4 } { vertex 5 } { opposite-edge 9 } { next-edge 18 } }
+ T{ b-edge { face 4 } { vertex 7 } { opposite-edge 13 } { next-edge 19 } }
+ T{ b-edge { face 4 } { vertex 3 } { opposite-edge 1 } { next-edge 16 } }
+
+ T{ b-edge { face 5 } { vertex 4 } { opposite-edge 7 } { next-edge 21 } }
+ T{ b-edge { face 5 } { vertex 0 } { opposite-edge 3 } { next-edge 22 } }
+ T{ b-edge { face 5 } { vertex 2 } { opposite-edge 15 } { next-edge 23 } }
+ T{ b-edge { face 5 } { vertex 6 } { opposite-edge 11 } { next-edge 20 } }
+ } }
+ { vertices {
+ T{ vertex { position double-4{ -1.0 -1.0 -1.0 0.0 } } { edge 0 } }
+ T{ vertex { position double-4{ -1.0 1.0 -1.0 0.0 } } { edge 1 } }
+ T{ vertex { position double-4{ 1.0 -1.0 -1.0 0.0 } } { edge 3 } }
+ T{ vertex { position double-4{ 1.0 1.0 -1.0 0.0 } } { edge 2 } }
+ T{ vertex { position double-4{ -1.0 -1.0 1.0 0.0 } } { edge 4 } }
+ T{ vertex { position double-4{ -1.0 1.0 1.0 0.0 } } { edge 5 } }
+ T{ vertex { position double-4{ 1.0 -1.0 1.0 0.0 } } { edge 8 } }
+ T{ vertex { position double-4{ 1.0 1.0 1.0 0.0 } } { edge 9 } }
+ } }
+ }
+
+CONSTANT: missing-face-cube-b-rep
+ T{ b-rep
+ { faces {
+ T{ face { edge 0 } { next-ring f } { base-face 0 } }
+ T{ face { edge 4 } { next-ring f } { base-face 1 } }
+ T{ face { edge 8 } { next-ring f } { base-face 2 } }
+ T{ face { edge 12 } { next-ring f } { base-face 3 } }
+ T{ face { edge 16 } { next-ring f } { base-face 4 } }
+ } }
+ { edges {
+ T{ b-edge { face 0 } { vertex 0 } { opposite-edge 6 } { next-edge 1 } }
+ T{ b-edge { face 0 } { vertex 1 } { opposite-edge 19 } { next-edge 2 } }
+ T{ b-edge { face 0 } { vertex 3 } { opposite-edge 12 } { next-edge 3 } }
+ T{ b-edge { face 0 } { vertex 2 } { opposite-edge f } { next-edge 0 } }
+
+ T{ b-edge { face 1 } { vertex 4 } { opposite-edge 10 } { next-edge 5 } }
+ T{ b-edge { face 1 } { vertex 5 } { opposite-edge 16 } { next-edge 6 } }
+ T{ b-edge { face 1 } { vertex 1 } { opposite-edge 0 } { next-edge 7 } }
+ T{ b-edge { face 1 } { vertex 0 } { opposite-edge f } { next-edge 4 } }
+
+ T{ b-edge { face 2 } { vertex 6 } { opposite-edge 14 } { next-edge 9 } }
+ T{ b-edge { face 2 } { vertex 7 } { opposite-edge 17 } { next-edge 10 } }
+ T{ b-edge { face 2 } { vertex 5 } { opposite-edge 4 } { next-edge 11 } }
+ T{ b-edge { face 2 } { vertex 4 } { opposite-edge f } { next-edge 8 } }
+
+ T{ b-edge { face 3 } { vertex 2 } { opposite-edge 2 } { next-edge 13 } }
+ T{ b-edge { face 3 } { vertex 3 } { opposite-edge f } { next-edge 14 } }
+ T{ b-edge { face 3 } { vertex 7 } { opposite-edge 8 } { next-edge 15 } }
+ T{ b-edge { face 3 } { vertex 6 } { opposite-edge 18 } { next-edge 12 } }
+
+ T{ b-edge { face 4 } { vertex 1 } { opposite-edge 5 } { next-edge 17 } }
+ T{ b-edge { face 4 } { vertex 5 } { opposite-edge 9 } { next-edge 18 } }
+ T{ b-edge { face 4 } { vertex 7 } { opposite-edge 13 } { next-edge 19 } }
+ T{ b-edge { face 4 } { vertex 3 } { opposite-edge 1 } { next-edge 16 } }
+ } }
+ { vertices {
+ T{ vertex { position double-4{ -1.0 -1.0 -1.0 0.0 } } { edge 0 } }
+ T{ vertex { position double-4{ -1.0 1.0 -1.0 0.0 } } { edge 1 } }
+ T{ vertex { position double-4{ 1.0 1.0 -1.0 0.0 } } { edge 3 } }
+ T{ vertex { position double-4{ 1.0 1.0 -1.0 0.0 } } { edge 2 } }
+ T{ vertex { position double-4{ -1.0 -1.0 1.0 0.0 } } { edge 4 } }
+ T{ vertex { position double-4{ -1.0 1.0 1.0 0.0 } } { edge 5 } }
+ T{ vertex { position double-4{ 1.0 1.0 1.0 0.0 } } { edge 8 } }
+ T{ vertex { position double-4{ 1.0 1.0 1.0 0.0 } } { edge 9 } }
+ } }
+ }
+
+CONSTANT: non-quad-face-cube-b-rep
+ T{ b-rep
+ { faces {
+ T{ face { edge 0 } { next-ring f } { base-face 0 } }
+ T{ face { edge 4 } { next-ring f } { base-face 1 } }
+ T{ face { edge 8 } { next-ring f } { base-face 2 } }
+ T{ face { edge 12 } { next-ring f } { base-face 3 } }
+ T{ face { edge 18 } { next-ring f } { base-face 4 } }
+ } }
+ { edges {
+ T{ b-edge { face 0 } { vertex 0 } { opposite-edge 6 } { next-edge 1 } }
+ T{ b-edge { face 0 } { vertex 1 } { opposite-edge 19 } { next-edge 2 } }
+ T{ b-edge { face 0 } { vertex 3 } { opposite-edge 12 } { next-edge 3 } }
+ T{ b-edge { face 0 } { vertex 2 } { opposite-edge 19 } { next-edge 0 } }
+
+ T{ b-edge { face 1 } { vertex 4 } { opposite-edge 10 } { next-edge 5 } }
+ T{ b-edge { face 1 } { vertex 5 } { opposite-edge 16 } { next-edge 6 } }
+ T{ b-edge { face 1 } { vertex 1 } { opposite-edge 0 } { next-edge 7 } }
+ T{ b-edge { face 1 } { vertex 0 } { opposite-edge 18 } { next-edge 4 } }
+
+ T{ b-edge { face 2 } { vertex 6 } { opposite-edge 14 } { next-edge 9 } }
+ T{ b-edge { face 2 } { vertex 7 } { opposite-edge 17 } { next-edge 10 } }
+ T{ b-edge { face 2 } { vertex 5 } { opposite-edge 4 } { next-edge 11 } }
+ T{ b-edge { face 2 } { vertex 4 } { opposite-edge 21 } { next-edge 8 } }
+
+ T{ b-edge { face 3 } { vertex 2 } { opposite-edge 2 } { next-edge 13 } }
+ T{ b-edge { face 3 } { vertex 3 } { opposite-edge 20 } { next-edge 16 } }
+ T{ b-edge { face 3 } { vertex 7 } { opposite-edge 8 } { next-edge 15 } }
+ T{ b-edge { face 3 } { vertex 6 } { opposite-edge 18 } { next-edge 12 } }
+ T{ b-edge { face 3 } { vertex 1 } { opposite-edge 5 } { next-edge 17 } }
+ T{ b-edge { face 3 } { vertex 5 } { opposite-edge 9 } { next-edge 14 } }
+
+ T{ b-edge { face 4 } { vertex 4 } { opposite-edge 7 } { next-edge 19 } }
+ T{ b-edge { face 4 } { vertex 0 } { opposite-edge 3 } { next-edge 20 } }
+ T{ b-edge { face 4 } { vertex 2 } { opposite-edge 15 } { next-edge 21 } }
+ T{ b-edge { face 4 } { vertex 6 } { opposite-edge 11 } { next-edge 18 } }
+ } }
+ { vertices {
+ T{ vertex { position double-4{ -1.0 -1.0 -1.0 0.0 } } { edge 0 } }
+ T{ vertex { position double-4{ -1.0 1.0 -1.0 0.0 } } { edge 1 } }
+ T{ vertex { position double-4{ 1.0 1.0 -1.0 0.0 } } { edge 3 } }
+ T{ vertex { position double-4{ 1.0 1.0 -1.0 0.0 } } { edge 2 } }
+ T{ vertex { position double-4{ -1.0 -1.0 1.0 0.0 } } { edge 4 } }
+ T{ vertex { position double-4{ -1.0 1.0 1.0 0.0 } } { edge 5 } }
+ T{ vertex { position double-4{ 1.0 1.0 1.0 0.0 } } { edge 8 } }
+ T{ vertex { position double-4{ 1.0 1.0 1.0 0.0 } } { edge 9 } }
+ } }
+ }
+
+CONSTANT: multi-ringed-face-cube-b-rep
+ T{ b-rep
+ { faces {
+ T{ face { edge 0 } { next-ring f } { base-face 0 } }
+ T{ face { edge 4 } { next-ring f } { base-face 1 } }
+ T{ face { edge 8 } { next-ring f } { base-face 2 } }
+ T{ face { edge 12 } { next-ring f } { base-face 3 } }
+ T{ face { edge 16 } { next-ring f } { base-face 4 } }
+ T{ face { edge 20 } { next-ring 6 } { base-face 5 } }
+ T{ face { edge 24 } { next-ring f } { base-face 5 } }
+ } }
+ { edges {
+ T{ b-edge { face 0 } { vertex 0 } { opposite-edge 6 } { next-edge 1 } }
+ T{ b-edge { face 0 } { vertex 1 } { opposite-edge 19 } { next-edge 2 } }
+ T{ b-edge { face 0 } { vertex 3 } { opposite-edge 12 } { next-edge 3 } }
+ T{ b-edge { face 0 } { vertex 2 } { opposite-edge 21 } { next-edge 0 } }
+
+ T{ b-edge { face 1 } { vertex 4 } { opposite-edge 10 } { next-edge 5 } }
+ T{ b-edge { face 1 } { vertex 5 } { opposite-edge 16 } { next-edge 6 } }
+ T{ b-edge { face 1 } { vertex 1 } { opposite-edge 0 } { next-edge 7 } }
+ T{ b-edge { face 1 } { vertex 0 } { opposite-edge 20 } { next-edge 4 } }
+
+ T{ b-edge { face 2 } { vertex 6 } { opposite-edge 14 } { next-edge 9 } }
+ T{ b-edge { face 2 } { vertex 7 } { opposite-edge 17 } { next-edge 10 } }
+ T{ b-edge { face 2 } { vertex 5 } { opposite-edge 4 } { next-edge 11 } }
+ T{ b-edge { face 2 } { vertex 4 } { opposite-edge 23 } { next-edge 8 } }
+
+ T{ b-edge { face 3 } { vertex 2 } { opposite-edge 2 } { next-edge 13 } }
+ T{ b-edge { face 3 } { vertex 3 } { opposite-edge 22 } { next-edge 14 } }
+ T{ b-edge { face 3 } { vertex 7 } { opposite-edge 8 } { next-edge 15 } }
+ T{ b-edge { face 3 } { vertex 6 } { opposite-edge 18 } { next-edge 12 } }
+
+ T{ b-edge { face 4 } { vertex 1 } { opposite-edge 5 } { next-edge 17 } }
+ T{ b-edge { face 4 } { vertex 5 } { opposite-edge 9 } { next-edge 18 } }
+ T{ b-edge { face 4 } { vertex 7 } { opposite-edge 13 } { next-edge 19 } }
+ T{ b-edge { face 4 } { vertex 3 } { opposite-edge 1 } { next-edge 16 } }
+
+ T{ b-edge { face 5 } { vertex 4 } { opposite-edge 7 } { next-edge 21 } }
+ T{ b-edge { face 5 } { vertex 0 } { opposite-edge 3 } { next-edge 22 } }
+ T{ b-edge { face 5 } { vertex 2 } { opposite-edge 15 } { next-edge 23 } }
+ T{ b-edge { face 5 } { vertex 6 } { opposite-edge 11 } { next-edge 20 } }
+
+ T{ b-edge { face 6 } { vertex 8 } { opposite-edge f } { next-edge 25 } }
+ T{ b-edge { face 6 } { vertex 9 } { opposite-edge f } { next-edge 26 } }
+ T{ b-edge { face 6 } { vertex 10 } { opposite-edge f } { next-edge 27 } }
+ T{ b-edge { face 6 } { vertex 11 } { opposite-edge f } { next-edge 24 } }
+ } }
+ { vertices {
+ T{ vertex { position double-4{ -1.0 -1.0 -1.0 0.0 } } { edge 0 } }
+ T{ vertex { position double-4{ -1.0 1.0 -1.0 0.0 } } { edge 1 } }
+ T{ vertex { position double-4{ 1.0 1.0 -1.0 0.0 } } { edge 3 } }
+ T{ vertex { position double-4{ 1.0 1.0 -1.0 0.0 } } { edge 2 } }
+ T{ vertex { position double-4{ -1.0 -1.0 1.0 0.0 } } { edge 4 } }
+ T{ vertex { position double-4{ -1.0 1.0 1.0 0.0 } } { edge 5 } }
+ T{ vertex { position double-4{ 1.0 1.0 1.0 0.0 } } { edge 8 } }
+ T{ vertex { position double-4{ 1.0 1.0 1.0 0.0 } } { edge 9 } }
+
+ T{ vertex { position double-4{ -1.0 -1.0 0.5 0.0 } } { edge 24 } }
+ T{ vertex { position double-4{ -1.0 -1.0 -0.5 0.0 } } { edge 25 } }
+ T{ vertex { position double-4{ 1.0 1.0 -0.5 0.0 } } { edge 26 } }
+ T{ vertex { position double-4{ 1.0 1.0 0.5 0.0 } } { edge 27 } }
+ } }
+ }
+
+CONSTANT: valid-multi-valence-b-rep
+ T{ b-rep
+ { edges {
+ T{ b-edge { face 0 } { vertex 23 } { opposite-edge 12 } { next-edge 1 } }
+ T{ b-edge { face 0 } { vertex 22 } { opposite-edge 8 } { next-edge 2 } }
+ T{ b-edge { face 0 } { vertex 20 } { opposite-edge 4 } { next-edge 3 } }
+ T{ b-edge { face 0 } { vertex 21 } { opposite-edge 16 } { next-edge 0 } }
+
+ T{ b-edge { face 1 } { vertex 21 } { opposite-edge 2 } { next-edge 5 } }
+ T{ b-edge { face 1 } { vertex 20 } { opposite-edge 11 } { next-edge 6 } }
+ T{ b-edge { face 1 } { vertex 16 } { opposite-edge 20 } { next-edge 7 } }
+ T{ b-edge { face 1 } { vertex 17 } { opposite-edge 17 } { next-edge 4 } }
+
+ T{ b-edge { face 2 } { vertex 20 } { opposite-edge 1 } { next-edge 9 } }
+ T{ b-edge { face 2 } { vertex 22 } { opposite-edge 15 } { next-edge 10 } }
+ T{ b-edge { face 2 } { vertex 18 } { opposite-edge 24 } { next-edge 11 } }
+ T{ b-edge { face 2 } { vertex 16 } { opposite-edge 5 } { next-edge 8 } }
+
+ T{ b-edge { face 3 } { vertex 22 } { opposite-edge 0 } { next-edge 13 } }
+ T{ b-edge { face 3 } { vertex 23 } { opposite-edge 19 } { next-edge 14 } }
+ T{ b-edge { face 3 } { vertex 19 } { opposite-edge 28 } { next-edge 15 } }
+ T{ b-edge { face 3 } { vertex 18 } { opposite-edge 9 } { next-edge 12 } }
+
+ T{ b-edge { face 4 } { vertex 23 } { opposite-edge 3 } { next-edge 17 } }
+ T{ b-edge { face 4 } { vertex 21 } { opposite-edge 7 } { next-edge 18 } }
+ T{ b-edge { face 4 } { vertex 17 } { opposite-edge 32 } { next-edge 19 } }
+ T{ b-edge { face 4 } { vertex 19 } { opposite-edge 13 } { next-edge 16 } }
+
+ T{ b-edge { face 5 } { vertex 17 } { opposite-edge 6 } { next-edge 21 } }
+ T{ b-edge { face 5 } { vertex 16 } { opposite-edge 27 } { next-edge 22 } }
+ T{ b-edge { face 5 } { vertex 0 } { opposite-edge 36 } { next-edge 23 } }
+ T{ b-edge { face 5 } { vertex 1 } { opposite-edge 33 } { next-edge 20 } }
+
+ T{ b-edge { face 6 } { vertex 16 } { opposite-edge 10 } { next-edge 25 } }
+ T{ b-edge { face 6 } { vertex 18 } { opposite-edge 31 } { next-edge 26 } }
+ T{ b-edge { face 6 } { vertex 2 } { opposite-edge 44 } { next-edge 27 } }
+ T{ b-edge { face 6 } { vertex 0 } { opposite-edge 21 } { next-edge 24 } }
+
+ T{ b-edge { face 7 } { vertex 18 } { opposite-edge 14 } { next-edge 29 } }
+ T{ b-edge { face 7 } { vertex 19 } { opposite-edge 35 } { next-edge 30 } }
+ T{ b-edge { face 7 } { vertex 3 } { opposite-edge 52 } { next-edge 31 } }
+ T{ b-edge { face 7 } { vertex 2 } { opposite-edge 25 } { next-edge 28 } }
+
+ T{ b-edge { face 8 } { vertex 19 } { opposite-edge 18 } { next-edge 33 } }
+ T{ b-edge { face 8 } { vertex 17 } { opposite-edge 23 } { next-edge 34 } }
+ T{ b-edge { face 8 } { vertex 1 } { opposite-edge 60 } { next-edge 35 } }
+ T{ b-edge { face 8 } { vertex 3 } { opposite-edge 29 } { next-edge 32 } }
+
+ T{ b-edge { face 9 } { vertex 1 } { opposite-edge 22 } { next-edge 37 } }
+ T{ b-edge { face 9 } { vertex 0 } { opposite-edge 43 } { next-edge 38 } }
+ T{ b-edge { face 9 } { vertex 8 } { opposite-edge 68 } { next-edge 39 } }
+ T{ b-edge { face 9 } { vertex 9 } { opposite-edge 65 } { next-edge 36 } }
+
+ T{ b-edge { face 10 } { vertex 0 } { opposite-edge 47 } { next-edge 41 } }
+ T{ b-edge { face 10 } { vertex 10 } { opposite-edge 73 } { next-edge 42 } }
+ T{ b-edge { face 10 } { vertex 24 } { opposite-edge 72 } { next-edge 43 } }
+ T{ b-edge { face 10 } { vertex 8 } { opposite-edge 37 } { next-edge 40 } }
+
+ T{ b-edge { face 11 } { vertex 0 } { opposite-edge 26 } { next-edge 45 } }
+ T{ b-edge { face 11 } { vertex 2 } { opposite-edge 51 } { next-edge 46 } }
+ T{ b-edge { face 11 } { vertex 12 } { opposite-edge 76 } { next-edge 47 } }
+ T{ b-edge { face 11 } { vertex 10 } { opposite-edge 40 } { next-edge 44 } }
+
+ T{ b-edge { face 12 } { vertex 2 } { opposite-edge 55 } { next-edge 49 } }
+ T{ b-edge { face 12 } { vertex 14 } { opposite-edge 81 } { next-edge 50 } }
+ T{ b-edge { face 12 } { vertex 26 } { opposite-edge 80 } { next-edge 51 } }
+ T{ b-edge { face 12 } { vertex 12 } { opposite-edge 45 } { next-edge 48 } }
+
+ T{ b-edge { face 13 } { vertex 2 } { opposite-edge 30 } { next-edge 53 } }
+ T{ b-edge { face 13 } { vertex 3 } { opposite-edge 59 } { next-edge 54 } }
+ T{ b-edge { face 13 } { vertex 15 } { opposite-edge 84 } { next-edge 55 } }
+ T{ b-edge { face 13 } { vertex 14 } { opposite-edge 48 } { next-edge 52 } }
+
+ T{ b-edge { face 14 } { vertex 3 } { opposite-edge 63 } { next-edge 57 } }
+ T{ b-edge { face 14 } { vertex 13 } { opposite-edge 89 } { next-edge 58 } }
+ T{ b-edge { face 14 } { vertex 27 } { opposite-edge 88 } { next-edge 59 } }
+ T{ b-edge { face 14 } { vertex 15 } { opposite-edge 53 } { next-edge 56 } }
+
+ T{ b-edge { face 15 } { vertex 3 } { opposite-edge 34 } { next-edge 61 } }
+ T{ b-edge { face 15 } { vertex 1 } { opposite-edge 64 } { next-edge 62 } }
+ T{ b-edge { face 15 } { vertex 11 } { opposite-edge 92 } { next-edge 63 } }
+ T{ b-edge { face 15 } { vertex 13 } { opposite-edge 56 } { next-edge 60 } }
+
+ T{ b-edge { face 16 } { vertex 11 } { opposite-edge 61 } { next-edge 65 } }
+ T{ b-edge { face 16 } { vertex 1 } { opposite-edge 39 } { next-edge 66 } }
+ T{ b-edge { face 16 } { vertex 9 } { opposite-edge 97 } { next-edge 67 } }
+ T{ b-edge { face 16 } { vertex 25 } { opposite-edge 96 } { next-edge 64 } }
+
+ T{ b-edge { face 17 } { vertex 9 } { opposite-edge 38 } { next-edge 69 } }
+ T{ b-edge { face 17 } { vertex 8 } { opposite-edge 75 } { next-edge 70 } }
+ T{ b-edge { face 17 } { vertex 4 } { opposite-edge 102 } { next-edge 71 } }
+ T{ b-edge { face 17 } { vertex 5 } { opposite-edge 98 } { next-edge 68 } }
+
+ T{ b-edge { face 18 } { vertex 8 } { opposite-edge 42 } { next-edge 73 } }
+ T{ b-edge { face 18 } { vertex 24 } { opposite-edge 41 } { next-edge 74 } }
+ T{ b-edge { face 18 } { vertex 10 } { opposite-edge 79 } { next-edge 75 } }
+ T{ b-edge { face 18 } { vertex 4 } { opposite-edge 69 } { next-edge 72 } }
+
+ T{ b-edge { face 19 } { vertex 10 } { opposite-edge 46 } { next-edge 77 } }
+ T{ b-edge { face 19 } { vertex 12 } { opposite-edge 83 } { next-edge 78 } }
+ T{ b-edge { face 19 } { vertex 6 } { opposite-edge 103 } { next-edge 79 } }
+ T{ b-edge { face 19 } { vertex 4 } { opposite-edge 74 } { next-edge 76 } }
+
+ T{ b-edge { face 20 } { vertex 12 } { opposite-edge 50 } { next-edge 81 } }
+ T{ b-edge { face 20 } { vertex 26 } { opposite-edge 49 } { next-edge 82 } }
+ T{ b-edge { face 20 } { vertex 14 } { opposite-edge 87 } { next-edge 83 } }
+ T{ b-edge { face 20 } { vertex 6 } { opposite-edge 77 } { next-edge 80 } }
+
+ T{ b-edge { face 21 } { vertex 14 } { opposite-edge 54 } { next-edge 85 } }
+ T{ b-edge { face 21 } { vertex 15 } { opposite-edge 91 } { next-edge 86 } }
+ T{ b-edge { face 21 } { vertex 7 } { opposite-edge 100 } { next-edge 87 } }
+ T{ b-edge { face 21 } { vertex 6 } { opposite-edge 82 } { next-edge 84 } }
+
+ T{ b-edge { face 22 } { vertex 15 } { opposite-edge 58 } { next-edge 89 } }
+ T{ b-edge { face 22 } { vertex 27 } { opposite-edge 57 } { next-edge 90 } }
+ T{ b-edge { face 22 } { vertex 13 } { opposite-edge 95 } { next-edge 91 } }
+ T{ b-edge { face 22 } { vertex 7 } { opposite-edge 85 } { next-edge 88 } }
+
+ T{ b-edge { face 23 } { vertex 13 } { opposite-edge 62 } { next-edge 93 } }
+ T{ b-edge { face 23 } { vertex 11 } { opposite-edge 99 } { next-edge 94 } }
+ T{ b-edge { face 23 } { vertex 5 } { opposite-edge 101 } { next-edge 95 } }
+ T{ b-edge { face 23 } { vertex 7 } { opposite-edge 90 } { next-edge 92 } }
+
+ T{ b-edge { face 24 } { vertex 11 } { opposite-edge 67 } { next-edge 97 } }
+ T{ b-edge { face 24 } { vertex 25 } { opposite-edge 66 } { next-edge 98 } }
+ T{ b-edge { face 24 } { vertex 9 } { opposite-edge 71 } { next-edge 99 } }
+ T{ b-edge { face 24 } { vertex 5 } { opposite-edge 93 } { next-edge 96 } }
+
+ T{ b-edge { face 25 } { vertex 6 } { opposite-edge 86 } { next-edge 101 } }
+ T{ b-edge { face 25 } { vertex 7 } { opposite-edge 94 } { next-edge 102 } }
+ T{ b-edge { face 25 } { vertex 5 } { opposite-edge 70 } { next-edge 103 } }
+ T{ b-edge { face 25 } { vertex 4 } { opposite-edge 78 } { next-edge 100 } }
+ } }
+ { vertices {
+ T{ vertex { position double-4{ 1.0 1.0 1.0 0.0 } } { edge 37 } }
+ T{ vertex { position double-4{ 1.0 1.0 -1.0 0.0 } } { edge 36 } }
+ T{ vertex { position double-4{ 1.0 -1.0 1.0 0.0 } } { edge 52 } }
+ T{ vertex { position double-4{ 1.0 -1.0 -1.0 0.0 } } { edge 53 } }
+
+ T{ vertex { position double-4{ 3.0 1.0 1.0 0.0 } } { edge 70 } }
+ T{ vertex { position double-4{ 3.0 1.0 -1.0 0.0 } } { edge 71 } }
+ T{ vertex { position double-4{ 3.0 -1.0 1.0 0.0 } } { edge 87 } }
+ T{ vertex { position double-4{ 3.0 -1.0 -1.0 0.0 } } { edge 86 } }
+
+ T{ vertex { position double-4{ 2.0 2.0 1.0 0.0 } } { edge 38 } }
+ T{ vertex { position double-4{ 2.0 2.0 -1.0 0.0 } } { edge 39 } }
+ T{ vertex { position double-4{ 2.0 1.0 2.0 0.0 } } { edge 47 } }
+ T{ vertex { position double-4{ 2.0 1.0 -2.0 0.0 } } { edge 62 } }
+
+ T{ vertex { position double-4{ 2.0 -1.0 2.0 0.0 } } { edge 51 } }
+ T{ vertex { position double-4{ 2.0 -1.0 -2.0 0.0 } } { edge 57 } }
+ T{ vertex { position double-4{ 2.0 -2.0 1.0 0.0 } } { edge 55 } }
+ T{ vertex { position double-4{ 2.0 -2.0 -1.0 0.0 } } { edge 54 } }
+
+ T{ vertex { position double-4{ -1.0 1.0 1.0 0.0 } } { edge 6 } }
+ T{ vertex { position double-4{ -1.0 1.0 -1.0 0.0 } } { edge 7 } }
+ T{ vertex { position double-4{ -1.0 -1.0 1.0 0.0 } } { edge 15 } }
+ T{ vertex { position double-4{ -1.0 -1.0 -1.0 0.0 } } { edge 14 } }
+
+ T{ vertex { position double-4{ -2.0 1.0 1.0 0.0 } } { edge 2 } }
+ T{ vertex { position double-4{ -2.0 1.0 -1.0 0.0 } } { edge 3 } }
+ T{ vertex { position double-4{ -2.0 -1.0 1.0 0.0 } } { edge 1 } }
+ T{ vertex { position double-4{ -2.0 -1.0 -1.0 0.0 } } { edge 0 } }
+
+ T{ vertex { position double-4{ 2.0 2.0 2.0 0.0 } } { edge 42 } }
+ T{ vertex { position double-4{ 2.0 2.0 -2.0 0.0 } } { edge 67 } }
+ T{ vertex { position double-4{ 2.0 -2.0 2.0 0.0 } } { edge 50 } }
+ T{ vertex { position double-4{ 2.0 -2.0 -2.0 0.0 } } { edge 58 } }
+ } }
+ { faces {
+ T{ face { edge 0 } { next-ring f } { base-face 0 } }
+ T{ face { edge 4 } { next-ring f } { base-face 1 } }
+ T{ face { edge 8 } { next-ring f } { base-face 2 } }
+ T{ face { edge 12 } { next-ring f } { base-face 3 } }
+ T{ face { edge 16 } { next-ring f } { base-face 4 } }
+ T{ face { edge 20 } { next-ring f } { base-face 5 } }
+ T{ face { edge 24 } { next-ring f } { base-face 6 } }
+ T{ face { edge 28 } { next-ring f } { base-face 7 } }
+ T{ face { edge 32 } { next-ring f } { base-face 8 } }
+ T{ face { edge 36 } { next-ring f } { base-face 9 } }
+ T{ face { edge 40 } { next-ring f } { base-face 10 } }
+ T{ face { edge 44 } { next-ring f } { base-face 11 } }
+ T{ face { edge 48 } { next-ring f } { base-face 12 } }
+ T{ face { edge 52 } { next-ring f } { base-face 13 } }
+ T{ face { edge 56 } { next-ring f } { base-face 14 } }
+ T{ face { edge 60 } { next-ring f } { base-face 15 } }
+ T{ face { edge 64 } { next-ring f } { base-face 16 } }
+ T{ face { edge 68 } { next-ring f } { base-face 17 } }
+ T{ face { edge 72 } { next-ring f } { base-face 18 } }
+ T{ face { edge 76 } { next-ring f } { base-face 19 } }
+ T{ face { edge 80 } { next-ring f } { base-face 20 } }
+ T{ face { edge 84 } { next-ring f } { base-face 21 } }
+ T{ face { edge 88 } { next-ring f } { base-face 22 } }
+ T{ face { edge 92 } { next-ring f } { base-face 23 } }
+ T{ face { edge 96 } { next-ring f } { base-face 24 } }
+ T{ face { edge 100 } { next-ring f } { base-face 25 } }
+ } }
+ }
+
+CONSTANT: degenerate-incomplete-face
+ T{ b-rep
+ { edges {
+ T{ b-edge { face 0 } { vertex 0 } { opposite-edge 5 } { next-edge 1 } }
+ T{ b-edge { face 0 } { vertex 1 } { opposite-edge 4 } { next-edge 2 } }
+ T{ b-edge { face 0 } { vertex 2 } { opposite-edge 3 } { next-edge 3 } }
+ T{ b-edge { face 0 } { vertex 3 } { opposite-edge 2 } { next-edge 4 } }
+ T{ b-edge { face 0 } { vertex 2 } { opposite-edge 1 } { next-edge 5 } }
+ T{ b-edge { face 0 } { vertex 1 } { opposite-edge 0 } { next-edge 0 } }
+ } }
+ { vertices {
+ T{ vertex { position double-4{ -1 -1 0 0 } } { edge 0 } }
+ T{ vertex { position double-4{ 1 -1 0 0 } } { edge 1 } }
+ T{ vertex { position double-4{ 1 1 0 0 } } { edge 2 } }
+ T{ vertex { position double-4{ -1 1 0 0 } } { edge 3 } }
+ } }
+ { faces {
+ T{ face { edge 0 } { next-ring f } { base-face 0 } }
+ } }
+ }
+
+CONSTANT: partially-degenerate-second-face
+ T{ b-rep
+ { edges {
+ T{ b-edge { face 0 } { vertex 0 } { opposite-edge 6 } { next-edge 1 } }
+ T{ b-edge { face 0 } { vertex 1 } { opposite-edge 5 } { next-edge 2 } }
+ T{ b-edge { face 0 } { vertex 2 } { opposite-edge 4 } { next-edge 3 } }
+ T{ b-edge { face 0 } { vertex 3 } { opposite-edge 9 } { next-edge 0 } }
+
+ T{ b-edge { face 1 } { vertex 3 } { opposite-edge 2 } { next-edge 5 } }
+ T{ b-edge { face 1 } { vertex 2 } { opposite-edge 1 } { next-edge 6 } }
+ T{ b-edge { face 1 } { vertex 1 } { opposite-edge 0 } { next-edge 7 } }
+ T{ b-edge { face 1 } { vertex 0 } { opposite-edge 8 } { next-edge 8 } }
+ T{ b-edge { face 1 } { vertex 4 } { opposite-edge 7 } { next-edge 9 } }
+ T{ b-edge { face 1 } { vertex 0 } { opposite-edge 3 } { next-edge 4 } }
+ } }
+ { vertices {
+ T{ vertex { position double-4{ -1 -1 0 0 } } { edge 0 } }
+ T{ vertex { position double-4{ 1 -1 0 0 } } { edge 1 } }
+ T{ vertex { position double-4{ 1 1 0 0 } } { edge 2 } }
+ T{ vertex { position double-4{ -1 1 0 0 } } { edge 3 } }
+ T{ vertex { position double-4{ -2 -2 0 0 } } { edge 8 } }
+ } }
+ { faces {
+ T{ face { edge 0 } { next-ring f } { base-face 0 } }
+ T{ face { edge 4 } { next-ring f } { base-face 1 } }
+ } }
+ }
+
+: nth-when ( index/f seq -- elt/f )
+ over [ nth ] [ 2drop f ] if ; inline
+
+:: connect-b-rep ( b-rep -- )
+ b-rep faces>> [
+ [ b-rep edges>> nth-when ] change-edge
+ [ b-rep faces>> nth-when ] change-next-ring
+ [ b-rep faces>> nth-when ] change-base-face
+ drop
+ ] each
+
+ b-rep vertices>> [
+ [ b-rep edges>> nth-when ] change-edge
+ drop
+ ] each
+
+ b-rep edges>> [
+ [ b-rep faces>> nth-when ] change-face
+ [ b-rep vertices>> nth-when ] change-vertex
+ [ b-rep edges>> nth-when ] change-opposite-edge
+ [ b-rep edges>> nth-when ] change-next-edge
+ drop
+ ] each ;
+
+:: disconnect-b-rep ( b-rep -- )
+ b-rep faces>> >index-hash :> face-indices
+ b-rep edges>> >index-hash :> edge-indices
+ b-rep vertices>> >index-hash :> vertex-indices
+
+ b-rep faces>> [
+ [ edge-indices at ] change-edge
+ [ face-indices at ] change-next-ring
+ [ face-indices at ] change-base-face
+ drop
+ ] each
+
+ b-rep vertices>> [
+ [ edge-indices at ] change-edge
+ drop
+ ] each
+
+ b-rep edges>> [
+ [ face-indices at ] change-face
+ [ vertex-indices at ] change-vertex
+ [ edge-indices at ] change-opposite-edge
+ [ edge-indices at ] change-next-edge
+ drop
+ ] each ;
+
+valid-cube-b-rep connect-b-rep
+missing-face-cube-b-rep connect-b-rep
+non-quad-face-cube-b-rep connect-b-rep
+multi-ringed-face-cube-b-rep connect-b-rep
+valid-multi-valence-b-rep connect-b-rep
+degenerate-incomplete-face connect-b-rep
+partially-degenerate-second-face connect-b-rep
--- /dev/null
+! (c) 2010 Joe Groff bsd license
+USING: euler.b-rep euler.b-rep.examples euler.b-rep.io.obj
+io.streams.string literals math.vectors.simd.cords tools.test ;
+IN: euler.b-rep.io.obj.tests
+
+CONSTANT: valid-cube-obj
+"""v -1.0 -1.0 -1.0
+v -1.0 1.0 -1.0
+v 1.0 -1.0 -1.0
+v 1.0 1.0 -1.0
+v -1.0 -1.0 1.0
+v -1.0 1.0 1.0
+v 1.0 -1.0 1.0
+v 1.0 1.0 1.0
+f 1 2 4 3
+f 5 6 2 1
+f 7 8 6 5
+f 3 4 8 7
+f 2 6 8 4
+f 5 1 3 7
+"""
+
+CONSTANT: valid-cube-obj-relative-indices
+"""v -1.0 -1.0 -1.0
+v -1.0 1.0 -1.0
+v 1.0 -1.0 -1.0
+v 1.0 1.0 -1.0
+f -4 -3 -1 -2
+v -1.0 -1.0 1.0
+v -1.0 1.0 1.0
+v 1.0 -1.0 1.0
+v 1.0 1.0 1.0
+f -4 -3 -7 -8
+f 7 8 6 5
+f 3 4 8 7
+f 2 6 8 4
+f 5 1 3 7
+"""
+
+CONSTANT: valid-cube-obj-texcoords
+"""# comment should be ignored
+v -1.0 -1.0 -1.0
+v -1.0 1.0 -1.0
+v 1.0 -1.0 -1.0
+v 1.0 1.0 -1.0
+v -1.0 -1.0 1.0
+v -1.0 1.0 1.0
+v 1.0 -1.0 1.0
+v 1.0 1.0 1.0
+vt 0 0
+vt 0 1
+vt 1 0
+vt 1 1
+f 1/1 2/2 4/4 3/3
+f 5/1 6/2 2/2 1/1
+f 7/3 8/4 6/2 5/1
+f 3/3 4/4 8/4 7/3
+f 2/2 6/2 8/4 4/4
+f 5/1 1/1 3/3 7/3
+"""
+
+{ $ valid-cube-obj } [ [ valid-cube-b-rep write-obj ] with-string-writer ] unit-test
+
+{
+ V{
+ double-4{ -1.0 -1.0 -1.0 0.0 }
+ double-4{ -1.0 1.0 -1.0 0.0 }
+ double-4{ 1.0 -1.0 -1.0 0.0 }
+ double-4{ 1.0 1.0 -1.0 0.0 }
+ double-4{ -1.0 -1.0 1.0 0.0 }
+ double-4{ -1.0 1.0 1.0 0.0 }
+ double-4{ 1.0 -1.0 1.0 0.0 }
+ double-4{ 1.0 1.0 1.0 0.0 }
+ }
+ V{
+ { 0 1 3 2 }
+ { 4 5 1 0 }
+ { 6 7 5 4 }
+ { 2 3 7 6 }
+ { 1 5 7 3 }
+ { 4 0 2 6 }
+ }
+} [
+ valid-cube-obj [ (read-obj) ] with-string-reader
+] unit-test
+
+{
+ V{
+ double-4{ -1.0 -1.0 -1.0 0.0 }
+ double-4{ -1.0 1.0 -1.0 0.0 }
+ double-4{ 1.0 -1.0 -1.0 0.0 }
+ double-4{ 1.0 1.0 -1.0 0.0 }
+ double-4{ -1.0 -1.0 1.0 0.0 }
+ double-4{ -1.0 1.0 1.0 0.0 }
+ double-4{ 1.0 -1.0 1.0 0.0 }
+ double-4{ 1.0 1.0 1.0 0.0 }
+ }
+ V{
+ { 0 1 3 2 }
+ { 4 5 1 0 }
+ { 6 7 5 4 }
+ { 2 3 7 6 }
+ { 1 5 7 3 }
+ { 4 0 2 6 }
+ }
+} [
+ valid-cube-obj-relative-indices [ (read-obj) ] with-string-reader
+] unit-test
+
+{
+ V{
+ double-4{ -1.0 -1.0 -1.0 0.0 }
+ double-4{ -1.0 1.0 -1.0 0.0 }
+ double-4{ 1.0 -1.0 -1.0 0.0 }
+ double-4{ 1.0 1.0 -1.0 0.0 }
+ double-4{ -1.0 -1.0 1.0 0.0 }
+ double-4{ -1.0 1.0 1.0 0.0 }
+ double-4{ 1.0 -1.0 1.0 0.0 }
+ double-4{ 1.0 1.0 1.0 0.0 }
+ }
+ V{
+ { 0 1 3 2 }
+ { 4 5 1 0 }
+ { 6 7 5 4 }
+ { 2 3 7 6 }
+ { 1 5 7 3 }
+ { 4 0 2 6 }
+ }
+} [
+ valid-cube-obj-texcoords [ (read-obj) ] with-string-reader
+] unit-test
--- /dev/null
+! (c) 2010 Joe Groff bsd license
+USING: accessors assocs combinators euler.b-rep fry
+game.models.half-edge grouping io kernel locals math
+math.parser math.vectors.simd.cords sequences splitting ;
+IN: euler.b-rep.io.obj
+
+<PRIVATE
+: write-obj-vertex ( vertex -- )
+ "v " write
+ position>> 3 head-slice [ " " write ] [ number>string write ] interleave nl ;
+
+: write-obj-face ( face vx-indices -- )
+ "f" write
+ [ edge>> ] dip '[ " " write vertex>> _ at 1 + number>string write ] each-face-edge nl ;
+PRIVATE>
+
+:: write-obj ( b-rep -- )
+ b-rep vertices>> :> vertices
+ vertices >index-hash :> vx-indices
+
+ vertices [ write-obj-vertex ] each
+ b-rep faces>> [ vx-indices write-obj-face ] each ;
+
+<PRIVATE
+:: reconstruct-face ( face-vertices vertices -- face edges )
+ face new
+ dup >>base-face
+ :> face
+ face-vertices [
+ vertices nth :> vertex
+ b-edge new
+ vertex >>vertex
+ face >>face
+ :> edge
+ vertex [ [ edge ] unless* ] change-edge drop
+ edge
+ ] { } map-as :> edges
+
+ edges 1 edges length 1 + edges <circular-slice> [ >>next-edge drop ] 2each
+ face edges first >>edge
+ edges ;
+
+:: reconstruct-b-rep ( vertex-positions faces-vertices -- b-rep )
+ vertex-positions [ vertex new swap >>position ] { } map-as :> vertices
+ V{ } clone :> edges
+ faces-vertices [ vertices reconstruct-face edges push-all ] { } map-as :> faces
+
+ b-rep new
+ faces >>faces
+ edges >>edges
+ vertices >>vertices
+ dup connect-opposite-edges ;
+
+: parse-vertex ( line -- position )
+ " " split first3 [ string>number >float ] tri@ 0.0 double-4-boa ;
+
+: read-vertex ( line vertices -- )
+ [ parse-vertex ] dip push ;
+
+: parse-face-index ( token vertices -- index )
+ swap "/" split1 drop string>number
+ dup 0 >= [ nip 1 - ] [ [ length ] dip + ] if ;
+
+: parse-face ( line vertices -- vertices )
+ [ " " split ] dip '[ _ parse-face-index ] map ;
+
+: read-face ( line vertices faces -- )
+ [ parse-face ] dip push ;
+
+PRIVATE>
+
+:: (read-obj) ( -- vertices faces )
+ V{ } clone :> vertices
+ V{ } clone :> faces
+ [
+ " " split1 swap {
+ { "#" [ drop ] }
+ { "v" [ vertices read-vertex ] }
+ { "f" [ vertices faces read-face ] }
+ [ 2drop ]
+ } case
+ ] each-line
+ vertices faces ;
+
+:: read-obj ( -- b-rep )
+ (read-obj) reconstruct-b-rep ;
--- /dev/null
+USING: accessors arrays assocs euler.b-rep
+game.models.half-edge kernel locals math math.vectors
+math.vectors.simd.cords sequences sets typed fry ;
+FROM: sequences.private => nth-unsafe set-nth-unsafe ;
+IN: euler.b-rep.subdivision
+
+: <vertex> ( position -- vertex ) vertex new swap >>position ; inline
+
+: face-points ( faces -- face-pts )
+ [ edge>> face-midpoint <vertex> ] map ; inline
+
+:: edge-points ( edges edge-indices face-indices face-points -- edge-pts )
+ edges length 0 <array> :> edge-pts
+
+ edges [| edge n |
+ edge opposite-edge>> :> opposite-edge
+ opposite-edge edge-indices at :> opposite-n
+
+ n opposite-n < [
+ edge vertex>> position>>
+ opposite-edge vertex>> position>> v+
+ edge face>> face-indices at face-points nth position>> v+
+ opposite-edge face>> face-indices at face-points nth position>> v+
+ 0.25 v*n
+ <vertex>
+ [ n edge-pts set-nth-unsafe ]
+ [ opposite-n edge-pts set-nth-unsafe ] bi
+ ] when
+ ] each-index
+
+ edge-pts ; inline
+
+:: vertex-points ( vertices edge-indices face-indices edge-pts face-points -- vertex-pts )
+ vertices [| vertex |
+ 0 double-4{ 0 0 0 0 } double-4{ 0 0 0 0 }
+ vertex edge>> [| valence face-sum edge-sum edge |
+ valence 1 +
+ face-sum edge face>> face-indices at face-points nth position>> v+
+ edge-sum edge next-edge>> vertex>> position>> v+
+ ] each-vertex-edge :> ( valence face-sum edge-sum )
+ valence >float :> fvalence
+ face-sum fvalence v/n :> face-avg
+ edge-sum fvalence v/n :> edge-avg
+ face-avg edge-avg v+ vertex position>> fvalence 2.0 - v*n v+
+ fvalence v/n
+ <vertex>
+ ] map ; inline
+
+TYPED:: subdivide ( brep: b-rep -- brep': b-rep )
+ brep vertices>> :> vertices
+ brep edges>> :> edges
+ brep faces>> :> faces
+
+ vertices >index-hash :> vertex-indices
+ edges >index-hash :> edge-indices
+ faces >index-hash :> face-indices
+
+ faces face-points :> face-pts
+ edges edge-indices face-indices face-pts edge-points :> edge-pts
+ vertices edge-indices face-indices edge-pts face-pts vertex-points :> vertex-pts
+
+ V{ } clone :> sub-edges
+ V{ } clone :> sub-faces
+
+ vertices [
+ edge>> [| edg |
+ edg edge-indices at edge-pts nth :> point-a
+ edg next-edge>> :> next-edg
+ next-edg vertex>> :> next-vertex
+ next-vertex vertex-indices at vertex-pts nth :> point-b
+ next-edg edge-indices at edge-pts nth :> point-c
+ edg face>> face-indices at face-pts nth :> point-d
+
+ face new
+ dup >>base-face :> fac
+
+ b-edge new
+ fac >>face
+ point-a >>vertex :> edg-a
+ b-edge new
+ fac >>face
+ point-b >>vertex :> edg-b
+ b-edge new
+ fac >>face
+ point-c >>vertex :> edg-c
+ b-edge new
+ fac >>face
+ point-d >>vertex :> edg-d
+ edg-a fac edge<<
+ edg-b edg-a next-edge<<
+ edg-c edg-b next-edge<<
+ edg-d edg-c next-edge<<
+ edg-a edg-d next-edge<<
+
+ fac sub-faces push
+ edg-a sub-edges push
+ edg-b sub-edges push
+ edg-c sub-edges push
+ edg-d sub-edges push
+
+ point-a [ edg-a or ] change-edge drop
+ point-b [ edg-b or ] change-edge drop
+ point-c [ edg-c or ] change-edge drop
+ point-d [ edg-d or ] change-edge drop
+ ] each-vertex-edge
+ ] each
+
+ b-rep new
+ sub-faces { } like >>faces
+ sub-edges { } like >>edges
+ face-pts edge-pts vertex-pts 3append members { } like >>vertices
+ [ connect-opposite-edges ] keep ;
--- /dev/null
+USING: accessors arrays euler.b-rep.examples
+euler.b-rep.triangulation math.vectors.simd.cords sequences
+tools.test gml kernel ;
+IN: euler.b-rep.triangulation.tests
+
+: triangle-vx-positions ( triangles -- positions )
+ [ [ position>> ] { } map-as ] { } map-as ;
+
+[
+ {
+ {
+ double-4{ 1.0 1.0 -1.0 0.0 }
+ double-4{ -1.0 -1.0 -1.0 0.0 }
+ double-4{ -1.0 1.0 -1.0 0.0 }
+ }
+ {
+ double-4{ -1.0 -1.0 -1.0 0.0 }
+ double-4{ 1.0 1.0 -1.0 0.0 }
+ double-4{ 1.0 -1.0 -1.0 0.0 }
+ }
+ }
+] [ valid-cube-b-rep faces>> first triangulate-face triangle-vx-positions ] unit-test
+
+[ { } ] [ degenerate-incomplete-face faces>> first triangulate-face triangle-vx-positions ] unit-test
+[ {
+ {
+ double-4{ 1.0 1.0 0.0 0.0 }
+ double-4{ -1.0 -1.0 0.0 0.0 }
+ double-4{ -1.0 1.0 0.0 0.0 }
+ }
+ {
+ double-4{ -1.0 -1.0 0.0 0.0 }
+ double-4{ 1.0 1.0 0.0 0.0 }
+ double-4{ 1.0 -1.0 0.0 0.0 }
+ }
+} ] [ partially-degenerate-second-face faces>> second triangulate-face triangle-vx-positions ] unit-test
+
+[
+ {
+ {
+ double-4{ -1.0 1.0 0.0 0.0 }
+ double-4{ -0.5 0.5 0.0 0.0 }
+ double-4{ -1.0 -1.0 0.0 0.0 }
+ }
+ {
+ double-4{ -0.5 0.5 0.0 0.0 }
+ double-4{ -1.0 1.0 0.0 0.0 }
+ double-4{ 1.0 1.0 0.0 0.0 }
+ }
+ {
+ double-4{ -0.5 0.5 0.0 0.0 }
+ double-4{ 1.0 1.0 0.0 0.0 }
+ double-4{ 0.5 0.5 0.0 0.0 }
+ }
+ {
+ double-4{ 0.5 0.5 0.0 0.0 }
+ double-4{ 1.0 1.0 0.0 0.0 }
+ double-4{ 0.5 -0.5 0.0 0.0 }
+ }
+ {
+ double-4{ -1.0 -1.0 0.0 0.0 }
+ double-4{ -0.5 -0.5 0.0 0.0 }
+ double-4{ 1.0 -1.0 0.0 0.0 }
+ }
+ {
+ double-4{ -0.5 -0.5 0.0 0.0 }
+ double-4{ -1.0 -1.0 0.0 0.0 }
+ double-4{ -0.5 0.5 0.0 0.0 }
+ }
+ {
+ double-4{ 1.0 -1.0 0.0 0.0 }
+ double-4{ -0.5 -0.5 0.0 0.0 }
+ double-4{ 0.5 -0.5 0.0 0.0 }
+ }
+ {
+ double-4{ 1.0 -1.0 0.0 0.0 }
+ double-4{ 0.5 -0.5 0.0 0.0 }
+ double-4{ 1.0 1.0 0.0 0.0 }
+ }
+ }
+] [
+ [ "vocab:gml/examples/torus.gml" run-gml-file ] make-gml nip
+ faces>> first triangulate-face triangle-vx-positions
+] unit-test
--- /dev/null
+USING: accessors alien.c-types alien.handles euler.b-rep
+game.models.half-edge grouping kernel locals opengl.gl
+opengl.glu sequences specialized-arrays specialized-vectors
+libc destructors alien.data ;
+IN: euler.b-rep.triangulation
+
+SPECIALIZED-ARRAY: double
+
+ERROR: triangulated-face-must-be-base ;
+
+<PRIVATE
+
+: tess-begin ( -- callback )
+ [| primitive-type vertices-h |
+ primitive-type GL_TRIANGLES =
+ [ "unexpected primitive type" throw ] unless
+ ] GLUtessBeginDataCallback ;
+
+: tess-end ( -- callback )
+ [| vertices-h |
+ ! nop
+ ] GLUtessEndDataCallback ;
+
+: tess-vertex ( -- callback )
+ [| vertex-h vertices-h |
+ vertex-h alien-handle-ptr>
+ vertices-h alien-handle-ptr> push
+ ] GLUtessVertexDataCallback ;
+
+: tess-edge-flag ( -- callback )
+ [| flag vertices-h |
+ ! nop
+ ] GLUtessEdgeFlagDataCallback ;
+
+PRIVATE>
+
+:: triangulate-face ( face -- triangles )
+ [
+ face dup base-face>> eq? [ triangulated-face-must-be-base ] unless
+
+ gluNewTess &gluDeleteTess :> tess
+ V{ } clone :> vertices
+ vertices <alien-handle-ptr> &release-alien-handle-ptr :> vertices-h
+
+ tess GLU_TESS_BEGIN_DATA tess-begin gluTessCallback
+ tess GLU_TESS_END_DATA tess-end gluTessCallback
+ tess GLU_TESS_VERTEX_DATA tess-vertex gluTessCallback
+ tess GLU_TESS_EDGE_FLAG_DATA tess-edge-flag gluTessCallback
+
+ tess vertices-h gluTessBeginPolygon
+
+ 4 double malloc-array &free :> vertex-buf
+
+ face [| ring |
+ tess gluTessBeginContour
+
+ ring edge>> [
+ tess swap vertex>>
+ [ position>> double >c-array ]
+ [ <alien-handle-ptr> &release-alien-handle-ptr ] bi gluTessVertex
+ ] each-face-edge
+
+ tess gluTessEndContour
+
+ ring next-ring>> dup
+ ] loop drop
+ tess gluTessEndPolygon
+
+ vertices { } like 3 <groups>
+ ] with-destructors ;
--- /dev/null
+USING: accessors kernel tools.test euler.b-rep euler.operators\r
+euler.modeling game.models.half-edge ;\r
+IN: euler.modeling.tests\r
+\r
+! polygon>double-face\r
+[ ] [\r
+ [\r
+ { { -1 -1 0 } { 1 -1 0 } { 1 1 0 } { -1 1 0 } }\r
+ smooth-smooth polygon>double-face\r
+ [ face-sides 4 assert= ]\r
+ [ opposite-edge>> face-sides 4 assert= ]\r
+ [ face-normal { 0.0 0.0 1.0 } assert= ]\r
+ tri\r
+ ] make-b-rep check-b-rep\r
+] unit-test\r
+\r
+! extrude-simple\r
+[ ] [\r
+ [\r
+ { { -1 -1 0 } { 1 -1 0 } { 1 1 0 } }\r
+ smooth-smooth polygon>double-face\r
+ 1 f extrude-simple\r
+ [ face-sides 3 assert= ]\r
+ [ opposite-edge>> face-sides 4 assert= ]\r
+ bi\r
+ ] make-b-rep check-b-rep\r
+] unit-test\r
+\r
+! project-pt-line\r
+[ { 0 1 0 } ] [ { 0 0 0 } { 0 1 0 } { 1 1 0 } project-pt-line ] unit-test\r
+[ { 0 1 0 } ] [ { 0 0 0 } { 1 1 0 } { 0 1 0 } project-pt-line ] unit-test\r
+[ { 0 1 0 } ] [ { 0 0 0 } { 2 1 0 } { 1 1 0 } project-pt-line ] unit-test\r
+[ { -1 1 0 } ] [ { -1 0 0 } { 2 1 0 } { 1 1 0 } project-pt-line ] unit-test\r
+[ { 1/2 1/2 0 } ] [ { 0 0 0 } { 0 1 0 } { 1 0 0 } project-pt-line ] unit-test\r
+\r
+! project-pt-plane\r
+[ { 0 0 1 } ] [ { 0 0 0 } { 0 0 1 } { 0 0 1 } -1 project-pt-plane ] unit-test\r
+[ { 0 0 -1 } ] [ { 0 0 0 } { 0 0 1 } { 0 0 1 } 1 project-pt-plane ] unit-test\r
+[ { 0 0 3 } ] [ { 0 0 0 } { 0 0 1 } { 0 0 1 } -3 project-pt-plane ] unit-test\r
+[ { 0 0 3 } ] [ { 0 0 0 } { 0 0 1 } { 0 0 -1 } 3 project-pt-plane ] unit-test\r
+[ { 0 0 1 } ] [ { 0 0 0 } { 0 0 1 } { 0 1 1 } -1 project-pt-plane ] unit-test\r
+\r
+[ { 0 2/3 1/3 } ] [ { 0 0 0 } { 0 2 1 } { 0 1 1 } -1 project-pt-plane ] unit-test\r
+\r
+[ { 0 0 1 } ] [ { 0 0 0 } { 0 0 1/2 } { 0 0 1 } -1 project-pt-plane ] unit-test\r
+[ { 0 1 1 } ] [ { 0 0 0 } { 0 1/2 1/2 } { 0 0 1 } -1 project-pt-plane ] unit-test\r
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.\r
+USING: accessors combinators fry kernel locals math.vectors\r
+namespaces sets sequences game.models.half-edge euler.b-rep\r
+euler.operators math ;\r
+IN: euler.modeling\r
+\r
+: (polygon>double-face) ( polygon -- edge )\r
+ [ first2 make-vefs ] keep\r
+ [ drop opposite-edge>> ] [ 2 tail-slice [ make-ev-one ] each ] 2bi\r
+ make-ef face-ccw ;\r
+\r
+SYMBOLS: smooth-smooth\r
+sharp-smooth\r
+smooth-sharp\r
+sharp-sharp\r
+smooth-like-vertex\r
+sharp-like-vertex\r
+smooth-continue\r
+sharp-continue ;\r
+\r
+: polygon>double-face ( polygon mode -- edge )\r
+ ! This only handles the simple case with no repeating vertices\r
+ drop\r
+ dup all-unique? [ "polygon>double-face doesn't support repeating vertices yet" throw ] unless\r
+ (polygon>double-face) ;\r
+\r
+:: extrude-simple ( edge dist sharp? -- edge )\r
+ edge face-normal dist v*n :> vec\r
+ edge vertex-pos vec v+ :> pos\r
+ edge pos make-ev-one :> e0!\r
+ e0 opposite-edge>> :> e-end\r
+ edge face-ccw :> edge!\r
+\r
+ [ edge e-end eq? not ] [\r
+ edge vertex-pos vec v+ :> pos\r
+ edge pos make-ev-one :> e1\r
+ e0 e1 make-ef drop\r
+ e1 e0!\r
+ edge face-ccw edge!\r
+ ] do while\r
+ \r
+ e-end face-ccw :> e-end\r
+ e0 e-end make-ef drop\r
+\r
+ e-end ;\r
+\r
+: check-bridge-rings ( e1 e2 -- )\r
+ {\r
+ [ [ face>> assert-no-rings ] bi@ ]\r
+ [ [ face>> assert-base-face ] bi@ ]\r
+ [ assert-different-faces ]\r
+ [ [ face-sides ] bi@ assert= ]\r
+ } 2cleave ;\r
+\r
+:: bridge-rings-simple ( e1 e2 sharp? -- edge )\r
+ e1 e2 check-bridge-rings\r
+ e1 e2 kill-f-make-rh\r
+ e1 e2 make-e-kill-r face-cw :> ea!\r
+ e2 face-ccw :> eb!\r
+ [ ea e1 eq? not ] [\r
+ ea eb make-ef opposite-edge>> face-cw ea!\r
+ eb face-ccw eb!\r
+ ] while\r
+ eb ;\r
+\r
+:: project-pt-line ( p p0 p1 -- q )\r
+ p1 p0 v- :> vt\r
+ p p0 v- vt v* sum\r
+ vt norm-sq /\r
+ vt n*v p0 v+ ; inline\r
+\r
+:: project-pt-plane ( line-p0 line-vt plane-n plane-d -- q )\r
+ plane-d neg plane-n line-p0 v. -\r
+ line-vt plane-n v. /\r
+ line-vt n*v line-p0 v+ ; inline\r
+\r
+: project-poly-plane ( poly vdir plane-n plane-d -- qoly )\r
+ '[ _ _ _ project-pt-plane ] map ; inline\r
--- /dev/null
+USING: accessors euler.operators euler.modeling euler.b-rep
+kernel tools.test game.models.half-edge combinators namespaces
+fry sequences make ;
+FROM: euler.b-rep => has-rings? ;
+IN: euler.operators.tests
+
+[ t ] [ [ ] make-b-rep b-rep? ] unit-test
+
+[ ] [
+ [
+ { 1 0 0 }
+ { 0 1 0 }
+ make-vefs
+ {
+ [ face-ccw vertex-pos { 1 0 0 } assert= ]
+ [ vertex-pos { 0 1 0 } assert= ]
+ [ vertex-valence 1 assert= ]
+ [ face-ccw vertex-valence 1 assert= ]
+ [ dup face-ccw assert-same-face ]
+ } cleave
+ ] make-b-rep check-b-rep
+] unit-test
+
+[ ] [
+ [
+ { 1 0 0 }
+ { 0 1 0 }
+ make-vefs
+ kill-vefs
+ ] make-b-rep assert-empty-b-rep
+] unit-test
+
+[
+ [
+ { 1 0 0 }
+ { 0 1 0 }
+ make-vefs
+ dup face-ccw
+ { 0 0 1 } make-ev
+ ] make-b-rep
+] [ edges-not-incident? ] must-fail-with
+
+[ ] [
+ [
+ 0
+ 1
+ make-vefs
+ dup 2 make-ev
+ [ vertex-pos 2 assert= ]
+ [ opposite-edge>> vertex-pos 1 assert= ]
+ bi
+ ] make-b-rep check-b-rep
+] unit-test
+
+[ ] [
+ [
+ { 1 0 0 }
+ { 0 1 0 }
+ make-vefs
+ dup dup { 0 0 1 } make-ev kill-ev
+ kill-vefs
+ ] make-b-rep assert-empty-b-rep
+] unit-test
+
+[ ] [
+ [
+ { 1 2 3 } smooth-smooth polygon>double-face
+ dup face-cw opposite-edge>>
+ 2dup [ "a" set ] [ "b" set ] bi*
+ 4 make-ev {
+ [ face-sides 4 assert= ]
+ [ vertex-pos 4 assert= ]
+ [ opposite-edge>> face-sides 4 assert= ]
+ [ face-ccw "b" get assert= ]
+ [ face-cw "a" get opposite-edge>> assert= ]
+ } cleave
+ ] make-b-rep check-b-rep
+] unit-test
+
+[ ] [
+ [
+ { 1 2 3 4 } smooth-smooth polygon>double-face
+ [ face-ccw opposite-edge>> ]
+ [ face-ccw face-ccw ]
+ [ dup face-ccw face-ccw make-ef drop ] tri
+ 5 make-ev {
+ [ vertex-pos 5 assert= ]
+ [ face-sides 4 assert= ]
+ } cleave
+ ] make-b-rep check-b-rep
+] unit-test
+
+[ ] [
+ [
+ { 1 0 0 }
+ { 0 1 0 }
+ make-vefs
+ [
+ dup dup make-ef
+ [ face>> ] bi@ eq? f assert=
+ ]
+ [ vertex-valence 3 assert= ]
+ bi
+ ] make-b-rep check-b-rep
+] unit-test
+
+[
+ [
+ { 1 0 0 }
+ { 0 1 0 }
+ make-vefs
+ dup dup make-ef make-ef
+ ] make-b-rep
+] [ edges-in-different-faces? ] must-fail-with
+
+[ ] [
+ [
+ { 1 0 0 }
+ { 0 1 0 }
+ make-vefs
+ dup opposite-edge>>
+ [ [ "a" set ] [ "b" set ] bi* ]
+ [
+ make-ef
+ {
+ [ vertex-valence 2 assert= ]
+ [ opposite-edge>> vertex-valence 2 assert= ]
+ [ next-edge>> "a" get assert= ]
+ [ opposite-edge>> next-edge>> "b" get assert= ]
+ [ dup opposite-edge>> [ face>> ] bi@ eq? f assert= ]
+ } cleave
+ ] 2bi
+ ] make-b-rep check-b-rep
+] unit-test
+
+[ ] [
+ [
+ { 1 2 3 4 } smooth-smooth polygon>double-face
+ { 5 6 7 8 } smooth-smooth polygon>double-face
+ { 9 10 11 12 } smooth-smooth polygon>double-face
+ {
+ [ [ drop ] dip kill-f-make-rh ]
+ [ [ drop ] 2dip kill-f-make-rh ]
+ [ [ drop ] dip [ face>> ] bi@ [ base-face>> ] dip assert= ]
+ [ [ drop ] 2dip [ face>> ] bi@ [ base-face>> ] dip assert= ]
+ [ 2nip face>> has-rings? t assert= ]
+ [ drop drop make-f-kill-rh ]
+ [ drop nip make-f-kill-rh ]
+ [ drop drop face>> dup base-face>> assert= ]
+ [ drop nip face>> dup base-face>> assert= ]
+ [ 2nip face>> has-rings? f assert= ]
+ } 3cleave
+ ] make-b-rep check-b-rep
+] unit-test
+
+[
+ { 0 1 0 }
+ { 1 0 0 }
+ { 1 2 1 }
+ { 2 1 1 }
+] [
+ [
+ { 1 0 0 }
+ { 0 1 0 }
+ make-vefs
+ dup opposite-edge>>
+ {
+ [ [ vertex-pos ] bi@ ]
+ [ drop { 1 1 1 } move-e ]
+ [ [ vertex-pos ] bi@ ]
+ } 2cleave
+ ] make-b-rep check-b-rep
+] unit-test
+
+[
+ {
+ { 2 1 1 }
+ { 1 2 1 }
+ { 1 1 2 }
+ }
+] [
+ [
+ { { 1 0 0 } { 0 1 0 } { 0 0 1 } } smooth-smooth polygon>double-face
+ [ { 1 1 1 } move-f ]
+ [ [ [ vertex-pos , ] each-face-edge ] { } make ]
+ bi
+ ] make-b-rep check-b-rep
+] unit-test
+
+! Make sure we update the face's edge when killing an edge
+[ ] [
+ [
+ { 1 2 3 4 } smooth-smooth polygon>double-face
+ kill-ev
+ ] make-b-rep check-b-rep
+] unit-test
+
+[ ] [
+ [
+ { 1 2 3 4 } smooth-smooth polygon>double-face
+ face-ccw kill-ev
+ ] make-b-rep check-b-rep
+] unit-test
+
+[ ] [
+ [
+ { 1 2 3 4 } smooth-smooth polygon>double-face
+ face-ccw face-ccw kill-ev
+ ] make-b-rep check-b-rep
+] unit-test
+
+[ ] [
+ [
+ { 1 2 3 4 } smooth-smooth polygon>double-face
+ face-ccw face-ccw face-ccw kill-ev
+ ] make-b-rep check-b-rep
+] unit-test
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+USING: accessors combinators fry kernel locals namespaces
+game.models.half-edge euler.b-rep sequences typed math
+math.vectors ;
+IN: euler.operators
+
+ERROR: edges-not-incident ;
+
+: assert-incident ( e1 e2 -- )
+ incident? [ edges-not-incident ] unless ;
+
+ERROR: should-not-be-equal obj1 obj2 ;
+
+: assert-not= ( obj1 obj2 -- )
+ 2dup eq? [ should-not-be-equal ] [ 2drop ] if ;
+
+ERROR: edges-in-different-faces ;
+
+: assert-same-face ( e1 e2 -- )
+ same-face? [ edges-in-different-faces ] unless ;
+
+ERROR: edges-in-same-face ;
+
+: assert-different-faces ( e1 e2 -- )
+ same-face? [ edges-in-same-face ] when ;
+
+: assert-isolated-component ( edge -- )
+ [ [ opposite-edge>> ] [ next-edge>> ] bi assert= ]
+ [ dup opposite-edge>> assert-same-face ]
+ bi ;
+
+ERROR: not-a-base-face face ;
+
+: assert-base-face ( face -- )
+ dup base-face? [ drop ] [ not-a-base-face ] if ;
+
+ERROR: has-rings face ;
+
+: assert-no-rings ( face -- )
+ dup next-ring>> [ has-rings ] [ drop ] if ;
+
+: assert-ring-of ( ring face -- )
+ [ base-face>> ] dip assert= ;
+
+: with-b-rep ( b-rep quot -- )
+ [ b-rep ] dip with-variable ; inline
+
+: make-b-rep ( quot -- b-rep )
+ <b-rep> [ swap with-b-rep ] [ finish-b-rep ] [ ] tri ; inline
+
+<PRIVATE
+
+:: make-loop ( vertex face -- edge )
+ b-rep get new-edge :> edge
+ vertex edge vertex<<
+ edge edge next-edge<<
+ face edge face<<
+
+ edge ;
+
+: make-loop-face ( vertex -- edge )
+ b-rep get new-face
+ dup >>base-face
+ make-loop ;
+
+:: make-edge ( vertex next-edge -- edge )
+ b-rep get new-edge :> edge
+ vertex edge vertex<<
+ next-edge edge next-edge<<
+ next-edge face>> edge face<<
+
+ edge ;
+
+: opposite-edges ( e1 e2 -- )
+ [ opposite-edge<< ] [ swap opposite-edge<< ] 2bi ;
+
+PRIVATE>
+
+MIXIN: point
+INSTANCE: sequence point
+INSTANCE: number point
+
+TYPED:: make-vefs ( pos1: point pos2: point -- edge: b-edge )
+ b-rep get :> b-rep
+
+ pos1 b-rep new-vertex :> v1
+ v1 make-loop-face :> e1
+
+ pos2 b-rep new-vertex :> v2
+ v2 e1 make-edge :> e2
+
+ e2 e1 next-edge<<
+ e1 e2 opposite-edges
+
+ e2 ;
+
+TYPED:: make-ev-one ( edge: b-edge point: point -- edge: b-edge )
+ point b-rep get new-vertex :> v
+ v edge make-edge :> e1'
+
+ edge vertex>> e1' make-edge :> e2'
+
+ e2' edge face-cw next-edge<<
+ e1' e2' opposite-edges
+
+ e1' ;
+
+<PRIVATE
+
+:: subdivide-vertex-cycle ( e1 e2 v -- )
+ e1 e2 eq? [
+ v e1 vertex<<
+ e1 vertex-cw e2 v subdivide-vertex-cycle
+ ] unless ;
+
+:: (make-ev) ( e1 e2 point -- edge )
+ e1 e2 assert-incident
+
+ point b-rep get new-vertex :> v'
+ v' e2 make-edge :> e1'
+
+ e1 vertex>> :> v
+
+ v e1 make-edge :> e2'
+
+ e1 e2 v' subdivide-vertex-cycle
+
+ e1 face-cw :> e1p
+ e2 face-cw :> e2p
+ e1 opposite-edge>> :> e1m
+
+ e1m e1p assert-not=
+
+ e1' e2p next-edge<<
+ e2' e1p next-edge<<
+
+ e1' e2' opposite-edges
+
+ e1' ;
+
+PRIVATE>
+
+TYPED:: make-ev ( e1: b-edge e2: b-edge point: point -- edge: b-edge )
+ e1 e2 eq?
+ [ e1 point make-ev-one ] [ e1 e2 point (make-ev) ] if ;
+
+<PRIVATE
+
+: subdivide-edge-cycle ( face e1 e2 -- )
+ 2dup eq? [ 3drop ] [
+ [ drop face<< ]
+ [ [ next-edge>> ] dip subdivide-edge-cycle ] 3bi
+ ] if ;
+
+PRIVATE>
+
+TYPED:: make-ef ( e1: b-edge e2: b-edge -- edge: b-edge )
+ e1 e2 assert-same-face
+
+ e2 vertex>> make-loop-face :> e1'
+ e1 vertex>> e2 make-edge :> e2'
+ e1' e2' opposite-edges
+
+ e1 face-cw :> e1p
+
+ e1 e2 eq? [
+ e2 face-cw :> e2p
+
+ e1' face>> e1 e2 subdivide-edge-cycle
+
+ e1' e2p next-edge<<
+ e1 e1' next-edge<<
+ ] unless
+
+ e2' e1p next-edge<<
+ e1' ;
+
+TYPED:: make-e-kill-r ( edge-ring: b-edge edge-face: b-edge -- edge: b-edge )
+ edge-ring face>> :> ring
+ edge-face face>> :> face
+ ring face assert-ring-of
+
+ edge-ring [ face >>face drop ] each-face-edge
+
+ edge-ring vertex>> edge-face make-edge :> e1
+ edge-face vertex>> edge-ring make-edge :> e2
+
+ ring face delete-ring
+ ring b-rep get delete-face
+
+ e2 edge-face face-cw next-edge<<
+ e1 edge-ring face-cw next-edge<<
+
+ e1 e2 opposite-edges
+
+ e1 ;
+
+TYPED:: make-f-kill-rh ( edge-ring: b-edge -- )
+ edge-ring face>> :> ring
+ ring base-face>> :> base-face
+ ring base-face delete-ring
+ ring ring base-face<< ;
+
+TYPED:: kill-vefs ( edge: b-edge -- )
+ edge assert-isolated-component
+
+ b-rep get :> b-rep
+ edge dup opposite-edge>> :> ( e2 e1 )
+
+ e1 vertex>> :> v1
+ e2 vertex>> :> v2
+
+ e1 face>> b-rep delete-face
+
+ e1 b-rep delete-edge
+ e2 b-rep delete-edge
+ v1 b-rep delete-vertex
+ v2 b-rep delete-vertex ;
+
+TYPED:: kill-ev ( edge: b-edge -- )
+ b-rep get :> b-rep
+
+ edge vertex>> :> v
+ edge opposite-edge>> :> edge'
+ edge' vertex>> :> v'
+
+ edge [ v' >>vertex drop ] each-vertex-edge
+
+ edge face-cw :> edgep
+ edge' face-cw :> edge'p
+
+ edge next-edge>> edgep next-edge<<
+ edge' next-edge>> edge'p next-edge<<
+
+ v b-rep delete-vertex
+ edge b-rep delete-edge
+ edge' b-rep delete-edge ;
+
+TYPED:: kill-ef ( edge: b-edge -- )
+ b-rep get :> b-rep
+
+ edge :> e1
+ edge opposite-edge>> :> e2
+
+ e1 e2 assert-different-faces
+
+ e1 face-cw :> e1p
+ e2 face-cw :> e2p
+
+ e1 face>> :> f1
+ e2 face>> :> f2
+
+ e1 [ f2 >>face drop ] each-face-edge
+ f1 b-rep delete-face
+
+ e1 e2 incident? [
+ e2 next-edge>> e2p next-edge<<
+
+ ] [
+ e2 next-edge>> e1p next-edge<<
+ e1 next-edge>> e2p next-edge<<
+ ] if
+
+ e1 b-rep delete-edge
+ e2 b-rep delete-edge ;
+
+TYPED:: kill-e-make-r ( edge: b-edge -- edge-ring: b-edge )
+ b-rep get :> b-rep
+
+ edge opposite-edge>> :> edge'
+ edge' next-edge>> :> edge-ring
+ edge-ring opposite-edge>> :> edge-ring'
+
+ edge edge' assert-same-face
+ edge edge-ring assert-same-face
+ edge edge-ring' assert-different-faces
+
+ b-rep new-face :> ring
+
+ ring edge face>> base-face>> add-ring
+ ring edge' edge subdivide-edge-cycle
+
+ edge b-rep delete-edge
+ edge' b-rep delete-edge
+
+ edge-ring ;
+
+TYPED:: kill-f-make-rh ( edge-face: b-edge edge-base-face: b-edge -- )
+ edge-face face>> :> face
+ edge-base-face face>> :> base-face
+
+ face assert-base-face
+ base-face assert-base-face
+ edge-face edge-base-face assert-different-faces
+
+ face base-face add-ring ;
+
+TYPED: move-v ( edge: b-edge point: point -- )
+ swap vertex>> position<< ;
+
+TYPED: move-e ( edge: b-edge offset: point -- )
+ [ dup opposite-edge>> ] dip
+ '[ vertex>> [ _ v+ ] change-position drop ] bi@ ;
+
+TYPED: move-f ( edge: b-edge offset: point -- )
+ '[ vertex>> [ _ v+ ] change-position drop ] each-face-edge ;
+
+TYPED: sharp-e ( edge: b-edge sharp?: boolean -- )
+ >>sharpness drop ;
+
+TYPED: sharp-f ( edge: b-edge sharp?: boolean -- )
+ '[ _ sharp-e ] each-face-edge ;
+
+TYPED: sharp-v ( edge: b-edge sharp?: boolean -- )
+ '[ _ sharp-e ] each-vertex-edge ;
+
+TYPED: material-f ( edge: b-edge material -- ) 2drop ;
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+USING: accessors euler.b-rep euler.operators
+game.models.half-edge gml.macros gml.printer gml.runtime
+gml.types io io.styles kernel namespaces ;
+FROM: alien.c-types => >c-bool c-bool> ;
+IN: gml.b-rep
+
+LOG-GML: makeVEFS ( p1 p2 -- edge ) make-vefs ;
+
+LOG-GML: makeEV ( e0 e1 p -- edge ) make-ev ;
+
+LOG-GML: makeEVone ( e0 p -- edge ) dupd make-ev ;
+
+LOG-GML: makeEF ( e1 e2 -- edge ) make-ef ;
+
+LOG-GML: makeEkillR ( edge-ring edge-face -- edge ) make-e-kill-r ;
+
+LOG-GML: makeFkillRH ( edge-ring -- ) make-f-kill-rh ;
+
+LOG-GML: killVEFS ( edge -- ) kill-vefs ;
+
+LOG-GML: killEV ( edge -- ) kill-ev ;
+
+LOG-GML: killEF ( edge -- ) kill-ef ;
+
+LOG-GML: killEmakeR ( edge -- edge-ring ) kill-e-make-r ;
+
+LOG-GML: killFmakeRH ( face-edge base-face-edge -- ) kill-f-make-rh ;
+
+GML: moveV ( edge point -- ) move-v ;
+
+GML: moveE ( edge offset -- ) move-e ;
+
+GML: moveF ( edge offset -- ) move-f ;
+
+GML: vertexCW ( e0 -- e1 ) vertex-cw ;
+
+GML: vertexCCW ( e0 -- e1 ) vertex-ccw ;
+
+GML: faceCW ( e0 -- e1 ) face-cw ;
+
+GML: faceCCW ( e0 -- e1 ) face-ccw ;
+
+GML: baseface ( e0 -- e1 ) base-face>> ;
+
+GML: nextring ( e0 -- e1 ) dup next-ring>> [ nip ] [ base-face>> ] if* ;
+
+GML: facenormal ( e0 -- n ) face-normal ;
+GML: faceplanedist ( e0 -- d ) face-plane-dist ;
+GML: faceplane ( e0 -- n d ) face-plane ;
+
+GML: facemidpoint ( e0 -- v ) face-midpoint ;
+
+GML: facedegree ( e0 -- n ) face-sides ;
+
+GML: edgemate ( e0 -- e1 ) opposite-edge>> ;
+GML: edgeflip ( e0 -- e1 ) opposite-edge>> ;
+
+GML: edgedirection ( e0 -- v ) edge-direction ;
+
+GML: vertexpos ( e0 -- p ) vertex-pos ;
+
+GML: valence ( e0 -- n ) vertex-valence ;
+
+GML: sameEdge ( e0 e1 -- ? ) same-edge? >true ;
+
+GML: sameFace ( e0 e1 -- ? ) same-face? >true ;
+
+GML: sameVertex ( e0 e1 -- ? ) incident? >true ;
+
+GML: isBaseface ( e -- ? ) face>> base-face? ;
+
+GML: sharpE ( e sharp -- ) c-bool> sharp-e ;
+
+GML: sharpF ( e sharp -- ) c-bool> sharp-f ;
+
+GML: sharpV ( e sharp -- ) c-bool> sharp-v ;
+
+GML: issharp ( e -- sharp ) sharpness>> >c-bool ;
+
+GML: isValidEdge ( e -- ? ) b-rep get is-valid-edge? ;
+
+GML: materialF ( e material -- ) material-f ;
+
+GML: setcurrentmaterial ( material -- ) drop ;
+GML: getcurrentmaterial ( -- material ) "none" name ;
+GML: pushcurrentmaterial ( material -- ) drop ;
+GML: popcurrentmaterial ( -- material ) "none" name ;
+GML: getmaterialnames ( -- [material] ) { } ;
+GML: setfacematerial ( e material -- ) material-f ;
+GML: getfacematerial ( e -- material ) drop "none" name ;
+
+GML: setsharpness ( sharp -- ) c-bool> set-sharpness ;
+GML: getsharpness ( -- sharp ) get-sharpness >c-bool ;
+GML: pushsharpness ( sharp -- ) c-bool> push-sharpness ;
+GML: popsharpness ( -- sharp ) pop-sharpness >c-bool ;
+
+GML: connectedvertices ( e0 e1 -- connected )
+ ! Stupid variable-arity word!
+ connecting-edge [ [ over push-operand ] when* ] [ >c-bool ] bi ;
+
+M: b-edge write-gml
+ dup vertex>> position>> vertex-style [
+ "«Edge " write
+ [ vertex>> position>> write-gml "-" write ] [
+ opposite-edge>> vertex>> position>>
+ dup vertex-style [ write-gml ] with-style
+ ] bi
+ "»" write
+ ] with-style ;
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+USING: gml.types gml.printer gml.runtime math math.ranges
+continuations combinators arrays kernel vectors accessors
+prettyprint fry sequences assocs locals hashtables grouping
+sorting models ;
+IN: gml.core
+
+! Tokens
+GML: cvx ( array -- proc ) { } <proc> ;
+GML: cvlit ( proc -- array ) array>> ;
+GML: exec ( obj -- ) exec-proc ;
+
+! Stack shuffling
+: pop-slice ( seq n -- subseq )
+ [ tail ] [ swap shorten ] 2bi ;
+: pop-slice* ( seq n -- subseq )
+ over length swap - pop-slice ;
+
+GML: pop ( a -- ) drop ;
+GML: pops ( n -- )
+ over operand-stack>> [ length swap - ] keep shorten ;
+GML: dup ( a -- a a ) dup ;
+GML: exch ( a b -- b a ) swap ;
+GML: index ( n -- value )
+ over operand-stack>> [ length 1 - swap - ] keep nth ;
+
+ERROR: roll-out-of-bounds n j ;
+
+GML: roll ( n j -- )
+ 2dup abs < [ roll-out-of-bounds ] when
+ [ [ dup operand-stack>> ] dip over length swap - pop-slice ] dip
+ neg over length rem cut-slice swap append over
+ operand-stack>> push-all ;
+
+GML: clear ( -- ) dup operand-stack>> delete-all ;
+GML: cleartomark ( -- )
+ dup [ find-marker ] [ operand-stack>> ] bi shorten ;
+GML: count ( -- n ) dup operand-stack>> length ;
+GML: counttomark ( -- n ) dup [ operand-stack>> length ] [ find-marker ] bi - ;
+
+! Arrays
+GML: ] ( -- array )
+ dup
+ [ [ operand-stack>> ] [ find-marker ] bi pop-slice { } like ]
+ [ operand-stack>> pop* ]
+ bi ;
+
+GML: array ( n -- array )
+ [ dup operand-stack>> ] dip pop-slice* { } like ;
+
+GML: length ( array -- len ) length ;
+GML: append ( array elt -- array' ) suffix ;
+GML: eappend ( elt array -- array' ) swap suffix ;
+
+GML: pop-back ( -- array' )
+ ! Stupid variable arity word!
+ dup pop-operand dup integer?
+ [ [ dup pop-operand ] dip head* ] [ but-last ] if ;
+
+GML: pop-front ( -- array' )
+ ! Stupid variable arity word!
+ dup pop-operand dup integer?
+ [ [ dup pop-operand ] dip tail ] [ rest ] if ;
+
+GML: arrayappend ( array1 array2 -- array3 ) append ;
+GML: arrayremove ( array1 n -- array3 ) swap wrap remove-nth ;
+GML: aload ( array -- ) over operand-stack>> push-all ;
+GML: array-get ( array indices -- result ) [ (gml-get) ] with map ;
+GML: flatten ( array -- flatarray )
+ [ dup array? [ 1array ] unless ] map concat ;
+GML: reverse ( array -- reversed ) reverse ;
+GML: slice ( array n k -- slice )
+ [a,b) swap '[ _ wrap nth ] map ;
+GML:: subarray ( array n k -- slice )
+ k n k + array subseq ;
+GML: sort-number-permutation ( array -- permutation )
+ [ 2array ] map-index sort-keys reverse values ;
+
+! Dictionaries
+ERROR: not-a-dict obj ;
+: check-dict ( obj -- obj' ) dup hashtable? [ not-a-dict ] unless ; inline
+
+GML: begin ( dict -- ) check-dict over dictionary-stack>> push ;
+GML: end ( -- ) dup dictionary-stack>> pop* ;
+GML: dict ( -- dict ) H{ } clone ;
+
+GML: dictfromarray ( -- dict )
+ ! Stupid variable-arity word!
+ dup pop-operand {
+ { [ dup hashtable? ] [ [ dup pop-operand ] dip ] }
+ { [ dup array? ] [ H{ } clone ] }
+ } cond
+ swap 2 group assoc-union! ;
+
+GML: keys ( dict -- keys ) keys ;
+GML: known ( dict key -- ? ) swap key? >true ;
+GML: values ( dict -- values ) values ;
+GML: where ( key -- ? )
+ ! Stupid variable-arity word!
+ over dictionary-stack>> [ key? ] with find swap
+ [ over push-operand 1 ] [ drop 0 ] if ;
+
+: current-dict ( gml -- assoc ) dictionary-stack>> last ; inline
+
+GML: currentdict ( -- dict ) dup current-dict ;
+GML: load ( name -- value ) over lookup-name ;
+
+ERROR: not-a-name obj ;
+
+: check-name ( obj -- obj' ) dup name? [ not-a-name ] unless ; inline
+
+GML: def ( name value -- ) swap check-name pick current-dict set-at ;
+GML: edef ( value name -- ) check-name pick current-dict set-at ;
+GML: undef ( name -- ) check-name over current-dict delete-at ;
+
+! Dictionaries and arrays
+GML: get ( collection key -- elt ) (gml-get) ;
+GML: put ( collection key elt -- ) (gml-put) ;
+GML: copy ( collection -- collection' ) (gml-copy) ;
+
+! Control flow
+: proc>quot ( proc -- quot: ( registers gml -- registers gml ) )
+ '[ _ exec-proc ] ; inline
+: proc>quot1 ( proc -- quot: ( registers gml value -- registers gml ) )
+ '[ over push-operand _ exec-proc ] ; inline
+: proc>quot2 ( proc -- quot: ( registers gml value1 value2 -- registers gml ) )
+ '[ [ over push-operand ] bi@ _ exec-proc ] ; inline
+
+GML: if ( flag proc -- ) [ true? ] [ proc>quot ] bi* when ;
+GML: ifelse ( flag proc0 proc1 -- ) [ true? ] [ proc>quot ] [ proc>quot ] tri* if ;
+GML:: ifpop ( x y flag -- x/y ) flag true? y x ? ;
+GML: exit ( -- ) return ;
+GML: loop ( proc -- )
+ '[ _ proc>quot '[ @ t ] loop ] with-return ;
+GML: repeat ( n proc -- )
+ '[ _ _ proc>quot times ] with-return ;
+GML: for ( a s b proc -- )
+ '[ _ _ _ _ [ swap <range> ] dip proc>quot1 each ] with-return ;
+GML: forx ( a s b proc -- )
+ '[ _ _ _ _ [ 1 - swap <range> ] dip proc>quot1 each ] with-return ;
+GML: forall ( array proc -- )
+ '[ _ _ proc>quot1 each ] with-return ;
+GML: twoforall ( array1 array2 proc -- )
+ '[ _ _ _ proc>quot2 2each ] with-return ;
+GML:: map ( array proc -- )
+ :> gml
+ marker gml push-operand
+ gml array proc proc>quot1 each
+ gml-] ;
+GML:: twomap ( array1 array2 proc -- )
+ :> gml
+ marker gml push-operand
+ gml array1 array2 proc proc>quot2 2each
+ gml-] ;
+
+! Extensions to real GML
+GML: print ( obj -- ) print-gml ;
+GML: test ( obj1 obj2 -- ) swap assert= ;
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+USING: gml.types gml.printer gml.runtime math math.constants
+math.functions math.matrices math.order math.ranges math.trig
+math.vectors continuations combinators arrays kernel vectors
+accessors prettyprint fry sequences assocs locals hashtables
+grouping sorting classes.struct math.vectors.simd
+math.vectors.simd.cords random random.mersenne-twister
+system namespaces ;
+IN: gml.coremath
+
+! :: gml-scalar-op ( a b scalar-quot mixed-quot vector-quot -- c )
+! {
+! { [ b float? ] [ a b scalar-quot call ] }
+! { [ b integer? ] [ a b scalar-quot call ] }
+! { [ b vec2d? ] [ a scalar>vec2d b mixed-quot call ] }
+! { [ b vec3d? ] [ a scalar>vec3d b mixed-quot call ] }
+! } cond ; inline
+!
+! :: gml-math-op ( a b scalar-quot mixed-quot vector-quot -- c )
+! {
+! { [ a float? ] [ a b scalar-quot mixed-quot vector-quot gml-scalar-op ] }
+! { [ a integer? ] [ a b scalar-quot mixed-quot vector-quot gml-scalar-op ] }
+! { [ a vec2d? ] [
+! {
+! { [ b vec2d? ] [ a b vector-quot call ] }
+! { [ b float? ] [ a b scalar>vec2d mixed-quot call ] }
+! { [ b integer? ] [ a b scalar>vec2d mixed-quot call ] }
+! } cond
+! ] }
+! { [ a vec3d? ] [
+! {
+! { [ b vec3d? ] [ a b vector-quot call ] }
+! { [ b float? ] [ a b scalar>vec3d mixed-quot call ] }
+! { [ b integer? ] [ a b scalar>vec3d mixed-quot call ] }
+! } cond
+! ] }
+! } cond ; inline
+
+! Don't use locals here until a limitation in the propagation pass
+! is fixed (constraints on slots). Maybe optimizing GML math ops
+! like this isn't worth it anyway, since GML is interpreted
+FROM: generalizations => npick ;
+
+: gml-scalar-op ( a b scalar-quot mixed-quot vector-quot -- c )
+ {
+ { [ 4 npick float? ] [ 2drop call ] }
+ { [ 4 npick integer? ] [ 2drop call ] }
+ { [ 4 npick vec2d? ] [ drop nip [ scalar>vec2d ] 2dip call ] }
+ { [ 4 npick vec3d? ] [ drop nip [ scalar>vec3d ] 2dip call ] }
+ } cond ; inline
+
+: gml-math-op ( a b scalar-quot mixed-quot vector-quot -- c )
+ {
+ { [ 5 npick float? ] [ gml-scalar-op ] }
+ { [ 5 npick integer? ] [ gml-scalar-op ] }
+ { [ 5 npick vec2d? ] [
+ {
+ { [ 4 npick vec2d? ] [ 2nip call ] }
+ { [ 4 npick float? ] [ drop nip [ scalar>vec2d ] dip call ] }
+ { [ 4 npick integer? ] [ drop nip [ scalar>vec2d ] dip call ] }
+ } cond
+ ] }
+ { [ 5 npick vec3d? ] [
+ {
+ { [ 4 npick vec3d? ] [ 2nip call ] }
+ { [ 4 npick float? ] [ drop nip [ scalar>vec3d ] dip call ] }
+ { [ 4 npick integer? ] [ drop nip [ scalar>vec3d ] dip call ] }
+ } cond
+ ] }
+ } cond ; inline
+
+GML: add ( a b -- c ) [ + ] [ v+ ] [ v+ ] gml-math-op ;
+GML: sub ( a b -- c ) [ - ] [ v- ] [ v- ] gml-math-op ;
+GML: mul ( a b -- c ) [ * ] [ v* ] [ v. ] gml-math-op ;
+GML: div ( a b -- c ) [ /f ] [ v/ mask-vec3d ] [ v/ mask-vec3d ] gml-math-op ;
+GML: mod ( a b -- c ) mod ;
+
+GML: neg ( x -- y )
+ {
+ { [ dup integer? ] [ neg ] }
+ { [ dup float? ] [ neg ] }
+ { [ dup vec2d? ] [ vneg ] }
+ { [ dup vec3d? ] [ vneg mask-vec3d ] }
+ } cond ;
+
+GML: eq ( a b -- c ) = >true ;
+GML: ne ( a b -- c ) = not >true ;
+GML: ge ( a b -- c ) >= >true ;
+GML: gt ( a b -- c ) > >true ;
+GML: le ( a b -- c ) <= >true ;
+GML: lt ( a b -- c ) < >true ;
+
+! Trig
+GML: sin ( x -- y ) >float deg>rad sin ;
+GML: asin ( x -- y ) >float asin rad>deg ;
+GML: cos ( x -- y ) >float deg>rad cos ;
+GML: acos ( x -- y ) >float acos rad>deg ;
+GML: tan ( x -- y ) >float deg>rad tan ;
+GML: atan ( x -- y ) >float atan rad>deg ;
+
+FROM: math.libm => fatan2 ;
+GML: atan2 ( x y -- z ) [ >float ] bi@ fatan2 rad>deg ;
+
+GML: pi ( -- pi ) pi ;
+
+! Bitwise ops
+: logical-op ( a b quot -- c ) [ [ true? ] bi@ ] dip call >true ; inline
+
+GML: and ( a b -- c ) [ and ] logical-op ;
+GML: or ( a b -- c ) [ or ] logical-op ;
+GML: not ( a -- b ) 0 number= >true ;
+
+! Misc functions
+GML: abs ( x -- y )
+ {
+ { [ dup integer? ] [ abs ] }
+ { [ dup float? ] [ abs ] }
+ { [ dup vec2d? ] [ norm ] }
+ { [ dup vec3d? ] [ norm ] }
+ } cond ;
+
+: must-be-positive ( x -- x ) dup 0 < [ "Domain error" throw ] when ; inline
+
+GML: sqrt ( x -- y ) must-be-positive sqrt ;
+GML: inv ( x -- y ) >float recip ;
+GML: log ( x -- y ) must-be-positive log10 ;
+GML: ln ( x -- y ) must-be-positive log ;
+GML: exp ( x -- y ) e^ ;
+GML: pow ( x y -- z ) [ >float ] bi@ ^ ;
+
+GML: ceiling ( x -- y ) ceiling ;
+GML: floor ( x -- y ) floor ;
+GML: trunc ( x -- y ) truncate ;
+GML: round ( x -- y ) round ;
+
+GML: clamp ( x v -- y ) first2 clamp ;
+
+! Vector functions
+GML: getX ( vec -- x )
+ {
+ { [ dup vec2d? ] [ first ] }
+ { [ dup vec3d? ] [ first ] }
+ } cond ;
+
+GML: getY ( vec -- x )
+ {
+ { [ dup vec2d? ] [ second ] }
+ { [ dup vec3d? ] [ second ] }
+ } cond ;
+
+GML: getZ ( vec -- x )
+ {
+ { [ dup vec3d? ] [ third ] }
+ } cond ;
+
+GML: putX ( vec x -- x )
+ {
+ { [ over vec2d? ] [ [ second ] dip swap <vec2d> ] }
+ { [ over vec3d? ] [ [ [ second ] [ third ] bi ] dip -rot <vec3d> ] }
+ } cond ;
+
+GML: putY ( vec y -- x )
+ {
+ { [ over vec2d? ] [ [ first ] dip <vec2d> ] }
+ { [ over vec3d? ] [ [ [ first ] [ third ] bi ] dip swap <vec3d> ] }
+ } cond ;
+
+GML: putZ ( vec z -- x )
+ {
+ { [ over vec3d? ] [ [ first2 ] dip <vec3d> ] }
+ } cond ;
+
+GML: dist ( u v -- x ) distance ;
+
+GML: normalize ( u -- v ) normalize mask-vec3d ;
+
+GML: planemul ( u v p -- w )
+ first2 [ v*n ] bi-curry@ bi* v+ ;
+
+GML: cross ( u v -- w ) cross ;
+
+: normal ( vec -- norm )
+ [ first double-4{ 0 1 0 0 } n*v ]
+ [ second double-4{ -1 0 0 0 } n*v ]
+ [ third double-4{ -1 0 0 0 } n*v ] tri v+ v+ ; inline
+
+GML: aNormal ( x -- y )
+ {
+ { [ dup vec2d? ] [ normalize double-2{ 1 -1 } v* { 1 0 } vshuffle ] }
+ { [ dup vec3d? ] [ normalize normal ] }
+ } cond ;
+
+: det2 ( x y -- z )
+ { 1 0 } vshuffle double-2{ 1 -1 } v* v* sum ; inline
+
+: det3 ( x y z -- w )
+ [ cross ] dip v. ; inline
+
+GML: determinant ( x -- y )
+ {
+ { [ dup vec2d? ] [ [ dup pop-operand ] dip det2 ] }
+ { [ dup vec3d? ] [ [ dup [ pop-operand ] [ pop-operand ] bi swap ] dip det3 ] }
+ } cond ;
+
+GML: vector2 ( x y -- v ) <vec2d> ;
+
+GML: vector3 ( x y z -- v ) <vec3d> ;
+
+GML: random ( -- x ) 0.0 1.0 uniform-random-float ;
+
+GML: randomseed ( n -- )
+ dup 0 < [ drop nano-count 1000000 /i ] when
+ <mersenne-twister> random-generator set ;
+
+! Extensions to real GML
+GML: approx-eq ( a b -- c )
+ [ 10e-5 ~ ] [ 10e-5 v~ ] [ 10e-5 v~ ] gml-math-op >true ;
--- /dev/null
+usereg
+
+(1,1,1) !v0
+(1,0,1) !v1
+(0,0,1) !v2
+(0,1,1) !v3
+
+(1,1,0) !v4
+(1,0,0) !v5
+(0,0,0) !v6
+(0,1,0) !v7
+
+:v0 :v1 makeVEFS dup
+[ :v2 :v3 ]
+{ makeEVone } forall
+exch edgemate exch makeEF
+
+:v7 makeEVone
+dup faceCCW faceCCW
+[ :v4 :v5 :v6 ]
+{
+ makeEVone
+ makeEF vertexCW
+ dup faceCCW faceCCW
+} forall
+faceCCW makeEF
+
+edgemate !e
+:e :e facemidpoint
+:e facenormal add
+
+!p !e
+:e :p makeEVone
+dup edgemate !e
+{
+ dup faceCCW faceCCW
+ dup :e eq { exit } if
+ makeEF edgemate
+} loop
+
+pop pop
--- /dev/null
+usereg !nrml !backwall !wall !poly\r
+{ usereg !door !wall\r
+ :door edgemate :wall killFmakeRH\r
+ :door edgemate faceCCW\r
+ :wall makeEkillR\r
+ dup faceCCW faceCCW\r
+ :door edgemate\r
+ exch makeEF pop\r
+ faceCCW killEF\r
+} !glue-ringface-edges\r
+\r
+:poly 0 get !pr\r
+:poly -1 get !pl\r
+:wall vertexpos !pw0\r
+:wall edgemate vertexpos !pw1\r
+:pr :pw0 :pw1 project_ptline !prb\r
+:pl :pw0 :pw1 project_ptline !plb\r
+[ :plb :plb :prb :prb ]\r
+:poly arrayappend !poly\r
+\r
+:poly :nrml neg :backwall faceplane\r
+project_polyplane\r
+ 5 poly2doubleface edgemate !backdoor\r
+:poly 5 poly2doubleface !door\r
+:wall :door :glue-ringface-edges\r
+:backwall :backdoor :glue-ringface-edges\r
+:backdoor faceCCW :door 2 bridgerings\r
+\r
+!doorL\r
+:doorL edgemate 2 faceCCW edgemate !doorR\r
+:doorL edgemate faceCCW killEF\r
+:doorR edgemate faceCCW killEmakeR pop\r
+:doorL edgemate isBaseface {\r
+ :doorR edgemate makeFkillRH\r
+} if\r
+\r
+:doorL :doorR\r
--- /dev/null
+usereg
+
+0.0 !alpha
+0.1 !thickness
+
+:alpha sin :alpha cos 0 vector3 !p
+
+:p :p (0,0,1) cross :alpha 0.5 mul rot_vec
+0.3 mul !q
+
+(0,0,1) :p (0,0,1) cross :alpha 0.5 mul rot_vec
+:thickness mul !r
+
+[ :p :q add :r add
+ :p :q sub :r add
+ :p :q sub :r sub
+ :p :q add :r sub
+] 4 poly2doubleface dup !e0
+
+10.0 10.0 360.0 { !alpha
+
+:alpha sin :alpha cos 0 vector3 !p
+
+:p :p (0,0,1) cross :alpha 0.5 mul rot_vec
+0.3 mul !q
+
+(0,0,1) :p (0,0,1) cross :alpha 0.5 mul rot_vec
+:thickness mul !r
+
+[ :p :q add :r add
+ :p :q sub :r add
+ :p :q sub :r sub
+ :p :q add :r sub
+] 4 poly2doubleface !e
+:e edgemate faceCCW 1 bridgerings-simple pop
+:e
+} forx
+
+:e0 edgemate faceCW 1 bridgerings-simple pop
--- /dev/null
+usereg\r
+\r
+[ (-1,-1,0) (1,-1,0)\r
+ (1,1,0) (-1,1,0) ] !poly\r
+\r
+:poly 1 poly2doubleface\r
+dup edgemate exch\r
+1 1 extrude-simple !f0 !f1\r
+\r
+:poly { 0.5 mul } map reverse\r
+5 poly2doubleface\r
+dup edgemate exch\r
+-1 1 extrude-simple\r
+!r0 !r1\r
+\r
+:r0 :f0 killFmakeRH\r
+:r1 :f1 killFmakeRH\r
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+USING: arrays kernel math.matrices math.vectors.simd.cords
+math.trig gml.runtime ;
+IN: gml.geometry
+
+GML: rot_vec ( v n alpha -- v )
+ ! Inefficient!
+ deg>rad rotation-matrix4 swap >array m.v >double-4 ;
--- /dev/null
+IN: gml.tests
+USING: accessors combinators gml tools.test kernel sequences euler.b-rep ;
+
+[ ] [ [ "vocab:gml/test-core.gml" run-gml-file ] make-gml 2drop ] unit-test
+
+[ ] [ [ "vocab:gml/test-coremath.gml" run-gml-file ] make-gml 2drop ] unit-test
+
+[ ] [ [ "vocab:gml/test-geometry.gml" run-gml-file ] make-gml 2drop ] unit-test
+
+[ ] [
+ [ "vocab:gml/examples/cube.gml" run-gml-file ] make-gml nip
+ {
+ [ check-b-rep ]
+ [ faces>> length 9 assert= ]
+ [ vertices>> length 9 assert= ]
+ [ edges>> length 32 assert= ]
+ [ genus 0 assert= ]
+ } cleave
+] unit-test
+
+[ ] [
+ [ "vocab:gml/examples/torus.gml" run-gml-file ] make-gml nip
+ {
+ [ check-b-rep ]
+ [ faces>> [ base-face? ] partition [ length 10 assert= ] [ length 2 assert= ] bi* ]
+ [ vertices>> length 16 assert= ]
+ [ edges>> length 48 assert= ]
+ ! faces are not convex in this example
+ ! [ genus 1 assert= ]
+ } cleave
+] unit-test
+
+[ ] [
+ [ "vocab:gml/examples/mobius.gml" run-gml-file ] make-gml nip
+ {
+ [ check-b-rep ]
+ [ genus 1 assert= ]
+ } cleave
+] unit-test
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+USING: accessors continuations debugger fry io io.encodings.utf8
+io.files kernel namespaces sequences euler.b-rep euler.operators
+gml.core gml.coremath gml.b-rep gml.geometry gml.modeling
+gml.parser gml.printer gml.runtime gml.viewer ;
+IN: gml
+
+TUPLE: gml-file-error pathname error ;
+
+C: <gml-file-error> gml-file-error
+
+M: gml-file-error error.
+ "Error in GML file “" write
+ dup pathname>> write "”:" print nl
+ error>> error. ;
+
+: gml-stack. ( gml -- )
+ operand-stack>> [
+ "Operand stack:" print
+ [ "• " write print-gml ] each
+ ] unless-empty ;
+
+SYMBOL: gml
+
+: make-gml ( quot -- gml b-rep )
+ [
+ <gml> gml set
+ <b-rep> b-rep set
+ call
+ gml get
+ b-rep get dup finish-b-rep
+ ] with-scope ; inline
+
+: with-gml ( gml b-rep quot -- )
+ [
+ [ gml set ]
+ [ b-rep set ]
+ [ call ]
+ tri*
+ ] with-scope ; inline
+
+: run-gml-string ( string -- )
+ [ gml get ] dip parse-gml exec drop ;
+
+: run-gml-file ( pathname -- )
+ [ utf8 file-contents run-gml-string ]
+ [ <gml-file-error> rethrow ]
+ recover ;
+
+SYMBOLS: pre-hook post-hook ;
+
+[ ] pre-hook set-global
+[ ] post-hook set-global
+
+: (gml-listener) ( -- )
+ "GML> " write flush readln [
+ '[
+ pre-hook get call( -- )
+ _ run-gml-string
+ post-hook get call( -- )
+ ] try
+ [ gml get gml-stack. ] try
+ (gml-listener)
+ ] when* ;
+
+: gml-listener ( -- )
+ [ (gml-listener) ] make-gml 2drop ;
+
+MAIN: gml-listener
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs classes.tuple combinators.short-circuit
+effects.parser fry generalizations gml.runtime kernel
+kernel.private lexer locals macros namespaces parser
+prettyprint sequences system words ;
+IN: gml.macros
+
+TUPLE: macro macro-id timestamp log ;
+
+SYMBOL: next-macro-id
+next-macro-id [ 0 ] initialize
+
+SYMBOL: macros
+macros [ H{ } clone ] initialize
+
+SYMBOL: current-macro
+
+: <macro> ( -- macro )
+ macro new
+ next-macro-id [ get ] [ inc ] bi >>macro-id
+ nano-count >>timestamp
+ V{ } clone >>log ; inline
+
+: save-euler-op ( euler-op -- ) current-macro get log>> push ;
+
+MACRO:: log-euler-op ( class def inputs -- )
+ class inputs def inputs '[ [ current-macro get [ _ boa save-euler-op ] [ _ ndrop ] if ] _ _ nbi ] ;
+
+SYNTAX: LOG-GML:
+ [let
+ (GML:) :> ( word name effect def )
+
+ name "-record" append create-in :> record-class
+ record-class tuple effect in>> define-tuple-class
+
+ record-class def effect in>> length
+ '[ _ _ _ log-euler-op ] :> logging-def
+
+ word name effect logging-def define-gml-primitive
+ ] ;
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.\r
+USING: kernel sequences euler.modeling gml.runtime ;\r
+IN: gml.modeling\r
+\r
+GML: poly2doubleface ( poly mode -- edge )\r
+ {\r
+ smooth-smooth\r
+ sharp-smooth\r
+ smooth-sharp\r
+ sharp-sharp\r
+ smooth-like-vertex\r
+ sharp-like-vertex\r
+ smooth-continue\r
+ sharp-continue\r
+ } nth polygon>double-face ;\r
+\r
+GML: extrude-simple ( edge dist sharp -- edge ) extrude-simple ;\r
+\r
+GML: bridgerings-simple ( e1 e2 sharp -- edge ) bridge-rings-simple ;\r
+\r
+GML: project_ptline ( p p0 p1 -- q ) project-pt-line ;\r
+\r
+GML: project_ptplane ( p dir n d -- q ) project-pt-plane ;\r
+\r
+GML: project_polyplane ( [p] dir n d -- [q] ) project-poly-plane ;\r
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+USING: accessors kernel arrays strings math.parser peg peg.ebnf
+gml.types gml.runtime sequences sequences.deep locals combinators math ;
+IN: gml.parser
+
+TUPLE: comment string ;
+
+C: <comment> comment
+
+: register-index ( name registers -- n )
+ 2dup index dup [ 2nip ] [ drop [ nip length ] [ push ] 2bi ] if ;
+
+: resolve-register ( insn registers -- )
+ [ dup name>> ] dip register-index >>n drop ;
+
+ERROR: missing-usereg ;
+
+:: (resolve-registers) ( array registers -- ? )
+ f :> use-registers!
+ array [
+ {
+ { [ dup use-registers? ] [ use-registers! ] }
+ { [ dup read-register? ] [ registers resolve-register ] }
+ { [ dup exec-register? ] [ registers resolve-register ] }
+ { [ dup write-register? ] [ registers resolve-register ] }
+ { [ dup proc? ] [
+ dup [ use-registers? ] any? [ drop ] [
+ array>> registers (resolve-registers) drop
+ ] if
+ ] }
+ [ drop ]
+ } cond
+ ] each
+ use-registers ;
+
+:: resolve-registers ( array -- )
+ V{ } clone :> registers
+ array [ use-registers? ] any? [
+ array registers (resolve-registers)
+ registers length >>n drop
+ ] when ;
+
+: parse-proc ( array -- proc )
+ >array [ resolve-registers ] [ { } <proc> ] bi ;
+
+ERROR: bad-vector-length seq n ;
+
+: parse-vector ( seq -- vec )
+ dup length {
+ { 2 [ first2 <vec2d> ] }
+ { 3 [ first3 <vec3d> ] }
+ [ bad-vector-length ]
+ } case ;
+
+EBNF: parse-gml
+
+Letter = [a-zA-Z]
+Digit = [0-9]
+Digits = Digit+
+
+Sign = ('+' => [[ first ]]|'-' => [[ first ]])?
+
+StopChar = ('('|')'|'['|']'|'{'|'}'|'/'|'/'|';'|':'|'!'|'.')
+
+Space = ' ' | '\t' | '\r' | '\n'
+
+Spaces = Space* => [[ ignore ]]
+
+Newline = ('\n' | '\r')
+
+Number = Sign Digit+ ('.' => [[ first ]] Digit+)? ('e' => [[ first ]] Sign Digit+)?
+ => [[ flatten sift >string string>number ]]
+
+VectorComponents = (Number:f Spaces ',' Spaces => [[ f ]])*:fs Number:f Spaces => [[ fs f suffix ]]
+
+Vector = '(' Spaces VectorComponents ')' => [[ second parse-vector ]]
+
+StringChar = !('"').
+
+String = '"' StringChar+:s '"' => [[ s >string ]]
+
+NameChar = !(Space|StopChar).
+
+Name = NameChar+ => [[ >string ]]
+
+Comment = ('%' (!(Newline) .)* (Newline|!(.))) => [[ <comment> ]]
+
+ArrayStart = '[' => [[ marker ]]
+
+ArrayEnd = ']' => [[ exec" ]" ]]
+
+ExecArray = '{' Token*:ts Spaces '}' => [[ ts parse-proc ]]
+
+LiteralName = '/' Name:n => [[ n name ]]
+
+UseReg = "usereg" !(NameChar) => [[ <use-registers> ]]
+
+ReadReg = ";" Name:n => [[ n <read-register> ]]
+ExecReg = ":" Name:n => [[ n <exec-register> ]]
+WriteReg = "!" Name:n => [[ n <write-register> ]]
+
+ExecName = Name:n => [[ n exec-name ]]
+
+PathNameComponent = "." Name:n => [[ n name ]]
+PathName = PathNameComponent+ => [[ <pathname> ]]
+
+Token = Spaces
+ (Comment |
+ Number |
+ Vector |
+ String |
+ ArrayStart |
+ ArrayEnd |
+ ExecArray |
+ LiteralName |
+ UseReg |
+ ReadReg |
+ ExecReg |
+ WriteReg |
+ ExecName |
+ PathName)
+
+Tokens = Token* => [[ [ comment? not ] filter ]]
+
+Program = Tokens Spaces !(.) => [[ parse-proc ]]
+
+;EBNF
+
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+USING: accessors arrays assocs classes gml.runtime gml.types
+hashtables io io.styles kernel math math.parser math.vectors.simd
+math.vectors.simd.cords sequences strings colors ;
+IN: gml.printer
+
+GENERIC: write-gml ( obj -- )
+
+M: object write-gml "«Object: " write name>> write "»" write ;
+M: integer write-gml number>string write ;
+M: float write-gml number>string write ;
+M: string write-gml "\"" write write "\"" write ;
+M: name write-gml "/" write string>> write ;
+M: exec-name write-gml name>> string>> write ;
+M: pathname write-gml names>> [ "." write string>> write ] each ;
+M: use-registers write-gml drop "usereg" write ;
+M: read-register write-gml ";" write name>> write ;
+M: exec-register write-gml ":" write name>> write ;
+M: write-register write-gml "!" write name>> write ;
+
+: write-vector ( vec n -- )
+ head-slice
+ "(" write [ "," write ] [ number>string write ] interleave ")" write ;
+M: double-2 write-gml 2 write-vector ;
+
+M: array write-gml
+ "[" write [ bl ] [ write-gml ] interleave "]" write ;
+M: proc write-gml
+ "{" write array>> [ bl ] [ write-gml ] interleave "}" write ;
+M: hashtable write-gml
+ "«Dictionary with " write
+ assoc-size number>string write
+ " entries»" write ;
+
+: print-gml ( obj -- ) write-gml nl ;
+
+CONSTANT: vertex-colors
+ {
+ T{ rgba f 0. 0. 2/3. 1. }
+ T{ rgba f 0. 2/3. 0. 1. }
+ T{ rgba f 0. 2/3. 2/3. 1. }
+ T{ rgba f 2/3. 0. 0. 1. }
+ T{ rgba f 2/3. 0. 2/3. 1. }
+ T{ rgba f 2/3. 1/3. 0. 1. }
+ T{ rgba f 0. 0. 1. 1. }
+ T{ rgba f 0. 1. 0. 1. }
+ T{ rgba f 0. 1. 1. 1. }
+ T{ rgba f 1. 0. 0. 1. }
+ T{ rgba f 1. 0. 1. 1. }
+ T{ rgba f 1. 1. 0. 1. }
+ }
+
+: vertex-color ( position -- rgba )
+ first3 [ [ >float double>bits ] [ >integer ] bi + ] tri@
+ bitxor bitxor vertex-colors length mod vertex-colors nth ;
+
+: vertex-style ( position -- rgba )
+ vertex-color foreground associate ;
+
+M: double-4 write-gml dup vertex-style [ 3 write-vector ] with-style ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+USING: accessors arrays assocs fry generic.parser kernel locals
+locals.parser macros math math.ranges memoize parser sequences
+sequences.private strings strings.parser lexer namespaces
+vectors words generalizations sequences.generalizations
+effects.parser gml.types ;
+IN: gml.runtime
+
+TUPLE: name < identity-tuple { string read-only } ;
+
+SYMBOL: names
+
+names [ H{ } clone ] initialize
+
+: name ( string -- name ) names get-global [ \ name boa ] cache ;
+
+TUPLE: gml { operand-stack vector } { dictionary-stack vector } ;
+
+: push-operand ( value gml -- ) operand-stack>> push ; inline
+
+: peek-operand ( gml -- value ? )
+ operand-stack>> [ f f ] [ last t ] if-empty ; inline
+
+: pop-operand ( gml -- value ) operand-stack>> pop ; inline
+
+GENERIC: (exec) ( registers gml obj -- registers gml )
+
+! A bit of efficiency
+FROM: kernel.private => declare ;
+
+: is-gml ( registers gml obj -- registers gml obj )
+ { array gml object } declare ; inline
+
+<<
+
+: (EXEC:) ( quot -- method def )
+ scan-word \ (exec) create-method-in
+ swap call( -- quot ) [ is-gml ] prepend ;
+
+SYNTAX: EXEC: [ parse-definition ] (EXEC:) define ;
+
+SYNTAX: EXEC:: [ [ parse-definition ] parse-locals-definition drop ] (EXEC:) define ;
+
+>>
+
+! Literals
+EXEC: object over push-operand ;
+
+EXEC: proc array>> pick <proc> over push-operand ;
+
+! Executable names
+TUPLE: exec-name < identity-tuple name ;
+
+MEMO: exec-name ( string -- name ) name \ exec-name boa ;
+
+SYNTAX: exec" lexer get skip-blank parse-string exec-name suffix! ;
+
+ERROR: unbound-name { name name } ;
+
+: lookup-name ( name gml -- value )
+ dupd dictionary-stack>> assoc-stack
+ [ ] [ unbound-name ] ?if ; inline
+
+GENERIC: exec-proc ( registers gml proc -- registers gml )
+
+M:: proc exec-proc ( registers gml proc -- registers gml )
+ proc registers>>
+ gml
+ proc array>> [ (exec) ] each 2drop
+ registers gml ;
+
+FROM: combinators.private => execute-effect-unsafe ;
+
+CONSTANT: primitive-effect ( registers gml -- registers gml )
+
+M: word exec-proc primitive-effect execute-effect-unsafe ;
+
+M: object exec-proc (exec) ;
+
+EXEC: exec-name name>> over lookup-name exec-proc ;
+
+! Registers
+ERROR: unbound-register name ;
+
+:: lookup-register ( registers gml obj -- value )
+ obj n>> registers nth [
+ obj name>> unbound-register
+ ] unless* ;
+
+TUPLE: read-register { name string } { n fixnum } ;
+
+: <read-register> ( name -- read-register ) 0 read-register boa ;
+
+EXEC: read-register
+ [ 2dup ] dip lookup-register over push-operand ;
+
+TUPLE: exec-register { name string } { n fixnum } ;
+
+: <exec-register> ( name -- exec-register ) 0 exec-register boa ;
+
+EXEC: exec-register
+ [ 2dup ] dip lookup-register exec-proc ;
+
+TUPLE: write-register { name string } { n fixnum } ;
+
+: <write-register> ( name -- write-register ) 0 write-register boa ;
+
+EXEC:: write-register ( registers gml obj -- registers gml )
+ gml pop-operand obj n>> registers set-nth
+ registers gml ;
+
+TUPLE: use-registers { n fixnum } ;
+
+: <use-registers> ( -- use-registers ) use-registers new ;
+
+EXEC: use-registers
+ n>> f <array> '[ drop _ ] dip ;
+
+! Pathnames
+TUPLE: pathname names ;
+
+C: <pathname> pathname
+
+: at-pathname ( pathname assoc -- value )
+ swap names>> [ swap ?at [ unbound-name ] unless ] each ;
+
+EXEC:: pathname ( registers gml obj -- registers gml )
+ obj gml pop-operand at-pathname gml push-operand
+ registers gml ;
+
+! List building and stuff
+TUPLE: marker < identity-tuple ;
+CONSTANT: marker T{ marker }
+
+ERROR: no-marker-found ;
+ERROR: gml-stack-underflow ;
+
+: find-marker ( gml -- n )
+ operand-stack>> [ marker eq? ] find-last
+ [ 1 + ] [ no-marker-found ] if ; inline
+
+! Primitives
+: check-stack ( seq n -- seq n )
+ 2dup swap length > [ gml-stack-underflow ] when ; inline
+
+: lastn ( seq n -- elts... )
+ check-stack
+ [ tail-slice* ] keep firstn-unsafe ; inline
+
+: popn ( seq n -- elts... )
+ check-stack
+ [ lastn ] [ over length swap - swap shorten ] 2bi ; inline
+
+: set-lastn ( elts... seq n -- )
+ [ tail-slice* ] keep set-firstn-unsafe ; inline
+
+: pushn ( elts... seq n -- )
+ [ over length + swap lengthen ] 2keep set-lastn ; inline
+
+MACRO: inputs ( inputs# -- quot: ( gml -- gml inputs... ) )
+ '[ dup operand-stack>> _ popn ] ;
+
+MACRO: outputs ( outputs# -- quot: ( gml outputs... -- gml ) )
+ [ 1 + ] keep '[ _ npick operand-stack>> _ pushn ] ;
+
+MACRO: gml-primitive (
+ inputs#
+ outputs#
+ quot: ( registers gml inputs... -- outputs... )
+ --
+ quot: ( registers gml -- registers gml )
+)
+ swap '[ _ inputs @ _ outputs ] ;
+
+SYMBOL: global-dictionary
+
+global-dictionary [ H{ } clone ] initialize
+
+: add-primitive ( word name -- )
+ name global-dictionary get-global set-at ;
+
+: define-gml-primitive ( word name effect def -- )
+ [ '[ _ add-primitive ] keep ]
+ [ [ in>> length ] [ out>> length ] bi ]
+ [ '[ { gml } declare _ _ _ gml-primitive ] ] tri*
+ primitive-effect define-declared ;
+
+: scan-gml-name ( -- word name )
+ scan-token [ "gml-" prepend create-in ] keep ;
+
+: (GML:) ( -- word name effect def )
+ scan-gml-name scan-effect parse-definition ;
+
+SYNTAX: GML:
+ (GML:) define-gml-primitive ;
+
+SYNTAX: GML::
+ [let
+ scan-gml-name :> ( word name )
+ word [ parse-definition ] parse-locals-definition :> ( word def effect )
+ word name effect def define-gml-primitive
+ ] ;
+
+: <gml> ( -- gml )
+ gml new
+ global-dictionary get clone 1vector >>dictionary-stack
+ V{ } clone >>operand-stack ;
+
+: exec ( gml proc -- gml ) [ { } ] 2dip exec-proc nip ;
--- /dev/null
+% Missing core words:
+% bind
+% break
+% catch
+% catch-error
+% echo
+% eput
+% resetinterpreter
+% throw
+% tokenformat
+% tokensize
+% type
+
+"Literals" print
+
+[] [] test
+[-10] [-10] test
+[10] [+10] test
+[10.5] [10.5] test
+[10.5] [+10.5] test
+[-10.5] [-10.5] test
+[1000000.0] [10e5] test
+[1000000.0] [+10e5] test
+[-1000000.0] [-10e5] test
+[1050000.0] [10.5e5] test
+[1050000.0] [+10.5e5] test
+[-1050000.0] [-10.5e5] test
+[(1,2)][(1,2)] test
+[(1,2,3)][(1,2,3)] test
+["Hello"] ["Hello"] test
+
+[1] [{useregs} length] test
+
+"Stack shuffling" print
+
+[1] [1 2 pop] test
+[1 2 ] [1 2 3 8 2 pops] test
+[2 1] [1 2 exch] test
+["a""b""c""d""d"] ["a""b""c""d" 0 index] test
+["a""b""c""d""a"] ["a""b""c""d" 3 index] test
+[0 2 3 1][0 1 2 3 3 -1 roll] test
+[0 3 1 2][0 1 2 3 3 1 roll] test
+[0 1 2 3][0 1 2 3 3 0 roll] test
+[3 0 1 2][0 1 2 3 4 1 roll] test
+[1 2 3 0][0 1 2 3 4 -1 roll] test
+["a" "b" "c" ["g"]] ["a" "b" "c" ["d" "e" "f" cleartomark "g"]] test
+["d" "e" "f" "g" 4] ["d" "e" "f" "g" counttomark] test
+
+"Arrays" print
+
+[[1 2 "X"]] [1 2 "X" 3 array] test
+[-10] [[1 2 -10] 2 get] test
+[-10] [[1 2 -10] -1 get] test
+[[1 2 4]] [[1 2 -10] dup 2 4 put] test
+[[1 "X" -10]] [[1 2 -10] dup -2 "X" put] test
+[["a" "b" "c" "d"]] [["a" "b"] ["c" "d"] arrayappend] test
+[["a" "b" 100]] [["a" "b"] 100 append] test
+[{"a" "b" 100}] [{"a" "b"} 100 append] test
+[["a" "b" "c"]] [["a" "b" "c" "d" "e"] 2 pop-back] test
+[{"a" "b" "c"}] [{"a" "b" "c" "d" "e"} 2 pop-back] test
+[["a" "b" "c" "d" "e"]] [["a" "b" "c" "d" "e"] 0 pop-back] test
+[{"a" "b" "c" "d" "e"}] [{"a" "b" "c" "d" "e"} 0 pop-back] test
+[["a" "b" "c" "d"]] [["a" "b" "c" "d" "e"] pop-back] test
+[{"a" "b" "c" "d"}] [{"a" "b" "c" "d" "e"} pop-back] test
+[["c" "d" "e"]] [["a" "b" "c" "d" "e"] 2 pop-front] test
+[{"c" "d" "e"}] [{"a" "b" "c" "d" "e"} 2 pop-front] test
+[["a" "b" "c" "d" "e"]] [["a" "b" "c" "d" "e"] 0 pop-front] test
+[{"a" "b" "c" "d" "e"}] [{"a" "b" "c" "d" "e"} 0 pop-front] test
+[["b" "c" "d" "e"]] [["a" "b" "c" "d" "e"] pop-front] test
+[{"b" "c" "d" "e"}] [{"a" "b" "c" "d" "e"} pop-front] test
+["Boo" 1 2 3] ["Boo" [1 2 3] aload] test
+[4] [["a" "b" "c" "d"] length] test
+[[3 2 1 2 2]] [[1 2 3] [5 1 0 1 1] array-get] test
+[[1 2 4 5 6]] [[1 2 3 4 5 6] 2 arrayremove] test
+[[1 2 3 4 6]] [[1 2 3 4 5 6] -2 arrayremove] test
+[[1 "hallo" 2 3 4]] [[1 ["hallo" 2] 3 [4] []] flatten] test
+[[1 2 [3]]] [[1 [2 [3]]] flatten] test
+[[16.2 33.5 49.0 64.3 80.5]] [[80.5 64.3 49.0 33.5 16.2] reverse] test
+[[ 3 4 5 1 2 3 4 5 1 2 ]] [[ 1 2 3 4 5 ] -3 7 slice] test
+[[ "c" "d" "e" ]] [[ "a" "b" "c" "d" "e" "f" "g" ] 3 2 subarray] test
+
+[
+ [2 1 6] %A(rray)
+ [2 0 1] %P(ermutation)
+ 1
+]
+[
+ [ 2 1 6 ]
+ dup
+ sort-number-permutation
+ dup
+ 2 %index of the first element in p
+ get %get the first element of P
+] test
+
+"Dictionaries" print
+
+[3 4] [
+ /x 4 def
+ dict begin
+ /x 3 def
+ x
+ end
+ x
+] test
+
+[3 4] [
+ /x 4 def
+ dict begin
+ /x 3 def
+ currentdict /x get
+ end
+ currentdict /x get
+] test
+
+dict begin
+/squared {dup mul} def
+[25] [5 squared] test
+[{dup mul}] [/squared load] test
+end
+
+[3 4] [
+ /x 4 def
+ dict begin
+ /x 3 def
+ x
+ /x undef
+ x
+ end
+] test
+
+dict begin
+
+/mydict dict def
+mydict /total 0 put
+[1] [mydict /total known] test
+[0] [mydict /badname known] test
+
+end
+
+dict begin
+ /myBlack (0.0,0.0,0.0) def
+
+ [1] [currentdict /myBlack known] test
+ [0] [currentdict /myWhite known] test
+end
+
+dict begin
+ /bing 5 def
+ /bong "OH HAI" def
+
+ dict begin
+ /bong 10 def
+
+ [1 "OH HAI"] [/bing where exch /bong get] test
+
+ end
+end
+
+[3 3] [
+ /d dict def
+ d /x 3 put
+ d /x get
+ d copy /x 100 put
+ d /x get
+] test
+
+[5] [
+ dict begin
+ /a 1 def
+ /b 2 def
+ /c 3 def
+ /d 4 def
+ /e 5 def
+ currentdict keys length
+ end
+] test
+
+[/a 10 /b 20 /c 30] dictfromarray begin
+ [10] [a] test
+ [20] [b] test
+ [30] [c] test
+end
+
+dict dup
+[/a 10 /b 20 /c 30] exch dictfromarray begin
+ [10] [a] test
+ [20] [b] test
+ [30] [c] test
+end
+
+% Ensure original was mutated too!
+begin
+ [10] [a] test
+ [20] [b] test
+ [30] [c] test
+end
+
+"Pathnames" print
+["Barak"] [
+ dict dup begin
+ dict dup /name exch def
+ begin
+ /first "Barak" def
+ /last "Obama" def
+ end
+ end
+ .name.first
+] test
+
+"Control flow" print
+
+["Yes"] [1 {"Yes"} if] test
+[] [0 {"Yes"} if] test
+
+["Yes"] [1 {"Yes"} {"No"} ifelse] test
+["No"] [0 {"Yes"} {"No"} ifelse] test
+
+[1 2 4 8 16] [1 {dup 2 mul dup 16 ge {exit} if} loop] test
+
+[["A" "A" "A" "A" "A" "A" "A" "A"]] [["A"] 3 {dup arrayappend} repeat] test
+
+[2 6 10 14 18 22 26 30 34 38] [1 2 19 {2 mul} for] test
+[2 6 10 14 18 22 26 30 34] [1 2 19 {2 mul} forx] test
+
+[2 6 10 14] [1 2 7 {2 mul} for] test
+[3 7 11 15] [[1 2 7 {2 mul} for] {1 add} forall] test
+[[3 7 11 15]] [[1 2 7 {2 mul} for] {1 add} map] test
+
+[ 10.1 9 8 7 6 5 4 3 2 ]
+[
+ [ 1.1 2 3 4 5 6 7 8 9 ]
+ [ 9 7 5 3 1 -1 -3 -5 -7 ]
+ { add } twoforall
+] test
+
+[ -7.9 -5 -2 1 4 7 10 13 16 ]
+[
+ [ 1.1 2 3 4 5 6 7 8 9 ]
+ [ 9 7 5 3 1 -1 -3 -5 -7 ]
+ { sub } twoforall
+] test
+
+[[10.1 9 8 7 6 5 4 3 2]]
+[
+ [ 1.1 2 3 4 5 6 7 8 9 ]
+ [ 9 7 5 3 1 -1 -3 -5 -7 ]
+ { add } twomap
+] test
+
+[/x] [/x /y 0 ifpop] test
+[/y] [/x /y 1 ifpop] test
+
+"Registers" print
+[2 1] [1 2 {usereg !b !a ;b ;a} exec] test
+
+[100] [
+ {
+ usereg
+ {dup mul} !squared
+ 10 !x
+
+ :x :squared
+ } exec
+] test
+
+% Ghetto closures
+[6] [
+ /closure-test {
+ usereg
+
+ 5 !x
+
+ {:x 1 add !x} exec
+
+ :x
+ } def
+ closure-test
+] test
+
+[8] [
+ /closure-test {
+ usereg
+
+ 5 !x
+
+ {:x 1 add !x}
+
+ 7 !x
+
+ exec
+
+ :x
+ } def
+ closure-test
+] test
+
+"Make sure nothing is left on the stack after the test" print
+count [exch] [0] test
--- /dev/null
+% Missing math words:
+% aNormal
+
+"Arithmetic" print
+[17] [9 8 add] test
+[(10,20)] [(5,14) (5,6) add] test
+[(10,20,30)] [(5,14,23) (5,6,7) add] test
+
+[-34] [30 64 sub] test
+[(0,8,16)] [(5,14,23) (5,6,7) sub] test
+
+[1170] [117 10 mul] test
+[(15,42)] [(5,14) 3 mul] test
+[(10,28)] [2 (5,14) mul] test
+[(15,42,69)] [(5,14,23) 3 mul] test
+[(10,28,46)] [2 (5,14,23) mul] test
+[2.0] [(1,0) (2,3) mul] test
+[6.0] [(1,0,1) (2,3,4) mul] test
+
+% Stupid bug with vec3 dot product
+[20.0] [(1,0,1) 1 add (2,4,6) mul] test
+
+[0.125] [2 16 div] test
+[(1,4,10)] [(2,8,20) 2 div] test
+
+[3] [7 4 mod] test
+
+[-1.0] [1.0 neg] test
+
+[(-1,-2)] [(1,2) neg] test
+[(-1,-2,-3)] [(1,2,3) neg] test
+
+"Comparisons" print
+[1] [1 1 eq] test
+[0] [1 2 eq] test
+[0] [1 1 ne] test
+[1] [1 2 ne] test
+[1] [1 0 ge] test
+[1] [1 1 ge] test
+[0] [1 2 ge] test
+[1] [1 0 gt] test
+[0] [1 1 gt] test
+[0] [1 2 gt] test
+[0] [1 0 le] test
+[1] [1 1 le] test
+[1] [1 2 le] test
+[0] [1 0 lt] test
+[0] [1 1 lt] test
+[1] [1 2 lt] test
+
+[-1.0] [-2.0 (-1.0,10.0) clamp] test
+[0.5] [0.5 (-1.0,10.0) clamp] test
+[10.0] [22.0 (-1.0,10.0) clamp] test
+
+"Logical operators" print
+[0] [0 0 and] test
+[0] [0 1 and] test
+[0] [0.0 0 and] test
+[0] [0.0 0.0 and] test
+[1] [1.0 1 and] test
+[1] [1.0 "hi" and] test
+
+[0] [0 0 or] test
+[1] [0 1 or] test
+[0] [0.0 0 or] test
+[0] [0.0 0.0 or] test
+[1] [1.0 1 or] test
+[1] [1.0 "hi" or] test
+
+[1] [0 not] test
+[1] [0.0 not] test
+[0] [1 not] test
+[0] ["Hi" not] test
+
+"Functions" print
+[126.42] [-126.42 abs] test
+[5.0] [(3,4) abs] test
+[129.0] [128.15 ceiling] test
+[128.0] [128.95 floor] test
+[-13.0] [-12.35 floor] test
+[12.0] [12.34 trunc] test
+[12] [12 trunc] test
+[-12.0] [-12.35 trunc] test
+[12.0] [12.34 round] test
+[13.0] [12.64 round] test
+[-12.0] [-12.35 round] test
+[-13.0] [-12.65 round] test
+[2.0] [4 sqrt] test
+
+[0.25] [4 inv] test
+[3.0] [1000 log] test
+[1000.0] [10 3 pow] test
+
+[180.0] [-1 acos] test
+[0.0] [1 acos] test
+[-90.0] [-1 asin] test
+[90.0] [1 asin] test
+[-45.0] [-1 atan] test
+[45.0] [1 atan] test
+[45.0] [1 1 atan2] test
+[135.0] [1 -1 atan2] test
+[-45.0] [-1 1 atan2] test
+
+"Vector operations" print
+[5.0] [(5.0,1.3) getX] test
+[1.3] [(5.0,1.3) getY] test
+[5.0] [(5.0,1.3,2.7) getX] test
+[1.3] [(5.0,1.3,2.7) getY] test
+[2.7] [(5.0,1.3,2.7) getZ] test
+
+[(1.7,1.3)] [(5.0,1.3) 1.7 putX] test
+[(5.0,1.7)] [(5.0,1.3) 1.7 putY] test
+[(1.7,1.3,2.7)] [(5.0,1.3,2.7) 1.7 putX] test
+[(5.0,1.7,2.7)] [(5.0,1.3,2.7) 1.7 putY] test
+[(5.0,1.3,1.7)] [(5.0,1.3,2.7) 1.7 putZ] test
+
+[(5.0,1.3)] [5.0 1.3 vector2] test
+[(5.0,1.3,2.7)] [5.0 1.3 2.7 vector3] test
+
+[(3.5,4.1,0.0)] [(1.0,0.0,0.0) (0.0,1.0,0.0) (3.5,4.1) planemul] test
+
+[(0.0,0.0,1.0)] [(1.0,0.0,0.0) (0.0,1.0,0.0) cross] test
+[(0.0,-1.0,0.0)] [(1.0,0.0,0.0) (0.0,0.0,1.0) cross] test
+
+[(-0.0,1)] [(1,0) aNormal] test
+[(-0.0,-1)] [(-1,0) aNormal] test
+[(-1,0)] [(0,1) aNormal] test
+[(1,0)] [(0,-1) aNormal] test
+% [(0.0,1,0)] [(1,0,0) aNormal] test
+% [(-0.0,-1,0)] [(-1,0,0) aNormal] test
+% [(-1,0,0)] [(0,1,0) aNormal] test
+% [(1,0,0)] [(0,-1,0) aNormal] test
+% [(-1,0,0)] [(0,0,1) aNormal] test
+% [(1,0,0)] [(0,0,-1) aNormal] test
+
+[-2.0] [(1,2) (3,4) determinant] test
+[0.0] [(1,2,3) (4,5,6) (7,8,9) determinant] test
+[6.0] [(1,2,3) (4,5,6) (7,8,7) determinant] test
+
+"Fibonacci" print
+
+dict begin
+
+ /fib {
+ dup 1 le {pop 1} {dup 1 sub fib exch 2 sub fib add} ifelse
+ } def
+
+ [121393] [25 fib] test
+
+ /fibreg {
+ dup 1 le
+ {pop 1}
+ {
+ usereg !n
+ ;n 1 sub fib !x
+ ;n 2 sub fib !y
+ ;x ;y add
+ } ifelse
+ } def
+
+ [121393] [25 fibreg] test
+
+end
+
+"Make sure nothing is left on the stack after the test" print
+count [exch] [0] test
--- /dev/null
+[(1,0,0)] [(1,0,0) (0,1,0) 0 rot_vec] test
+
+[1] [(1,0,0) (0,1,0) 90 rot_vec (0,0,-1) approx-eq] test
+[1] [(1,2,3) (0,1,0) 90 rot_vec (3,2,-1) approx-eq] test
+
+[1]
+[
+ (1,2,3) (4,5,6) normalize 45 rot_vec
+ (1.43574109907107,1.539329069804002,3.093398375782619) approx-eq
+] test
+
+"Make sure nothing is left on the stack after the test" print
+count [exch] [0] test
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+USING: accessors kernel math sequences sequences.private
+hashtables assocs locals arrays combinators classes.struct
+math.vectors math.vectors.simd math.vectors.simd.cords ;
+IN: gml.types
+
+: true? ( obj -- ? ) 0 number= not ; inline
+: >true ( ? -- 1/0 ) 1 0 ? ; inline
+
+TUPLE: proc { array array read-only } { registers array read-only } ;
+
+C: <proc> proc
+
+M: proc clone [ array>> clone ] [ registers>> clone ] bi <proc> ;
+
+M: proc length array>> length ;
+M: proc nth-unsafe array>> nth-unsafe ;
+M: proc set-nth-unsafe array>> set-nth-unsafe ;
+M: proc like drop dup proc? [ { } like { } <proc> ] unless ;
+M: proc new-sequence drop 0 <array> { } <proc> ;
+
+INSTANCE: proc sequence
+
+: wrap ( n seq -- n seq ) [ length rem ] keep ; inline
+
+GENERIC# (gml-get) 1 ( collection key -- elt )
+
+M: sequence (gml-get) swap wrap nth ;
+M: hashtable (gml-get) swap at ;
+
+GENERIC# (gml-put) 2 ( collection key elt -- )
+
+M:: sequence (gml-put) ( collection key elt -- )
+ elt key collection wrap set-nth ;
+M:: hashtable (gml-put) ( collection key elt -- )
+ elt key collection set-at ;
+
+GENERIC: (gml-copy) ( collection -- collection' )
+
+M: array (gml-copy) clone ;
+M: hashtable (gml-copy) clone ;
+M: proc (gml-copy) clone ;
+
+ALIAS: vec2d? double-2?
+
+ALIAS: <vec2d> double-2-boa
+
+ALIAS: scalar>vec2d double-2-with
+
+ALIAS: vec3d? double-4?
+
+: <vec3d> ( x y z -- vec ) 0.0 double-4-boa ; inline
+
+: scalar>vec3d ( x -- vec ) dup dup 0.0 double-4-boa ; inline
+
+GENERIC: mask-vec3d ( value -- value' )
+
+M: double-2 mask-vec3d ; inline
+
+M: double-4 mask-vec3d
+ longlong-4{ -1 -1 -1 0 } double-4-cast vbitand ; inline
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.\r
+USING: arrays accessors euler.b-rep fry gml gml.runtime gml.viewer\r
+gml.printer io.directories io.encodings.utf8 io.files\r
+io.pathnames io.streams.string kernel locals models namespaces\r
+sequences ui ui.gadgets ui.gadgets.buttons ui.gadgets.editors\r
+ui.gadgets.frames ui.gadgets.grids ui.gadgets.labels\r
+ui.gadgets.packs ui.gadgets.scrollers ui.gadgets.worlds\r
+ui.gadgets.tables ui.gadgets.labeled unicode.case ;\r
+FROM: gml => gml ;\r
+IN: gml.ui\r
+\r
+SINGLETON: stack-entry-renderer\r
+\r
+M: stack-entry-renderer row-columns\r
+ drop [ write-gml ] with-string-writer 1array ;\r
+\r
+M: stack-entry-renderer row-value\r
+ drop ;\r
+\r
+: <stack-table> ( model -- table )\r
+ stack-entry-renderer <table>\r
+ 10 >>min-rows\r
+ 10 >>max-rows\r
+ 40 >>min-cols\r
+ 40 >>max-cols ;\r
+\r
+: <stack-display> ( model -- gadget )\r
+ <stack-table> <scroller> "Operand stack" <labeled-gadget> ;\r
+\r
+TUPLE: gml-editor < frame editor gml stack-model b-rep b-rep-model ;\r
+\r
+: update-models ( gml-editor -- )\r
+ [ [ b-rep>> dup finish-b-rep ] [ b-rep-model>> ] bi set-model ]\r
+ [ [ gml>> operand-stack>> ] [ stack-model>> ] bi set-model ]\r
+ bi ;\r
+\r
+: with-gml-editor ( gml-editor quot -- )\r
+ '[\r
+ [ [ gml>> gml set ] [ b-rep>> b-rep set ] bi @ ]\r
+ [ update-models ]\r
+ bi\r
+ ] with-scope ; inline\r
+\r
+: find-gml-editor ( gadget -- gml-editor )\r
+ [ gml-editor? ] find-parent ;\r
+\r
+: load-input ( file gml-editor -- )\r
+ [ utf8 file-contents ] dip editor>> set-editor-string ;\r
+\r
+: update-viewer ( gml-editor -- )\r
+ dup [ editor>> editor-string run-gml-string ] with-gml-editor ;\r
+\r
+: new-viewer ( gml-editor -- )\r
+ [ update-viewer ]\r
+ [ [ b-rep-model>> ] [ stack-model>> ] bi gml-viewer ]\r
+ bi ;\r
+\r
+: reset-viewer ( gml-editor -- )\r
+ [\r
+ b-rep get clear-b-rep\r
+ gml get operand-stack>> delete-all\r
+ ] with-gml-editor ;\r
+\r
+: <new-button> ( -- button )\r
+ "New viewer" [ find-gml-editor new-viewer ] <border-button> ;\r
+\r
+: <update-button> ( -- button )\r
+ "Update viewer" [ find-gml-editor update-viewer ] <border-button> ;\r
+\r
+: <reset-button> ( -- button )\r
+ "Reset viewer" [ find-gml-editor reset-viewer ] <border-button> ;\r
+\r
+: <control-buttons> ( -- gadget )\r
+ <shelf> { 5 5 } >>gap\r
+ <new-button> add-gadget\r
+ <update-button> add-gadget\r
+ <reset-button> add-gadget ;\r
+\r
+CONSTANT: example-dir "vocab:gml/examples/"\r
+\r
+: gml-files ( -- seq )\r
+ example-dir directory-files\r
+ [ file-extension >lower "gml" = ] filter ;\r
+\r
+: <example-button> ( file -- button )\r
+ dup '[ example-dir _ append-path swap find-gml-editor load-input ]\r
+ <border-button> ;\r
+\r
+: <example-buttons> ( -- gadget )\r
+ gml-files\r
+ <pile> { 5 5 } >>gap \r
+ "Examples:" <label> add-gadget\r
+ [ <example-button> add-gadget ] reduce ;\r
+\r
+: <editor-panel> ( editor -- gadget )\r
+ 30 >>min-rows\r
+ 30 >>max-rows\r
+ 40 >>min-cols\r
+ 40 >>max-cols\r
+ <scroller> "Editor" <labeled-gadget> ;\r
+\r
+: <gml-editor> ( -- gadget )\r
+ 2 3 gml-editor new-frame\r
+ <gml> >>gml\r
+ <b-rep> >>b-rep\r
+ dup b-rep>> <model> >>b-rep-model\r
+ dup gml>> operand-stack>> <model> >>stack-model\r
+ { 20 20 } >>gap\r
+ { 0 0 } >>filled-cell\r
+ <source-editor> >>editor\r
+ dup editor>> <editor-panel> { 0 0 } grid-add\r
+ dup stack-model>> <stack-display> { 0 1 } grid-add\r
+ <control-buttons> { 0 2 } grid-add\r
+ <example-buttons> { 1 0 } grid-add ;\r
+\r
+M: gml-editor focusable-child* editor>> ;\r
+\r
+: gml-editor-window ( -- )\r
+ <gml-editor> "Generative Modeling Language" open-window ;\r
+\r
+MAIN: gml-editor-window\r
--- /dev/null
+USING: gml.viewer math.vectors.simd.cords tools.test ;\r
+IN: gml.viewer.tests\r
+\r
+[ {\r
+ double-4{ 0 0 0 0 }\r
+ double-4{ 1 1 1 1 }\r
+} ] [ { double-4{ 0 0 0 0 } { double-4{ 1 1 1 1 } 2 } 3 } selected-vectors ] unit-test\r
--- /dev/null
+#version 110\r
+\r
+varying vec4 frag_color;\r
+\r
+void main()\r
+{\r
+ gl_FragColor = frag_color;\r
+}\r
+\r
--- /dev/null
+USING: accessors alien.c-types alien.data.map arrays assocs\r
+byte-arrays colors combinators combinators.short-circuit\r
+destructors euler.b-rep euler.b-rep.triangulation fry\r
+game.input game.loop game.worlds game.models.half-edge gml.printer\r
+gpu gpu.buffers gpu.framebuffers gpu.render gpu.shaders gpu.state\r
+gpu.util.wasd hashtables images kernel literals locals math\r
+math.ranges math.vectors math.vectors.conversion math.vectors.simd\r
+math.vectors.simd.cords method-chains models sequences sets\r
+specialized-arrays specialized-vectors typed math.order namespaces\r
+ui ui.gadgets.worlds ui.gestures ui.pixel-formats growable vectors\r
+alien.data ;\r
+FROM: math.matrices => m.v ;\r
+FROM: models => change-model ;\r
+SPECIALIZED-VECTORS: ushort float-4 ;\r
+IN: gml.viewer\r
+\r
+CONSTANT: neutral-edge-color float-4{ 1 1 1 1 }\r
+CONSTANT: neutral-face-color float-4{ 1 1 1 1 }\r
+CONSTANT: selected-face-color float-4{ 1 0.9 0.8 1 }\r
+\r
+: double-4>float-4 ( in: double-4 -- out: float-4 )\r
+ [ head>> ] [ tail>> ] bi double-2 float-4 vconvert ; inline\r
+: rgba>float-4 ( in: rgba -- out: float-4 )\r
+ >rgba-components float-4-boa ; inline\r
+\r
+: face-color ( edge -- color )\r
+ face-normal float-4{ 0 1 0.1 0 } v. 0.3 * 0.4 + dup dup 1.0 float-4-boa ; inline\r
+\r
+TUPLE: b-rep-vertices\r
+ { array byte-array read-only }\r
+ { face-vertex-count integer read-only }\r
+ { edge-vertex-count integer read-only }\r
+ { point-vertex-count integer read-only } ;\r
+\r
+:: <b-rep-vertices> ( face-array face-count\r
+ edge-array edge-count\r
+ point-array point-count -- vxs )\r
+ face-array edge-array point-array 3append\r
+ face-count edge-count point-count \ b-rep-vertices boa ; inline\r
+\r
+: face-selected? ( face selected -- ? )\r
+ [ f ] 2dip [ edge>> ] dip '[ _ in? or ] each-face-edge ;\r
+\r
+:: b-rep-face-vertices ( b-rep selected -- vertices count indices )\r
+ float-4-vector{ } clone :> vertices\r
+ ushort-vector{ } clone :> indices\r
+\r
+ 0 b-rep faces>> [| count face |\r
+ face selected face-selected? :> selected?\r
+ face dup base-face>> eq? [\r
+ face edge>> face-color\r
+ selected? selected-face-color neutral-face-color ? v* :> color\r
+ face triangulate-face seq>> :> triangles\r
+ triangles members :> tri-vertices\r
+ tri-vertices >index-hash :> vx-indices\r
+\r
+ tri-vertices [\r
+ position>> double-4>float-4 vertices push\r
+ color vertices push\r
+ ] each\r
+ triangles [ vx-indices at count + indices push ] each\r
+\r
+ count tri-vertices length +\r
+ ] [ count ] if\r
+ ] each :> total\r
+ vertices float-4 >c-array underlying>>\r
+ total\r
+ indices ushort-array{ } like ;\r
+\r
+: b-rep-edge-vertices ( b-rep -- vertices count )\r
+ vertices>> [\r
+ [\r
+ position>> [ double-4>float-4 ] keep\r
+ [ drop neutral-edge-color ]\r
+ [ vertex-color rgba>float-4 ] 2bi\r
+ ] data-map( object -- float-4[4] )\r
+ ] [ length 2 * ] bi ; inline\r
+\r
+GENERIC: selected-vectors ( object -- vectors )\r
+M: object selected-vectors drop { } ;\r
+M: double-4 selected-vectors 1array ;\r
+M: sequence selected-vectors [ selected-vectors ] map concat ;\r
+\r
+: selected-vertices ( selected -- vertices count )\r
+ selected-vectors [\r
+ [ [ double-4>float-4 ] [ vertex-color rgba>float-4 ] bi ]\r
+ data-map( object -- float-4[2] )\r
+ ] [ length ] bi ; inline\r
+\r
+: edge-vertex-index ( e vertex-indices selected -- n selected? )\r
+ [ dup vertex>> ] [ at 2 * ] [ swapd in? [ [ 1 + ] when ] keep ] tri* ;\r
+\r
+:: b-rep-edge-index-array ( b-rep selected offset -- edge-indices )\r
+ b-rep vertices>> >index-hash :> vertex-indices\r
+ b-rep edges>> length <ushort-vector> :> edge-indices\r
+\r
+ b-rep edges>> [| e |\r
+ e opposite-edge>> :> o\r
+ e vertex-indices selected edge-vertex-index [ offset + ] dip :> ( from e-selected? )\r
+ o vertex-indices selected edge-vertex-index [ offset + ] dip :> ( to o-selected? )\r
+\r
+ from to < [ from edge-indices push to edge-indices push ] when\r
+ ] each\r
+\r
+ edge-indices ushort-array{ } like ;\r
+\r
+:: make-b-rep-vertices ( b-rep selected -- vertices face-indices edge-indices point-indices )\r
+ b-rep selected b-rep-face-vertices :> ( face-vertices face-count face-indices )\r
+ b-rep b-rep-edge-vertices :> ( edge-vertices edge-count )\r
+ selected selected-vertices :> ( sel-vertices sel-count )\r
+ face-vertices face-count edge-vertices edge-count sel-vertices sel-count\r
+ <b-rep-vertices> :> vertices\r
+ \r
+ vertices array>>\r
+\r
+ face-indices\r
+\r
+ b-rep selected vertices face-vertex-count>> b-rep-edge-index-array\r
+ vertices\r
+\r
+ [ face-vertex-count>> ]\r
+ [ edge-vertex-count>> + dup ]\r
+ [ point-vertex-count>> + ] tri\r
+ [a,b) ushort >c-array ;\r
+\r
+VERTEX-FORMAT: wire-vertex-format\r
+ { "vertex" float-components 3 f }\r
+ { f float-components 1 f }\r
+ { "color" float-components 4 f } ;\r
+\r
+GLSL-SHADER-FILE: gml-viewer-vertex-shader vertex-shader "viewer.v.glsl"\r
+GLSL-SHADER-FILE: gml-viewer-fragment-shader fragment-shader "viewer.f.glsl"\r
+GLSL-PROGRAM: gml-viewer-program\r
+ gml-viewer-vertex-shader gml-viewer-fragment-shader\r
+ wire-vertex-format ;\r
+\r
+TUPLE: gml-viewer-world < wasd-world\r
+ { b-rep b-rep }\r
+ selected\r
+ program\r
+ vertex-array\r
+ face-indices edge-indices point-indices\r
+ view-faces? view-edges?\r
+ drag? ;\r
+\r
+TYPED: refresh-b-rep-view ( world: gml-viewer-world -- )\r
+ dup model>> value>> >>b-rep\r
+ dup vertex-array>> [ vertex-array-buffer dispose ] when*\r
+ dup [ b-rep>> ] [ selected>> value>> ] bi make-b-rep-vertices {\r
+ [\r
+ static-upload draw-usage vertex-buffer byte-array>buffer\r
+ over program>> <vertex-array> >>vertex-array\r
+ ]\r
+ [ >>face-indices ]\r
+ [ >>edge-indices ]\r
+ [ >>point-indices ]\r
+ } spread\r
+ drop ;\r
+\r
+: viewable? ( gml-viewer-world -- ? )\r
+ { [ b-rep>> ] [ program>> ] } 1&& ;\r
+\r
+M: gml-viewer-world model-changed\r
+ nip\r
+ [ model>> value>> ]\r
+ [ b-rep<< ] \r
+ [ dup viewable? [ refresh-b-rep-view ] [ drop ] if ] tri ;\r
+\r
+: init-viewer-model ( gml-viewer-world -- )\r
+ [ dup model>> add-connection ] \r
+ [ dup selected>> add-connection ] bi ;\r
+\r
+: reset-view ( gml-viewer-world -- )\r
+ { 0.0 0.0 5.0 } 0.0 0.0 set-wasd-view drop ;\r
+\r
+M: gml-viewer-world begin-game-world\r
+ init-gpu\r
+ t >>view-faces?\r
+ t >>view-edges?\r
+ T{ point-state { size 5.0 } } set-gpu-state\r
+ dup reset-view\r
+ gml-viewer-program <program-instance> >>program\r
+ dup init-viewer-model\r
+ refresh-b-rep-view ;\r
+\r
+M: gml-viewer-world end-game-world\r
+ [ dup selected>> remove-connection ]\r
+ [ dup model>> remove-connection ] bi ;\r
+\r
+M: gml-viewer-world draw-world*\r
+ system-framebuffer {\r
+ { default-attachment { 0.0 0.0 0.0 1.0 } }\r
+ { depth-attachment 1.0 }\r
+ } clear-framebuffer\r
+ \r
+ [\r
+ dup view-faces?>> [\r
+ T{ depth-state { comparison cmp-less } } set-gpu-state\r
+ {\r
+ { "primitive-mode" [ drop triangles-mode ] }\r
+ { "indexes" [ face-indices>> ] }\r
+ { "uniforms" [ <mvp-uniforms> ] }\r
+ { "vertex-array" [ vertex-array>> ] }\r
+ } <render-set> render\r
+ T{ depth-state { comparison f } } set-gpu-state\r
+ ] [ drop ] if\r
+ ] [\r
+ dup view-edges?>> [\r
+ {\r
+ { "primitive-mode" [ drop lines-mode ] }\r
+ { "indexes" [ edge-indices>> ] }\r
+ { "uniforms" [ <mvp-uniforms> ] }\r
+ { "vertex-array" [ vertex-array>> ] }\r
+ } <render-set> render\r
+ ] [ drop ] if\r
+ ] [ \r
+ {\r
+ { "primitive-mode" [ drop points-mode ] }\r
+ { "indexes" [ point-indices>> ] }\r
+ { "uniforms" [ <mvp-uniforms> ] }\r
+ { "vertex-array" [ vertex-array>> ] }\r
+ } <render-set> render\r
+ ] tri ;\r
+\r
+TYPED: rotate-view-mode ( world: gml-viewer-world -- )\r
+ dup view-edges?>> [\r
+ dup view-faces?>>\r
+ [ f >>view-faces? ]\r
+ [ f >>view-edges? t >>view-faces? ] if\r
+ ] [ t >>view-edges? ] if drop ;\r
+\r
+CONSTANT: edge-hitbox-radius 0.05\r
+\r
+:: line-nearest-t ( p0 u q0 v -- tp tq )\r
+ p0 q0 v- :> w0\r
+\r
+ u u v. :> a\r
+ u v v. :> b\r
+ v v v. :> c\r
+ u w0 v. :> d\r
+ v w0 v. :> e\r
+\r
+ a c * b b * - :> denom\r
+\r
+ b e * c d * - denom /f\r
+ a e * b d * - denom /f ;\r
+\r
+:: intersects-edge-node? ( source direction edge -- ? )\r
+ edge vertex>> position>> double-4>float-4 :> edge-source\r
+ edge opposite-edge>> vertex>> position>> double-4>float-4 edge-source v- :> edge-direction\r
+\r
+ source direction edge-source edge-direction line-nearest-t :> ( ray-t edge-t )\r
+\r
+ ray-t 0.0 >= edge-t 0.0 0.5 between? and [\r
+ source direction ray-t v*n v+\r
+ edge-source edge-direction edge-t v*n v+ v- norm\r
+ edge-hitbox-radius <\r
+ ] [ f ] if ;\r
+\r
+: intersecting-edge-node ( source direction b-rep -- edge/f )\r
+ edges>> [ intersects-edge-node? ] with with find nip ;\r
+\r
+: select-edge ( world -- )\r
+ [ [ location>> ] [ hand-loc get wasd-pixel-ray ] bi ]\r
+ [ b-rep>> intersecting-edge-node ]\r
+ [ '[ _ [ selected>> push-model ] [ refresh-b-rep-view ] bi ] when* ] tri ;\r
+\r
+gml-viewer-world H{\r
+ { T{ button-up f f 1 } [ dup drag?>> [ drop ] [ select-edge ] if ] }\r
+ { T{ drag f 1 } [ t >>drag? drop ] }\r
+ { T{ key-down f f "RET" } [ reset-view ] }\r
+ { T{ key-down f f "TAB" } [ rotate-view-mode ] }\r
+} set-gestures\r
+\r
+AFTER: gml-viewer-world tick-game-world\r
+ dup drag?>> [\r
+ read-mouse buttons>>\r
+ ! FIXME: GTK Mouse buttons are an integer\r
+ ! MacOSX mouse buttons are an array of bools\r
+ dup integer? [ 0 bit? ] [ first ] if >>drag?\r
+ ] when drop ;\r
+\r
+M: gml-viewer-world wasd-mouse-scale drag?>> -1/600. 0.0 ? ;\r
+\r
+: wrap-in-model ( object -- model )\r
+ dup model? [ <model> ] unless ;\r
+: wrap-in-growable-model ( object -- model )\r
+ dup model? [\r
+ dup growable? [ >vector ] unless\r
+ <model>\r
+ ] unless ;\r
+\r
+: gml-viewer ( b-rep selection -- )\r
+ [ wrap-in-model ] [ wrap-in-growable-model ] bi*\r
+ '[\r
+ f T{ game-attributes\r
+ { world-class gml-viewer-world }\r
+ { title "GML wireframe viewer" }\r
+ { pixel-format-attributes {\r
+ windowed\r
+ double-buffered\r
+ T{ depth-bits f 16 }\r
+ } }\r
+ { grab-input? f }\r
+ { use-game-input? t }\r
+ { use-audio-engine? f }\r
+ { pref-dim { 1024 768 } }\r
+ { tick-interval-nanos $[ 30 fps ] }\r
+ } open-window*\r
+ _ >>model\r
+ _ >>selected\r
+ drop\r
+ ] with-ui ;\r
+\r
--- /dev/null
+#version 110\r
+\r
+uniform mat4 p_matrix;\r
+uniform mat4 mv_matrix;\r
+\r
+attribute vec3 vertex;\r
+attribute vec4 color;\r
+\r
+varying vec4 frag_color;\r
+\r
+void main()\r
+{\r
+ gl_Position = p_matrix * mv_matrix * vec4(vertex, 1.0);\r
+ frag_color = color;\r
+}\r
projects / factor.git / commitdiff