--- /dev/null
+USING: accessors euler.b-rep euler.modeling euler.operators
+euler.b-rep.examples kernel locals math.vectors.simd.cords
+namespaces sequences tools.test ;
+IN: euler.b-rep.tests
+
+{ double-4{ 0.0 0.0 -1.0 0.0 } }
+[ valid-cube-b-rep edges>> first face-normal ] unit-test
+
+{ double-4{ 0.0 0.0 -1.0 0.0 } -1.0 }
+[ valid-cube-b-rep edges>> first face-plane ] unit-test
+
+{ t } [ 0 multi-ringed-face-cube-b-rep faces>> nth base-face? ] unit-test
+{ t } [ 5 multi-ringed-face-cube-b-rep faces>> nth base-face? ] unit-test
+{ f } [ 6 multi-ringed-face-cube-b-rep faces>> nth base-face? ] unit-test
+
+:: mock-face ( p0 p1 p2 -- edge )
+ b-edge new vertex new p0 >>position >>vertex :> e0
+ b-edge new vertex new p1 >>position >>vertex :> e1
+ b-edge new vertex new p2 >>position >>vertex :> e2
+
+ e1 e0 next-edge<<
+ e2 e1 next-edge<<
+ e0 e2 next-edge<<
+
+ e0 ;
+
+{
+ double-4{
+ 0x1.279a74590331dp-1
+ 0x1.279a74590331dp-1
+ 0x1.279a74590331dp-1
+ 0.0
+ }
+ -0x1.bb67ae8584cabp1
+} [
+ double-4{ 1 0 5 0 }
+ double-4{ 0 1 5 0 }
+ double-4{ 0 0 6 0 } mock-face face-plane
+] unit-test
+
+V{ t } clone sharpness-stack [
+ [ t ] [ get-sharpness ] unit-test
+ [ V{ f } ] [ f set-sharpness sharpness-stack get ] unit-test
+ [ V{ f t } t ] [ t push-sharpness sharpness-stack get get-sharpness ] unit-test
+ [ t V{ f } f ] [ pop-sharpness sharpness-stack get get-sharpness ] unit-test
+] with-variable
+
+{ t } [ valid-cube-b-rep [ edges>> first ] keep is-valid-edge? ] unit-test
+{ f } [ b-edge new valid-cube-b-rep is-valid-edge? ] unit-test
+
+{ t } [
+ valid-cube-b-rep edges>>
+ [ [ 0 swap nth ] [ 1 swap nth ] bi connecting-edge ]
+ [ 0 swap nth ] bi eq?
+] unit-test
+
+{ t } [
+ valid-cube-b-rep edges>>
+ [ [ 1 swap nth ] [ 0 swap nth ] bi connecting-edge ]
+ [ 6 swap nth ] bi eq?
+] unit-test
+
+{ t } [
+ valid-cube-b-rep edges>>
+ [ [ 0 swap nth ] [ 3 swap nth ] bi connecting-edge ]
+ [ 21 swap nth ] bi eq?
+] unit-test
+
+{ f } [
+ valid-cube-b-rep edges>>
+ [ 0 swap nth ] [ 2 swap nth ] bi connecting-edge
+] unit-test
+
+{ double-4{ 0 0 -1 0 } } [
+ [
+ { double-4{ 0 0 0 0 } double-4{ 0 1 0 0 } double-4{ 0 2 0 0 } double-4{ 1 1 0 0 } }
+ smooth-smooth polygon>double-face face-normal
+ ] make-b-rep drop
+] unit-test
--- /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 ) H{ } zip-index-as ; 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 [ bl ] [ number>string write ] interleave nl ;
+
+: write-obj-face ( face vx-indices -- )
+ "f" write
+ [ edge>> ] dip '[ bl 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
+euler.modeling game.models.half-edge ;
+IN: euler.modeling.tests
+
+! polygon>double-face
+{ } [
+ [
+ { { -1 -1 0 } { 1 -1 0 } { 1 1 0 } { -1 1 0 } }
+ smooth-smooth polygon>double-face
+ [ face-sides 4 assert= ]
+ [ opposite-edge>> face-sides 4 assert= ]
+ [ face-normal { 0.0 0.0 1.0 } assert= ]
+ tri
+ ] make-b-rep check-b-rep
+] unit-test
+
+! extrude-simple
+{ } [
+ [
+ { { -1 -1 0 } { 1 -1 0 } { 1 1 0 } }
+ smooth-smooth polygon>double-face
+ 1 f extrude-simple
+ [ face-sides 3 assert= ]
+ [ opposite-edge>> face-sides 4 assert= ]
+ bi
+ ] make-b-rep check-b-rep
+] unit-test
+
+! project-pt-line
+{ { 0 1 0 } } [ { 0 0 0 } { 0 1 0 } { 1 1 0 } project-pt-line ] unit-test
+{ { 0 1 0 } } [ { 0 0 0 } { 1 1 0 } { 0 1 0 } project-pt-line ] unit-test
+{ { 0 1 0 } } [ { 0 0 0 } { 2 1 0 } { 1 1 0 } project-pt-line ] unit-test
+{ { -1 1 0 } } [ { -1 0 0 } { 2 1 0 } { 1 1 0 } project-pt-line ] unit-test
+{ { 1/2 1/2 0 } } [ { 0 0 0 } { 0 1 0 } { 1 0 0 } project-pt-line ] unit-test
+
+! project-pt-plane
+{ { 0 0 1 } } [ { 0 0 0 } { 0 0 1 } { 0 0 1 } -1 project-pt-plane ] unit-test
+{ { 0 0 -1 } } [ { 0 0 0 } { 0 0 1 } { 0 0 1 } 1 project-pt-plane ] unit-test
+{ { 0 0 3 } } [ { 0 0 0 } { 0 0 1 } { 0 0 1 } -3 project-pt-plane ] unit-test
+{ { 0 0 3 } } [ { 0 0 0 } { 0 0 1 } { 0 0 -1 } 3 project-pt-plane ] unit-test
+{ { 0 0 1 } } [ { 0 0 0 } { 0 0 1 } { 0 1 1 } -1 project-pt-plane ] unit-test
+
+{ { 0 2/3 1/3 } } [ { 0 0 0 } { 0 2 1 } { 0 1 1 } -1 project-pt-plane ] unit-test
+
+{ { 0 0 1 } } [ { 0 0 0 } { 0 0 1/2 } { 0 0 1 } -1 project-pt-plane ] unit-test
+{ { 0 1 1 } } [ { 0 0 0 } { 0 1/2 1/2 } { 0 0 1 } -1 project-pt-plane ] unit-test
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+USING: accessors combinators fry kernel locals math.vectors
+namespaces sets sequences game.models.half-edge euler.b-rep
+euler.operators math ;
+IN: euler.modeling
+
+: (polygon>double-face) ( polygon -- edge )
+ [ first2 make-vefs ] keep
+ [ drop opposite-edge>> ] [ 2 tail-slice [ make-ev-one ] each ] 2bi
+ make-ef face-ccw ;
+
+SYMBOLS: smooth-smooth
+sharp-smooth
+smooth-sharp
+sharp-sharp
+smooth-like-vertex
+sharp-like-vertex
+smooth-continue
+sharp-continue ;
+
+: polygon>double-face ( polygon mode -- edge )
+ ! This only handles the simple case with no repeating vertices
+ drop
+ dup all-unique? [ "polygon>double-face doesn't support repeating vertices yet" throw ] unless
+ (polygon>double-face) ;
+
+:: extrude-simple ( edge dist sharp? -- edge )
+ edge face-normal dist v*n :> vec
+ edge vertex-pos vec v+ :> pos
+ edge pos make-ev-one :> e0!
+ e0 opposite-edge>> :> e-end
+ edge face-ccw :> edge!
+
+ [ edge e-end eq? not ] [
+ edge vertex-pos vec v+ :> pos
+ edge pos make-ev-one :> e1
+ e0 e1 make-ef drop
+ e1 e0!
+ edge face-ccw edge!
+ ] do while
+
+ e-end face-ccw :> e-end
+ e0 e-end make-ef drop
+
+ e-end ;
+
+: check-bridge-rings ( e1 e2 -- )
+ {
+ [ [ face>> assert-no-rings ] bi@ ]
+ [ [ face>> assert-base-face ] bi@ ]
+ [ assert-different-faces ]
+ [ [ face-sides ] bi@ assert= ]
+ } 2cleave ;
+
+:: bridge-rings-simple ( e1 e2 sharp? -- edge )
+ e1 e2 check-bridge-rings
+ e1 e2 kill-f-make-rh
+ e1 e2 make-e-kill-r face-cw :> ea!
+ e2 face-ccw :> eb!
+ [ ea e1 eq? not ] [
+ ea eb make-ef opposite-edge>> face-cw ea!
+ eb face-ccw eb!
+ ] while
+ eb ;
+
+:: project-pt-line ( p p0 p1 -- q )
+ p1 p0 v- :> vt
+ p p0 v- vt v* sum
+ vt norm-sq /
+ vt n*v p0 v+ ; inline
+
+:: project-pt-plane ( line-p0 line-vt plane-n plane-d -- q )
+ plane-d neg plane-n line-p0 v. -
+ line-vt plane-n v. /
+ line-vt n*v line-p0 v+ ; inline
+
+: project-poly-plane ( poly vdir plane-n plane-d -- qoly )
+ '[ _ _ _ project-pt-plane ] map ; inline
--- /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
+
+USING: accessors arrays combinators combinators.short-circuit
+fry kernel locals math math.intervals math.vectors multi-methods
+sequences ;
+FROM: multi-methods => GENERIC: ;
+IN: flatland
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Two dimensional world protocol
+
+GENERIC: x ( obj -- x )
+GENERIC: y ( obj -- y )
+
+GENERIC: (x!) ( x obj -- )
+GENERIC: (y!) ( y obj -- )
+
+: x! ( obj x -- obj ) over (x!) ;
+: y! ( obj y -- obj ) over (y!) ;
+
+GENERIC: width ( obj -- width )
+GENERIC: height ( obj -- height )
+
+GENERIC: (width!) ( width obj -- )
+GENERIC: (height!) ( height obj -- )
+
+: width! ( obj width -- obj ) over (width!) ;
+: height! ( obj height -- obj ) over (width!) ;
+
+! Predicates on relative placement
+
+GENERIC: to-the-left-of? ( obj obj -- ? )
+GENERIC: to-the-right-of? ( obj obj -- ? )
+
+GENERIC: below? ( obj obj -- ? )
+GENERIC: above? ( obj obj -- ? )
+
+GENERIC: in-between-horizontally? ( obj obj -- ? )
+
+GENERIC: horizontal-interval ( obj -- interval )
+
+GENERIC: move-to ( obj obj -- )
+
+GENERIC: move-by ( obj delta -- )
+
+GENERIC: move-left-by ( obj obj -- )
+GENERIC: move-right-by ( obj obj -- )
+
+GENERIC: left ( obj -- left )
+GENERIC: right ( obj -- right )
+GENERIC: bottom ( obj -- bottom )
+GENERIC: top ( obj -- top )
+
+GENERIC: distance ( a b -- c )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Some of the above methods work on two element sequences.
+! A two element sequence may represent a point in space or describe
+! width and height.
+
+METHOD: x { sequence } first ;
+METHOD: y { sequence } second ;
+
+METHOD: (x!) { number sequence } set-first ;
+METHOD: (y!) { number sequence } set-second ;
+
+METHOD: width { sequence } first ;
+METHOD: height { sequence } second ;
+
+: changed-x ( seq quot -- ) over [ [ x ] dip call ] dip (x!) ; inline
+: changed-y ( seq quot -- ) over [ [ y ] dip call ] dip (y!) ; inline
+
+METHOD: move-to { sequence sequence } [ x x! ] [ y y! ] bi drop ;
+METHOD: move-by { sequence sequence } dupd v+ [ x x! ] [ y y! ] bi drop ;
+
+METHOD: move-left-by { sequence number } '[ _ - ] changed-x ;
+METHOD: move-right-by { sequence number } '[ _ + ] changed-x ;
+
+! METHOD: move-left-by { sequence number } neg 0 2array move-by ;
+! METHOD: move-right-by { sequence number } 0 2array move-by ;
+
+! METHOD:: move-left-by { SEQ:sequence X:number -- )
+! SEQ { X 0 } { -1 0 } v* move-by ;
+
+METHOD: distance { sequence sequence } v- norm ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! A class for objects with a position
+
+TUPLE: <pos> pos ;
+
+METHOD: x { <pos> } pos>> first ;
+METHOD: y { <pos> } pos>> second ;
+
+METHOD: (x!) { number <pos> } pos>> set-first ;
+METHOD: (y!) { number <pos> } pos>> set-second ;
+
+METHOD: to-the-left-of? { <pos> number } [ x ] dip < ;
+METHOD: to-the-right-of? { <pos> number } [ x ] dip > ;
+
+METHOD: move-left-by { <pos> number } [ pos>> ] dip move-left-by ;
+METHOD: move-right-by { <pos> number } [ pos>> ] dip move-right-by ;
+
+METHOD: above? { <pos> number } [ y ] dip > ;
+METHOD: below? { <pos> number } [ y ] dip < ;
+
+METHOD: move-by { <pos> sequence } '[ _ v+ ] change-pos drop ;
+
+METHOD: distance { <pos> <pos> } [ pos>> ] bi@ distance ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! A class for objects with velocity. It inherits from <pos>. Hey, if
+! it's moving it has a position right? Unless it's some alternate universe...
+
+TUPLE: <vel> < <pos> vel ;
+
+: moving-up? ( obj -- ? ) vel>> y 0 > ;
+: moving-down? ( obj -- ? ) vel>> y 0 < ;
+
+: step-size ( vel time -- dist ) [ vel>> ] dip v*n ;
+: move-for ( vel time -- ) dupd step-size move-by ;
+
+: reverse-horizontal-velocity ( vel -- ) vel>> [ x neg ] [ ] bi (x!) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! The 'pos' slot indicates the lower left hand corner of the
+! rectangle. The 'dim' is holds the width and height.
+
+TUPLE: <rectangle> < <pos> dim ;
+
+METHOD: width { <rectangle> } dim>> first ;
+METHOD: height { <rectangle> } dim>> second ;
+
+METHOD: left { <rectangle> } x ;
+METHOD: right { <rectangle> } [ x ] [ width ] bi + ;
+METHOD: bottom { <rectangle> } y ;
+METHOD: top { <rectangle> } [ y ] [ height ] bi + ;
+
+: bottom-left ( rectangle -- pos ) pos>> ;
+
+: center-x ( rectangle -- x ) [ left ] [ width 2 / ] bi + ;
+: center-y ( rectangle -- y ) [ bottom ] [ height 2 / ] bi + ;
+
+: center ( rectangle -- seq ) [ center-x ] [ center-y ] bi 2array ;
+
+METHOD: to-the-left-of? { <pos> <rectangle> } [ x ] [ left ] bi* < ;
+METHOD: to-the-right-of? { <pos> <rectangle> } [ x ] [ right ] bi* > ;
+
+METHOD: below? { <pos> <rectangle> } [ y ] [ bottom ] bi* < ;
+METHOD: above? { <pos> <rectangle> } [ y ] [ top ] bi* > ;
+
+METHOD: horizontal-interval { <rectangle> }
+ [ left ] [ right ] bi [a,b] ;
+
+METHOD: in-between-horizontally? { <pos> <rectangle> }
+ [ x ] [ horizontal-interval ] bi* interval-contains? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <extent> left right bottom top ;
+
+METHOD: left { <extent> } left>> ;
+METHOD: right { <extent> } right>> ;
+METHOD: bottom { <extent> } bottom>> ;
+METHOD: top { <extent> } top>> ;
+
+METHOD: width { <extent> } [ right>> ] [ left>> ] bi - ;
+METHOD: height { <extent> } [ top>> ] [ bottom>> ] bi - ;
+
+! METHOD: to-extent ( <rectangle> -- <extent> )
+! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave <extent> boa ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: to-the-left-of? { sequence <rectangle> } [ x ] [ left ] bi* < ;
+METHOD: to-the-right-of? { sequence <rectangle> } [ x ] [ right ] bi* > ;
+
+METHOD: below? { sequence <rectangle> } [ y ] [ bottom ] bi* < ;
+METHOD: above? { sequence <rectangle> } [ y ] [ top ] bi* > ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Some support for the' 'rect' class from math.geometry.rect'
+
+! METHOD: width ( rect -- width ) dim>> first ;
+! METHOD: height ( rect -- height ) dim>> second ;
+
+! METHOD: left ( rect -- left ) loc>> x
+! METHOD: right ( rect -- right ) [ loc>> x ] [ width ] bi + ;
+
+! METHOD: to-the-left-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* < ;
+! METHOD: to-the-right-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* > ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: wrap ( POINT RECT -- POINT )
+ {
+ { [ POINT RECT to-the-left-of? ] [ RECT right ] }
+ { [ POINT RECT to-the-right-of? ] [ RECT left ] }
+ { [ t ] [ POINT x ] }
+ }
+ cond
+
+ {
+ { [ POINT RECT below? ] [ RECT top ] }
+ { [ POINT RECT above? ] [ RECT bottom ] }
+ { [ t ] [ POINT y ] }
+ }
+ cond
+
+ 2array ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: within? ( a b -- ? )
+
+METHOD: within? { <pos> <rectangle> }
+ {
+ [ left to-the-right-of? ]
+ [ right to-the-left-of? ]
+ [ bottom above? ]
+ [ top below? ]
+ }
+ 2&& ;
--- /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 )
+ zip-index sort-keys reverse values ;
+
+! Dictionaries
+ERROR: not-a-dict object ;
+: 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 object ;
+
+: 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 -- quot )
+ 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-word-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.
+USING: kernel sequences euler.modeling gml.runtime ;
+IN: gml.modeling
+
+GML: poly2doubleface ( poly mode -- edge )
+ {
+ smooth-smooth
+ sharp-smooth
+ smooth-sharp
+ sharp-sharp
+ smooth-like-vertex
+ sharp-like-vertex
+ smooth-continue
+ sharp-continue
+ } nth polygon>double-face ;
+
+GML: extrude-simple ( edge dist sharp -- edge ) extrude-simple ;
+
+GML: bridgerings-simple ( e1 e2 sharp -- edge ) bridge-rings-simple ;
+
+GML: project_ptline ( p p0 p1 -- q ) project-pt-line ;
+
+GML: project_ptplane ( p dir n d -- q ) project-pt-plane ;
+
+GML: project_polyplane ( [p] dir n d -- [q] ) project-poly-plane ;
--- /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\n\r]
+
+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? ] reject ]]
+
+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-short-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-word-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) of ;
+
+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.
+USING: arrays accessors euler.b-rep fry gml gml.runtime gml.viewer
+gml.printer io.directories io.encodings.utf8 io.files
+io.pathnames io.streams.string kernel locals models namespaces
+sequences ui ui.gadgets ui.gadgets.buttons ui.gadgets.editors
+ui.gadgets.frames ui.gadgets.grids ui.gadgets.labels
+ui.gadgets.packs ui.gadgets.scrollers ui.gadgets.worlds
+ui.gadgets.tables ui.gadgets.labeled unicode.case ;
+FROM: gml => gml ;
+IN: gml.ui
+
+SINGLETON: stack-entry-renderer
+
+M: stack-entry-renderer row-columns
+ drop [ write-gml ] with-string-writer 1array ;
+
+M: stack-entry-renderer row-value
+ drop ;
+
+: <stack-table> ( model -- table )
+ stack-entry-renderer <table>
+ 10 >>min-rows
+ 10 >>max-rows
+ 40 >>min-cols
+ 40 >>max-cols ;
+
+: <stack-display> ( model -- gadget )
+ <stack-table> <scroller> "Operand stack" <labeled-gadget> ;
+
+TUPLE: gml-editor < frame editor gml stack-model b-rep b-rep-model ;
+
+: update-models ( gml-editor -- )
+ [ [ b-rep>> dup finish-b-rep ] [ b-rep-model>> ] bi set-model ]
+ [ [ gml>> operand-stack>> ] [ stack-model>> ] bi set-model ]
+ bi ;
+
+: with-gml-editor ( gml-editor quot -- )
+ '[
+ [ [ gml>> gml set ] [ b-rep>> b-rep set ] bi @ ]
+ [ update-models ]
+ bi
+ ] with-scope ; inline
+
+: find-gml-editor ( gadget -- gml-editor )
+ [ gml-editor? ] find-parent ;
+
+: load-input ( file gml-editor -- )
+ [ utf8 file-contents ] dip editor>> set-editor-string ;
+
+: update-viewer ( gml-editor -- )
+ dup [ editor>> editor-string run-gml-string ] with-gml-editor ;
+
+: new-viewer ( gml-editor -- )
+ [ update-viewer ]
+ [ [ b-rep-model>> ] [ stack-model>> ] bi gml-viewer ]
+ bi ;
+
+: reset-viewer ( gml-editor -- )
+ [
+ b-rep get clear-b-rep
+ gml get operand-stack>> delete-all
+ ] with-gml-editor ;
+
+: <new-button> ( -- button )
+ "New viewer" [ find-gml-editor new-viewer ] <border-button> ;
+
+: <update-button> ( -- button )
+ "Update viewer" [ find-gml-editor update-viewer ] <border-button> ;
+
+: <reset-button> ( -- button )
+ "Reset viewer" [ find-gml-editor reset-viewer ] <border-button> ;
+
+: <control-buttons> ( -- gadget )
+ <shelf> { 5 5 } >>gap
+ <new-button> add-gadget
+ <update-button> add-gadget
+ <reset-button> add-gadget ;
+
+CONSTANT: example-dir "vocab:gml/examples/"
+
+: gml-files ( -- seq )
+ example-dir directory-files
+ [ file-extension >lower "gml" = ] filter ;
+
+: <example-button> ( file -- button )
+ dup '[ example-dir _ append-path swap find-gml-editor load-input ]
+ <border-button> ;
+
+: <example-buttons> ( -- gadget )
+ gml-files
+ <pile> { 5 5 } >>gap
+ "Examples:" <label> add-gadget
+ [ <example-button> add-gadget ] reduce ;
+
+: <editor-panel> ( editor -- gadget )
+ 30 >>min-rows
+ 30 >>max-rows
+ 40 >>min-cols
+ 40 >>max-cols
+ <scroller> "Editor" <labeled-gadget> ;
+
+: <gml-editor> ( -- gadget )
+ 2 3 gml-editor new-frame
+ <gml> >>gml
+ <b-rep> >>b-rep
+ dup b-rep>> <model> >>b-rep-model
+ dup gml>> operand-stack>> <model> >>stack-model
+ { 20 20 } >>gap
+ { 0 0 } >>filled-cell
+ <source-editor> >>editor
+ dup editor>> <editor-panel> { 0 0 } grid-add
+ dup stack-model>> <stack-display> { 0 1 } grid-add
+ <control-buttons> { 0 2 } grid-add
+ <example-buttons> { 1 0 } grid-add ;
+
+M: gml-editor focusable-child* editor>> ;
+
+: gml-editor-window ( -- )
+ <gml-editor> "Generative Modeling Language" open-window ;
+
+MAIN: gml-editor-window
--- /dev/null
+USING: gml.viewer math.vectors.simd.cords tools.test ;
+IN: gml.viewer.tests
+
+{ {
+ double-4{ 0 0 0 0 }
+ double-4{ 1 1 1 1 }
+} } [ { double-4{ 0 0 0 0 } { double-4{ 1 1 1 1 } 2 } 3 } selected-vectors ] unit-test
--- /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 alien.data.map arrays
+assocs byte-arrays colors combinators combinators.short-circuit
+destructors euler.b-rep euler.b-rep.triangulation fry game.input
+game.loop game.models.half-edge game.worlds gml.printer gpu
+gpu.buffers gpu.framebuffers gpu.render gpu.shaders gpu.state
+gpu.util.wasd growable images kernel literals locals math
+math.order math.ranges math.vectors math.vectors.conversion
+math.vectors.simd math.vectors.simd.cords method-chains models
+namespaces sequences sets specialized-vectors typed ui
+ui.gadgets ui.gadgets.worlds ui.gestures ui.pixel-formats
+vectors ;
+FROM: math.matrices => m.v ;
+FROM: models => change-model ;
+SPECIALIZED-VECTORS: ushort float-4 ;
+IN: gml.viewer
+
+CONSTANT: neutral-edge-color float-4{ 1 1 1 1 }
+CONSTANT: neutral-face-color float-4{ 1 1 1 1 }
+CONSTANT: selected-face-color float-4{ 1 0.9 0.8 1 }
+
+: double-4>float-4 ( in: double-4 -- out: float-4 )
+ [ head>> ] [ tail>> ] bi double-2 float-4 vconvert ; inline
+: rgba>float-4 ( in: rgba -- out: float-4 )
+ >rgba-components float-4-boa ; inline
+
+: face-color ( edge -- color )
+ face-normal float-4{ 0 1 0.1 0 } v. 0.3 * 0.4 + dup dup 1.0 float-4-boa ; inline
+
+TUPLE: b-rep-vertices
+ { array byte-array read-only }
+ { face-vertex-count integer read-only }
+ { edge-vertex-count integer read-only }
+ { point-vertex-count integer read-only } ;
+
+:: <b-rep-vertices> ( face-array face-count
+ edge-array edge-count
+ point-array point-count -- vxs )
+ face-array edge-array point-array 3append
+ face-count edge-count point-count \ b-rep-vertices boa ; inline
+
+: face-selected? ( face selected -- ? )
+ [ f ] 2dip [ edge>> ] dip '[ _ in? or ] each-face-edge ;
+
+:: b-rep-face-vertices ( b-rep selected -- vertices count indices )
+ float-4-vector{ } clone :> vertices
+ ushort-vector{ } clone :> indices
+
+ 0 b-rep faces>> [| count face |
+ face selected face-selected? :> selected?
+ face dup base-face>> eq? [
+ face edge>> face-color
+ selected? selected-face-color neutral-face-color ? v* :> color
+ face triangulate-face seq>> :> triangles
+ triangles members :> tri-vertices
+ tri-vertices >index-hash :> vx-indices
+
+ tri-vertices [
+ position>> double-4>float-4 vertices push
+ color vertices push
+ ] each
+ triangles [ vx-indices at count + indices push ] each
+
+ count tri-vertices length +
+ ] [ count ] if
+ ] each :> total
+ vertices float-4 >c-array underlying>>
+ total
+ indices ushort-array{ } like ;
+
+: b-rep-edge-vertices ( b-rep -- vertices count )
+ vertices>> [
+ [
+ position>> [ double-4>float-4 ] keep
+ [ drop neutral-edge-color ]
+ [ vertex-color rgba>float-4 ] 2bi
+ ] data-map( object -- float-4[4] )
+ ] [ length 2 * ] bi ; inline
+
+GENERIC: selected-vectors ( object -- vectors )
+M: object selected-vectors drop { } ;
+M: double-4 selected-vectors 1array ;
+M: sequence selected-vectors [ selected-vectors ] map concat ;
+
+: selected-vertices ( selected -- vertices count )
+ selected-vectors [
+ [ [ double-4>float-4 ] [ vertex-color rgba>float-4 ] bi ]
+ data-map( object -- float-4[2] )
+ ] [ length ] bi ; inline
+
+: edge-vertex-index ( e vertex-indices selected -- n selected? )
+ [ dup vertex>> ] [ at 2 * ] [ swapd in? [ [ 1 + ] when ] keep ] tri* ;
+
+:: b-rep-edge-index-array ( b-rep selected offset -- edge-indices )
+ b-rep vertices>> >index-hash :> vertex-indices
+ b-rep edges>> length <ushort-vector> :> edge-indices
+
+ b-rep edges>> [| e |
+ e opposite-edge>> :> o
+ e vertex-indices selected edge-vertex-index [ offset + ] dip :> ( from e-selected? )
+ o vertex-indices selected edge-vertex-index [ offset + ] dip :> ( to o-selected? )
+
+ from to < [ from edge-indices push to edge-indices push ] when
+ ] each
+
+ edge-indices ushort-array{ } like ;
+
+:: make-b-rep-vertices ( b-rep selected -- vertices face-indices edge-indices point-indices )
+ b-rep selected b-rep-face-vertices :> ( face-vertices face-count face-indices )
+ b-rep b-rep-edge-vertices :> ( edge-vertices edge-count )
+ selected selected-vertices :> ( sel-vertices sel-count )
+ face-vertices face-count edge-vertices edge-count sel-vertices sel-count
+ <b-rep-vertices> :> vertices
+
+ vertices array>>
+
+ face-indices
+
+ b-rep selected vertices face-vertex-count>> b-rep-edge-index-array
+ vertices
+
+ [ face-vertex-count>> ]
+ [ edge-vertex-count>> + dup ]
+ [ point-vertex-count>> + ] tri
+ [a,b) ushort >c-array ;
+
+VERTEX-FORMAT: wire-vertex-format
+ { "vertex" float-components 3 f }
+ { f float-components 1 f }
+ { "color" float-components 4 f } ;
+
+GLSL-SHADER-FILE: gml-viewer-vertex-shader vertex-shader "viewer.v.glsl"
+GLSL-SHADER-FILE: gml-viewer-fragment-shader fragment-shader "viewer.f.glsl"
+GLSL-PROGRAM: gml-viewer-program
+ gml-viewer-vertex-shader gml-viewer-fragment-shader
+ wire-vertex-format ;
+
+TUPLE: gml-viewer-world < wasd-world
+ { b-rep b-rep }
+ selected
+ program
+ vertex-array
+ face-indices edge-indices point-indices
+ view-faces? view-edges?
+ drag? ;
+
+TYPED: refresh-b-rep-view ( world: gml-viewer-world -- )
+ dup control-value >>b-rep
+ dup vertex-array>> [ vertex-array-buffer dispose ] when*
+ dup [ b-rep>> ] [ selected>> value>> ] bi make-b-rep-vertices {
+ [
+ static-upload draw-usage vertex-buffer byte-array>buffer
+ over program>> <vertex-array> >>vertex-array
+ ]
+ [ >>face-indices ]
+ [ >>edge-indices ]
+ [ >>point-indices ]
+ } spread
+ drop ;
+
+: viewable? ( gml-viewer-world -- ? )
+ { [ b-rep>> ] [ program>> ] } 1&& ;
+
+M: gml-viewer-world model-changed
+ nip
+ [ control-value ]
+ [ b-rep<< ]
+ [ dup viewable? [ refresh-b-rep-view ] [ drop ] if ] tri ;
+
+: init-viewer-model ( gml-viewer-world -- )
+ [ dup model>> add-connection ]
+ [ dup selected>> add-connection ] bi ;
+
+: reset-view ( gml-viewer-world -- )
+ { 0.0 0.0 5.0 } 0.0 0.0 set-wasd-view drop ;
+
+M: gml-viewer-world begin-game-world
+ init-gpu
+ t >>view-faces?
+ t >>view-edges?
+ T{ point-state { size 5.0 } } set-gpu-state
+ dup reset-view
+ gml-viewer-program <program-instance> >>program
+ dup init-viewer-model
+ refresh-b-rep-view ;
+
+M: gml-viewer-world end-game-world
+ [ dup selected>> remove-connection ]
+ [ dup model>> remove-connection ] bi ;
+
+M: gml-viewer-world draw-world*
+ system-framebuffer {
+ { default-attachment { 0.0 0.0 0.0 1.0 } }
+ { depth-attachment 1.0 }
+ } clear-framebuffer
+
+ [
+ dup view-faces?>> [
+ T{ depth-state { comparison cmp-less } } set-gpu-state
+ {
+ { "primitive-mode" [ drop triangles-mode ] }
+ { "indexes" [ face-indices>> ] }
+ { "uniforms" [ <mvp-uniforms> ] }
+ { "vertex-array" [ vertex-array>> ] }
+ } <render-set> render
+ T{ depth-state { comparison f } } set-gpu-state
+ ] [ drop ] if
+ ] [
+ dup view-edges?>> [
+ {
+ { "primitive-mode" [ drop lines-mode ] }
+ { "indexes" [ edge-indices>> ] }
+ { "uniforms" [ <mvp-uniforms> ] }
+ { "vertex-array" [ vertex-array>> ] }
+ } <render-set> render
+ ] [ drop ] if
+ ] [
+ {
+ { "primitive-mode" [ drop points-mode ] }
+ { "indexes" [ point-indices>> ] }
+ { "uniforms" [ <mvp-uniforms> ] }
+ { "vertex-array" [ vertex-array>> ] }
+ } <render-set> render
+ ] tri ;
+
+TYPED: rotate-view-mode ( world: gml-viewer-world -- )
+ dup view-edges?>> [
+ dup view-faces?>>
+ [ f >>view-faces? ]
+ [ f >>view-edges? t >>view-faces? ] if
+ ] [ t >>view-edges? ] if drop ;
+
+CONSTANT: edge-hitbox-radius 0.05
+
+:: line-nearest-t ( p0 u q0 v -- tp tq )
+ p0 q0 v- :> w0
+
+ u u v. :> a
+ u v v. :> b
+ v v v. :> c
+ u w0 v. :> d
+ v w0 v. :> e
+
+ a c * b b * - :> denom
+
+ b e * c d * - denom /f
+ a e * b d * - denom /f ;
+
+:: intersects-edge-node? ( source direction edge -- ? )
+ edge vertex>> position>> double-4>float-4 :> edge-source
+ edge opposite-edge>> vertex>> position>> double-4>float-4 edge-source v- :> edge-direction
+
+ source direction edge-source edge-direction line-nearest-t :> ( ray-t edge-t )
+
+ ray-t 0.0 >= edge-t 0.0 0.5 between? and [
+ source direction ray-t v*n v+
+ edge-source edge-direction edge-t v*n v+ v- norm
+ edge-hitbox-radius <
+ ] [ f ] if ;
+
+: intersecting-edge-node ( source direction b-rep -- edge/f )
+ edges>> [ intersects-edge-node? ] 2with find nip ;
+
+: select-edge ( world -- )
+ [ [ location>> ] [ hand-loc get wasd-pixel-ray ] bi ]
+ [ b-rep>> intersecting-edge-node ]
+ [ '[ _ [ selected>> push-model ] [ refresh-b-rep-view ] bi ] when* ] tri ;
+
+gml-viewer-world H{
+ { T{ button-up f f 1 } [ dup drag?>> [ drop ] [ select-edge ] if ] }
+ { T{ drag f 1 } [ t >>drag? drop ] }
+ { T{ key-down f f "RET" } [ reset-view ] }
+ { T{ key-down f f "TAB" } [ rotate-view-mode ] }
+} set-gestures
+
+AFTER: gml-viewer-world tick-game-world
+ dup drag?>> [
+ read-mouse buttons>>
+ ! FIXME: GTK Mouse buttons are an integer
+ ! MacOSX mouse buttons are an array of bools
+ dup integer? [ 0 bit? ] [ first ] if >>drag?
+ ] when drop ;
+
+M: gml-viewer-world wasd-mouse-scale drag?>> -1/600. 0.0 ? ;
+
+: wrap-in-model ( object -- model )
+ dup model? [ <model> ] unless ;
+: wrap-in-growable-model ( object -- model )
+ dup model? [
+ dup growable? [ >vector ] unless
+ <model>
+ ] unless ;
+
+: gml-viewer ( b-rep selection -- )
+ [ wrap-in-model ] [ wrap-in-growable-model ] bi*
+ '[
+ f T{ game-attributes
+ { world-class gml-viewer-world }
+ { title "GML wireframe viewer" }
+ { pixel-format-attributes {
+ windowed
+ double-buffered
+ T{ depth-bits f 16 }
+ } }
+ { grab-input? f }
+ { use-game-input? t }
+ { use-audio-engine? f }
+ { pref-dim { 1024 768 } }
+ { tick-interval-nanos $[ 30 fps ] }
+ } open-window*
+ _ >>model
+ _ >>selected
+ drop
+ ] with-ui ;
--- /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
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences vectors classes classes.algebra
+combinators arrays words assocs parser namespaces make
+definitions prettyprint prettyprint.backend prettyprint.custom
+quotations generalizations sequences.generalizations debugger io
+compiler.units kernel.private effects accessors hashtables
+sorting shuffle math.order sets see effects.parser ;
+FROM: namespaces => set ;
+IN: multi-methods
+
+! PART I: Converting hook specializers
+: canonicalize-specializer-0 ( specializer -- specializer' )
+ [ \ f or ] map ;
+
+SYMBOL: args
+
+SYMBOL: hooks
+
+SYMBOL: total
+
+: canonicalize-specializer-1 ( specializer -- specializer' )
+ [
+ [ class? ] filter
+ [ length iota <reversed> [ 1 + neg ] map ] keep zip
+ [ length args [ max ] change ] keep
+ ]
+ [
+ [ pair? ] filter
+ [ keys [ hooks get adjoin ] each ] keep
+ ] bi append ;
+
+: canonicalize-specializer-2 ( specializer -- specializer' )
+ [
+ [
+ {
+ { [ dup integer? ] [ ] }
+ { [ dup word? ] [ hooks get index ] }
+ } cond args get +
+ ] dip
+ ] assoc-map ;
+
+: canonicalize-specializer-3 ( specializer -- specializer' )
+ [ total get object <array> <enum> ] dip assoc-union! seq>> ;
+
+: canonicalize-specializers ( methods -- methods' hooks )
+ [
+ [ [ canonicalize-specializer-0 ] dip ] assoc-map
+
+ 0 args set
+ V{ } clone hooks set
+
+ [ [ canonicalize-specializer-1 ] dip ] assoc-map
+
+ hooks [ natural-sort ] change
+
+ [ [ canonicalize-specializer-2 ] dip ] assoc-map
+
+ args get hooks get length + total set
+
+ [ [ canonicalize-specializer-3 ] dip ] assoc-map
+
+ hooks get
+ ] with-scope ;
+
+: drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
+
+: prepare-method ( method n -- quot )
+ [ 1quotation ] [ drop-n-quot ] bi* prepend ;
+
+: prepare-methods ( methods -- methods' prologue )
+ canonicalize-specializers
+ [ length [ prepare-method ] curry assoc-map ] keep
+ [ [ get ] curry ] map concat [ ] like ;
+
+! Part II: Topologically sorting specializers
+: maximal-element ( seq quot -- n elt )
+ dupd [
+ swapd [ call +lt+ = ] 2curry any? not
+ ] 2curry find [ "Topological sort failed" throw ] unless* ;
+ inline
+
+: topological-sort ( seq quot -- newseq )
+ [ >vector [ dup empty? not ] ] dip
+ [ dupd maximal-element [ over remove-nth! drop ] dip ] curry
+ produce nip ; inline
+
+: classes< ( seq1 seq2 -- lt/eq/gt )
+ [
+ {
+ { [ 2dup eq? ] [ +eq+ ] }
+ { [ 2dup [ class<= ] [ swap class<= ] 2bi and ] [ +eq+ ] }
+ { [ 2dup class<= ] [ +lt+ ] }
+ { [ 2dup swap class<= ] [ +gt+ ] }
+ [ +eq+ ]
+ } cond 2nip
+ ] 2map [ +eq+ eq? not ] find nip +eq+ or ;
+
+: sort-methods ( alist -- alist' )
+ [ [ first ] bi@ classes< ] topological-sort ;
+
+! PART III: Creating dispatch quotation
+: picker ( n -- quot )
+ {
+ { 0 [ [ dup ] ] }
+ { 1 [ [ over ] ] }
+ { 2 [ [ pick ] ] }
+ [ 1 - picker [ dip swap ] curry ]
+ } case ;
+
+: (multi-predicate) ( class picker -- quot )
+ swap predicate-def append ;
+
+: multi-predicate ( classes -- quot )
+ dup length iota <reversed>
+ [ picker 2array ] 2map
+ [ drop object eq? ] assoc-reject
+ [ [ t ] ] [
+ [ (multi-predicate) ] { } assoc>map
+ unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
+ ] if-empty ;
+
+: argument-count ( methods -- n )
+ keys 0 [ length max ] reduce ;
+
+ERROR: no-method arguments generic ;
+
+: make-default-method ( methods generic -- quot )
+ [ argument-count ] dip [ [ narray ] dip no-method ] 2curry ;
+
+: multi-dispatch-quot ( methods generic -- quot )
+ [ make-default-method ]
+ [ drop [ [ multi-predicate ] dip ] assoc-map reverse! ]
+ 2bi alist>quot ;
+
+! Generic words
+PREDICATE: generic < word
+ "multi-methods" word-prop >boolean ;
+
+: methods ( word -- alist )
+ "multi-methods" word-prop >alist ;
+
+: make-generic ( generic -- quot )
+ [
+ [ methods prepare-methods % sort-methods ] keep
+ multi-dispatch-quot %
+ ] [ ] make ;
+
+: update-generic ( word -- )
+ dup make-generic define ;
+
+! Methods
+PREDICATE: method-body < word
+ "multi-method-generic" word-prop >boolean ;
+
+M: method-body stack-effect
+ "multi-method-generic" word-prop stack-effect ;
+
+M: method-body crossref?
+ "forgotten" word-prop not ;
+
+: method-word-name ( specializer generic -- string )
+ [ name>> % "-" % unparse % ] "" make ;
+
+: method-word-props ( specializer generic -- assoc )
+ [
+ "multi-method-generic" ,,
+ "multi-method-specializer" ,,
+ ] H{ } make ;
+
+: <method> ( specializer generic -- word )
+ [ method-word-props ] 2keep
+ method-word-name f <word>
+ swap >>props ;
+
+: with-methods ( word quot -- )
+ over [
+ [ "multi-methods" word-prop ] dip call
+ ] dip update-generic ; inline
+
+: reveal-method ( method classes generic -- )
+ [ set-at ] with-methods ;
+
+: method ( classes word -- method )
+ "multi-methods" word-prop at ;
+
+: create-method ( classes generic -- method )
+ 2dup method dup [
+ 2nip
+ ] [
+ drop [ <method> dup ] 2keep reveal-method
+ ] if ;
+
+: niceify-method ( seq -- seq )
+ [ dup \ f eq? [ drop f ] when ] map ;
+
+M: no-method error.
+ "Type check error" print
+ nl
+ "Generic word " write dup generic>> pprint
+ " does not have a method applicable to inputs:" print
+ dup arguments>> short.
+ nl
+ "Inputs have signature:" print
+ dup arguments>> [ class-of ] map niceify-method .
+ nl
+ "Available methods: " print
+ generic>> methods canonicalize-specializers drop sort-methods
+ keys [ niceify-method ] map stack. ;
+
+: forget-method ( specializer generic -- )
+ [ delete-at ] with-methods ;
+
+: method>spec ( method -- spec )
+ [ "multi-method-specializer" word-prop ]
+ [ "multi-method-generic" word-prop ] bi prefix ;
+
+: define-generic ( word effect -- )
+ over set-stack-effect
+ dup "multi-methods" word-prop [ drop ] [
+ [ H{ } clone "multi-methods" set-word-prop ]
+ [ update-generic ]
+ bi
+ ] if ;
+
+! Syntax
+SYNTAX: GENERIC: scan-new-word scan-effect define-generic ;
+
+: parse-method ( -- quot classes generic )
+ parse-definition [ 2 tail ] [ second ] [ first ] tri ;
+
+: create-method-in ( specializer generic -- method )
+ create-method dup save-location f set-last-word ;
+
+: scan-new-method ( -- method )
+ scan-word scan-object swap create-method-in ;
+
+: (METHOD:) ( -- method def ) scan-new-method parse-definition ;
+
+SYNTAX: METHOD: (METHOD:) define ;
+
+! For compatibility
+SYNTAX: M:
+ scan-word 1array scan-word create-method-in
+ parse-definition
+ define ;
+
+! Definition protocol. We qualify core generics here
+QUALIFIED: syntax
+
+syntax:M: generic definer drop \ GENERIC: f ;
+
+syntax:M: generic definition drop f ;
+
+PREDICATE: method-spec < array
+ unclip generic? [ [ class? ] all? ] dip and ;
+
+syntax:M: method-spec where
+ dup unclip method [ ] [ first ] ?if where ;
+
+syntax:M: method-spec set-where
+ unclip method set-where ;
+
+syntax:M: method-spec definer
+ unclip method definer ;
+
+syntax:M: method-spec definition
+ unclip method definition ;
+
+syntax:M: method-spec synopsis*
+ unclip method synopsis* ;
+
+syntax:M: method-spec forget*
+ unclip method forget* ;
+
+syntax:M: method-body definer
+ drop \ METHOD: \ ; ;
+
+syntax:M: method-body synopsis*
+ dup definer.
+ [ "multi-method-generic" word-prop pprint-word ]
+ [ "multi-method-specializer" word-prop pprint* ] bi ;
--- /dev/null
+Experimental multiple dispatch implementation
--- /dev/null
+extensions
--- /dev/null
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings ;
+IN: multi-methods.tests
+
+[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
+
+: setup-canon-test ( -- )
+ 0 args set
+ V{ } clone hooks set ;
+
+: canon-test-1 ( -- seq )
+ { integer { cpu x86 } sequence } canonicalize-specializer-1 ;
+
+[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ ] with-scope
+] unit-test
+
+[ { { 0 integer } { 1 sequence } { 2 x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ ] with-scope
+] unit-test
+
+[ { integer sequence x86 } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ args get hooks get length + total set
+ canonicalize-specializer-3
+ ] with-scope
+] unit-test
+
+CONSTANT: example-1
+ {
+ { { { cpu x86 } { os linux } } "a" }
+ { { { cpu ppc } } "b" }
+ { { string { os windows } } "c" }
+ }
+
+[
+ {
+ { { object x86 linux } "a" }
+ { { object ppc object } "b" }
+ { { string object windows } "c" }
+ }
+ { cpu os }
+] [
+ example-1 canonicalize-specializers
+] unit-test
+
+[
+ {
+ { { object x86 linux } [ drop drop "a" ] }
+ { { object ppc object } [ drop drop "b" ] }
+ { { string object windows } [ drop drop "c" ] }
+ }
+ [ \ cpu get \ os get ]
+] [
+ example-1 prepare-methods
+] unit-test
--- /dev/null
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings words compiler.units quotations ;
+IN: multi-methods.tests
+
+DEFER: fake
+\ fake H{ } clone "multi-methods" set-word-prop
+<< ( -- ) \ fake set-stack-effect >>
+
+[
+ [ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
+
+ [ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ]
+ [ { } \ fake method-word-props ] unit-test
+
+ [ t ] [ { } \ fake <method> method-body? ] unit-test
+
+ [ { } [ ] ] [ \ fake methods prepare-methods [ sort-methods ] dip ] unit-test
+
+ [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test
+
+ [ t ] [ \ fake make-generic quotation? ] unit-test
+
+ [ ] [ \ fake update-generic ] unit-test
+
+ DEFER: testing
+
+ [ ] [ \ testing ( -- ) define-generic ] unit-test
+
+ [ t ] [ \ testing generic? ] unit-test
+] with-compilation-unit
--- /dev/null
+USING: math strings sequences tools.test ;
+IN: multi-methods.tests
+
+GENERIC: legacy-test ( a -- b )
+
+M: integer legacy-test sq ;
+M: string legacy-test " hey" append ;
+
+[ 25 ] [ 5 legacy-test ] unit-test
+[ "hello hey" ] [ "hello" legacy-test ] unit-test
--- /dev/null
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings definitions prettyprint debugger arrays
+hashtables continuations classes assocs accessors see ;
+RENAME: GENERIC: multi-methods => multi-methods:GENERIC:
+IN: multi-methods.tests
+
+multi-methods:GENERIC: first-test ( -- )
+
+[ t ] [ \ first-test generic? ] unit-test
+
+MIXIN: thing
+
+SINGLETON: paper INSTANCE: paper thing
+SINGLETON: scissors INSTANCE: scissors thing
+SINGLETON: rock INSTANCE: rock thing
+
+multi-methods:GENERIC: beats? ( obj1 obj2 -- ? )
+
+METHOD: beats? { paper scissors } 2drop t ;
+METHOD: beats? { scissors rock } 2drop t ;
+METHOD: beats? { rock paper } 2drop t ;
+METHOD: beats? { thing thing } 2drop f ;
+
+: play ( obj1 obj2 -- ? ) beats? ;
+
+[ { } 3 play ] must-fail
+[ t ] [ error get no-method? ] unit-test
+[ ] [ error get error. ] unit-test
+[ { { } 3 } ] [ error get arguments>> ] unit-test
+[ t ] [ paper scissors play ] unit-test
+[ f ] [ scissors paper play ] unit-test
+
+[ t ] [ { beats? paper scissors } method-spec? ] unit-test
+[ ] [ { beats? paper scissors } see ] unit-test
+
+SYMBOL: some-var
+
+multi-methods:GENERIC: hook-test ( obj -- obj )
+
+METHOD: hook-test { array { some-var array } } reverse ;
+METHOD: hook-test { { some-var array } } class-of ;
+METHOD: hook-test { hashtable { some-var number } } assoc-size ;
+
+{ 1 2 3 } some-var set
+[ { f t t } ] [ { t t f } hook-test ] unit-test
+[ fixnum ] [ 3 hook-test ] unit-test
+5.0 some-var set
+[ 0 ] [ H{ } hook-test ] unit-test
+
+"error" some-var set
+[ H{ } hook-test ] must-fail
+[ t ] [ error get no-method? ] unit-test
+[ { H{ } "error" } ] [ error get arguments>> ] unit-test
+
+MIXIN: busted
+
+TUPLE: busted-1 ;
+TUPLE: busted-2 ; INSTANCE: busted-2 busted
+TUPLE: busted-3 ;
+
+multi-methods:GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
+
+METHOD: busted-sort { busted-1 busted-2 } ;
+METHOD: busted-sort { busted-2 busted-3 } ;
+METHOD: busted-sort { busted busted } ;
--- /dev/null
+USING: kernel multi-methods tools.test math arrays sequences
+math.order ;
+IN: multi-methods.tests
+
+[ { 1 2 3 4 5 6 } ] [
+ { 6 4 5 1 3 2 } [ <=> ] topological-sort
+] unit-test
+
+[ +lt+ ] [
+ { fixnum array } { number sequence } classes<
+] unit-test
+
+[ +eq+ ] [
+ { number sequence } { number sequence } classes<
+] unit-test
+
+[ +gt+ ] [
+ { object object } { number sequence } classes<
+] unit-test
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: help.markup help.syntax multiline ;
+IN: pair-rocket
+
+HELP: =>
+{ $syntax "a => b" }
+{ $description "Constructs a two-element array from the objects immediately before and after the " { $snippet "=>" } ". This syntax can be used inside sequence and assoc literals." }
+{ $examples
+{ $unchecked-example "USING: pair-rocket prettyprint ;
+
+H{ \"foo\" => 1 \"bar\" => 2 } ."
+"H{ { \"foo\" 1 } { \"bar\" 2 } }" }
+}
+;
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: kernel pair-rocket tools.test ;
+IN: pair-rocket.tests
+
+{ { "a" 1 } } [ "a" => 1 ] unit-test
+{ { { "a" } { 1 } } } [ { "a" } => { 1 } ] unit-test
+{ { drop 1 } } [ drop => 1 ] unit-test
+
+{ H{ { "zippity" 5 } { "doo" 2 } { "dah" 7 } } }
+[ H{ "zippity" => 5 "doo" => 2 "dah" => 7 } ] unit-test
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: arrays kernel parser sequences ;
+IN: pair-rocket
+
+SYNTAX: => dup pop scan-object 2array suffix! ;
--- /dev/null
+H{ "foo" => 1 "bar" => 2 } style literal syntax
--- /dev/null
+USING: accessors alien.c-types alien.data arrays calendar colors
+combinators combinators.short-circuit flatland generalizations
+grouping kernel locals math math.intervals math.order
+math.rectangles math.vectors namespaces opengl opengl.gl
+opengl.glu processing.shapes sequences sequences.generalizations
+shuffle threads ui ui.gadgets ui.gestures ui.render ;
+FROM: multi-methods => GENERIC: METHOD: ;
+FROM: syntax => M: ;
+IN: pong
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Inspired by this Ruby/Shoes version by why: http://gist.github.com/26431
+!
+! Which was based on this Nodebox version: http://billmill.org/pong.html
+! by Bill Mill.
+!
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: clamp-to-interval ( x interval -- x )
+ [ from>> first max ] [ to>> first min ] bi ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <play-field> < <rectangle> ;
+TUPLE: <paddle> < <rectangle> ;
+
+TUPLE: <computer> < <paddle> { speed initial: 10 } ;
+
+: computer-move-left ( computer -- ) dup speed>> move-left-by ;
+: computer-move-right ( computer -- ) dup speed>> move-right-by ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <ball> < <vel>
+ { diameter initial: 20 }
+ { bounciness initial: 1.2 }
+ { max-speed initial: 10 } ;
+
+: above-lower-bound? ( ball field -- ? ) bottom 50 - above? ;
+: below-upper-bound? ( ball field -- ? ) top 50 + below? ;
+
+: in-bounds? ( ball field -- ? )
+ {
+ [ above-lower-bound? ]
+ [ below-upper-bound? ]
+ } 2&& ;
+
+:: bounce-change-vertical-velocity ( BALL -- )
+
+ BALL vel>> y neg
+ BALL bounciness>> *
+
+ BALL max-speed>> min
+
+ BALL vel>> (y!) ;
+
+:: bounce-off-paddle ( BALL PADDLE -- )
+
+ BALL bounce-change-vertical-velocity
+
+ BALL x PADDLE center x - 0.25 * BALL vel>> (x!)
+
+ PADDLE top BALL pos>> (y!) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mouse-x ( -- x ) hand-loc get first ;
+
+:: valid-paddle-interval ( PADDLE PLAY-FIELD -- interval )
+
+ PLAY-FIELD [ left ] [ right ] bi PADDLE width - [a,b] ;
+
+:: align-paddle-with-mouse ( PADDLE PLAY-FIELD -- )
+
+ mouse-x
+
+ PADDLE PLAY-FIELD valid-paddle-interval
+
+ clamp-to-interval
+
+ PADDLE pos>> (x!) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Protocol for drawing PONG objects
+
+GENERIC: draw ( obj -- )
+
+METHOD: draw { <paddle> } [ bottom-left ] [ dim>> ] bi rectangle ;
+METHOD: draw { <ball> } [ pos>> ] [ diameter>> 2 / ] bi circle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <pong> < gadget paused field ball player computer ;
+
+: pong ( -- gadget )
+ <pong> new
+ T{ <play-field> { pos { 0 0 } } { dim { 400 400 } } } clone >>field
+ T{ <ball> { pos { 50 50 } } { vel { 3 4 } } } clone >>ball
+ T{ <paddle> { pos { 200 396 } } { dim { 75 4 } } } clone >>player
+ T{ <computer> { pos { 200 0 } } { dim { 75 4 } } } clone >>computer ;
+
+M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
+M: <pong> ungraft* ( <pong> -- ) t >>paused drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <pong> draw-gadget* ( PONG -- )
+
+ PONG computer>> draw
+ PONG player>> draw
+ PONG ball>> draw ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-system ( GADGET -- )
+
+ GADGET field>> :> FIELD
+ GADGET ball>> :> BALL
+ GADGET player>> :> PLAYER
+ GADGET computer>> :> COMPUTER
+
+ BALL FIELD in-bounds? [
+
+ PLAYER FIELD align-paddle-with-mouse
+
+ BALL 1 move-for
+
+ ! computer reaction
+
+ BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
+ BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
+
+ ! check if ball bounced off something
+
+ ! player-blocked-ball?
+ BALL PLAYER { [ above? ] [ in-between-horizontally? ] } 2&&
+ [ BALL PLAYER bounce-off-paddle ] when
+
+ ! computer-blocked-ball?
+ BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } 2&&
+ [ BALL COMPUTER bounce-off-paddle ] when
+
+ ! bounced-off-wall?
+ BALL FIELD in-between-horizontally? not
+ [ BALL reverse-horizontal-velocity ] when
+
+ ] [ t GADGET paused<< ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: start-pong-thread ( GADGET -- )
+ f GADGET paused<<
+ [
+ [
+ GADGET paused>>
+ [ f ]
+ [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
+ if
+ ]
+ loop
+ ]
+ in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pong-window ( -- ) pong [ "PONG" open-window ] [ start-pong-thread ] bi ;
+
+: pong-main ( -- ) [ pong-window ] with-ui ;
+
+MAIN: pong-window
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: accessors arrays combinators definitions fry kernel
+locals.types namespaces parser quotations see sequences slots
+words ;
+FROM: kernel.private => declare ;
+FROM: help.markup.private => link-effect? ;
+IN: variables
+
+PREDICATE: variable < word
+ "variable-setter" word-prop >boolean ;
+
+GENERIC: variable-setter ( word -- word' )
+
+M: variable variable-setter "variable-setter" word-prop ;
+M: local-reader variable-setter "local-writer" word-prop ;
+
+SYNTAX: set:
+ scan-object variable-setter suffix! ;
+
+: [variable-getter] ( variable -- quot )
+ '[ _ get ] ;
+: [variable-setter] ( variable -- quot )
+ '[ _ set ] ;
+
+: (define-variable) ( word getter setter -- )
+ [ ( -- value ) define-inline ]
+ [
+ [
+ [ name>> "set: " prepend <uninterned-word> ]
+ [ over "variable-setter" set-word-prop ] bi
+ ] dip ( value -- ) define-inline
+ ] bi-curry* bi ;
+
+: define-variable ( word -- )
+ dup [ [variable-getter] ] [ [variable-setter] ] bi (define-variable) ;
+
+SYNTAX: VAR:
+ scan-new-word define-variable ;
+
+M: variable definer drop \ VAR: f ;
+M: variable definition drop f ;
+M: variable link-effect? drop f ;
+M: variable print-stack-effect? drop f ;
+
+PREDICATE: typed-variable < variable
+ "variable-type" word-prop >boolean ;
+
+: [typed-getter] ( quot type -- quot )
+ 1array '[ @ _ declare ] ;
+: [typed-setter] ( quot type -- quot )
+ instance-check-quot prepose ;
+
+: define-typed-variable ( word type -- )
+ dupd {
+ [ [ [variable-getter] ] dip [typed-getter] ]
+ [ [ [variable-setter] ] dip [typed-setter] ]
+ [ "variable-type" set-word-prop ]
+ [ initial-value drop swap set-global ]
+ } 2cleave (define-variable) ;
+
+SYNTAX: TYPED-VAR:
+ scan-new-word scan-object define-typed-variable ;
+
+M: typed-variable definer drop \ TYPED-VAR: f ;
+M: typed-variable definition "variable-type" word-prop 1quotation ;
+
+TUPLE: global-box value ;
+
+PREDICATE: global-variable < variable
+ def>> first global-box? ;
+
+: [global-getter] ( box -- quot )
+ '[ _ value>> ] ;
+: [global-setter] ( box -- quot )
+ '[ _ value<< ] ;
+
+: define-global ( word -- )
+ global-box new [ [global-getter] ] [ [global-setter] ] bi (define-variable) ;
+
+SYNTAX: GLOBAL:
+ scan-new-word define-global ;
+
+M: global-variable definer drop \ GLOBAL: f ;
+
+INTERSECTION: typed-global-variable
+ global-variable typed-variable ;
+
+: define-typed-global ( word type -- )
+ 2dup "variable-type" set-word-prop
+ dup initial-value drop global-box boa swap
+ [ [ [global-getter] ] dip [typed-getter] ]
+ [ [ [global-setter] ] dip [typed-setter] ] 2bi (define-variable) ;
+
+SYNTAX: TYPED-GLOBAL:
+ scan-new-word scan-object define-typed-global ;
+
+M: typed-global-variable definer drop \ TYPED-GLOBAL: f ;
+++ /dev/null
-USING: accessors euler.b-rep euler.modeling euler.operators
-euler.b-rep.examples kernel locals math.vectors.simd.cords
-namespaces sequences tools.test ;
-IN: euler.b-rep.tests
-
-{ double-4{ 0.0 0.0 -1.0 0.0 } }
-[ valid-cube-b-rep edges>> first face-normal ] unit-test
-
-{ double-4{ 0.0 0.0 -1.0 0.0 } -1.0 }
-[ valid-cube-b-rep edges>> first face-plane ] unit-test
-
-{ t } [ 0 multi-ringed-face-cube-b-rep faces>> nth base-face? ] unit-test
-{ t } [ 5 multi-ringed-face-cube-b-rep faces>> nth base-face? ] unit-test
-{ f } [ 6 multi-ringed-face-cube-b-rep faces>> nth base-face? ] unit-test
-
-:: mock-face ( p0 p1 p2 -- edge )
- b-edge new vertex new p0 >>position >>vertex :> e0
- b-edge new vertex new p1 >>position >>vertex :> e1
- b-edge new vertex new p2 >>position >>vertex :> e2
-
- e1 e0 next-edge<<
- e2 e1 next-edge<<
- e0 e2 next-edge<<
-
- e0 ;
-
-{
- double-4{
- 0x1.279a74590331dp-1
- 0x1.279a74590331dp-1
- 0x1.279a74590331dp-1
- 0.0
- }
- -0x1.bb67ae8584cabp1
-} [
- double-4{ 1 0 5 0 }
- double-4{ 0 1 5 0 }
- double-4{ 0 0 6 0 } mock-face face-plane
-] unit-test
-
-V{ t } clone sharpness-stack [
- [ t ] [ get-sharpness ] unit-test
- [ V{ f } ] [ f set-sharpness sharpness-stack get ] unit-test
- [ V{ f t } t ] [ t push-sharpness sharpness-stack get get-sharpness ] unit-test
- [ t V{ f } f ] [ pop-sharpness sharpness-stack get get-sharpness ] unit-test
-] with-variable
-
-{ t } [ valid-cube-b-rep [ edges>> first ] keep is-valid-edge? ] unit-test
-{ f } [ b-edge new valid-cube-b-rep is-valid-edge? ] unit-test
-
-{ t } [
- valid-cube-b-rep edges>>
- [ [ 0 swap nth ] [ 1 swap nth ] bi connecting-edge ]
- [ 0 swap nth ] bi eq?
-] unit-test
-
-{ t } [
- valid-cube-b-rep edges>>
- [ [ 1 swap nth ] [ 0 swap nth ] bi connecting-edge ]
- [ 6 swap nth ] bi eq?
-] unit-test
-
-{ t } [
- valid-cube-b-rep edges>>
- [ [ 0 swap nth ] [ 3 swap nth ] bi connecting-edge ]
- [ 21 swap nth ] bi eq?
-] unit-test
-
-{ f } [
- valid-cube-b-rep edges>>
- [ 0 swap nth ] [ 2 swap nth ] bi connecting-edge
-] unit-test
-
-{ double-4{ 0 0 -1 0 } } [
- [
- { double-4{ 0 0 0 0 } double-4{ 0 1 0 0 } double-4{ 0 2 0 0 } double-4{ 1 1 0 0 } }
- smooth-smooth polygon>double-face face-normal
- ] make-b-rep drop
-] unit-test
+++ /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 ) H{ } zip-index-as ; 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 [ bl ] [ number>string write ] interleave nl ;
-
-: write-obj-face ( face vx-indices -- )
- "f" write
- [ edge>> ] dip '[ bl 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
-euler.modeling game.models.half-edge ;
-IN: euler.modeling.tests
-
-! polygon>double-face
-{ } [
- [
- { { -1 -1 0 } { 1 -1 0 } { 1 1 0 } { -1 1 0 } }
- smooth-smooth polygon>double-face
- [ face-sides 4 assert= ]
- [ opposite-edge>> face-sides 4 assert= ]
- [ face-normal { 0.0 0.0 1.0 } assert= ]
- tri
- ] make-b-rep check-b-rep
-] unit-test
-
-! extrude-simple
-{ } [
- [
- { { -1 -1 0 } { 1 -1 0 } { 1 1 0 } }
- smooth-smooth polygon>double-face
- 1 f extrude-simple
- [ face-sides 3 assert= ]
- [ opposite-edge>> face-sides 4 assert= ]
- bi
- ] make-b-rep check-b-rep
-] unit-test
-
-! project-pt-line
-{ { 0 1 0 } } [ { 0 0 0 } { 0 1 0 } { 1 1 0 } project-pt-line ] unit-test
-{ { 0 1 0 } } [ { 0 0 0 } { 1 1 0 } { 0 1 0 } project-pt-line ] unit-test
-{ { 0 1 0 } } [ { 0 0 0 } { 2 1 0 } { 1 1 0 } project-pt-line ] unit-test
-{ { -1 1 0 } } [ { -1 0 0 } { 2 1 0 } { 1 1 0 } project-pt-line ] unit-test
-{ { 1/2 1/2 0 } } [ { 0 0 0 } { 0 1 0 } { 1 0 0 } project-pt-line ] unit-test
-
-! project-pt-plane
-{ { 0 0 1 } } [ { 0 0 0 } { 0 0 1 } { 0 0 1 } -1 project-pt-plane ] unit-test
-{ { 0 0 -1 } } [ { 0 0 0 } { 0 0 1 } { 0 0 1 } 1 project-pt-plane ] unit-test
-{ { 0 0 3 } } [ { 0 0 0 } { 0 0 1 } { 0 0 1 } -3 project-pt-plane ] unit-test
-{ { 0 0 3 } } [ { 0 0 0 } { 0 0 1 } { 0 0 -1 } 3 project-pt-plane ] unit-test
-{ { 0 0 1 } } [ { 0 0 0 } { 0 0 1 } { 0 1 1 } -1 project-pt-plane ] unit-test
-
-{ { 0 2/3 1/3 } } [ { 0 0 0 } { 0 2 1 } { 0 1 1 } -1 project-pt-plane ] unit-test
-
-{ { 0 0 1 } } [ { 0 0 0 } { 0 0 1/2 } { 0 0 1 } -1 project-pt-plane ] unit-test
-{ { 0 1 1 } } [ { 0 0 0 } { 0 1/2 1/2 } { 0 0 1 } -1 project-pt-plane ] unit-test
+++ /dev/null
-! Copyright (C) 2010 Slava Pestov.
-USING: accessors combinators fry kernel locals math.vectors
-namespaces sets sequences game.models.half-edge euler.b-rep
-euler.operators math ;
-IN: euler.modeling
-
-: (polygon>double-face) ( polygon -- edge )
- [ first2 make-vefs ] keep
- [ drop opposite-edge>> ] [ 2 tail-slice [ make-ev-one ] each ] 2bi
- make-ef face-ccw ;
-
-SYMBOLS: smooth-smooth
-sharp-smooth
-smooth-sharp
-sharp-sharp
-smooth-like-vertex
-sharp-like-vertex
-smooth-continue
-sharp-continue ;
-
-: polygon>double-face ( polygon mode -- edge )
- ! This only handles the simple case with no repeating vertices
- drop
- dup all-unique? [ "polygon>double-face doesn't support repeating vertices yet" throw ] unless
- (polygon>double-face) ;
-
-:: extrude-simple ( edge dist sharp? -- edge )
- edge face-normal dist v*n :> vec
- edge vertex-pos vec v+ :> pos
- edge pos make-ev-one :> e0!
- e0 opposite-edge>> :> e-end
- edge face-ccw :> edge!
-
- [ edge e-end eq? not ] [
- edge vertex-pos vec v+ :> pos
- edge pos make-ev-one :> e1
- e0 e1 make-ef drop
- e1 e0!
- edge face-ccw edge!
- ] do while
-
- e-end face-ccw :> e-end
- e0 e-end make-ef drop
-
- e-end ;
-
-: check-bridge-rings ( e1 e2 -- )
- {
- [ [ face>> assert-no-rings ] bi@ ]
- [ [ face>> assert-base-face ] bi@ ]
- [ assert-different-faces ]
- [ [ face-sides ] bi@ assert= ]
- } 2cleave ;
-
-:: bridge-rings-simple ( e1 e2 sharp? -- edge )
- e1 e2 check-bridge-rings
- e1 e2 kill-f-make-rh
- e1 e2 make-e-kill-r face-cw :> ea!
- e2 face-ccw :> eb!
- [ ea e1 eq? not ] [
- ea eb make-ef opposite-edge>> face-cw ea!
- eb face-ccw eb!
- ] while
- eb ;
-
-:: project-pt-line ( p p0 p1 -- q )
- p1 p0 v- :> vt
- p p0 v- vt v* sum
- vt norm-sq /
- vt n*v p0 v+ ; inline
-
-:: project-pt-plane ( line-p0 line-vt plane-n plane-d -- q )
- plane-d neg plane-n line-p0 v. -
- line-vt plane-n v. /
- line-vt n*v line-p0 v+ ; inline
-
-: project-poly-plane ( poly vdir plane-n plane-d -- qoly )
- '[ _ _ _ project-pt-plane ] map ; inline
+++ /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
-
-USING: accessors arrays combinators combinators.short-circuit
-fry kernel locals math math.intervals math.vectors multi-methods
-sequences ;
-FROM: multi-methods => GENERIC: ;
-IN: flatland
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Two dimensional world protocol
-
-GENERIC: x ( obj -- x )
-GENERIC: y ( obj -- y )
-
-GENERIC: (x!) ( x obj -- )
-GENERIC: (y!) ( y obj -- )
-
-: x! ( obj x -- obj ) over (x!) ;
-: y! ( obj y -- obj ) over (y!) ;
-
-GENERIC: width ( obj -- width )
-GENERIC: height ( obj -- height )
-
-GENERIC: (width!) ( width obj -- )
-GENERIC: (height!) ( height obj -- )
-
-: width! ( obj width -- obj ) over (width!) ;
-: height! ( obj height -- obj ) over (width!) ;
-
-! Predicates on relative placement
-
-GENERIC: to-the-left-of? ( obj obj -- ? )
-GENERIC: to-the-right-of? ( obj obj -- ? )
-
-GENERIC: below? ( obj obj -- ? )
-GENERIC: above? ( obj obj -- ? )
-
-GENERIC: in-between-horizontally? ( obj obj -- ? )
-
-GENERIC: horizontal-interval ( obj -- interval )
-
-GENERIC: move-to ( obj obj -- )
-
-GENERIC: move-by ( obj delta -- )
-
-GENERIC: move-left-by ( obj obj -- )
-GENERIC: move-right-by ( obj obj -- )
-
-GENERIC: left ( obj -- left )
-GENERIC: right ( obj -- right )
-GENERIC: bottom ( obj -- bottom )
-GENERIC: top ( obj -- top )
-
-GENERIC: distance ( a b -- c )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Some of the above methods work on two element sequences.
-! A two element sequence may represent a point in space or describe
-! width and height.
-
-METHOD: x { sequence } first ;
-METHOD: y { sequence } second ;
-
-METHOD: (x!) { number sequence } set-first ;
-METHOD: (y!) { number sequence } set-second ;
-
-METHOD: width { sequence } first ;
-METHOD: height { sequence } second ;
-
-: changed-x ( seq quot -- ) over [ [ x ] dip call ] dip (x!) ; inline
-: changed-y ( seq quot -- ) over [ [ y ] dip call ] dip (y!) ; inline
-
-METHOD: move-to { sequence sequence } [ x x! ] [ y y! ] bi drop ;
-METHOD: move-by { sequence sequence } dupd v+ [ x x! ] [ y y! ] bi drop ;
-
-METHOD: move-left-by { sequence number } '[ _ - ] changed-x ;
-METHOD: move-right-by { sequence number } '[ _ + ] changed-x ;
-
-! METHOD: move-left-by { sequence number } neg 0 2array move-by ;
-! METHOD: move-right-by { sequence number } 0 2array move-by ;
-
-! METHOD:: move-left-by { SEQ:sequence X:number -- )
-! SEQ { X 0 } { -1 0 } v* move-by ;
-
-METHOD: distance { sequence sequence } v- norm ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! A class for objects with a position
-
-TUPLE: <pos> pos ;
-
-METHOD: x { <pos> } pos>> first ;
-METHOD: y { <pos> } pos>> second ;
-
-METHOD: (x!) { number <pos> } pos>> set-first ;
-METHOD: (y!) { number <pos> } pos>> set-second ;
-
-METHOD: to-the-left-of? { <pos> number } [ x ] dip < ;
-METHOD: to-the-right-of? { <pos> number } [ x ] dip > ;
-
-METHOD: move-left-by { <pos> number } [ pos>> ] dip move-left-by ;
-METHOD: move-right-by { <pos> number } [ pos>> ] dip move-right-by ;
-
-METHOD: above? { <pos> number } [ y ] dip > ;
-METHOD: below? { <pos> number } [ y ] dip < ;
-
-METHOD: move-by { <pos> sequence } '[ _ v+ ] change-pos drop ;
-
-METHOD: distance { <pos> <pos> } [ pos>> ] bi@ distance ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! A class for objects with velocity. It inherits from <pos>. Hey, if
-! it's moving it has a position right? Unless it's some alternate universe...
-
-TUPLE: <vel> < <pos> vel ;
-
-: moving-up? ( obj -- ? ) vel>> y 0 > ;
-: moving-down? ( obj -- ? ) vel>> y 0 < ;
-
-: step-size ( vel time -- dist ) [ vel>> ] dip v*n ;
-: move-for ( vel time -- ) dupd step-size move-by ;
-
-: reverse-horizontal-velocity ( vel -- ) vel>> [ x neg ] [ ] bi (x!) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! The 'pos' slot indicates the lower left hand corner of the
-! rectangle. The 'dim' is holds the width and height.
-
-TUPLE: <rectangle> < <pos> dim ;
-
-METHOD: width { <rectangle> } dim>> first ;
-METHOD: height { <rectangle> } dim>> second ;
-
-METHOD: left { <rectangle> } x ;
-METHOD: right { <rectangle> } [ x ] [ width ] bi + ;
-METHOD: bottom { <rectangle> } y ;
-METHOD: top { <rectangle> } [ y ] [ height ] bi + ;
-
-: bottom-left ( rectangle -- pos ) pos>> ;
-
-: center-x ( rectangle -- x ) [ left ] [ width 2 / ] bi + ;
-: center-y ( rectangle -- y ) [ bottom ] [ height 2 / ] bi + ;
-
-: center ( rectangle -- seq ) [ center-x ] [ center-y ] bi 2array ;
-
-METHOD: to-the-left-of? { <pos> <rectangle> } [ x ] [ left ] bi* < ;
-METHOD: to-the-right-of? { <pos> <rectangle> } [ x ] [ right ] bi* > ;
-
-METHOD: below? { <pos> <rectangle> } [ y ] [ bottom ] bi* < ;
-METHOD: above? { <pos> <rectangle> } [ y ] [ top ] bi* > ;
-
-METHOD: horizontal-interval { <rectangle> }
- [ left ] [ right ] bi [a,b] ;
-
-METHOD: in-between-horizontally? { <pos> <rectangle> }
- [ x ] [ horizontal-interval ] bi* interval-contains? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <extent> left right bottom top ;
-
-METHOD: left { <extent> } left>> ;
-METHOD: right { <extent> } right>> ;
-METHOD: bottom { <extent> } bottom>> ;
-METHOD: top { <extent> } top>> ;
-
-METHOD: width { <extent> } [ right>> ] [ left>> ] bi - ;
-METHOD: height { <extent> } [ top>> ] [ bottom>> ] bi - ;
-
-! METHOD: to-extent ( <rectangle> -- <extent> )
-! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave <extent> boa ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: to-the-left-of? { sequence <rectangle> } [ x ] [ left ] bi* < ;
-METHOD: to-the-right-of? { sequence <rectangle> } [ x ] [ right ] bi* > ;
-
-METHOD: below? { sequence <rectangle> } [ y ] [ bottom ] bi* < ;
-METHOD: above? { sequence <rectangle> } [ y ] [ top ] bi* > ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Some support for the' 'rect' class from math.geometry.rect'
-
-! METHOD: width ( rect -- width ) dim>> first ;
-! METHOD: height ( rect -- height ) dim>> second ;
-
-! METHOD: left ( rect -- left ) loc>> x
-! METHOD: right ( rect -- right ) [ loc>> x ] [ width ] bi + ;
-
-! METHOD: to-the-left-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* < ;
-! METHOD: to-the-right-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* > ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: wrap ( POINT RECT -- POINT )
- {
- { [ POINT RECT to-the-left-of? ] [ RECT right ] }
- { [ POINT RECT to-the-right-of? ] [ RECT left ] }
- { [ t ] [ POINT x ] }
- }
- cond
-
- {
- { [ POINT RECT below? ] [ RECT top ] }
- { [ POINT RECT above? ] [ RECT bottom ] }
- { [ t ] [ POINT y ] }
- }
- cond
-
- 2array ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: within? ( a b -- ? )
-
-METHOD: within? { <pos> <rectangle> }
- {
- [ left to-the-right-of? ]
- [ right to-the-left-of? ]
- [ bottom above? ]
- [ top below? ]
- }
- 2&& ;
+++ /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 )
- zip-index sort-keys reverse values ;
-
-! Dictionaries
-ERROR: not-a-dict object ;
-: 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 object ;
-
-: 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 -- quot )
- 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-word-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.
-USING: kernel sequences euler.modeling gml.runtime ;
-IN: gml.modeling
-
-GML: poly2doubleface ( poly mode -- edge )
- {
- smooth-smooth
- sharp-smooth
- smooth-sharp
- sharp-sharp
- smooth-like-vertex
- sharp-like-vertex
- smooth-continue
- sharp-continue
- } nth polygon>double-face ;
-
-GML: extrude-simple ( edge dist sharp -- edge ) extrude-simple ;
-
-GML: bridgerings-simple ( e1 e2 sharp -- edge ) bridge-rings-simple ;
-
-GML: project_ptline ( p p0 p1 -- q ) project-pt-line ;
-
-GML: project_ptplane ( p dir n d -- q ) project-pt-plane ;
-
-GML: project_polyplane ( [p] dir n d -- [q] ) project-poly-plane ;
+++ /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\n\r]
-
-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? ] reject ]]
-
-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-word-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) of ;
-
-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.
-USING: arrays accessors euler.b-rep fry gml gml.runtime gml.viewer
-gml.printer io.directories io.encodings.utf8 io.files
-io.pathnames io.streams.string kernel locals models namespaces
-sequences ui ui.gadgets ui.gadgets.buttons ui.gadgets.editors
-ui.gadgets.frames ui.gadgets.grids ui.gadgets.labels
-ui.gadgets.packs ui.gadgets.scrollers ui.gadgets.worlds
-ui.gadgets.tables ui.gadgets.labeled unicode.case ;
-FROM: gml => gml ;
-IN: gml.ui
-
-SINGLETON: stack-entry-renderer
-
-M: stack-entry-renderer row-columns
- drop [ write-gml ] with-string-writer 1array ;
-
-M: stack-entry-renderer row-value
- drop ;
-
-: <stack-table> ( model -- table )
- stack-entry-renderer <table>
- 10 >>min-rows
- 10 >>max-rows
- 40 >>min-cols
- 40 >>max-cols ;
-
-: <stack-display> ( model -- gadget )
- <stack-table> <scroller> "Operand stack" <labeled-gadget> ;
-
-TUPLE: gml-editor < frame editor gml stack-model b-rep b-rep-model ;
-
-: update-models ( gml-editor -- )
- [ [ b-rep>> dup finish-b-rep ] [ b-rep-model>> ] bi set-model ]
- [ [ gml>> operand-stack>> ] [ stack-model>> ] bi set-model ]
- bi ;
-
-: with-gml-editor ( gml-editor quot -- )
- '[
- [ [ gml>> gml set ] [ b-rep>> b-rep set ] bi @ ]
- [ update-models ]
- bi
- ] with-scope ; inline
-
-: find-gml-editor ( gadget -- gml-editor )
- [ gml-editor? ] find-parent ;
-
-: load-input ( file gml-editor -- )
- [ utf8 file-contents ] dip editor>> set-editor-string ;
-
-: update-viewer ( gml-editor -- )
- dup [ editor>> editor-string run-gml-string ] with-gml-editor ;
-
-: new-viewer ( gml-editor -- )
- [ update-viewer ]
- [ [ b-rep-model>> ] [ stack-model>> ] bi gml-viewer ]
- bi ;
-
-: reset-viewer ( gml-editor -- )
- [
- b-rep get clear-b-rep
- gml get operand-stack>> delete-all
- ] with-gml-editor ;
-
-: <new-button> ( -- button )
- "New viewer" [ find-gml-editor new-viewer ] <border-button> ;
-
-: <update-button> ( -- button )
- "Update viewer" [ find-gml-editor update-viewer ] <border-button> ;
-
-: <reset-button> ( -- button )
- "Reset viewer" [ find-gml-editor reset-viewer ] <border-button> ;
-
-: <control-buttons> ( -- gadget )
- <shelf> { 5 5 } >>gap
- <new-button> add-gadget
- <update-button> add-gadget
- <reset-button> add-gadget ;
-
-CONSTANT: example-dir "vocab:gml/examples/"
-
-: gml-files ( -- seq )
- example-dir directory-files
- [ file-extension >lower "gml" = ] filter ;
-
-: <example-button> ( file -- button )
- dup '[ example-dir _ append-path swap find-gml-editor load-input ]
- <border-button> ;
-
-: <example-buttons> ( -- gadget )
- gml-files
- <pile> { 5 5 } >>gap
- "Examples:" <label> add-gadget
- [ <example-button> add-gadget ] reduce ;
-
-: <editor-panel> ( editor -- gadget )
- 30 >>min-rows
- 30 >>max-rows
- 40 >>min-cols
- 40 >>max-cols
- <scroller> "Editor" <labeled-gadget> ;
-
-: <gml-editor> ( -- gadget )
- 2 3 gml-editor new-frame
- <gml> >>gml
- <b-rep> >>b-rep
- dup b-rep>> <model> >>b-rep-model
- dup gml>> operand-stack>> <model> >>stack-model
- { 20 20 } >>gap
- { 0 0 } >>filled-cell
- <source-editor> >>editor
- dup editor>> <editor-panel> { 0 0 } grid-add
- dup stack-model>> <stack-display> { 0 1 } grid-add
- <control-buttons> { 0 2 } grid-add
- <example-buttons> { 1 0 } grid-add ;
-
-M: gml-editor focusable-child* editor>> ;
-
-: gml-editor-window ( -- )
- <gml-editor> "Generative Modeling Language" open-window ;
-
-MAIN: gml-editor-window
+++ /dev/null
-USING: gml.viewer math.vectors.simd.cords tools.test ;
-IN: gml.viewer.tests
-
-{ {
- double-4{ 0 0 0 0 }
- double-4{ 1 1 1 1 }
-} } [ { double-4{ 0 0 0 0 } { double-4{ 1 1 1 1 } 2 } 3 } selected-vectors ] unit-test
+++ /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 alien.data.map arrays
-assocs byte-arrays colors combinators combinators.short-circuit
-destructors euler.b-rep euler.b-rep.triangulation fry game.input
-game.loop game.models.half-edge game.worlds gml.printer gpu
-gpu.buffers gpu.framebuffers gpu.render gpu.shaders gpu.state
-gpu.util.wasd growable images kernel literals locals math
-math.order math.ranges math.vectors math.vectors.conversion
-math.vectors.simd math.vectors.simd.cords method-chains models
-namespaces sequences sets specialized-vectors typed ui
-ui.gadgets ui.gadgets.worlds ui.gestures ui.pixel-formats
-vectors ;
-FROM: math.matrices => m.v ;
-FROM: models => change-model ;
-SPECIALIZED-VECTORS: ushort float-4 ;
-IN: gml.viewer
-
-CONSTANT: neutral-edge-color float-4{ 1 1 1 1 }
-CONSTANT: neutral-face-color float-4{ 1 1 1 1 }
-CONSTANT: selected-face-color float-4{ 1 0.9 0.8 1 }
-
-: double-4>float-4 ( in: double-4 -- out: float-4 )
- [ head>> ] [ tail>> ] bi double-2 float-4 vconvert ; inline
-: rgba>float-4 ( in: rgba -- out: float-4 )
- >rgba-components float-4-boa ; inline
-
-: face-color ( edge -- color )
- face-normal float-4{ 0 1 0.1 0 } v. 0.3 * 0.4 + dup dup 1.0 float-4-boa ; inline
-
-TUPLE: b-rep-vertices
- { array byte-array read-only }
- { face-vertex-count integer read-only }
- { edge-vertex-count integer read-only }
- { point-vertex-count integer read-only } ;
-
-:: <b-rep-vertices> ( face-array face-count
- edge-array edge-count
- point-array point-count -- vxs )
- face-array edge-array point-array 3append
- face-count edge-count point-count \ b-rep-vertices boa ; inline
-
-: face-selected? ( face selected -- ? )
- [ f ] 2dip [ edge>> ] dip '[ _ in? or ] each-face-edge ;
-
-:: b-rep-face-vertices ( b-rep selected -- vertices count indices )
- float-4-vector{ } clone :> vertices
- ushort-vector{ } clone :> indices
-
- 0 b-rep faces>> [| count face |
- face selected face-selected? :> selected?
- face dup base-face>> eq? [
- face edge>> face-color
- selected? selected-face-color neutral-face-color ? v* :> color
- face triangulate-face seq>> :> triangles
- triangles members :> tri-vertices
- tri-vertices >index-hash :> vx-indices
-
- tri-vertices [
- position>> double-4>float-4 vertices push
- color vertices push
- ] each
- triangles [ vx-indices at count + indices push ] each
-
- count tri-vertices length +
- ] [ count ] if
- ] each :> total
- vertices float-4 >c-array underlying>>
- total
- indices ushort-array{ } like ;
-
-: b-rep-edge-vertices ( b-rep -- vertices count )
- vertices>> [
- [
- position>> [ double-4>float-4 ] keep
- [ drop neutral-edge-color ]
- [ vertex-color rgba>float-4 ] 2bi
- ] data-map( object -- float-4[4] )
- ] [ length 2 * ] bi ; inline
-
-GENERIC: selected-vectors ( object -- vectors )
-M: object selected-vectors drop { } ;
-M: double-4 selected-vectors 1array ;
-M: sequence selected-vectors [ selected-vectors ] map concat ;
-
-: selected-vertices ( selected -- vertices count )
- selected-vectors [
- [ [ double-4>float-4 ] [ vertex-color rgba>float-4 ] bi ]
- data-map( object -- float-4[2] )
- ] [ length ] bi ; inline
-
-: edge-vertex-index ( e vertex-indices selected -- n selected? )
- [ dup vertex>> ] [ at 2 * ] [ swapd in? [ [ 1 + ] when ] keep ] tri* ;
-
-:: b-rep-edge-index-array ( b-rep selected offset -- edge-indices )
- b-rep vertices>> >index-hash :> vertex-indices
- b-rep edges>> length <ushort-vector> :> edge-indices
-
- b-rep edges>> [| e |
- e opposite-edge>> :> o
- e vertex-indices selected edge-vertex-index [ offset + ] dip :> ( from e-selected? )
- o vertex-indices selected edge-vertex-index [ offset + ] dip :> ( to o-selected? )
-
- from to < [ from edge-indices push to edge-indices push ] when
- ] each
-
- edge-indices ushort-array{ } like ;
-
-:: make-b-rep-vertices ( b-rep selected -- vertices face-indices edge-indices point-indices )
- b-rep selected b-rep-face-vertices :> ( face-vertices face-count face-indices )
- b-rep b-rep-edge-vertices :> ( edge-vertices edge-count )
- selected selected-vertices :> ( sel-vertices sel-count )
- face-vertices face-count edge-vertices edge-count sel-vertices sel-count
- <b-rep-vertices> :> vertices
-
- vertices array>>
-
- face-indices
-
- b-rep selected vertices face-vertex-count>> b-rep-edge-index-array
- vertices
-
- [ face-vertex-count>> ]
- [ edge-vertex-count>> + dup ]
- [ point-vertex-count>> + ] tri
- [a,b) ushort >c-array ;
-
-VERTEX-FORMAT: wire-vertex-format
- { "vertex" float-components 3 f }
- { f float-components 1 f }
- { "color" float-components 4 f } ;
-
-GLSL-SHADER-FILE: gml-viewer-vertex-shader vertex-shader "viewer.v.glsl"
-GLSL-SHADER-FILE: gml-viewer-fragment-shader fragment-shader "viewer.f.glsl"
-GLSL-PROGRAM: gml-viewer-program
- gml-viewer-vertex-shader gml-viewer-fragment-shader
- wire-vertex-format ;
-
-TUPLE: gml-viewer-world < wasd-world
- { b-rep b-rep }
- selected
- program
- vertex-array
- face-indices edge-indices point-indices
- view-faces? view-edges?
- drag? ;
-
-TYPED: refresh-b-rep-view ( world: gml-viewer-world -- )
- dup control-value >>b-rep
- dup vertex-array>> [ vertex-array-buffer dispose ] when*
- dup [ b-rep>> ] [ selected>> value>> ] bi make-b-rep-vertices {
- [
- static-upload draw-usage vertex-buffer byte-array>buffer
- over program>> <vertex-array> >>vertex-array
- ]
- [ >>face-indices ]
- [ >>edge-indices ]
- [ >>point-indices ]
- } spread
- drop ;
-
-: viewable? ( gml-viewer-world -- ? )
- { [ b-rep>> ] [ program>> ] } 1&& ;
-
-M: gml-viewer-world model-changed
- nip
- [ control-value ]
- [ b-rep<< ]
- [ dup viewable? [ refresh-b-rep-view ] [ drop ] if ] tri ;
-
-: init-viewer-model ( gml-viewer-world -- )
- [ dup model>> add-connection ]
- [ dup selected>> add-connection ] bi ;
-
-: reset-view ( gml-viewer-world -- )
- { 0.0 0.0 5.0 } 0.0 0.0 set-wasd-view drop ;
-
-M: gml-viewer-world begin-game-world
- init-gpu
- t >>view-faces?
- t >>view-edges?
- T{ point-state { size 5.0 } } set-gpu-state
- dup reset-view
- gml-viewer-program <program-instance> >>program
- dup init-viewer-model
- refresh-b-rep-view ;
-
-M: gml-viewer-world end-game-world
- [ dup selected>> remove-connection ]
- [ dup model>> remove-connection ] bi ;
-
-M: gml-viewer-world draw-world*
- system-framebuffer {
- { default-attachment { 0.0 0.0 0.0 1.0 } }
- { depth-attachment 1.0 }
- } clear-framebuffer
-
- [
- dup view-faces?>> [
- T{ depth-state { comparison cmp-less } } set-gpu-state
- {
- { "primitive-mode" [ drop triangles-mode ] }
- { "indexes" [ face-indices>> ] }
- { "uniforms" [ <mvp-uniforms> ] }
- { "vertex-array" [ vertex-array>> ] }
- } <render-set> render
- T{ depth-state { comparison f } } set-gpu-state
- ] [ drop ] if
- ] [
- dup view-edges?>> [
- {
- { "primitive-mode" [ drop lines-mode ] }
- { "indexes" [ edge-indices>> ] }
- { "uniforms" [ <mvp-uniforms> ] }
- { "vertex-array" [ vertex-array>> ] }
- } <render-set> render
- ] [ drop ] if
- ] [
- {
- { "primitive-mode" [ drop points-mode ] }
- { "indexes" [ point-indices>> ] }
- { "uniforms" [ <mvp-uniforms> ] }
- { "vertex-array" [ vertex-array>> ] }
- } <render-set> render
- ] tri ;
-
-TYPED: rotate-view-mode ( world: gml-viewer-world -- )
- dup view-edges?>> [
- dup view-faces?>>
- [ f >>view-faces? ]
- [ f >>view-edges? t >>view-faces? ] if
- ] [ t >>view-edges? ] if drop ;
-
-CONSTANT: edge-hitbox-radius 0.05
-
-:: line-nearest-t ( p0 u q0 v -- tp tq )
- p0 q0 v- :> w0
-
- u u v. :> a
- u v v. :> b
- v v v. :> c
- u w0 v. :> d
- v w0 v. :> e
-
- a c * b b * - :> denom
-
- b e * c d * - denom /f
- a e * b d * - denom /f ;
-
-:: intersects-edge-node? ( source direction edge -- ? )
- edge vertex>> position>> double-4>float-4 :> edge-source
- edge opposite-edge>> vertex>> position>> double-4>float-4 edge-source v- :> edge-direction
-
- source direction edge-source edge-direction line-nearest-t :> ( ray-t edge-t )
-
- ray-t 0.0 >= edge-t 0.0 0.5 between? and [
- source direction ray-t v*n v+
- edge-source edge-direction edge-t v*n v+ v- norm
- edge-hitbox-radius <
- ] [ f ] if ;
-
-: intersecting-edge-node ( source direction b-rep -- edge/f )
- edges>> [ intersects-edge-node? ] 2with find nip ;
-
-: select-edge ( world -- )
- [ [ location>> ] [ hand-loc get wasd-pixel-ray ] bi ]
- [ b-rep>> intersecting-edge-node ]
- [ '[ _ [ selected>> push-model ] [ refresh-b-rep-view ] bi ] when* ] tri ;
-
-gml-viewer-world H{
- { T{ button-up f f 1 } [ dup drag?>> [ drop ] [ select-edge ] if ] }
- { T{ drag f 1 } [ t >>drag? drop ] }
- { T{ key-down f f "RET" } [ reset-view ] }
- { T{ key-down f f "TAB" } [ rotate-view-mode ] }
-} set-gestures
-
-AFTER: gml-viewer-world tick-game-world
- dup drag?>> [
- read-mouse buttons>>
- ! FIXME: GTK Mouse buttons are an integer
- ! MacOSX mouse buttons are an array of bools
- dup integer? [ 0 bit? ] [ first ] if >>drag?
- ] when drop ;
-
-M: gml-viewer-world wasd-mouse-scale drag?>> -1/600. 0.0 ? ;
-
-: wrap-in-model ( object -- model )
- dup model? [ <model> ] unless ;
-: wrap-in-growable-model ( object -- model )
- dup model? [
- dup growable? [ >vector ] unless
- <model>
- ] unless ;
-
-: gml-viewer ( b-rep selection -- )
- [ wrap-in-model ] [ wrap-in-growable-model ] bi*
- '[
- f T{ game-attributes
- { world-class gml-viewer-world }
- { title "GML wireframe viewer" }
- { pixel-format-attributes {
- windowed
- double-buffered
- T{ depth-bits f 16 }
- } }
- { grab-input? f }
- { use-game-input? t }
- { use-audio-engine? f }
- { pref-dim { 1024 768 } }
- { tick-interval-nanos $[ 30 fps ] }
- } open-window*
- _ >>model
- _ >>selected
- drop
- ] with-ui ;
+++ /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
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences vectors classes classes.algebra
-combinators arrays words assocs parser namespaces make
-definitions prettyprint prettyprint.backend prettyprint.custom
-quotations generalizations sequences.generalizations debugger io
-compiler.units kernel.private effects accessors hashtables
-sorting shuffle math.order sets see effects.parser ;
-FROM: namespaces => set ;
-IN: multi-methods
-
-! PART I: Converting hook specializers
-: canonicalize-specializer-0 ( specializer -- specializer' )
- [ \ f or ] map ;
-
-SYMBOL: args
-
-SYMBOL: hooks
-
-SYMBOL: total
-
-: canonicalize-specializer-1 ( specializer -- specializer' )
- [
- [ class? ] filter
- [ length iota <reversed> [ 1 + neg ] map ] keep zip
- [ length args [ max ] change ] keep
- ]
- [
- [ pair? ] filter
- [ keys [ hooks get adjoin ] each ] keep
- ] bi append ;
-
-: canonicalize-specializer-2 ( specializer -- specializer' )
- [
- [
- {
- { [ dup integer? ] [ ] }
- { [ dup word? ] [ hooks get index ] }
- } cond args get +
- ] dip
- ] assoc-map ;
-
-: canonicalize-specializer-3 ( specializer -- specializer' )
- [ total get object <array> <enum> ] dip assoc-union! seq>> ;
-
-: canonicalize-specializers ( methods -- methods' hooks )
- [
- [ [ canonicalize-specializer-0 ] dip ] assoc-map
-
- 0 args set
- V{ } clone hooks set
-
- [ [ canonicalize-specializer-1 ] dip ] assoc-map
-
- hooks [ natural-sort ] change
-
- [ [ canonicalize-specializer-2 ] dip ] assoc-map
-
- args get hooks get length + total set
-
- [ [ canonicalize-specializer-3 ] dip ] assoc-map
-
- hooks get
- ] with-scope ;
-
-: drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
-
-: prepare-method ( method n -- quot )
- [ 1quotation ] [ drop-n-quot ] bi* prepend ;
-
-: prepare-methods ( methods -- methods' prologue )
- canonicalize-specializers
- [ length [ prepare-method ] curry assoc-map ] keep
- [ [ get ] curry ] map concat [ ] like ;
-
-! Part II: Topologically sorting specializers
-: maximal-element ( seq quot -- n elt )
- dupd [
- swapd [ call +lt+ = ] 2curry any? not
- ] 2curry find [ "Topological sort failed" throw ] unless* ;
- inline
-
-: topological-sort ( seq quot -- newseq )
- [ >vector [ dup empty? not ] ] dip
- [ dupd maximal-element [ over remove-nth! drop ] dip ] curry
- produce nip ; inline
-
-: classes< ( seq1 seq2 -- lt/eq/gt )
- [
- {
- { [ 2dup eq? ] [ +eq+ ] }
- { [ 2dup [ class<= ] [ swap class<= ] 2bi and ] [ +eq+ ] }
- { [ 2dup class<= ] [ +lt+ ] }
- { [ 2dup swap class<= ] [ +gt+ ] }
- [ +eq+ ]
- } cond 2nip
- ] 2map [ +eq+ eq? not ] find nip +eq+ or ;
-
-: sort-methods ( alist -- alist' )
- [ [ first ] bi@ classes< ] topological-sort ;
-
-! PART III: Creating dispatch quotation
-: picker ( n -- quot )
- {
- { 0 [ [ dup ] ] }
- { 1 [ [ over ] ] }
- { 2 [ [ pick ] ] }
- [ 1 - picker [ dip swap ] curry ]
- } case ;
-
-: (multi-predicate) ( class picker -- quot )
- swap predicate-def append ;
-
-: multi-predicate ( classes -- quot )
- dup length iota <reversed>
- [ picker 2array ] 2map
- [ drop object eq? ] assoc-reject
- [ [ t ] ] [
- [ (multi-predicate) ] { } assoc>map
- unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
- ] if-empty ;
-
-: argument-count ( methods -- n )
- keys 0 [ length max ] reduce ;
-
-ERROR: no-method arguments generic ;
-
-: make-default-method ( methods generic -- quot )
- [ argument-count ] dip [ [ narray ] dip no-method ] 2curry ;
-
-: multi-dispatch-quot ( methods generic -- quot )
- [ make-default-method ]
- [ drop [ [ multi-predicate ] dip ] assoc-map reverse! ]
- 2bi alist>quot ;
-
-! Generic words
-PREDICATE: generic < word
- "multi-methods" word-prop >boolean ;
-
-: methods ( word -- alist )
- "multi-methods" word-prop >alist ;
-
-: make-generic ( generic -- quot )
- [
- [ methods prepare-methods % sort-methods ] keep
- multi-dispatch-quot %
- ] [ ] make ;
-
-: update-generic ( word -- )
- dup make-generic define ;
-
-! Methods
-PREDICATE: method-body < word
- "multi-method-generic" word-prop >boolean ;
-
-M: method-body stack-effect
- "multi-method-generic" word-prop stack-effect ;
-
-M: method-body crossref?
- "forgotten" word-prop not ;
-
-: method-word-name ( specializer generic -- string )
- [ name>> % "-" % unparse % ] "" make ;
-
-: method-word-props ( specializer generic -- assoc )
- [
- "multi-method-generic" ,,
- "multi-method-specializer" ,,
- ] H{ } make ;
-
-: <method> ( specializer generic -- word )
- [ method-word-props ] 2keep
- method-word-name f <word>
- swap >>props ;
-
-: with-methods ( word quot -- )
- over [
- [ "multi-methods" word-prop ] dip call
- ] dip update-generic ; inline
-
-: reveal-method ( method classes generic -- )
- [ set-at ] with-methods ;
-
-: method ( classes word -- method )
- "multi-methods" word-prop at ;
-
-: create-method ( classes generic -- method )
- 2dup method dup [
- 2nip
- ] [
- drop [ <method> dup ] 2keep reveal-method
- ] if ;
-
-: niceify-method ( seq -- seq )
- [ dup \ f eq? [ drop f ] when ] map ;
-
-M: no-method error.
- "Type check error" print
- nl
- "Generic word " write dup generic>> pprint
- " does not have a method applicable to inputs:" print
- dup arguments>> short.
- nl
- "Inputs have signature:" print
- dup arguments>> [ class-of ] map niceify-method .
- nl
- "Available methods: " print
- generic>> methods canonicalize-specializers drop sort-methods
- keys [ niceify-method ] map stack. ;
-
-: forget-method ( specializer generic -- )
- [ delete-at ] with-methods ;
-
-: method>spec ( method -- spec )
- [ "multi-method-specializer" word-prop ]
- [ "multi-method-generic" word-prop ] bi prefix ;
-
-: define-generic ( word effect -- )
- over set-stack-effect
- dup "multi-methods" word-prop [ drop ] [
- [ H{ } clone "multi-methods" set-word-prop ]
- [ update-generic ]
- bi
- ] if ;
-
-! Syntax
-SYNTAX: GENERIC: scan-new-word scan-effect define-generic ;
-
-: parse-method ( -- quot classes generic )
- parse-definition [ 2 tail ] [ second ] [ first ] tri ;
-
-: create-method-in ( specializer generic -- method )
- create-method dup save-location f set-last-word ;
-
-: scan-new-method ( -- method )
- scan-word scan-object swap create-method-in ;
-
-: (METHOD:) ( -- method def ) scan-new-method parse-definition ;
-
-SYNTAX: METHOD: (METHOD:) define ;
-
-! For compatibility
-SYNTAX: M:
- scan-word 1array scan-word create-method-in
- parse-definition
- define ;
-
-! Definition protocol. We qualify core generics here
-QUALIFIED: syntax
-
-syntax:M: generic definer drop \ GENERIC: f ;
-
-syntax:M: generic definition drop f ;
-
-PREDICATE: method-spec < array
- unclip generic? [ [ class? ] all? ] dip and ;
-
-syntax:M: method-spec where
- dup unclip method [ ] [ first ] ?if where ;
-
-syntax:M: method-spec set-where
- unclip method set-where ;
-
-syntax:M: method-spec definer
- unclip method definer ;
-
-syntax:M: method-spec definition
- unclip method definition ;
-
-syntax:M: method-spec synopsis*
- unclip method synopsis* ;
-
-syntax:M: method-spec forget*
- unclip method forget* ;
-
-syntax:M: method-body definer
- drop \ METHOD: \ ; ;
-
-syntax:M: method-body synopsis*
- dup definer.
- [ "multi-method-generic" word-prop pprint-word ]
- [ "multi-method-specializer" word-prop pprint* ] bi ;
+++ /dev/null
-Experimental multiple dispatch implementation
+++ /dev/null
-extensions
+++ /dev/null
-USING: multi-methods tools.test math sequences namespaces system
-kernel strings ;
-IN: multi-methods.tests
-
-[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
-
-: setup-canon-test ( -- )
- 0 args set
- V{ } clone hooks set ;
-
-: canon-test-1 ( -- seq )
- { integer { cpu x86 } sequence } canonicalize-specializer-1 ;
-
-[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [
- [
- setup-canon-test
- canon-test-1
- ] with-scope
-] unit-test
-
-[ { { 0 integer } { 1 sequence } { 2 x86 } } ] [
- [
- setup-canon-test
- canon-test-1
- canonicalize-specializer-2
- ] with-scope
-] unit-test
-
-[ { integer sequence x86 } ] [
- [
- setup-canon-test
- canon-test-1
- canonicalize-specializer-2
- args get hooks get length + total set
- canonicalize-specializer-3
- ] with-scope
-] unit-test
-
-CONSTANT: example-1
- {
- { { { cpu x86 } { os linux } } "a" }
- { { { cpu ppc } } "b" }
- { { string { os windows } } "c" }
- }
-
-[
- {
- { { object x86 linux } "a" }
- { { object ppc object } "b" }
- { { string object windows } "c" }
- }
- { cpu os }
-] [
- example-1 canonicalize-specializers
-] unit-test
-
-[
- {
- { { object x86 linux } [ drop drop "a" ] }
- { { object ppc object } [ drop drop "b" ] }
- { { string object windows } [ drop drop "c" ] }
- }
- [ \ cpu get \ os get ]
-] [
- example-1 prepare-methods
-] unit-test
+++ /dev/null
-USING: multi-methods tools.test math sequences namespaces system
-kernel strings words compiler.units quotations ;
-IN: multi-methods.tests
-
-DEFER: fake
-\ fake H{ } clone "multi-methods" set-word-prop
-<< ( -- ) \ fake set-stack-effect >>
-
-[
- [ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
-
- [ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ]
- [ { } \ fake method-word-props ] unit-test
-
- [ t ] [ { } \ fake <method> method-body? ] unit-test
-
- [ { } [ ] ] [ \ fake methods prepare-methods [ sort-methods ] dip ] unit-test
-
- [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test
-
- [ t ] [ \ fake make-generic quotation? ] unit-test
-
- [ ] [ \ fake update-generic ] unit-test
-
- DEFER: testing
-
- [ ] [ \ testing ( -- ) define-generic ] unit-test
-
- [ t ] [ \ testing generic? ] unit-test
-] with-compilation-unit
+++ /dev/null
-USING: math strings sequences tools.test ;
-IN: multi-methods.tests
-
-GENERIC: legacy-test ( a -- b )
-
-M: integer legacy-test sq ;
-M: string legacy-test " hey" append ;
-
-[ 25 ] [ 5 legacy-test ] unit-test
-[ "hello hey" ] [ "hello" legacy-test ] unit-test
+++ /dev/null
-USING: multi-methods tools.test math sequences namespaces system
-kernel strings definitions prettyprint debugger arrays
-hashtables continuations classes assocs accessors see ;
-RENAME: GENERIC: multi-methods => multi-methods:GENERIC:
-IN: multi-methods.tests
-
-multi-methods:GENERIC: first-test ( -- )
-
-[ t ] [ \ first-test generic? ] unit-test
-
-MIXIN: thing
-
-SINGLETON: paper INSTANCE: paper thing
-SINGLETON: scissors INSTANCE: scissors thing
-SINGLETON: rock INSTANCE: rock thing
-
-multi-methods:GENERIC: beats? ( obj1 obj2 -- ? )
-
-METHOD: beats? { paper scissors } 2drop t ;
-METHOD: beats? { scissors rock } 2drop t ;
-METHOD: beats? { rock paper } 2drop t ;
-METHOD: beats? { thing thing } 2drop f ;
-
-: play ( obj1 obj2 -- ? ) beats? ;
-
-[ { } 3 play ] must-fail
-[ t ] [ error get no-method? ] unit-test
-[ ] [ error get error. ] unit-test
-[ { { } 3 } ] [ error get arguments>> ] unit-test
-[ t ] [ paper scissors play ] unit-test
-[ f ] [ scissors paper play ] unit-test
-
-[ t ] [ { beats? paper scissors } method-spec? ] unit-test
-[ ] [ { beats? paper scissors } see ] unit-test
-
-SYMBOL: some-var
-
-multi-methods:GENERIC: hook-test ( obj -- obj )
-
-METHOD: hook-test { array { some-var array } } reverse ;
-METHOD: hook-test { { some-var array } } class-of ;
-METHOD: hook-test { hashtable { some-var number } } assoc-size ;
-
-{ 1 2 3 } some-var set
-[ { f t t } ] [ { t t f } hook-test ] unit-test
-[ fixnum ] [ 3 hook-test ] unit-test
-5.0 some-var set
-[ 0 ] [ H{ } hook-test ] unit-test
-
-"error" some-var set
-[ H{ } hook-test ] must-fail
-[ t ] [ error get no-method? ] unit-test
-[ { H{ } "error" } ] [ error get arguments>> ] unit-test
-
-MIXIN: busted
-
-TUPLE: busted-1 ;
-TUPLE: busted-2 ; INSTANCE: busted-2 busted
-TUPLE: busted-3 ;
-
-multi-methods:GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
-
-METHOD: busted-sort { busted-1 busted-2 } ;
-METHOD: busted-sort { busted-2 busted-3 } ;
-METHOD: busted-sort { busted busted } ;
+++ /dev/null
-USING: kernel multi-methods tools.test math arrays sequences
-math.order ;
-IN: multi-methods.tests
-
-[ { 1 2 3 4 5 6 } ] [
- { 6 4 5 1 3 2 } [ <=> ] topological-sort
-] unit-test
-
-[ +lt+ ] [
- { fixnum array } { number sequence } classes<
-] unit-test
-
-[ +eq+ ] [
- { number sequence } { number sequence } classes<
-] unit-test
-
-[ +gt+ ] [
- { object object } { number sequence } classes<
-] unit-test
+++ /dev/null
-! (c)2009 Joe Groff bsd license
-USING: help.markup help.syntax multiline ;
-IN: pair-rocket
-
-HELP: =>
-{ $syntax "a => b" }
-{ $description "Constructs a two-element array from the objects immediately before and after the " { $snippet "=>" } ". This syntax can be used inside sequence and assoc literals." }
-{ $examples
-{ $unchecked-example """USING: pair-rocket prettyprint ;
-
-H{ "foo" => 1 "bar" => 2 } ."""
-"""H{ { "foo" 1 } { "bar" 2 } }""" }
-}
-;
+++ /dev/null
-! (c)2009 Joe Groff bsd license
-USING: kernel pair-rocket tools.test ;
-IN: pair-rocket.tests
-
-{ { "a" 1 } } [ "a" => 1 ] unit-test
-{ { { "a" } { 1 } } } [ { "a" } => { 1 } ] unit-test
-{ { drop 1 } } [ drop => 1 ] unit-test
-
-{ H{ { "zippity" 5 } { "doo" 2 } { "dah" 7 } } }
-[ H{ "zippity" => 5 "doo" => 2 "dah" => 7 } ] unit-test
+++ /dev/null
-! (c)2009 Joe Groff bsd license
-USING: arrays kernel parser sequences ;
-IN: pair-rocket
-
-SYNTAX: => dup pop scan-object 2array suffix! ;
+++ /dev/null
-H{ "foo" => 1 "bar" => 2 } style literal syntax
+++ /dev/null
-USING: accessors alien.c-types alien.data arrays calendar colors
-combinators combinators.short-circuit flatland generalizations
-grouping kernel locals math math.intervals math.order
-math.rectangles math.vectors namespaces opengl opengl.gl
-opengl.glu processing.shapes sequences sequences.generalizations
-shuffle threads ui ui.gadgets ui.gestures ui.render ;
-FROM: multi-methods => GENERIC: METHOD: ;
-FROM: syntax => M: ;
-IN: pong
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-! Inspired by this Ruby/Shoes version by why: http://gist.github.com/26431
-!
-! Which was based on this Nodebox version: http://billmill.org/pong.html
-! by Bill Mill.
-!
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: clamp-to-interval ( x interval -- x )
- [ from>> first max ] [ to>> first min ] bi ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <play-field> < <rectangle> ;
-TUPLE: <paddle> < <rectangle> ;
-
-TUPLE: <computer> < <paddle> { speed initial: 10 } ;
-
-: computer-move-left ( computer -- ) dup speed>> move-left-by ;
-: computer-move-right ( computer -- ) dup speed>> move-right-by ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <ball> < <vel>
- { diameter initial: 20 }
- { bounciness initial: 1.2 }
- { max-speed initial: 10 } ;
-
-: above-lower-bound? ( ball field -- ? ) bottom 50 - above? ;
-: below-upper-bound? ( ball field -- ? ) top 50 + below? ;
-
-: in-bounds? ( ball field -- ? )
- {
- [ above-lower-bound? ]
- [ below-upper-bound? ]
- } 2&& ;
-
-:: bounce-change-vertical-velocity ( BALL -- )
-
- BALL vel>> y neg
- BALL bounciness>> *
-
- BALL max-speed>> min
-
- BALL vel>> (y!) ;
-
-:: bounce-off-paddle ( BALL PADDLE -- )
-
- BALL bounce-change-vertical-velocity
-
- BALL x PADDLE center x - 0.25 * BALL vel>> (x!)
-
- PADDLE top BALL pos>> (y!) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: mouse-x ( -- x ) hand-loc get first ;
-
-:: valid-paddle-interval ( PADDLE PLAY-FIELD -- interval )
-
- PLAY-FIELD [ left ] [ right ] bi PADDLE width - [a,b] ;
-
-:: align-paddle-with-mouse ( PADDLE PLAY-FIELD -- )
-
- mouse-x
-
- PADDLE PLAY-FIELD valid-paddle-interval
-
- clamp-to-interval
-
- PADDLE pos>> (x!) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Protocol for drawing PONG objects
-
-GENERIC: draw ( obj -- )
-
-METHOD: draw { <paddle> } [ bottom-left ] [ dim>> ] bi rectangle ;
-METHOD: draw { <ball> } [ pos>> ] [ diameter>> 2 / ] bi circle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <pong> < gadget paused field ball player computer ;
-
-: pong ( -- gadget )
- <pong> new
- T{ <play-field> { pos { 0 0 } } { dim { 400 400 } } } clone >>field
- T{ <ball> { pos { 50 50 } } { vel { 3 4 } } } clone >>ball
- T{ <paddle> { pos { 200 396 } } { dim { 75 4 } } } clone >>player
- T{ <computer> { pos { 200 0 } } { dim { 75 4 } } } clone >>computer ;
-
-M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
-M: <pong> ungraft* ( <pong> -- ) t >>paused drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M:: <pong> draw-gadget* ( PONG -- )
-
- PONG computer>> draw
- PONG player>> draw
- PONG ball>> draw ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: iterate-system ( GADGET -- )
-
- GADGET field>> :> FIELD
- GADGET ball>> :> BALL
- GADGET player>> :> PLAYER
- GADGET computer>> :> COMPUTER
-
- BALL FIELD in-bounds? [
-
- PLAYER FIELD align-paddle-with-mouse
-
- BALL 1 move-for
-
- ! computer reaction
-
- BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
- BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
-
- ! check if ball bounced off something
-
- ! player-blocked-ball?
- BALL PLAYER { [ above? ] [ in-between-horizontally? ] } 2&&
- [ BALL PLAYER bounce-off-paddle ] when
-
- ! computer-blocked-ball?
- BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } 2&&
- [ BALL COMPUTER bounce-off-paddle ] when
-
- ! bounced-off-wall?
- BALL FIELD in-between-horizontally? not
- [ BALL reverse-horizontal-velocity ] when
-
- ] [ t GADGET paused<< ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: start-pong-thread ( GADGET -- )
- f GADGET paused<<
- [
- [
- GADGET paused>>
- [ f ]
- [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
- if
- ]
- loop
- ]
- in-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pong-window ( -- ) pong [ "PONG" open-window ] [ start-pong-thread ] bi ;
-
-: pong-main ( -- ) [ pong-window ] with-ui ;
-
-MAIN: pong-window
+++ /dev/null
-! (c)2010 Joe Groff bsd license
-USING: accessors arrays combinators definitions fry kernel
-locals.types namespaces parser quotations see sequences slots
-words ;
-FROM: kernel.private => declare ;
-FROM: help.markup.private => link-effect? ;
-IN: variables
-
-PREDICATE: variable < word
- "variable-setter" word-prop >boolean ;
-
-GENERIC: variable-setter ( word -- word' )
-
-M: variable variable-setter "variable-setter" word-prop ;
-M: local-reader variable-setter "local-writer" word-prop ;
-
-SYNTAX: set:
- scan-object variable-setter suffix! ;
-
-: [variable-getter] ( variable -- quot )
- '[ _ get ] ;
-: [variable-setter] ( variable -- quot )
- '[ _ set ] ;
-
-: (define-variable) ( word getter setter -- )
- [ ( -- value ) define-inline ]
- [
- [
- [ name>> "set: " prepend <uninterned-word> ]
- [ over "variable-setter" set-word-prop ] bi
- ] dip ( value -- ) define-inline
- ] bi-curry* bi ;
-
-: define-variable ( word -- )
- dup [ [variable-getter] ] [ [variable-setter] ] bi (define-variable) ;
-
-SYNTAX: VAR:
- scan-new-word define-variable ;
-
-M: variable definer drop \ VAR: f ;
-M: variable definition drop f ;
-M: variable link-effect? drop f ;
-M: variable print-stack-effect? drop f ;
-
-PREDICATE: typed-variable < variable
- "variable-type" word-prop >boolean ;
-
-: [typed-getter] ( quot type -- quot )
- 1array '[ @ _ declare ] ;
-: [typed-setter] ( quot type -- quot )
- instance-check-quot prepose ;
-
-: define-typed-variable ( word type -- )
- dupd {
- [ [ [variable-getter] ] dip [typed-getter] ]
- [ [ [variable-setter] ] dip [typed-setter] ]
- [ "variable-type" set-word-prop ]
- [ initial-value drop swap set-global ]
- } 2cleave (define-variable) ;
-
-SYNTAX: TYPED-VAR:
- scan-new-word scan-object define-typed-variable ;
-
-M: typed-variable definer drop \ TYPED-VAR: f ;
-M: typed-variable definition "variable-type" word-prop 1quotation ;
-
-TUPLE: global-box value ;
-
-PREDICATE: global-variable < variable
- def>> first global-box? ;
-
-: [global-getter] ( box -- quot )
- '[ _ value>> ] ;
-: [global-setter] ( box -- quot )
- '[ _ value<< ] ;
-
-: define-global ( word -- )
- global-box new [ [global-getter] ] [ [global-setter] ] bi (define-variable) ;
-
-SYNTAX: GLOBAL:
- scan-new-word define-global ;
-
-M: global-variable definer drop \ GLOBAL: f ;
-
-INTERSECTION: typed-global-variable
- global-variable typed-variable ;
-
-: define-typed-global ( word type -- )
- 2dup "variable-type" set-word-prop
- dup initial-value drop global-box boa swap
- [ [ [global-getter] ] dip [typed-getter] ]
- [ [ [global-setter] ] dip [typed-setter] ] 2bi (define-variable) ;
-
-SYNTAX: TYPED-GLOBAL:
- scan-new-word scan-object define-typed-global ;
-
-M: typed-global-variable definer drop \ TYPED-GLOBAL: f ;
projects / factor.git / commitdiff