steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

gml, euler: Initial commit.

db4
Doug Coleman 2013-06-18 16:42:13 -07:00
parent 75dccbe329
commit e270175af0
37 changed files with 4179 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

79
extra/euler/b-rep/b-rep-tests.factor Normal file
View File

@ -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{
HEX: 1.279a74590331dp-1
HEX: 1.279a74590331dp-1
HEX: 1.279a74590331dp-1
0.0
}
HEX: -1.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

234
extra/euler/b-rep/b-rep.factor Normal file
View File

@ -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 ) [ 2array ] map-index >hashtable ; inline
TUPLE: b-edge < edge sharpness macro ;
TUPLE: vertex < identity-tuple position edge ;
TUPLE: face < identity-tuple edge next-ring base-face ;
:: (opposite) ( e1 e2 quot: ( edge -- edge' ) -- edge )
e1 quot call :> e0
e0 e2 eq? [ e1 ] [ e0 e2 quot (opposite) ] if ;
inline recursive
: opposite ( edge quot: ( edge -- edge' ) -- edge )
dupd (opposite) ; inline
: face-ccw ( edge -- edge ) next-edge>> ; inline
: face-cw ( edge -- edge ) [ face-ccw ] opposite ; inline
: vertex-cw ( edge -- edge ) opposite-edge>> next-edge>> ; inline
: vertex-ccw ( edge -- edge ) [ vertex-cw ] opposite ; inline
: base-face? ( face -- ? ) dup base-face>> eq? ; inline
: has-rings? ( face -- ? ) next-ring>> >boolean ; inline
: incident? ( e1 e2 -- ? ) [ vertex>> ] bi@ eq? ; inline
TUPLE: b-rep < identity-tuple faces edges vertices ;
: <b-rep> ( -- b-rep )
V{ } clone V{ } clone V{ } clone b-rep boa ;
SYMBOL: sharpness-stack
sharpness-stack [ V{ t } ] initialize
: set-sharpness ( sharp? -- ) >boolean sharpness-stack get set-last ;
: get-sharpness ( -- sharp? ) sharpness-stack get last ;
: push-sharpness ( sharp? -- ) >boolean sharpness-stack get push ;
: pop-sharpness ( -- sharp? )
sharpness-stack get
dup length 1 = [ first ] [ pop ] if ;
: new-vertex ( position b-rep -- vertex )
[ f vertex boa dup ] dip vertices>> push ; inline
: new-edge ( b-rep -- edge )
[ b-edge new get-sharpness >>sharpness dup ] dip edges>> push ; inline
: new-face ( b-rep -- face )
[ face new dup ] dip faces>> push ; inline
: delete-vertex ( vertex b-rep -- )
vertices>> remove! drop ; inline
: delete-edge ( edge b-rep -- )
edges>> remove! drop ; inline
: delete-face ( face b-rep -- )
faces>> remove! drop ; inline
: add-ring ( ring base-face -- )
[ >>base-face drop ]
[ next-ring>> >>next-ring drop ]
[ swap >>next-ring drop ]
2tri ;
: delete-ring ( ring base-face -- )
2dup next-ring>> eq?
[ [ next-ring>> ] dip next-ring<< ]
[ next-ring>> delete-ring ]
if ;
: vertex-pos ( edge -- pos )
vertex>> position>> ; inline
: same-edge? ( e1 e2 -- ? )
{ [ eq? ] [ opposite-edge>> eq? ] } 2|| ;
: same-face? ( e1 e2 -- ? )
[ face>> ] bi@ eq? ;
: edge-direction ( edge -- v )
[ face-ccw ] keep [ vertex-pos ] bi@ v- ;
: normal ( v0 v1 v2 -- v )
[ drop v- ] [ [ drop ] 2dip v- ] 3bi cross ;
ERROR: all-points-colinear ;
: face-normal ( edge -- n )
face-edges
[
dup face-ccw dup face-ccw
[ vertex-pos ] tri@ normal
] map
[ [ zero? ] all? not ] find nip
[ normalize ] [ all-points-colinear ] if* ;
: (face-plane-dist) ( normal edge -- d )
vertex-pos v. neg ; inline
: face-plane-dist ( edge -- d )
[ face-normal ] [ (face-plane-dist) ] bi ; inline
: face-plane ( edge -- n d )
[ face-normal dup ] [ (face-plane-dist) ] bi ; inline
: face-midpoint ( edge -- v )
face-edges
[ [ vertex-pos ] [ v+ ] map-reduce ] [ length ] bi v/n ;
: clear-b-rep ( b-rep -- )
[ faces>> delete-all ]
[ edges>> delete-all ]
[ vertices>> delete-all ]
tri ;
: connect-opposite-edges ( b-rep -- )
edges>>
[ [ [ next-edge>> vertex>> ] [ vertex>> 2array ] [ ] tri ] H{ } map>assoc ]
[ swap '[ [ vertex>> ] [ next-edge>> vertex>> 2array _ at ] [ opposite-edge<< ] tri ] each ] bi ;
: connect-faces ( b-rep -- )
edges>> [ dup face>> edge<< ] each ;
: connect-vertices ( b-rep -- )
edges>> [ dup vertex>> edge<< ] each ;
: finish-b-rep ( b-rep -- )
[ connect-faces ] [ connect-vertices ] bi ;
: characteristic ( b-rep -- n )
! Assumes b-rep is connected and all faces are convex
[ vertices>> length ]
[ edges>> length 2 / ]
[ faces>> [ base-face? ] count ] tri
[ - ] dip + ;
: genus ( b-rep -- n )
! Assumes b-rep is connected and all faces are convex
characteristic 2 swap - 2 / ;
SYMBOLS: live-vertices live-edges live-faces ;
ERROR: dead-vertex vertex ;
: check-live-vertex ( vertex -- )
dup live-vertices get in? [ drop ] [ dead-vertex ] if ;
ERROR: dead-edge edge ;
: check-live-edge ( edge -- )
dup live-edges get in? [ drop ] [ dead-edge ] if ;
ERROR: dead-face face ;
: check-live-face ( face -- )
dup live-faces get in? [ drop ] [ dead-face ] if ;
: check-vertex ( vertex -- )
[ edge>> check-live-edge ]
[ dup edge>> [ vertex>> assert= ] with each-vertex-edge ]
bi ;
: check-edge ( edge -- )
{
[ vertex>> check-live-vertex ]
[ opposite-edge>> check-live-edge ]
[ face>> check-live-face ]
[ dup opposite-edge>> opposite-edge>> assert= ]
} cleave ;
: check-face ( face -- )
[ edge>> check-live-edge ]
[ dup edge>> [ face>> assert= ] with each-face-edge ]
bi ;
: check-ring ( base-face face -- )
[ check-face ] [ base-face>> assert= ] bi ;
: check-base-face ( face -- )
[ check-face ]
[ dup [ next-ring>> ] follow rest [ check-ring ] with each ] bi ;
: check-b-rep ( b-rep -- )
[
[
[ vertices>> fast-set live-vertices set ]
[ edges>> fast-set live-edges set ]
[ faces>> fast-set live-faces set ] tri
]
[
[ vertices>> [ check-vertex ] each ]
[ edges>> [ check-edge ] each ]
[ faces>> [ base-face? ] filter [ check-base-face ] each ] tri
] bi
] with-scope ;
: empty-b-rep? ( b-rep -- ? )
[ faces>> ] [ edges>> ] [ vertices>> ] tri
[ empty? ] tri@ and and ;
ERROR: b-rep-not-empty b-rep ;
: assert-empty-b-rep ( b-rep -- )
dup empty-b-rep? [ drop ] [ b-rep-not-empty ] if ;
: is-valid-edge? ( e brep -- ? )
edges>> member? ; inline
: edge-endpoints ( edge -- from to )
[ vertex>> position>> ]
[ opposite-edge>> vertex>> position>> ] bi ; inline
:: connecting-edge ( e0 e1 -- edge/f )
e1 vertex>> :> target-vertex
e0 vertex>> target-vertex eq? [ f ] [
f e0 [| ret edge |
edge opposite-edge>> vertex>> target-vertex eq?
[ edge edge f ]
[ f edge vertex-cw dup e0 eq? not ] if
] loop drop
] if ;

521
extra/euler/b-rep/examples/examples.factor Normal file
View File

@ -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

131
extra/euler/b-rep/io/obj/obj-tests.factor Normal file
View File

@ -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

86
extra/euler/b-rep/io/obj/obj.factor Normal file
View File

@ -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
<PRIVATE
: write-obj-vertex ( vertex -- )
"v " write
position>> 3 head-slice [ " " write ] [ number>string write ] interleave nl ;
: write-obj-face ( face vx-indices -- )
"f" write
[ edge>> ] dip '[ " " write vertex>> _ at 1 + number>string write ] each-face-edge nl ;
PRIVATE>
:: write-obj ( b-rep -- )
b-rep vertices>> :> vertices
vertices >index-hash :> vx-indices
vertices [ write-obj-vertex ] each
b-rep faces>> [ vx-indices write-obj-face ] each ;
<PRIVATE
:: reconstruct-face ( face-vertices vertices -- face edges )
face new
dup >>base-face
:> face
face-vertices [
vertices nth :> vertex
b-edge new
vertex >>vertex
face >>face
:> edge
vertex [ [ edge ] unless* ] change-edge drop
edge
] { } map-as :> edges
edges 1 edges length 1 + edges <circular-slice> [ >>next-edge drop ] 2each
face edges first >>edge
edges ;
:: reconstruct-b-rep ( vertex-positions faces-vertices -- b-rep )
vertex-positions [ vertex new swap >>position ] { } map-as :> vertices
V{ } clone :> edges
faces-vertices [ vertices reconstruct-face edges push-all ] { } map-as :> faces
b-rep new
faces >>faces
edges >>edges
vertices >>vertices
dup connect-opposite-edges ;
: parse-vertex ( line -- position )
" " split first3 [ string>number >float ] tri@ 0.0 double-4-boa ;
: read-vertex ( line vertices -- )
[ parse-vertex ] dip push ;
: parse-face-index ( token vertices -- index )
swap "/" split1 drop string>number
dup 0 >= [ nip 1 - ] [ [ length ] dip + ] if ;
: parse-face ( line vertices -- vertices )
[ " " split ] dip '[ _ parse-face-index ] map ;
: read-face ( line vertices faces -- )
[ parse-face ] dip push ;
PRIVATE>
:: (read-obj) ( -- vertices faces )
V{ } clone :> vertices
V{ } clone :> faces
[
" " split1 swap {
{ "#" [ drop ] }
{ "v" [ vertices read-vertex ] }
{ "f" [ vertices faces read-face ] }
[ 2drop ]
} case
] each-line
vertices faces ;
:: read-obj ( -- b-rep )
(read-obj) reconstruct-b-rep ;

112
extra/euler/b-rep/subdivision/subdivision.factor Normal file
View File

@ -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
: <vertex> ( position -- vertex ) vertex new swap >>position ; inline
: face-points ( faces -- face-pts )
[ edge>> face-midpoint <vertex> ] map ; inline
:: edge-points ( edges edge-indices face-indices face-points -- edge-pts )
edges length 0 <array> :> edge-pts
edges [| edge n |
edge opposite-edge>> :> opposite-edge
opposite-edge edge-indices at :> opposite-n
n opposite-n < [
edge vertex>> position>>
opposite-edge vertex>> position>> v+
edge face>> face-indices at face-points nth position>> v+
opposite-edge face>> face-indices at face-points nth position>> v+
0.25 v*n
<vertex>
[ n edge-pts set-nth-unsafe ]
[ opposite-n edge-pts set-nth-unsafe ] bi
] when
] each-index
edge-pts ; inline
:: vertex-points ( vertices edge-indices face-indices edge-pts face-points -- vertex-pts )
vertices [| vertex |
0 double-4{ 0 0 0 0 } double-4{ 0 0 0 0 }
vertex edge>> [| valence face-sum edge-sum edge |
valence 1 +
face-sum edge face>> face-indices at face-points nth position>> v+
edge-sum edge next-edge>> vertex>> position>> v+
] each-vertex-edge :> ( valence face-sum edge-sum )
valence >float :> fvalence
face-sum fvalence v/n :> face-avg
edge-sum fvalence v/n :> edge-avg
face-avg edge-avg v+ vertex position>> fvalence 2.0 - v*n v+
fvalence v/n
<vertex>
] map ; inline
TYPED:: subdivide ( brep: b-rep -- brep': b-rep )
brep vertices>> :> vertices
brep edges>> :> edges
brep faces>> :> faces
vertices >index-hash :> vertex-indices
edges >index-hash :> edge-indices
faces >index-hash :> face-indices
faces face-points :> face-pts
edges edge-indices face-indices face-pts edge-points :> edge-pts
vertices edge-indices face-indices edge-pts face-pts vertex-points :> vertex-pts
V{ } clone :> sub-edges
V{ } clone :> sub-faces
vertices [
edge>> [| edg |
edg edge-indices at edge-pts nth :> point-a
edg next-edge>> :> next-edg
next-edg vertex>> :> next-vertex
next-vertex vertex-indices at vertex-pts nth :> point-b
next-edg edge-indices at edge-pts nth :> point-c
edg face>> face-indices at face-pts nth :> point-d
face new
dup >>base-face :> fac
b-edge new
fac >>face
point-a >>vertex :> edg-a
b-edge new
fac >>face
point-b >>vertex :> edg-b
b-edge new
fac >>face
point-c >>vertex :> edg-c
b-edge new
fac >>face
point-d >>vertex :> edg-d
edg-a fac edge<<
edg-b edg-a next-edge<<
edg-c edg-b next-edge<<
edg-d edg-c next-edge<<
edg-a edg-d next-edge<<
fac sub-faces push
edg-a sub-edges push
edg-b sub-edges push
edg-c sub-edges push
edg-d sub-edges push
point-a [ edg-a or ] change-edge drop
point-b [ edg-b or ] change-edge drop
point-c [ edg-c or ] change-edge drop
point-d [ edg-d or ] change-edge drop
] each-vertex-edge
] each
b-rep new
sub-faces { } like >>faces
sub-edges { } like >>edges
face-pts edge-pts vertex-pts 3append members { } like >>vertices
[ connect-opposite-edges ] keep ;

84
extra/euler/b-rep/triangulation/triangulation-tests.factor Normal file
View File

@ -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

70
extra/euler/b-rep/triangulation/triangulation.factor Normal file
View File

@ -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 ;
<PRIVATE
: tess-begin ( -- callback )
[| primitive-type vertices-h |
primitive-type GL_TRIANGLES =
[ "unexpected primitive type" throw ] unless
] GLUtessBeginDataCallback ;
: tess-end ( -- callback )
[| vertices-h |
! nop
] GLUtessEndDataCallback ;
: tess-vertex ( -- callback )
[| vertex-h vertices-h |
vertex-h alien-handle-ptr>
vertices-h alien-handle-ptr> push
] GLUtessVertexDataCallback ;
: tess-edge-flag ( -- callback )
[| flag vertices-h |
! nop
] GLUtessEdgeFlagDataCallback ;
PRIVATE>
:: triangulate-face ( face -- triangles )
[
face dup base-face>> eq? [ triangulated-face-must-be-base ] unless
gluNewTess &gluDeleteTess :> tess
V{ } clone :> vertices
vertices <alien-handle-ptr> &release-alien-handle-ptr :> vertices-h
tess GLU_TESS_BEGIN_DATA tess-begin gluTessCallback
tess GLU_TESS_END_DATA tess-end gluTessCallback
tess GLU_TESS_VERTEX_DATA tess-vertex gluTessCallback
tess GLU_TESS_EDGE_FLAG_DATA tess-edge-flag gluTessCallback
tess vertices-h gluTessBeginPolygon
4 double malloc-array &free :> vertex-buf
face [| ring |
tess gluTessBeginContour
ring edge>> [
tess swap vertex>>
[ position>> double >c-array ]
[ <alien-handle-ptr> &release-alien-handle-ptr ] bi gluTessVertex
] each-face-edge
tess gluTessEndContour
ring next-ring>> dup
] loop drop
tess gluTessEndPolygon
vertices { } like 3 <groups>
] with-destructors ;

46
extra/euler/modeling/modeling-tests.factor Normal file
View File

@ -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

78
extra/euler/modeling/modeling.factor Normal file
View File

@ -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

217
extra/euler/operators/operators-tests.factor Normal file
View File

@ -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

317
extra/euler/operators/operators.factor Normal file
View File

@ -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 )
<b-rep> [ swap with-b-rep ] [ finish-b-rep ] [ ] tri ; inline
<PRIVATE
:: make-loop ( vertex face -- edge )
b-rep get new-edge :> edge
vertex edge vertex<<
edge edge next-edge<<
face edge face<<
edge ;
: make-loop-face ( vertex -- edge )
b-rep get new-face
dup >>base-face
make-loop ;
:: make-edge ( vertex next-edge -- edge )
b-rep get new-edge :> edge
vertex edge vertex<<
next-edge edge next-edge<<
next-edge face>> edge face<<
edge ;
: opposite-edges ( e1 e2 -- )
[ opposite-edge<< ] [ swap opposite-edge<< ] 2bi ;
PRIVATE>
MIXIN: point
INSTANCE: sequence point
INSTANCE: number point
TYPED:: make-vefs ( pos1: point pos2: point -- edge: b-edge )
b-rep get :> b-rep
pos1 b-rep new-vertex :> v1
v1 make-loop-face :> e1
pos2 b-rep new-vertex :> v2
v2 e1 make-edge :> e2
e2 e1 next-edge<<
e1 e2 opposite-edges
e2 ;
TYPED:: make-ev-one ( edge: b-edge point: point -- edge: b-edge )
point b-rep get new-vertex :> v
v edge make-edge :> e1'
edge vertex>> e1' make-edge :> e2'
e2' edge face-cw next-edge<<
e1' e2' opposite-edges
e1' ;
<PRIVATE
:: subdivide-vertex-cycle ( e1 e2 v -- )
e1 e2 eq? [
v e1 vertex<<
e1 vertex-cw e2 v subdivide-vertex-cycle
] unless ;
:: (make-ev) ( e1 e2 point -- edge )
e1 e2 assert-incident
point b-rep get new-vertex :> v'
v' e2 make-edge :> e1'
e1 vertex>> :> v
v e1 make-edge :> e2'
e1 e2 v' subdivide-vertex-cycle
e1 face-cw :> e1p
e2 face-cw :> e2p
e1 opposite-edge>> :> e1m
e1m e1p assert-not=
e1' e2p next-edge<<
e2' e1p next-edge<<
e1' e2' opposite-edges
e1' ;
PRIVATE>
TYPED:: make-ev ( e1: b-edge e2: b-edge point: point -- edge: b-edge )
e1 e2 eq?
[ e1 point make-ev-one ] [ e1 e2 point (make-ev) ] if ;
<PRIVATE
: subdivide-edge-cycle ( face e1 e2 -- )
2dup eq? [ 3drop ] [
[ drop face<< ]
[ [ next-edge>> ] dip subdivide-edge-cycle ] 3bi
] if ;
PRIVATE>
TYPED:: make-ef ( e1: b-edge e2: b-edge -- edge: b-edge )
e1 e2 assert-same-face
e2 vertex>> make-loop-face :> e1'
e1 vertex>> e2 make-edge :> e2'
e1' e2' opposite-edges
e1 face-cw :> e1p
e1 e2 eq? [
e2 face-cw :> e2p
e1' face>> e1 e2 subdivide-edge-cycle
e1' e2p next-edge<<
e1 e1' next-edge<<
] unless
e2' e1p next-edge<<
e1' ;
TYPED:: make-e-kill-r ( edge-ring: b-edge edge-face: b-edge -- edge: b-edge )
edge-ring face>> :> ring
edge-face face>> :> face
ring face assert-ring-of
edge-ring [ face >>face drop ] each-face-edge
edge-ring vertex>> edge-face make-edge :> e1
edge-face vertex>> edge-ring make-edge :> e2
ring face delete-ring
ring b-rep get delete-face
e2 edge-face face-cw next-edge<<
e1 edge-ring face-cw next-edge<<
e1 e2 opposite-edges
e1 ;
TYPED:: make-f-kill-rh ( edge-ring: b-edge -- )
edge-ring face>> :> ring
ring base-face>> :> base-face
ring base-face delete-ring
ring ring base-face<< ;
TYPED:: kill-vefs ( edge: b-edge -- )
edge assert-isolated-component
b-rep get :> b-rep
edge dup opposite-edge>> :> ( e2 e1 )
e1 vertex>> :> v1
e2 vertex>> :> v2
e1 face>> b-rep delete-face
e1 b-rep delete-edge
e2 b-rep delete-edge
v1 b-rep delete-vertex
v2 b-rep delete-vertex ;
TYPED:: kill-ev ( edge: b-edge -- )
b-rep get :> b-rep
edge vertex>> :> v
edge opposite-edge>> :> edge'
edge' vertex>> :> v'
edge [ v' >>vertex drop ] each-vertex-edge
edge face-cw :> edgep
edge' face-cw :> edge'p
edge next-edge>> edgep next-edge<<
edge' next-edge>> edge'p next-edge<<
v b-rep delete-vertex
edge b-rep delete-edge
edge' b-rep delete-edge ;
TYPED:: kill-ef ( edge: b-edge -- )
b-rep get :> b-rep
edge :> e1
edge opposite-edge>> :> e2
e1 e2 assert-different-faces
e1 face-cw :> e1p
e2 face-cw :> e2p
e1 face>> :> f1
e2 face>> :> f2
e1 [ f2 >>face drop ] each-face-edge
f1 b-rep delete-face
e1 e2 incident? [
e2 next-edge>> e2p next-edge<<
] [
e2 next-edge>> e1p next-edge<<
e1 next-edge>> e2p next-edge<<
] if
e1 b-rep delete-edge
e2 b-rep delete-edge ;
TYPED:: kill-e-make-r ( edge: b-edge -- edge-ring: b-edge )
b-rep get :> b-rep
edge opposite-edge>> :> edge'
edge' next-edge>> :> edge-ring
edge-ring opposite-edge>> :> edge-ring'
edge edge' assert-same-face
edge edge-ring assert-same-face
edge edge-ring' assert-different-faces
b-rep new-face :> ring
ring edge face>> base-face>> add-ring
ring edge' edge subdivide-edge-cycle
edge b-rep delete-edge
edge' b-rep delete-edge
edge-ring ;
TYPED:: kill-f-make-rh ( edge-face: b-edge edge-base-face: b-edge -- )
edge-face face>> :> face
edge-base-face face>> :> base-face
face assert-base-face
base-face assert-base-face
edge-face edge-base-face assert-different-faces
face base-face add-ring ;
TYPED: move-v ( edge: b-edge point: point -- )
swap vertex>> position<< ;
TYPED: move-e ( edge: b-edge offset: point -- )
[ dup opposite-edge>> ] dip
'[ vertex>> [ _ v+ ] change-position drop ] bi@ ;
TYPED: move-f ( edge: b-edge offset: point -- )
'[ vertex>> [ _ v+ ] change-position drop ] each-face-edge ;
TYPED: sharp-e ( edge: b-edge sharp?: boolean -- )
>>sharpness drop ;
TYPED: sharp-f ( edge: b-edge sharp?: boolean -- )
'[ _ sharp-e ] each-face-edge ;
TYPED: sharp-v ( edge: b-edge sharp?: boolean -- )
'[ _ sharp-e ] each-vertex-edge ;
TYPED: material-f ( edge: b-edge material -- ) 2drop ;

110
extra/gml/b-rep/b-rep.factor Normal file
View File

@ -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 ;

158
extra/gml/core/core.factor Normal file
View File

@ -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 ) { } <proc> ;
GML: cvlit ( proc -- array ) array>> ;
GML: exec ( obj -- ) exec-proc ;
! Stack shuffling
: pop-slice ( seq n -- subseq )
[ tail ] [ swap shorten ] 2bi ;
: pop-slice* ( seq n -- subseq )
over length swap - pop-slice ;
GML: pop ( a -- ) drop ;
GML: pops ( n -- )
over operand-stack>> [ length swap - ] keep shorten ;
GML: dup ( a -- a a ) dup ;
GML: exch ( a b -- b a ) swap ;
GML: index ( n -- value )
over operand-stack>> [ length 1 - swap - ] keep nth ;
ERROR: roll-out-of-bounds n j ;
GML: roll ( n j -- )
2dup abs < [ roll-out-of-bounds ] when
[ [ dup operand-stack>> ] dip over length swap - pop-slice ] dip
neg over length rem cut-slice swap append over
operand-stack>> push-all ;
GML: clear ( -- ) dup operand-stack>> delete-all ;
GML: cleartomark ( -- )
dup [ find-marker ] [ operand-stack>> ] bi shorten ;
GML: count ( -- n ) dup operand-stack>> length ;
GML: counttomark ( -- n ) dup [ operand-stack>> length ] [ find-marker ] bi - ;
! Arrays
GML: ] ( -- array )
dup
[ [ operand-stack>> ] [ find-marker ] bi pop-slice { } like ]
[ operand-stack>> pop* ]
bi ;
GML: array ( n -- array )
[ dup operand-stack>> ] dip pop-slice* { } like ;
GML: length ( array -- len ) length ;
GML: append ( array elt -- array' ) suffix ;
GML: eappend ( elt array -- array' ) swap suffix ;
GML: pop-back ( -- array' )
! Stupid variable arity word!
dup pop-operand dup integer?
[ [ dup pop-operand ] dip head* ] [ but-last ] if ;
GML: pop-front ( -- array' )
! Stupid variable arity word!
dup pop-operand dup integer?
[ [ dup pop-operand ] dip tail ] [ rest ] if ;
GML: arrayappend ( array1 array2 -- array3 ) append ;
GML: arrayremove ( array1 n -- array3 ) swap wrap remove-nth ;
GML: aload ( array -- ) over operand-stack>> push-all ;
GML: array-get ( array indices -- result ) [ (gml-get) ] with map ;
GML: flatten ( array -- flatarray )
[ dup array? [ 1array ] unless ] map concat ;
GML: reverse ( array -- reversed ) reverse ;
GML: slice ( array n k -- slice )
[a,b) swap '[ _ wrap nth ] map ;
GML:: subarray ( array n k -- slice )
k n k + array subseq ;
GML: sort-number-permutation ( array -- permutation )
[ 2array ] map-index sort-keys reverse values ;
! Dictionaries
ERROR: not-a-dict obj ;
: check-dict ( obj -- obj' ) dup hashtable? [ not-a-dict ] unless ; inline
GML: begin ( dict -- ) check-dict over dictionary-stack>> push ;
GML: end ( -- ) dup dictionary-stack>> pop* ;
GML: dict ( -- dict ) H{ } clone ;
GML: dictfromarray ( -- dict )
! Stupid variable-arity word!
dup pop-operand {
{ [ dup hashtable? ] [ [ dup pop-operand ] dip ] }
{ [ dup array? ] [ H{ } clone ] }
} cond
swap 2 group assoc-union! ;
GML: keys ( dict -- keys ) keys ;
GML: known ( dict key -- ? ) swap key? >true ;
GML: values ( dict -- values ) values ;
GML: where ( key -- ? )
! Stupid variable-arity word!
over dictionary-stack>> [ key? ] with find swap
[ over push-operand 1 ] [ drop 0 ] if ;
: current-dict ( gml -- assoc ) dictionary-stack>> last ; inline
GML: currentdict ( -- dict ) dup current-dict ;
GML: load ( name -- value ) over lookup-name ;
ERROR: not-a-name obj ;
: check-name ( obj -- obj' ) dup name? [ not-a-name ] unless ; inline
GML: def ( name value -- ) swap check-name pick current-dict set-at ;
GML: edef ( value name -- ) check-name pick current-dict set-at ;
GML: undef ( name -- ) check-name over current-dict delete-at ;
! Dictionaries and arrays
GML: get ( collection key -- elt ) (gml-get) ;
GML: put ( collection key elt -- ) (gml-put) ;
GML: copy ( collection -- collection' ) (gml-copy) ;
! Control flow
: proc>quot ( proc -- quot: ( registers gml -- registers gml ) )
'[ _ exec-proc ] ; inline
: proc>quot1 ( proc -- quot: ( registers gml value -- registers gml ) )
'[ over push-operand _ exec-proc ] ; inline
: proc>quot2 ( proc -- quot: ( registers gml value1 value2 -- registers gml ) )
'[ [ over push-operand ] bi@ _ exec-proc ] ; inline
GML: if ( flag proc -- ) [ true? ] [ proc>quot ] bi* when ;
GML: ifelse ( flag proc0 proc1 -- ) [ true? ] [ proc>quot ] [ proc>quot ] tri* if ;
GML:: ifpop ( x y flag -- x/y ) flag true? y x ? ;
GML: exit ( -- ) return ;
GML: loop ( proc -- )
'[ _ proc>quot '[ @ t ] loop ] with-return ;
GML: repeat ( n proc -- )
'[ _ _ proc>quot times ] with-return ;
GML: for ( a s b proc -- )
'[ _ _ _ _ [ swap <range> ] dip proc>quot1 each ] with-return ;
GML: forx ( a s b proc -- )
'[ _ _ _ _ [ 1 - swap <range> ] dip proc>quot1 each ] with-return ;
GML: forall ( array proc -- )
'[ _ _ proc>quot1 each ] with-return ;
GML: twoforall ( array1 array2 proc -- )
'[ _ _ _ proc>quot2 2each ] with-return ;
GML:: map ( array proc -- )
:> gml
marker gml push-operand
gml array proc proc>quot1 each
gml-] ;
GML:: twomap ( array1 array2 proc -- )
:> gml
marker gml push-operand
gml array1 array2 proc proc>quot2 2each
gml-] ;
! Extensions to real GML
GML: print ( obj -- ) print-gml ;
GML: test ( obj1 obj2 -- ) swap assert= ;

217
extra/gml/coremath/coremath.factor Normal file
View File

@ -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 <vec2d> ] }
{ [ over vec3d? ] [ [ [ second ] [ third ] bi ] dip -rot <vec3d> ] }
} cond ;
GML: putY ( vec y -- x )
{
{ [ over vec2d? ] [ [ first ] dip <vec2d> ] }
{ [ over vec3d? ] [ [ [ first ] [ third ] bi ] dip swap <vec3d> ] }
} cond ;
GML: putZ ( vec z -- x )
{
{ [ over vec3d? ] [ [ first2 ] dip <vec3d> ] }
} cond ;
GML: dist ( u v -- x ) distance ;
GML: normalize ( u -- v ) normalize mask-vec3d ;
GML: planemul ( u v p -- w )
first2 [ v*n ] bi-curry@ bi* v+ ;
GML: cross ( u v -- w ) cross ;
: normal ( vec -- norm )
[ first double-4{ 0 1 0 0 } n*v ]
[ second double-4{ -1 0 0 0 } n*v ]
[ third double-4{ -1 0 0 0 } n*v ] tri v+ v+ ; inline
GML: aNormal ( x -- y )
{
{ [ dup vec2d? ] [ normalize double-2{ 1 -1 } v* { 1 0 } vshuffle ] }
{ [ dup vec3d? ] [ normalize normal ] }
} cond ;
: det2 ( x y -- z )
{ 1 0 } vshuffle double-2{ 1 -1 } v* v* sum ; inline
: det3 ( x y z -- w )
[ cross ] dip v. ; inline
GML: determinant ( x -- y )
{
{ [ dup vec2d? ] [ [ dup pop-operand ] dip det2 ] }
{ [ dup vec3d? ] [ [ dup [ pop-operand ] [ pop-operand ] bi swap ] dip det3 ] }
} cond ;
GML: vector2 ( x y -- v ) <vec2d> ;
GML: vector3 ( x y z -- v ) <vec3d> ;
GML: random ( -- x ) 0.0 1.0 uniform-random-float ;
GML: randomseed ( n -- )
dup 0 < [ drop nano-count 1000000 /i ] when
<mersenne-twister> random-generator set ;
! Extensions to real GML
GML: approx-eq ( a b -- c )
[ 10e-5 ~ ] [ 10e-5 v~ ] [ 10e-5 v~ ] gml-math-op >true ;

41
extra/gml/examples/cube.gml Normal file
View File

@ -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

37
extra/gml/examples/doorway.gml Normal file
View File

@ -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

39
extra/gml/examples/mobius.gml Normal file
View File

@ -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

17
extra/gml/examples/torus.gml Normal file
View File

@ -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

8
extra/gml/geometry/geometry.factor Normal file
View File

@ -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 ;

39
extra/gml/gml-tests.factor Normal file
View File

@ -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

69
extra/gml/gml.factor Normal file
View File

@ -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> gml-file-error
M: gml-file-error error.
"Error in GML file “" write
dup pathname>> write "”:" print nl
error>> error. ;
: gml-stack. ( gml -- )
operand-stack>> [
"Operand stack:" print
[ "• " write print-gml ] each
] unless-empty ;
SYMBOL: gml
: make-gml ( quot -- gml b-rep )
[
<gml> gml set
<b-rep> b-rep set
call
gml get
b-rep get dup finish-b-rep
] with-scope ; inline
: with-gml ( gml b-rep quot -- )
[
[ gml set ]
[ b-rep set ]
[ call ]
tri*
] with-scope ; inline
: run-gml-string ( string -- )
[ gml get ] dip parse-gml exec drop ;
: run-gml-file ( pathname -- )
[ utf8 file-contents run-gml-string ]
[ <gml-file-error> rethrow ]
recover ;
SYMBOLS: pre-hook post-hook ;
[ ] pre-hook set-global
[ ] post-hook set-global
: (gml-listener) ( -- )
"GML> " write flush readln [
'[
pre-hook get call( -- )
_ run-gml-string
post-hook get call( -- )
] try
[ gml get gml-stack. ] try
(gml-listener)
] when* ;
: gml-listener ( -- )
[ (gml-listener) ] make-gml 2drop ;
MAIN: gml-listener

41
extra/gml/macros/macros.factor Normal file
View File

@ -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 )
macro new
next-macro-id [ get ] [ inc ] bi >>macro-id
nano-count >>timestamp
V{ } clone >>log ; inline
: save-euler-op ( euler-op -- ) current-macro get log>> push ;
MACRO:: log-euler-op ( class def inputs -- )
class inputs def inputs '[ [ current-macro get [ _ boa save-euler-op ] [ _ ndrop ] if ] _ _ nbi ] ;
SYNTAX: LOG-GML:
[let
(GML:) :> ( word name effect def )
name "-record" append create-in :> record-class
record-class tuple effect in>> define-tuple-class
record-class def effect in>> length
'[ _ _ _ log-euler-op ] :> logging-def
word name effect logging-def define-gml-primitive
] ;

25
extra/gml/modeling/modeling.factor Normal file
View File

@ -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 ;

128
extra/gml/parser/parser.factor Normal file
View File

@ -0,0 +1,128 @@
! Copyright (C) 2010 Slava Pestov.
USING: accessors kernel arrays strings math.parser peg peg.ebnf
gml.types gml.runtime sequences sequences.deep locals combinators math ;
IN: gml.parser
TUPLE: comment string ;
C: <comment> comment
: register-index ( name registers -- n )
2dup index dup [ 2nip ] [ drop [ nip length ] [ push ] 2bi ] if ;
: resolve-register ( insn registers -- )
[ dup name>> ] dip register-index >>n drop ;
ERROR: missing-usereg ;
:: (resolve-registers) ( array registers -- ? )
f :> use-registers!
array [
{
{ [ dup use-registers? ] [ use-registers! ] }
{ [ dup read-register? ] [ registers resolve-register ] }
{ [ dup exec-register? ] [ registers resolve-register ] }
{ [ dup write-register? ] [ registers resolve-register ] }
{ [ dup proc? ] [
dup [ use-registers? ] any? [ drop ] [
array>> registers (resolve-registers) drop
] if
] }
[ drop ]
} cond
] each
use-registers ;
:: resolve-registers ( array -- )
V{ } clone :> registers
array [ use-registers? ] any? [
array registers (resolve-registers)
registers length >>n drop
] when ;
: parse-proc ( array -- proc )
>array [ resolve-registers ] [ { } <proc> ] bi ;
ERROR: bad-vector-length seq n ;
: parse-vector ( seq -- vec )
dup length {
{ 2 [ first2 <vec2d> ] }
{ 3 [ first3 <vec3d> ] }
[ bad-vector-length ]
} case ;
EBNF: parse-gml
Letter = [a-zA-Z]
Digit = [0-9]
Digits = Digit+
Sign = ('+' => [[ first ]]|'-' => [[ first ]])?
StopChar = ('('|')'|'['|']'|'{'|'}'|'/'|'/'|';'|':'|'!'|'.')
Space = ' ' | '\t' | '\r' | '\n'
Spaces = Space* => [[ ignore ]]
Newline = ('\n' | '\r')
Number = Sign Digit+ ('.' => [[ first ]] Digit+)? ('e' => [[ first ]] Sign Digit+)?
=> [[ flatten sift >string string>number ]]
VectorComponents = (Number:f Spaces ',' Spaces => [[ f ]])*:fs Number:f Spaces => [[ fs f suffix ]]
Vector = '(' Spaces VectorComponents ')' => [[ second parse-vector ]]
StringChar = !('"').
String = '"' StringChar+:s '"' => [[ s >string ]]
NameChar = !(Space|StopChar).
Name = NameChar+ => [[ >string ]]
Comment = ('%' (!(Newline) .)* (Newline|!(.))) => [[ <comment> ]]
ArrayStart = '[' => [[ marker ]]
ArrayEnd = ']' => [[ exec" ]" ]]
ExecArray = '{' Token*:ts Spaces '}' => [[ ts parse-proc ]]
LiteralName = '/' Name:n => [[ n name ]]
UseReg = "usereg" !(NameChar) => [[ <use-registers> ]]
ReadReg = ";" Name:n => [[ n <read-register> ]]
ExecReg = ":" Name:n => [[ n <exec-register> ]]
WriteReg = "!" Name:n => [[ n <write-register> ]]
ExecName = Name:n => [[ n exec-name ]]
PathNameComponent = "." Name:n => [[ n name ]]
PathName = PathNameComponent+ => [[ <pathname> ]]
Token = Spaces
(Comment |
Number |
Vector |
String |
ArrayStart |
ArrayEnd |
ExecArray |
LiteralName |
UseReg |
ReadReg |
ExecReg |
WriteReg |
ExecName |
PathName)
Tokens = Token* => [[ [ comment? not ] filter ]]
Program = Tokens Spaces !(.) => [[ parse-proc ]]
;EBNF

60
extra/gml/printer/printer.factor Normal file
View File

@ -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 ;

1
extra/gml/runtime/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

209
extra/gml/runtime/runtime.factor Normal file
View File

@ -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 <proc> over push-operand ;
! Executable names
TUPLE: exec-name < identity-tuple name ;
MEMO: exec-name ( string -- name ) name \ exec-name boa ;
SYNTAX: exec" lexer get skip-blank parse-string exec-name suffix! ;
ERROR: unbound-name { name name } ;
: lookup-name ( name gml -- value )
dupd dictionary-stack>> assoc-stack
[ ] [ unbound-name ] ?if ; inline
GENERIC: exec-proc ( registers gml proc -- registers gml )
M:: proc exec-proc ( registers gml proc -- registers gml )
proc registers>>
gml
proc array>> [ (exec) ] each 2drop
registers gml ;
FROM: combinators.private => execute-effect-unsafe ;
CONSTANT: primitive-effect ( registers gml -- registers gml )
M: word exec-proc primitive-effect execute-effect-unsafe ;
M: object exec-proc (exec) ;
EXEC: exec-name name>> over lookup-name exec-proc ;
! Registers
ERROR: unbound-register name ;
:: lookup-register ( registers gml obj -- value )
obj n>> registers nth [
obj name>> unbound-register
] unless* ;
TUPLE: read-register { name string } { n fixnum } ;
: <read-register> ( name -- read-register ) 0 read-register boa ;
EXEC: read-register
[ 2dup ] dip lookup-register over push-operand ;
TUPLE: exec-register { name string } { n fixnum } ;
: <exec-register> ( name -- exec-register ) 0 exec-register boa ;
EXEC: exec-register
[ 2dup ] dip lookup-register exec-proc ;
TUPLE: write-register { name string } { n fixnum } ;
: <write-register> ( name -- write-register ) 0 write-register boa ;
EXEC:: write-register ( registers gml obj -- registers gml )
gml pop-operand obj n>> registers set-nth
registers gml ;
TUPLE: use-registers { n fixnum } ;
: <use-registers> ( -- use-registers ) use-registers new ;
EXEC: use-registers
n>> f <array> '[ drop _ ] dip ;
! Pathnames
TUPLE: pathname names ;
C: <pathname> pathname
: at-pathname ( pathname assoc -- value )
swap names>> [ swap ?at [ unbound-name ] unless ] each ;
EXEC:: pathname ( registers gml obj -- registers gml )
obj gml pop-operand at-pathname gml push-operand
registers gml ;
! List building and stuff
TUPLE: marker < identity-tuple ;
CONSTANT: marker T{ marker }
ERROR: no-marker-found ;
ERROR: gml-stack-underflow ;
: find-marker ( gml -- n )
operand-stack>> [ marker eq? ] find-last
[ 1 + ] [ no-marker-found ] if ; inline
! Primitives
: check-stack ( seq n -- seq n )
2dup swap length > [ gml-stack-underflow ] when ; inline
: lastn ( seq n -- elts... )
check-stack
[ tail-slice* ] keep firstn-unsafe ; inline
: popn ( seq n -- elts... )
check-stack
[ lastn ] [ over length swap - swap shorten ] 2bi ; inline
: set-lastn ( elts... seq n -- )
[ tail-slice* ] keep set-firstn-unsafe ; inline
: pushn ( elts... seq n -- )
[ over length + swap lengthen ] 2keep set-lastn ; inline
MACRO: inputs ( inputs# -- quot: ( gml -- gml inputs... ) )
'[ dup operand-stack>> _ popn ] ;
MACRO: outputs ( outputs# -- quot: ( gml outputs... -- gml ) )
[ 1 + ] keep '[ _ npick operand-stack>> _ pushn ] ;
MACRO: gml-primitive (
inputs#
outputs#
quot: ( registers gml inputs... -- outputs... )
--
quot: ( registers gml -- registers gml )
)
swap '[ _ inputs @ _ outputs ] ;
SYMBOL: global-dictionary
global-dictionary [ H{ } clone ] initialize
: add-primitive ( word name -- )
name global-dictionary get-global set-at ;
: define-gml-primitive ( word name effect def -- )
[ '[ _ add-primitive ] keep ]
[ [ in>> length ] [ out>> length ] bi ]
[ '[ { gml } declare _ _ _ gml-primitive ] ] tri*
primitive-effect define-declared ;
: scan-gml-name ( -- word name )
scan-token [ "gml-" prepend create-in ] keep ;
: (GML:) ( -- word name effect def )
scan-gml-name scan-effect parse-definition ;
SYNTAX: GML:
(GML:) define-gml-primitive ;
SYNTAX: GML::
[let
scan-gml-name :> ( word name )
word [ parse-definition ] parse-locals-definition :> ( word def effect )
word name effect def define-gml-primitive
] ;
: <gml> ( -- gml )
gml new
global-dictionary get clone 1vector >>dictionary-stack
V{ } clone >>operand-stack ;
: exec ( gml proc -- gml ) [ { } ] 2dip exec-proc nip ;

299
extra/gml/test-core.gml Normal file
View File

@ -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

166
extra/gml/test-coremath.gml Normal file
View File

@ -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

13
extra/gml/test-geometry.gml Normal file
View File

@ -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

61
extra/gml/types/types.factor Normal file
View File

@ -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> proc
M: proc clone [ array>> clone ] [ registers>> clone ] bi <proc> ;
M: proc length array>> length ;
M: proc nth-unsafe array>> nth-unsafe ;
M: proc set-nth-unsafe array>> set-nth-unsafe ;
M: proc like drop dup proc? [ { } like { } <proc> ] unless ;
M: proc new-sequence drop 0 <array> { } <proc> ;
INSTANCE: proc sequence
: wrap ( n seq -- n seq ) [ length rem ] keep ; inline
GENERIC# (gml-get) 1 ( collection key -- elt )
M: sequence (gml-get) swap wrap nth ;
M: hashtable (gml-get) swap at ;
GENERIC# (gml-put) 2 ( collection key elt -- )
M:: sequence (gml-put) ( collection key elt -- )
elt key collection wrap set-nth ;
M:: hashtable (gml-put) ( collection key elt -- )
elt key collection set-at ;
GENERIC: (gml-copy) ( collection -- collection' )
M: array (gml-copy) clone ;
M: hashtable (gml-copy) clone ;
M: proc (gml-copy) clone ;
ALIAS: vec2d? double-2?
ALIAS: <vec2d> double-2-boa
ALIAS: scalar>vec2d double-2-with
ALIAS: vec3d? double-4?
: <vec3d> ( x y z -- vec ) 0.0 double-4-boa ; inline
: scalar>vec3d ( x -- vec ) dup dup 0.0 double-4-boa ; inline
GENERIC: mask-vec3d ( value -- value' )
M: double-2 mask-vec3d ; inline
M: double-4 mask-vec3d
longlong-4{ -1 -1 -1 0 } double-4-cast vbitand ; inline

121
extra/gml/ui/ui.factor Normal file
View File

@ -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 ;
: <stack-table> ( model -- table )
stack-entry-renderer <table>
10 >>min-rows
10 >>max-rows
40 >>min-cols
40 >>max-cols ;
: <stack-display> ( model -- gadget )
<stack-table> <scroller> "Operand stack" <labeled-gadget> ;
TUPLE: gml-editor < frame editor gml stack-model b-rep b-rep-model ;
: update-models ( gml-editor -- )
[ [ b-rep>> dup finish-b-rep ] [ b-rep-model>> ] bi set-model ]
[ [ gml>> operand-stack>> ] [ stack-model>> ] bi set-model ]
bi ;
: with-gml-editor ( gml-editor quot -- )
'[
[ [ gml>> gml set ] [ b-rep>> b-rep set ] bi @ ]
[ update-models ]
bi
] with-scope ; inline
: find-gml-editor ( gadget -- gml-editor )
[ gml-editor? ] find-parent ;
: load-input ( file gml-editor -- )
[ utf8 file-contents ] dip editor>> set-editor-string ;
: update-viewer ( gml-editor -- )
dup [ editor>> editor-string run-gml-string ] with-gml-editor ;
: new-viewer ( gml-editor -- )
[ update-viewer ]
[ [ b-rep-model>> ] [ stack-model>> ] bi gml-viewer ]
bi ;
: reset-viewer ( gml-editor -- )
[
b-rep get clear-b-rep
gml get operand-stack>> delete-all
] with-gml-editor ;
: <new-button> ( -- button )
"New viewer" [ find-gml-editor new-viewer ] <border-button> ;
: <update-button> ( -- button )
"Update viewer" [ find-gml-editor update-viewer ] <border-button> ;
: <reset-button> ( -- button )
"Reset viewer" [ find-gml-editor reset-viewer ] <border-button> ;
: <control-buttons> ( -- gadget )
<shelf> { 5 5 } >>gap
<new-button> add-gadget
<update-button> add-gadget
<reset-button> add-gadget ;
CONSTANT: example-dir "vocab:gml/examples/"
: gml-files ( -- seq )
example-dir directory-files
[ file-extension >lower "gml" = ] filter ;
: <example-button> ( file -- button )
dup '[ example-dir _ append-path swap find-gml-editor load-input ]
<border-button> ;
: <example-buttons> ( -- gadget )
gml-files
<pile> { 5 5 } >>gap
"Examples:" <label> add-gadget
[ <example-button> add-gadget ] reduce ;
: <editor-panel> ( editor -- gadget )
30 >>min-rows
30 >>max-rows
40 >>min-cols
40 >>max-cols
<scroller> "Editor" <labeled-gadget> ;
: <gml-editor> ( -- gadget )
2 3 gml-editor new-frame
<gml> >>gml
<b-rep> >>b-rep
dup b-rep>> <model> >>b-rep-model
dup gml>> operand-stack>> <model> >>stack-model
{ 20 20 } >>gap
{ 0 0 } >>filled-cell
<source-editor> >>editor
dup editor>> <editor-panel> { 0 0 } grid-add
dup stack-model>> <stack-display> { 0 1 } grid-add
<control-buttons> { 0 2 } grid-add
<example-buttons> { 1 0 } grid-add ;
M: gml-editor focusable-child* editor>> ;
: gml-editor-window ( -- )
<gml-editor> "Generative Modeling Language" open-window ;
MAIN: gml-editor-window

7
extra/gml/viewer/viewer-tests.factor Normal file
View File

@ -0,0 +1,7 @@
USING: gml.viewer math.vectors.simd.cords tools.test ;
IN: gml.viewer.tests
[ {
double-4{ 0 0 0 0 }
double-4{ 1 1 1 1 }
} ] [ { double-4{ 0 0 0 0 } { double-4{ 1 1 1 1 } 2 } 3 } selected-vectors ] unit-test

9
extra/gml/viewer/viewer.f.glsl Normal file
View File

@ -0,0 +1,9 @@
#version 110
varying vec4 frag_color;
void main()
{
gl_FragColor = frag_color;
}

314
extra/gml/viewer/viewer.factor Normal file
View File

@ -0,0 +1,314 @@
USING: accessors alien.c-types alien.data.map arrays assocs
byte-arrays colors combinators combinators.short-circuit
destructors euler.b-rep euler.b-rep.triangulation fry
game.input game.loop game.worlds game.models.half-edge gml.printer
gpu gpu.buffers gpu.framebuffers gpu.render gpu.shaders gpu.state
gpu.util.wasd hashtables images kernel literals locals math
math.ranges math.vectors math.vectors.conversion math.vectors.simd
math.vectors.simd.cords method-chains models sequences sets
specialized-arrays specialized-vectors typed math.order namespaces
ui ui.gadgets.worlds ui.gestures ui.pixel-formats growable vectors
alien.data ;
FROM: math.matrices => m.v ;
FROM: models => change-model ;
SPECIALIZED-VECTORS: ushort float-4 ;
IN: gml.viewer
CONSTANT: neutral-edge-color float-4{ 1 1 1 1 }
CONSTANT: neutral-face-color float-4{ 1 1 1 1 }
CONSTANT: selected-face-color float-4{ 1 0.9 0.8 1 }
: double-4>float-4 ( in: double-4 -- out: float-4 )
[ head>> ] [ tail>> ] bi double-2 float-4 vconvert ; inline
: rgba>float-4 ( in: rgba -- out: float-4 )
>rgba-components float-4-boa ; inline
: face-color ( edge -- color )
face-normal float-4{ 0 1 0.1 0 } v. 0.3 * 0.4 + dup dup 1.0 float-4-boa ; inline
TUPLE: b-rep-vertices
{ array byte-array read-only }
{ face-vertex-count integer read-only }
{ edge-vertex-count integer read-only }
{ point-vertex-count integer read-only } ;
:: <b-rep-vertices> ( face-array face-count
edge-array edge-count
point-array point-count -- vxs )
face-array edge-array point-array 3append
face-count edge-count point-count \ b-rep-vertices boa ; inline
: face-selected? ( face selected -- ? )
[ f ] 2dip [ edge>> ] dip '[ _ in? or ] each-face-edge ;
:: b-rep-face-vertices ( b-rep selected -- vertices count indices )
float-4-vector{ } clone :> vertices
ushort-vector{ } clone :> indices
0 b-rep faces>> [| count face |
face selected face-selected? :> selected?
face dup base-face>> eq? [
face edge>> face-color
selected? selected-face-color neutral-face-color ? v* :> color
face triangulate-face seq>> :> triangles
triangles members :> tri-vertices
tri-vertices >index-hash :> vx-indices
tri-vertices [
position>> double-4>float-4 vertices push
color vertices push
] each
triangles [ vx-indices at count + indices push ] each
count tri-vertices length +
] [ count ] if
] each :> total
vertices float-4 >c-array underlying>>
total
indices ushort-array{ } like ;
: b-rep-edge-vertices ( b-rep -- vertices count )
vertices>> [
[
position>> [ double-4>float-4 ] keep
[ drop neutral-edge-color ]
[ vertex-color rgba>float-4 ] 2bi
] data-map( object -- float-4[4] )
] [ length 2 * ] bi ; inline
GENERIC: selected-vectors ( object -- vectors )
M: object selected-vectors drop { } ;
M: double-4 selected-vectors 1array ;
M: sequence selected-vectors [ selected-vectors ] map concat ;
: selected-vertices ( selected -- vertices count )
selected-vectors [
[ [ double-4>float-4 ] [ vertex-color rgba>float-4 ] bi ]
data-map( object -- float-4[2] )
] [ length ] bi ; inline
: edge-vertex-index ( e vertex-indices selected -- n selected? )
[ dup vertex>> ] [ at 2 * ] [ swapd in? [ [ 1 + ] when ] keep ] tri* ;
:: b-rep-edge-index-array ( b-rep selected offset -- edge-indices )
b-rep vertices>> >index-hash :> vertex-indices
b-rep edges>> length <ushort-vector> :> edge-indices
b-rep edges>> [| e |
e opposite-edge>> :> o
e vertex-indices selected edge-vertex-index [ offset + ] dip :> ( from e-selected? )
o vertex-indices selected edge-vertex-index [ offset + ] dip :> ( to o-selected? )
from to < [ from edge-indices push to edge-indices push ] when
] each
edge-indices ushort-array{ } like ;
:: make-b-rep-vertices ( b-rep selected -- vertices face-indices edge-indices point-indices )
b-rep selected b-rep-face-vertices :> ( face-vertices face-count face-indices )
b-rep b-rep-edge-vertices :> ( edge-vertices edge-count )
selected selected-vertices :> ( sel-vertices sel-count )
face-vertices face-count edge-vertices edge-count sel-vertices sel-count
<b-rep-vertices> :> vertices
vertices array>>
face-indices
b-rep selected vertices face-vertex-count>> b-rep-edge-index-array
vertices
[ face-vertex-count>> ]
[ edge-vertex-count>> + dup ]
[ point-vertex-count>> + ] tri
[a,b) ushort >c-array ;
VERTEX-FORMAT: wire-vertex-format
{ "vertex" float-components 3 f }
{ f float-components 1 f }
{ "color" float-components 4 f } ;
GLSL-SHADER-FILE: gml-viewer-vertex-shader vertex-shader "viewer.v.glsl"
GLSL-SHADER-FILE: gml-viewer-fragment-shader fragment-shader "viewer.f.glsl"
GLSL-PROGRAM: gml-viewer-program
gml-viewer-vertex-shader gml-viewer-fragment-shader
wire-vertex-format ;
TUPLE: gml-viewer-world < wasd-world
{ b-rep b-rep }
selected
program
vertex-array
face-indices edge-indices point-indices
view-faces? view-edges?
drag? ;
TYPED: refresh-b-rep-view ( world: gml-viewer-world -- )
dup model>> value>> >>b-rep
dup vertex-array>> [ vertex-array-buffer dispose ] when*
dup [ b-rep>> ] [ selected>> value>> ] bi make-b-rep-vertices {
[
static-upload draw-usage vertex-buffer byte-array>buffer
over program>> <vertex-array> >>vertex-array
]
[ >>face-indices ]
[ >>edge-indices ]
[ >>point-indices ]
} spread
drop ;
: viewable? ( gml-viewer-world -- ? )
{ [ b-rep>> ] [ program>> ] } 1&& ;
M: gml-viewer-world model-changed
nip
[ model>> value>> ]
[ b-rep<< ]
[ dup viewable? [ refresh-b-rep-view ] [ drop ] if ] tri ;
: init-viewer-model ( gml-viewer-world -- )
[ dup model>> add-connection ]
[ dup selected>> add-connection ] bi ;
: reset-view ( gml-viewer-world -- )
{ 0.0 0.0 5.0 } 0.0 0.0 set-wasd-view drop ;
M: gml-viewer-world begin-game-world
init-gpu
t >>view-faces?
t >>view-edges?
T{ point-state { size 5.0 } } set-gpu-state
dup reset-view
gml-viewer-program <program-instance> >>program
dup init-viewer-model
refresh-b-rep-view ;
M: gml-viewer-world end-game-world
[ dup selected>> remove-connection ]
[ dup model>> remove-connection ] bi ;
M: gml-viewer-world draw-world*
system-framebuffer {
{ default-attachment { 0.0 0.0 0.0 1.0 } }
{ depth-attachment 1.0 }
} clear-framebuffer
[
dup view-faces?>> [
T{ depth-state { comparison cmp-less } } set-gpu-state
{
{ "primitive-mode" [ drop triangles-mode ] }
{ "indexes" [ face-indices>> ] }
{ "uniforms" [ <mvp-uniforms> ] }
{ "vertex-array" [ vertex-array>> ] }
} <render-set> render
T{ depth-state { comparison f } } set-gpu-state
] [ drop ] if
] [
dup view-edges?>> [
{
{ "primitive-mode" [ drop lines-mode ] }
{ "indexes" [ edge-indices>> ] }
{ "uniforms" [ <mvp-uniforms> ] }
{ "vertex-array" [ vertex-array>> ] }
} <render-set> render
] [ drop ] if
] [
{
{ "primitive-mode" [ drop points-mode ] }
{ "indexes" [ point-indices>> ] }
{ "uniforms" [ <mvp-uniforms> ] }
{ "vertex-array" [ vertex-array>> ] }
} <render-set> render
] tri ;
TYPED: rotate-view-mode ( world: gml-viewer-world -- )
dup view-edges?>> [
dup view-faces?>>
[ f >>view-faces? ]
[ f >>view-edges? t >>view-faces? ] if
] [ t >>view-edges? ] if drop ;
CONSTANT: edge-hitbox-radius 0.05
:: line-nearest-t ( p0 u q0 v -- tp tq )
p0 q0 v- :> w0
u u v. :> a
u v v. :> b
v v v. :> c
u w0 v. :> d
v w0 v. :> e
a c * b b * - :> denom
b e * c d * - denom /f
a e * b d * - denom /f ;
:: intersects-edge-node? ( source direction edge -- ? )
edge vertex>> position>> double-4>float-4 :> edge-source
edge opposite-edge>> vertex>> position>> double-4>float-4 edge-source v- :> edge-direction
source direction edge-source edge-direction line-nearest-t :> ( ray-t edge-t )
ray-t 0.0 >= edge-t 0.0 0.5 between? and [
source direction ray-t v*n v+
edge-source edge-direction edge-t v*n v+ v- norm
edge-hitbox-radius <
] [ f ] if ;
: intersecting-edge-node ( source direction b-rep -- edge/f )
edges>> [ intersects-edge-node? ] with with find nip ;
: select-edge ( world -- )
[ [ location>> ] [ hand-loc get wasd-pixel-ray ] bi ]
[ b-rep>> intersecting-edge-node ]
[ '[ _ [ selected>> push-model ] [ refresh-b-rep-view ] bi ] when* ] tri ;
gml-viewer-world H{
{ T{ button-up f f 1 } [ dup drag?>> [ drop ] [ select-edge ] if ] }
{ T{ drag f 1 } [ t >>drag? drop ] }
{ T{ key-down f f "RET" } [ reset-view ] }
{ T{ key-down f f "TAB" } [ rotate-view-mode ] }
} set-gestures
AFTER: gml-viewer-world tick-game-world
dup drag?>> [
read-mouse buttons>>
! FIXME: GTK Mouse buttons are an integer
! MacOSX mouse buttons are an array of bools
dup integer? [ 0 bit? ] [ first ] if >>drag?
] when drop ;
M: gml-viewer-world wasd-mouse-scale drag?>> -1/600. 0.0 ? ;
: wrap-in-model ( object -- model )
dup model? [ <model> ] unless ;
: wrap-in-growable-model ( object -- model )
dup model? [
dup growable? [ >vector ] unless
<model>
] unless ;
: gml-viewer ( b-rep selection -- )
[ wrap-in-model ] [ wrap-in-growable-model ] bi*
'[
f T{ game-attributes
{ world-class gml-viewer-world }
{ title "GML wireframe viewer" }
{ pixel-format-attributes {
windowed
double-buffered
T{ depth-bits f 16 }
} }
{ grab-input? f }
{ use-game-input? t }
{ use-audio-engine? f }
{ pref-dim { 1024 768 } }
{ tick-interval-nanos $[ 30 fps ] }
} open-window*
_ >>model
_ >>selected
drop
] with-ui ;

15
extra/gml/viewer/viewer.v.glsl Normal file
View File

@ -0,0 +1,15 @@
#version 110
uniform mat4 p_matrix;
uniform mat4 mv_matrix;
attribute vec3 vertex;
attribute vec4 color;
varying vec4 frag_color;
void main()
{
gl_Position = p_matrix * mv_matrix * vec4(vertex, 1.0);
frag_color = color;
}