From: John Benediktsson Date: Wed, 30 Mar 2016 17:29:58 +0000 (-0700) Subject: maintain gml, euler, flatland, pong, multi-methods, pair-rockets, variables. X-Git-Tag: unmaintained~1341 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=a82ae0027d2ed7455e293becabb11597b6ec2349 maintain gml, euler, flatland, pong, multi-methods, pair-rockets, variables. --- diff --git a/extra/euler/b-rep/b-rep-tests.factor b/extra/euler/b-rep/b-rep-tests.factor new file mode 100644 index 0000000000..7fe912e2fe --- /dev/null +++ b/extra/euler/b-rep/b-rep-tests.factor @@ -0,0 +1,79 @@ +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 diff --git a/extra/euler/b-rep/b-rep.factor b/extra/euler/b-rep/b-rep.factor new file mode 100644 index 0000000000..57234f5659 --- /dev/null +++ b/extra/euler/b-rep/b-rep.factor @@ -0,0 +1,234 @@ +! 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 ) + 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 ; diff --git a/extra/euler/b-rep/examples/examples.factor b/extra/euler/b-rep/examples/examples.factor new file mode 100644 index 0000000000..096af775e3 --- /dev/null +++ b/extra/euler/b-rep/examples/examples.factor @@ -0,0 +1,521 @@ +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 diff --git a/extra/euler/b-rep/io/obj/obj-tests.factor b/extra/euler/b-rep/io/obj/obj-tests.factor new file mode 100644 index 0000000000..3f2f8edae9 --- /dev/null +++ b/extra/euler/b-rep/io/obj/obj-tests.factor @@ -0,0 +1,131 @@ +! (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 diff --git a/extra/euler/b-rep/io/obj/obj.factor b/extra/euler/b-rep/io/obj/obj.factor new file mode 100644 index 0000000000..3f37e52e49 --- /dev/null +++ b/extra/euler/b-rep/io/obj/obj.factor @@ -0,0 +1,86 @@ +! (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 + +> 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 ; + +>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 [ >>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 ; diff --git a/extra/euler/b-rep/subdivision/subdivision.factor b/extra/euler/b-rep/subdivision/subdivision.factor new file mode 100644 index 0000000000..14ce362787 --- /dev/null +++ b/extra/euler/b-rep/subdivision/subdivision.factor @@ -0,0 +1,112 @@ +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 + +: ( position -- vertex ) vertex new swap >>position ; inline + +: face-points ( faces -- face-pts ) + [ edge>> face-midpoint ] map ; inline + +:: edge-points ( edges edge-indices face-indices face-points -- edge-pts ) + edges length 0 :> 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 + + [ 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 + + ] 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 ; diff --git a/extra/euler/b-rep/triangulation/triangulation-tests.factor b/extra/euler/b-rep/triangulation/triangulation-tests.factor new file mode 100644 index 0000000000..bcc38b2185 --- /dev/null +++ b/extra/euler/b-rep/triangulation/triangulation-tests.factor @@ -0,0 +1,84 @@ +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 diff --git a/extra/euler/b-rep/triangulation/triangulation.factor b/extra/euler/b-rep/triangulation/triangulation.factor new file mode 100644 index 0000000000..a88b29b669 --- /dev/null +++ b/extra/euler/b-rep/triangulation/triangulation.factor @@ -0,0 +1,70 @@ +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 ; + + + 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 &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 ] + [ &release-alien-handle-ptr ] bi gluTessVertex + ] each-face-edge + + tess gluTessEndContour + + ring next-ring>> dup + ] loop drop + tess gluTessEndPolygon + + vertices { } like 3 + ] with-destructors ; diff --git a/extra/euler/modeling/modeling-tests.factor b/extra/euler/modeling/modeling-tests.factor new file mode 100644 index 0000000000..0eb8f10e95 --- /dev/null +++ b/extra/euler/modeling/modeling-tests.factor @@ -0,0 +1,46 @@ +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 diff --git a/extra/euler/modeling/modeling.factor b/extra/euler/modeling/modeling.factor new file mode 100644 index 0000000000..21c6974283 --- /dev/null +++ b/extra/euler/modeling/modeling.factor @@ -0,0 +1,78 @@ +! 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 diff --git a/extra/euler/operators/operators-tests.factor b/extra/euler/operators/operators-tests.factor new file mode 100644 index 0000000000..da1617d9f3 --- /dev/null +++ b/extra/euler/operators/operators-tests.factor @@ -0,0 +1,217 @@ +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 diff --git a/extra/euler/operators/operators.factor b/extra/euler/operators/operators.factor new file mode 100644 index 0000000000..f2dea708d1 --- /dev/null +++ b/extra/euler/operators/operators.factor @@ -0,0 +1,317 @@ +! 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 ) + [ swap with-b-rep ] [ finish-b-rep ] [ ] tri ; inline + + 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' ; + + 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 ; + +> ] 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 ; diff --git a/extra/flatland/flatland.factor b/extra/flatland/flatland.factor new file mode 100644 index 0000000000..d47ec32e3e --- /dev/null +++ b/extra/flatland/flatland.factor @@ -0,0 +1,228 @@ + +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 ; + +METHOD: x { } pos>> first ; +METHOD: y { } pos>> second ; + +METHOD: (x!) { number } pos>> set-first ; +METHOD: (y!) { number } pos>> set-second ; + +METHOD: to-the-left-of? { number } [ x ] dip < ; +METHOD: to-the-right-of? { number } [ x ] dip > ; + +METHOD: move-left-by { number } [ pos>> ] dip move-left-by ; +METHOD: move-right-by { number } [ pos>> ] dip move-right-by ; + +METHOD: above? { number } [ y ] dip > ; +METHOD: below? { number } [ y ] dip < ; + +METHOD: move-by { sequence } '[ _ v+ ] change-pos drop ; + +METHOD: distance { } [ pos>> ] bi@ distance ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! A class for objects with velocity. It inherits from . Hey, if +! it's moving it has a position right? Unless it's some alternate universe... + +TUPLE: < 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: < dim ; + +METHOD: width { } dim>> first ; +METHOD: height { } dim>> second ; + +METHOD: left { } x ; +METHOD: right { } [ x ] [ width ] bi + ; +METHOD: bottom { } y ; +METHOD: top { } [ 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? { } [ x ] [ left ] bi* < ; +METHOD: to-the-right-of? { } [ x ] [ right ] bi* > ; + +METHOD: below? { } [ y ] [ bottom ] bi* < ; +METHOD: above? { } [ y ] [ top ] bi* > ; + +METHOD: horizontal-interval { } + [ left ] [ right ] bi [a,b] ; + +METHOD: in-between-horizontally? { } + [ x ] [ horizontal-interval ] bi* interval-contains? ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: left right bottom top ; + +METHOD: left { } left>> ; +METHOD: right { } right>> ; +METHOD: bottom { } bottom>> ; +METHOD: top { } top>> ; + +METHOD: width { } [ right>> ] [ left>> ] bi - ; +METHOD: height { } [ top>> ] [ bottom>> ] bi - ; + +! METHOD: to-extent ( -- ) +! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave boa ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: to-the-left-of? { sequence } [ x ] [ left ] bi* < ; +METHOD: to-the-right-of? { sequence } [ x ] [ right ] bi* > ; + +METHOD: below? { sequence } [ y ] [ bottom ] bi* < ; +METHOD: above? { sequence } [ 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? { } + { + [ left to-the-right-of? ] + [ right to-the-left-of? ] + [ bottom above? ] + [ top below? ] + } + 2&& ; diff --git a/extra/gml/b-rep/b-rep.factor b/extra/gml/b-rep/b-rep.factor new file mode 100644 index 0000000000..ff514c3ab7 --- /dev/null +++ b/extra/gml/b-rep/b-rep.factor @@ -0,0 +1,110 @@ +! 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 ; diff --git a/extra/gml/core/core.factor b/extra/gml/core/core.factor new file mode 100644 index 0000000000..dec8142cc2 --- /dev/null +++ b/extra/gml/core/core.factor @@ -0,0 +1,158 @@ +! 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 ) { } ; +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 ] dip proc>quot1 each ] with-return ; +GML: forx ( a s b proc -- ) + '[ _ _ _ _ [ 1 - swap ] 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= ; diff --git a/extra/gml/coremath/coremath.factor b/extra/gml/coremath/coremath.factor new file mode 100644 index 0000000000..bfb6a1b462 --- /dev/null +++ b/extra/gml/coremath/coremath.factor @@ -0,0 +1,217 @@ +! 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 ] } + { [ over vec3d? ] [ [ [ second ] [ third ] bi ] dip -rot ] } + } cond ; + +GML: putY ( vec y -- x ) + { + { [ over vec2d? ] [ [ first ] dip ] } + { [ over vec3d? ] [ [ [ first ] [ third ] bi ] dip swap ] } + } cond ; + +GML: putZ ( vec z -- x ) + { + { [ over vec3d? ] [ [ first2 ] dip ] } + } 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 ) ; + +GML: vector3 ( x y z -- v ) ; + +GML: random ( -- x ) 0.0 1.0 uniform-random-float ; + +GML: randomseed ( n -- ) + dup 0 < [ drop nano-count 1000000 /i ] when + 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 ; diff --git a/extra/gml/examples/cube.gml b/extra/gml/examples/cube.gml new file mode 100644 index 0000000000..1554b9e8b7 --- /dev/null +++ b/extra/gml/examples/cube.gml @@ -0,0 +1,41 @@ +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 diff --git a/extra/gml/examples/doorway.gml b/extra/gml/examples/doorway.gml new file mode 100644 index 0000000000..e6a5ee0b70 --- /dev/null +++ b/extra/gml/examples/doorway.gml @@ -0,0 +1,37 @@ +usereg !nrml !backwall !wall !poly +{ usereg !door !wall + :door edgemate :wall killFmakeRH + :door edgemate faceCCW + :wall makeEkillR + dup faceCCW faceCCW + :door edgemate + exch makeEF pop + faceCCW killEF +} !glue-ringface-edges + +:poly 0 get !pr +:poly -1 get !pl +:wall vertexpos !pw0 +:wall edgemate vertexpos !pw1 +:pr :pw0 :pw1 project_ptline !prb +:pl :pw0 :pw1 project_ptline !plb +[ :plb :plb :prb :prb ] +:poly arrayappend !poly + +:poly :nrml neg :backwall faceplane +project_polyplane + 5 poly2doubleface edgemate !backdoor +:poly 5 poly2doubleface !door +:wall :door :glue-ringface-edges +:backwall :backdoor :glue-ringface-edges +:backdoor faceCCW :door 2 bridgerings + +!doorL +:doorL edgemate 2 faceCCW edgemate !doorR +:doorL edgemate faceCCW killEF +:doorR edgemate faceCCW killEmakeR pop +:doorL edgemate isBaseface { + :doorR edgemate makeFkillRH +} if + +:doorL :doorR diff --git a/extra/gml/examples/mobius.gml b/extra/gml/examples/mobius.gml new file mode 100644 index 0000000000..0c7baa6c84 --- /dev/null +++ b/extra/gml/examples/mobius.gml @@ -0,0 +1,39 @@ +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 diff --git a/extra/gml/examples/torus.gml b/extra/gml/examples/torus.gml new file mode 100644 index 0000000000..095f872a8c --- /dev/null +++ b/extra/gml/examples/torus.gml @@ -0,0 +1,17 @@ +usereg + +[ (-1,-1,0) (1,-1,0) + (1,1,0) (-1,1,0) ] !poly + +:poly 1 poly2doubleface +dup edgemate exch +1 1 extrude-simple !f0 !f1 + +:poly { 0.5 mul } map reverse +5 poly2doubleface +dup edgemate exch +-1 1 extrude-simple +!r0 !r1 + +:r0 :f0 killFmakeRH +:r1 :f1 killFmakeRH diff --git a/extra/gml/geometry/geometry.factor b/extra/gml/geometry/geometry.factor new file mode 100644 index 0000000000..0a1acff745 --- /dev/null +++ b/extra/gml/geometry/geometry.factor @@ -0,0 +1,8 @@ +! 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 ; diff --git a/extra/gml/gml-tests.factor b/extra/gml/gml-tests.factor new file mode 100644 index 0000000000..99c099abac --- /dev/null +++ b/extra/gml/gml-tests.factor @@ -0,0 +1,39 @@ +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 diff --git a/extra/gml/gml.factor b/extra/gml/gml.factor new file mode 100644 index 0000000000..b910cff8f1 --- /dev/null +++ b/extra/gml/gml.factor @@ -0,0 +1,69 @@ +! 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 + +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 set + 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 ] + [ 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 diff --git a/extra/gml/macros/macros.factor b/extra/gml/macros/macros.factor new file mode 100644 index 0000000000..0f79d0d1d0 --- /dev/null +++ b/extra/gml/macros/macros.factor @@ -0,0 +1,41 @@ +! 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 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 + ] ; diff --git a/extra/gml/modeling/modeling.factor b/extra/gml/modeling/modeling.factor new file mode 100644 index 0000000000..4fc9cc9b73 --- /dev/null +++ b/extra/gml/modeling/modeling.factor @@ -0,0 +1,25 @@ +! 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 ; diff --git a/extra/gml/parser/parser.factor b/extra/gml/parser/parser.factor new file mode 100644 index 0000000000..c142541b69 --- /dev/null +++ b/extra/gml/parser/parser.factor @@ -0,0 +1,127 @@ +! 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 + +: 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 ] [ { } ] bi ; + +ERROR: bad-vector-length seq n ; + +: parse-vector ( seq -- vec ) + dup length { + { 2 [ first2 ] } + { 3 [ first3 ] } + [ 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|!(.))) => [[ ]] + +ArrayStart = '[' => [[ marker ]] + +ArrayEnd = ']' => [[ exec" ]" ]] + +ExecArray = '{' Token*:ts Spaces '}' => [[ ts parse-proc ]] + +LiteralName = '/' Name:n => [[ n name ]] + +UseReg = "usereg" !(NameChar) => [[ ]] + +ReadReg = ";" Name:n => [[ n ]] +ExecReg = ":" Name:n => [[ n ]] +WriteReg = "!" Name:n => [[ n ]] + +ExecName = Name:n => [[ n exec-name ]] + +PathNameComponent = "." Name:n => [[ n name ]] +PathName = PathNameComponent+ => [[ ]] + +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 diff --git a/extra/gml/printer/printer.factor b/extra/gml/printer/printer.factor new file mode 100644 index 0000000000..48b5ac9d36 --- /dev/null +++ b/extra/gml/printer/printer.factor @@ -0,0 +1,60 @@ +! 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 ; diff --git a/extra/gml/runtime/authors.txt b/extra/gml/runtime/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/gml/runtime/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/gml/runtime/runtime.factor b/extra/gml/runtime/runtime.factor new file mode 100644 index 0000000000..6460361966 --- /dev/null +++ b/extra/gml/runtime/runtime.factor @@ -0,0 +1,209 @@ +! 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 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 } ; + +: ( name -- read-register ) 0 read-register boa ; + +EXEC: read-register + [ 2dup ] dip lookup-register over push-operand ; + +TUPLE: exec-register { name string } { n fixnum } ; + +: ( name -- exec-register ) 0 exec-register boa ; + +EXEC: exec-register + [ 2dup ] dip lookup-register exec-proc ; + +TUPLE: write-register { name string } { n fixnum } ; + +: ( 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 new ; + +EXEC: use-registers + n>> f '[ drop _ ] dip ; + +! Pathnames +TUPLE: pathname names ; + +C: 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 new + global-dictionary get clone 1vector >>dictionary-stack + V{ } clone >>operand-stack ; + +: exec ( gml proc -- gml ) [ { } ] 2dip exec-proc nip ; diff --git a/extra/gml/test-core.gml b/extra/gml/test-core.gml new file mode 100644 index 0000000000..1eb5439a5a --- /dev/null +++ b/extra/gml/test-core.gml @@ -0,0 +1,299 @@ +% 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 diff --git a/extra/gml/test-coremath.gml b/extra/gml/test-coremath.gml new file mode 100644 index 0000000000..f8cd9eeb6b --- /dev/null +++ b/extra/gml/test-coremath.gml @@ -0,0 +1,166 @@ +% 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 diff --git a/extra/gml/test-geometry.gml b/extra/gml/test-geometry.gml new file mode 100644 index 0000000000..2bc86b3b11 --- /dev/null +++ b/extra/gml/test-geometry.gml @@ -0,0 +1,13 @@ +[(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 diff --git a/extra/gml/types/types.factor b/extra/gml/types/types.factor new file mode 100644 index 0000000000..a4de9d3aef --- /dev/null +++ b/extra/gml/types/types.factor @@ -0,0 +1,61 @@ +! 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 + +M: proc clone [ array>> clone ] [ registers>> clone ] bi ; + +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 { } ] unless ; +M: proc new-sequence drop 0 { } ; + +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: double-2-boa + +ALIAS: scalar>vec2d double-2-with + +ALIAS: vec3d? double-4? + +: ( 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 diff --git a/extra/gml/ui/ui.factor b/extra/gml/ui/ui.factor new file mode 100644 index 0000000000..aac7d3c4a3 --- /dev/null +++ b/extra/gml/ui/ui.factor @@ -0,0 +1,121 @@ +! 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 ; + +: ( model -- table ) + stack-entry-renderer + 10 >>min-rows + 10 >>max-rows + 40 >>min-cols + 40 >>max-cols ; + +: ( model -- gadget ) + "Operand stack" ; + +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 ; + +: ( -- button ) + "New viewer" [ find-gml-editor new-viewer ] ; + +: ( -- button ) + "Update viewer" [ find-gml-editor update-viewer ] ; + +: ( -- button ) + "Reset viewer" [ find-gml-editor reset-viewer ] ; + +: ( -- gadget ) + { 5 5 } >>gap + add-gadget + add-gadget + add-gadget ; + +CONSTANT: example-dir "vocab:gml/examples/" + +: gml-files ( -- seq ) + example-dir directory-files + [ file-extension >lower "gml" = ] filter ; + +: ( file -- button ) + dup '[ example-dir _ append-path swap find-gml-editor load-input ] + ; + +: ( -- gadget ) + gml-files + { 5 5 } >>gap + "Examples:"
- 10 >>min-rows - 10 >>max-rows - 40 >>min-cols - 40 >>max-cols ; - -: ( model -- gadget ) - "Operand stack" ; - -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 ; - -: ( -- button ) - "New viewer" [ find-gml-editor new-viewer ] ; - -: ( -- button ) - "Update viewer" [ find-gml-editor update-viewer ] ; - -: ( -- button ) - "Reset viewer" [ find-gml-editor reset-viewer ] ; - -: ( -- gadget ) - { 5 5 } >>gap - add-gadget - add-gadget - add-gadget ; - -CONSTANT: example-dir "vocab:gml/examples/" - -: gml-files ( -- seq ) - example-dir directory-files - [ file-extension >lower "gml" = ] filter ; - -: ( file -- button ) - dup '[ example-dir _ append-path swap find-gml-editor load-input ] - ; - -: ( -- gadget ) - gml-files - { 5 5 } >>gap - "Examples:"