From 9685aea6fecbd3ff295e048f61a98df81f162e61 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 21 May 2009 20:55:44 -0500 Subject: [PATCH 1/2] homogeneous coordinates coated in nurbsauce --- basis/math/vectors/vectors.factor | 3 + .../affine-transforms.factor | 3 - extra/math/vectors/homogeneous/authors.txt | 1 + .../homogeneous/homogeneous-tests.factor | 15 ++++ .../vectors/homogeneous/homogeneous.factor | 36 +++++++++ extra/math/vectors/homogeneous/summary.txt | 1 + extra/nurbs/authors.txt | 1 + extra/nurbs/nurbs-tests.factor | 32 ++++++++ extra/nurbs/nurbs.factor | 73 +++++++++++++++++++ extra/nurbs/summary.txt | 1 + 10 files changed, 163 insertions(+), 3 deletions(-) create mode 100644 extra/math/vectors/homogeneous/authors.txt create mode 100644 extra/math/vectors/homogeneous/homogeneous-tests.factor create mode 100644 extra/math/vectors/homogeneous/homogeneous.factor create mode 100644 extra/math/vectors/homogeneous/summary.txt create mode 100644 extra/nurbs/authors.txt create mode 100644 extra/nurbs/nurbs-tests.factor create mode 100644 extra/nurbs/nurbs.factor create mode 100644 extra/nurbs/summary.txt diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index 0fe1404516..14a66b5c18 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -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 } ; diff --git a/extra/math/affine-transforms/affine-transforms.factor b/extra/math/affine-transforms/affine-transforms.factor index d1fd602f72..7d63bbfac8 100644 --- a/extra/math/affine-transforms/affine-transforms.factor +++ b/extra/math/affine-transforms/affine-transforms.factor @@ -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 ; -: v~ ( a b epsilon -- ? ) - [ ~ ] curry 2all? ; - : a~ ( a b epsilon -- ? ) { [ [ [ x>> ] bi@ ] dip v~ ] diff --git a/extra/math/vectors/homogeneous/authors.txt b/extra/math/vectors/homogeneous/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/math/vectors/homogeneous/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/math/vectors/homogeneous/homogeneous-tests.factor b/extra/math/vectors/homogeneous/homogeneous-tests.factor new file mode 100644 index 0000000000..7e657dbe71 --- /dev/null +++ b/extra/math/vectors/homogeneous/homogeneous-tests.factor @@ -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 diff --git a/extra/math/vectors/homogeneous/homogeneous.factor b/extra/math/vectors/homogeneous/homogeneous.factor new file mode 100644 index 0000000000..218e56dfb5 --- /dev/null +++ b/extra/math/vectors/homogeneous/homogeneous.factor @@ -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 ; + diff --git a/extra/math/vectors/homogeneous/summary.txt b/extra/math/vectors/homogeneous/summary.txt new file mode 100644 index 0000000000..eb6d457267 --- /dev/null +++ b/extra/math/vectors/homogeneous/summary.txt @@ -0,0 +1 @@ +Homogeneous coordinate math diff --git a/extra/nurbs/authors.txt b/extra/nurbs/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/nurbs/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/nurbs/nurbs-tests.factor b/extra/nurbs/nurbs-tests.factor new file mode 100644 index 0000000000..db606f9c5c --- /dev/null +++ b/extra/nurbs/nurbs-tests.factor @@ -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 } 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 diff --git a/extra/nurbs/nurbs.factor b/extra/nurbs/nurbs.factor new file mode 100644 index 0000000000..ff77d3e915 --- /dev/null +++ b/extra/nurbs/nurbs.factor @@ -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) ; + +: ( 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 :> 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) ; + + diff --git a/extra/nurbs/summary.txt b/extra/nurbs/summary.txt new file mode 100644 index 0000000000..46b9bebffb --- /dev/null +++ b/extra/nurbs/summary.txt @@ -0,0 +1 @@ +NURBS curve evaluation From 3276ae3a088bf6e81ef5a37d8e739626482a660c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 21 May 2009 20:56:57 -0500 Subject: [PATCH 2/2] get rid of useless test --- basis/compiler/tree/cleanup/cleanup-tests.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index c596be263a..549d492d20 100755 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -136,8 +136,6 @@ M: object xyz ; \ +-integer-fixnum inlined? ] unit-test -[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test - [ t ] [ [ [ no-cond ] 1