Merge branch 'master' of git://factorcode.org/git/factor
commit
4b2a2a9d0a
|
@ -136,8 +136,6 @@ M: object xyz ;
|
|||
\ +-integer-fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
[ no-cond ] 1
|
||||
|
|
|
@ -62,6 +62,9 @@ IN: math.vectors
|
|||
[ first vnlerp ] [ second vnlerp ] bi-curry
|
||||
[ 2bi@ ] [ call ] bi* ;
|
||||
|
||||
: v~ ( a b epsilon -- ? )
|
||||
[ ~ ] curry 2all? ;
|
||||
|
||||
HINTS: vneg { array } ;
|
||||
HINTS: norm-sq { array } ;
|
||||
HINTS: norm { array } ;
|
||||
|
|
|
@ -65,9 +65,6 @@ CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0
|
|||
} 2cleave
|
||||
[ [ 2array ] 2bi@ ] dip <affine-transform> ;
|
||||
|
||||
: v~ ( a b epsilon -- ? )
|
||||
[ ~ ] curry 2all? ;
|
||||
|
||||
: a~ ( a b epsilon -- ? )
|
||||
{
|
||||
[ [ [ x>> ] bi@ ] dip v~ ]
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
|
@ -0,0 +1,15 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: math.vectors.homogeneous tools.test ;
|
||||
IN: math.vectors.homogeneous.tests
|
||||
|
||||
[ { 1.0 2.0 1.0 } ] [ { 1.0 0.0 1.0 } { 0.0 2.0 1.0 } h+ ] unit-test
|
||||
[ { 1.0 -2.0 1.0 } ] [ { 1.0 0.0 1.0 } { 0.0 2.0 1.0 } h- ] unit-test
|
||||
[ { 2.0 2.0 2.0 } ] [ { 1.0 0.0 1.0 } { 0.0 2.0 2.0 } h+ ] unit-test
|
||||
[ { 1.0 2.0 2.0 } ] [ { 1.0 0.0 2.0 } { 0.0 2.0 2.0 } h+ ] unit-test
|
||||
|
||||
[ { 2.0 4.0 2.0 } ] [ 2.0 { 1.0 2.0 2.0 } n*h ] unit-test
|
||||
[ { 2.0 4.0 2.0 } ] [ { 1.0 2.0 2.0 } 2.0 h*n ] unit-test
|
||||
|
||||
[ { 0.5 1.5 } ] [ { 1.0 3.0 2.0 } h>v ] unit-test
|
||||
[ { 0.5 1.5 1.0 } ] [ { 0.5 1.5 } v>h ] unit-test
|
||||
[ { 0.5 1.5 1.0 } ] [ { 0.5 1.5 } v>h ] unit-test
|
|
@ -0,0 +1,36 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: kernel math math.vectors sequences ;
|
||||
IN: math.vectors.homogeneous
|
||||
|
||||
: (homogeneous-xyz) ( h -- xyz )
|
||||
1 head* ; inline
|
||||
: (homogeneous-w) ( h -- w )
|
||||
peek ; inline
|
||||
|
||||
: h+ ( a b -- c )
|
||||
2dup [ (homogeneous-w) ] bi@ over =
|
||||
[ [ [ (homogeneous-xyz) ] bi@ v+ ] dip suffix ] [
|
||||
drop
|
||||
[ [ (homogeneous-xyz) ] [ (homogeneous-w) ] bi* v*n ]
|
||||
[ [ (homogeneous-w) ] [ (homogeneous-xyz) ] bi* n*v v+ ]
|
||||
[ [ (homogeneous-w) ] [ (homogeneous-w) ] bi* * suffix ] 2tri
|
||||
] if ;
|
||||
|
||||
: n*h ( n h -- nh )
|
||||
[ (homogeneous-xyz) n*v ] [ (homogeneous-w) suffix ] bi ;
|
||||
|
||||
: h*n ( h n -- nh )
|
||||
swap n*h ;
|
||||
|
||||
: hneg ( h -- -h )
|
||||
-1.0 swap n*h ;
|
||||
|
||||
: h- ( a b -- c )
|
||||
hneg h+ ;
|
||||
|
||||
: v>h ( v -- h )
|
||||
1.0 suffix ;
|
||||
|
||||
: h>v ( h -- v )
|
||||
[ (homogeneous-xyz) ] [ (homogeneous-w) ] bi v/n ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Homogeneous coordinate math
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
|
@ -0,0 +1,32 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: literals math math.functions math.vectors namespaces
|
||||
nurbs tools.test ;
|
||||
IN: nurbs.tests
|
||||
|
||||
SYMBOL: test-nurbs
|
||||
|
||||
CONSTANT: √2/2 $[ 0.5 sqrt ]
|
||||
CONSTANT: -√2/2 $[ 0.5 sqrt neg ]
|
||||
|
||||
! unit circle as NURBS
|
||||
3 {
|
||||
{ 1.0 0.0 1.0 }
|
||||
{ $ √2/2 $ √2/2 $ √2/2 }
|
||||
{ 0.0 1.0 1.0 }
|
||||
{ $ -√2/2 $ √2/2 $ √2/2 }
|
||||
{ -1.0 0.0 1.0 }
|
||||
{ $ -√2/2 $ -√2/2 $ √2/2 }
|
||||
{ 0.0 -1.0 1.0 }
|
||||
{ $ √2/2 $ -√2/2 $ √2/2 }
|
||||
{ 1.0 0.0 1.0 }
|
||||
} { 0.0 0.0 0.0 0.25 0.25 0.5 0.5 0.75 0.75 1.0 1.0 1.0 } <nurbs-curve> test-nurbs set
|
||||
|
||||
[ t ] [ test-nurbs get 0.0 eval-nurbs { 1.0 0.0 } 0.00001 v~ ] unit-test
|
||||
[ t ] [ test-nurbs get 0.25 eval-nurbs { 0.0 1.0 } 0.00001 v~ ] unit-test
|
||||
[ t ] [ test-nurbs get 0.5 eval-nurbs { -1.0 0.0 } 0.00001 v~ ] unit-test
|
||||
[ t ] [ test-nurbs get 0.75 eval-nurbs { 0.0 -1.0 } 0.00001 v~ ] unit-test
|
||||
|
||||
[ t ] [ test-nurbs get 0.125 eval-nurbs { $ √2/2 $ √2/2 } 0.00001 v~ ] unit-test
|
||||
[ t ] [ test-nurbs get 0.375 eval-nurbs { $ -√2/2 $ √2/2 } 0.00001 v~ ] unit-test
|
||||
[ t ] [ test-nurbs get 0.625 eval-nurbs { $ -√2/2 $ -√2/2 } 0.00001 v~ ] unit-test
|
||||
[ t ] [ test-nurbs get 0.875 eval-nurbs { $ √2/2 $ -√2/2 } 0.00001 v~ ] unit-test
|
|
@ -0,0 +1,73 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors arrays grouping kernel locals math math.order
|
||||
math.ranges math.vectors math.vectors.homogeneous sequences
|
||||
specialized-arrays.float ;
|
||||
IN: nurbs
|
||||
|
||||
TUPLE: nurbs-curve
|
||||
{ order integer }
|
||||
control-points
|
||||
knots
|
||||
(knot-constants) ;
|
||||
|
||||
: ?recip ( n -- 1/n )
|
||||
dup zero? [ recip ] unless ;
|
||||
|
||||
:: order-index-knot-constants ( curve order index -- knot-constants )
|
||||
curve knots>> :> knots
|
||||
index order 1 - + knots nth :> knot_i+k-1
|
||||
index knots nth :> knot_i
|
||||
index order + knots nth :> knot_i+k
|
||||
index 1 + knots nth :> knot_i+1
|
||||
|
||||
knot_i+k-1 knot_i - ?recip :> c1
|
||||
knot_i+1 knot_i+k - ?recip :> c2
|
||||
|
||||
knot_i c1 * neg :> c3
|
||||
knot_i+k c2 * neg :> c4
|
||||
|
||||
c1 c2 c3 c4 float-array{ } 4sequence ;
|
||||
|
||||
: order-knot-constants ( curve order -- knot-constants )
|
||||
2dup [ knots>> length ] dip - iota
|
||||
[ order-index-knot-constants ] with with map ;
|
||||
|
||||
: knot-constants ( curve -- knot-constants )
|
||||
2 over order>> [a,b]
|
||||
[ order-knot-constants ] with map ;
|
||||
|
||||
: update-knots ( curve -- curve )
|
||||
dup knot-constants >>(knot-constants) ;
|
||||
|
||||
: <nurbs-curve> ( order control-points knots -- nurbs-curve )
|
||||
f nurbs-curve boa update-knots ;
|
||||
|
||||
: knot-interval ( nurbs-curve t -- index )
|
||||
[ knots>> ] dip [ > ] curry find drop 1 - ;
|
||||
|
||||
: clip-range ( from to sequence -- from' to' )
|
||||
length min [ 0 max ] dip ;
|
||||
|
||||
:: eval-base ( knot-constants bases t -- base )
|
||||
knot-constants first t * knot-constants third + bases first *
|
||||
knot-constants second t * knot-constants fourth + bases second *
|
||||
+ ;
|
||||
|
||||
: (eval-curve) ( base-values control-points -- value )
|
||||
[ n*v ] 2map { 0.0 0.0 0.0 } [ v+ ] binary-reduce h>v ;
|
||||
|
||||
:: (eval-bases) ( curve t interval values order -- values' )
|
||||
order 2 - curve (knot-constants)>> nth :> all-knot-constants
|
||||
interval order interval + all-knot-constants clip-range :> to :> from
|
||||
from to all-knot-constants subseq :> knot-constants
|
||||
values { 0.0 } { 0.0 } surround 2 <clumps> :> bases
|
||||
|
||||
knot-constants bases [ t eval-base ] 2map :> values'
|
||||
order curve order>> =
|
||||
[ values' from to curve control-points>> subseq (eval-curve) ]
|
||||
[ curve t interval 1 - values' order 1 + (eval-bases) ] if ;
|
||||
|
||||
: eval-nurbs ( nurbs-curve t -- value )
|
||||
2dup knot-interval 1 - { 1.0 } 2 (eval-bases) ;
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
NURBS curve evaluation
|
Loading…
Reference in New Issue