Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2009-05-21 21:23:15 -05:00
commit 4b2a2a9d0a
11 changed files with 163 additions and 5 deletions

View File

@ -136,8 +136,6 @@ M: object xyz ;
\ +-integer-fixnum inlined?
] unit-test
[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
[ t ] [
[
[ no-cond ] 1

View File

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

View File

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

View File

@ -0,0 +1 @@
Joe Groff

View File

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

View File

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

View File

@ -0,0 +1 @@
Homogeneous coordinate math

1
extra/nurbs/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

View File

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

73
extra/nurbs/nurbs.factor Normal file
View File

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

1
extra/nurbs/summary.txt Normal file
View File

@ -0,0 +1 @@
NURBS curve evaluation