diff --git a/basis/math/polynomials/polynomials-docs.factor b/basis/math/polynomials/polynomials-docs.factor index edffa5377d..6617556270 100644 --- a/basis/math/polynomials/polynomials-docs.factor +++ b/basis/math/polynomials/polynomials-docs.factor @@ -93,7 +93,13 @@ HELP: pdiff { $description "Finds the derivative of " { $snippet "p" } "." } ; HELP: polyval -{ $values { "p" "a polynomial" } { "x" number } { "p[x]" number } } +{ $values { "x" number } { "p" "a polynomial" } { "p[x]" number } } { $description "Evaluate " { $snippet "p" } " with the input " { $snippet "x" } "." } -{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } 2 polyval ." "5" } } ; +{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval ." "5" } } ; +HELP: polyval* +{ $values { "p" "a literal polynomial" } } +{ $description "Macro version of " { $link polyval } ". Evaluates the literal polynomial " { $snippet "p" } " at the value off the top of the stack." } +{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval* ." "5" } } ; + +{ polyval polyval* } related-words diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index f65c4ecaaf..fd6eda4a90 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel make math math.order math.vectors sequences - splitting vectors ; + splitting vectors macros combinators ; IN: math.polynomials : pdiff ( p -- p' ) dup length v* { 0 } ?head drop ; -: polyval ( p x -- p[x] ) - [ dup length ] dip powers v. ; +: polyval ( x p -- p[x] ) + [ length swap powers ] [ nip ] 2bi v. ; + +MACRO: polyval* ( p -- ) + reverse + [ 1 tail [ \ * swap \ + [ ] 3sequence ] map ] + [ first \ drop swap [ ] 2sequence ] bi + prefix \ cleave [ ] 2sequence ; diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index 17f6c39f04..bad2733bbf 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -41,6 +41,13 @@ IN: math.vectors : set-axis ( u v axis -- w ) [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ; +: 2tetra@ ( p q r s t u v w quot -- ) + dup [ [ 2bi@ ] curry 4dip ] dip 2bi@ ; inline + +: trilerp ( aaa baa aba bba aab bab abb bbb {t,u,v} -- a_tuv ) + [ first lerp ] [ second lerp ] [ third lerp ] tri-curry + [ 2tetra@ ] [ 2bi@ ] [ call ] tri* ; + : bilerp ( aa ba ab bb {t,u} -- a_tu ) [ first lerp ] [ second lerp ] bi-curry [ 2bi@ ] [ call ] bi* ; @@ -72,3 +79,6 @@ HINTS: v. { array array } ; HINTS: vlerp { array array array } ; HINTS: vnlerp { array array object } ; + +HINTS: bilerp { object object object object array } ; +HINTS: trilerp { object object object object object object object object array } ; diff --git a/extra/math/affine-transforms/affine-transforms.factor b/extra/math/affine-transforms/affine-transforms.factor index 20b73ba678..d1fd602f72 100644 --- a/extra/math/affine-transforms/affine-transforms.factor +++ b/extra/math/affine-transforms/affine-transforms.factor @@ -17,6 +17,8 @@ CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0 [ drop origin>> ] 2tri v+ v+ ; +: ( -- a ) + { 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } ; : ( origin -- a ) [ { 1.0 0.0 } { 0.0 1.0 } ] dip ; : ( theta -- transform ) diff --git a/extra/noise/noise.factor b/extra/noise/noise.factor index c28768283c..46704eed36 100644 --- a/extra/noise/noise.factor +++ b/extra/noise/noise.factor @@ -1,61 +1,60 @@ USING: byte-arrays combinators fry images kernel locals math math.affine-transforms math.functions math.order math.polynomials math.vectors random random.mersenne-twister -sequences sequences.product ; +sequences sequences.product hints arrays sequences.private +combinators.short-circuit math.private ; IN: noise : ( -- table ) - 256 iota >byte-array randomize dup append ; + 256 iota >byte-array randomize dup append ; inline : with-seed ( seed quot -- ) [ ] dip with-random ; inline u hash 12 bitand zero? - [ gradients second ] - [ hash 13 bitand 12 = [ gradients first ] [ gradients third ] if ] if + [ y ] [ hash 13 bitand 12 = [ x ] [ z ] if ] if :> v hash 1 bitand zero? [ u ] [ u neg ] if hash 2 bitand zero? [ v ] [ v neg ] if + ; +HINTS: grad { fixnum float float float } ; + : unit-cube ( point -- cube ) - [ floor >fixnum 256 mod ] map ; + [ floor >fixnum 256 rem ] map ; -:: hashes ( table cube -- aaa baa aba bba aab bab abb bbb ) - cube first :> x - cube second :> y - cube third :> z - x table nth y + :> a - x 1 + table nth y + :> b +:: hashes ( table x y z -- aaa baa aba bba aab bab abb bbb ) + x table nth-unsafe y fixnum+fast :> a + x 1 fixnum+fast table nth-unsafe y fixnum+fast :> b - a table nth z + :> aa - b table nth z + :> ba - a 1 + table nth z + :> ab - b 1 + table nth z + :> bb + a table nth-unsafe z fixnum+fast :> aa + b table nth-unsafe z fixnum+fast :> ba + a 1 fixnum+fast table nth-unsafe z fixnum+fast :> ab + b 1 fixnum+fast table nth-unsafe z fixnum+fast :> bb - aa table nth - ba table nth - ab table nth - bb table nth - aa 1 + table nth - ba 1 + table nth - ab 1 + table nth - bb 1 + table nth ; + aa table nth-unsafe + ba table nth-unsafe + ab table nth-unsafe + bb table nth-unsafe + aa 1 fixnum+fast table nth-unsafe + ba 1 fixnum+fast table nth-unsafe + ab 1 fixnum+fast table nth-unsafe + bb 1 fixnum+fast table nth-unsafe ; inline -:: 2tetra@ ( p q r s t u v w quot -- ) - p q quot call - r s quot call - t u quot call - v w quot call - ; inline +HINTS: hashes { byte-array fixnum fixnum fixnum } ; : >byte-map ( floats -- bytes ) [ 255.0 * >fixnum ] B{ } map-as ; @@ -63,26 +62,33 @@ IN: noise : >image ( bytes dim -- image ) swap [ L f ] dip image boa ; -PRIVATE> - -:: perlin-noise ( table point -- value ) +:: perlin-noise-unsafe ( table point -- value ) point unit-cube :> cube point dup vfloor v- :> gradients gradients fade :> faded - table cube hashes { - [ gradients grad ] - [ gradients { -1.0 0.0 0.0 } v+ grad ] - [ gradients { 0.0 -1.0 0.0 } v+ grad ] - [ gradients { -1.0 -1.0 0.0 } v+ grad ] - [ gradients { 0.0 0.0 -1.0 } v+ grad ] - [ gradients { -1.0 0.0 -1.0 } v+ grad ] - [ gradients { 0.0 -1.0 -1.0 } v+ grad ] - [ gradients { -1.0 -1.0 -1.0 } v+ grad ] + table cube first3 hashes { + [ gradients first3 grad ] + [ gradients first3 [ 1.0 - ] [ ] [ ] tri* grad ] + [ gradients first3 [ ] [ 1.0 - ] [ ] tri* grad ] + [ gradients first3 [ 1.0 - ] [ 1.0 - ] [ ] tri* grad ] + [ gradients first3 [ ] [ ] [ 1.0 - ] tri* grad ] + [ gradients first3 [ 1.0 - ] [ ] [ 1.0 - ] tri* grad ] + [ gradients first3 [ ] [ 1.0 - ] [ 1.0 - ] tri* grad ] + [ gradients first3 [ 1.0 - ] [ 1.0 - ] [ 1.0 - ] tri* grad ] } spread - [ faded first lerp ] 2tetra@ - [ faded second lerp ] 2bi@ - faded third lerp ; + faded trilerp ; + +ERROR: invalid-perlin-noise-table table ; + +: validate-table ( table -- table ) + dup { [ byte-array? ] [ length 512 >= ] } 1&& + [ invalid-perlin-noise-table ] unless ; + +PRIVATE> + +: perlin-noise ( table point -- value ) + [ validate-table ] dip perlin-noise-unsafe ; inline : normalize-0-1 ( sequence -- sequence' ) [ supremum ] [ infimum [ - ] keep ] [ ] tri @@ -92,7 +98,8 @@ PRIVATE> [ 0.0 max 1.0 min ] map ; : perlin-noise-map ( table transform dim -- map ) - [ iota ] map [ a.v 0.0 suffix perlin-noise ] with with product-map ; + [ validate-table ] 2dip + [ iota ] map [ a.v 0.0 suffix perlin-noise-unsafe ] with with product-map ; : perlin-noise-byte-map ( table transform dim -- map ) perlin-noise-map normalize-0-1 >byte-map ;