gml, euler: Initial commit.
Doug Coleman
parent
75dccbe329
commit
e270175af0
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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= ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
] ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
#version 110
|
||||
|
||||
varying vec4 frag_color;
|
||||
|
||||
void main()
|
||||
{
|
||||
gl_FragColor = frag_color;
|
||||
}
|
||||
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
@ -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;
|
||||
}
|
||||
Loading…
Reference in New Issue