cut perlin-noise time in half

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

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
 
 <PRIVATE
@@ -80,6 +80,12 @@ PRIVATE>
 : pdiff ( p -- p' )
     dup length v* { 0 } ?head drop ;
 
-: polyval ( p x -- p[x] )
+: polyval ( x p -- p[x] )
-    [ dup length ] dip powers v. ;
+    [ length swap powers ] [ nip ] 2bi v. ;
+
+MACRO: polyval* ( p -- )
+    reverse
+    [ 1 tail [ \ * swap \ + [ ] 3sequence ] map ]
+    [ first \ drop swap [ ] 2sequence ] bi
+    prefix \ cleave [ ] 2sequence ;
 

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

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+ ;
 
+: <identity> ( -- a )
+    { 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } <affine-transform> ;
 : <translation> ( origin -- a )
     [ { 1.0 0.0 } { 0.0 1.0 } ] dip <affine-transform> ;
 : <rotation> ( theta -- transform )

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
 
 : <perlin-noise-table> ( -- table )
-    256 iota >byte-array randomize dup append ;
+    256 iota >byte-array randomize dup append ; inline
 
 : with-seed ( seed quot -- )
     [ <mersenne-twister> ] dip with-random ; inline
 
 <PRIVATE
 
-: fade ( point -- point' )
+: (fade) ( x y z -- x' y' z' )
-    { 0.0 0.0 0.0 10.0 -15.0 6.0 } swap [ polyval ] with map ;
+    [ { 0.0 0.0 0.0 10.0 -15.0 6.0 } polyval* ] tri@ ;
 
-:: grad ( hash gradients -- gradient )
+HINTS: (fade) { float float float } ;
-    hash 8  bitand zero? [ gradients first ] [ gradients second ] if
+
+: fade ( point -- point' )
+    first3 (fade) 3array ; inline
+
+:: grad ( hash x y z -- gradient )
+    hash 8  bitand zero? [ x ] [ y ] if
         :> u
     hash 12 bitand zero?
-    [ gradients second ]
+    [ y ] [ hash 13 bitand 12 = [ x ] [ z ] if ] if
-    [ hash 13 bitand 12 = [ gradients first ] [ gradients third ] 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 )
+:: hashes ( table x y z -- aaa baa aba bba aab bab abb bbb )
-    cube first  :> x
+    x               table nth-unsafe y fixnum+fast :> a
-    cube second :> y
+    x 1 fixnum+fast table nth-unsafe y fixnum+fast :> b
-    cube third  :> z
-    x     table nth y + :> a
-    x 1 + table nth y + :> b
 
-    a     table nth z + :> aa
+    a               table nth-unsafe z fixnum+fast :> aa
-    b     table nth z + :> ba
+    b               table nth-unsafe z fixnum+fast :> ba
-    a 1 + table nth z + :> ab
+    a 1 fixnum+fast table nth-unsafe z fixnum+fast :> ab
-    b 1 + table nth z + :> bb
+    b 1 fixnum+fast table nth-unsafe z fixnum+fast :> bb
 
-    aa     table nth 
+    aa               table nth-unsafe 
-    ba     table nth 
+    ba               table nth-unsafe 
-    ab     table nth 
+    ab               table nth-unsafe 
-    bb     table nth 
+    bb               table nth-unsafe 
-    aa 1 + table nth 
+    aa 1 fixnum+fast table nth-unsafe 
-    ba 1 + table nth 
+    ba 1 fixnum+fast table nth-unsafe 
-    ab 1 + table nth 
+    ab 1 fixnum+fast table nth-unsafe 
-    bb 1 + table nth ;
+    bb 1 fixnum+fast table nth-unsafe ; inline
 
-:: 2tetra@ ( p q r s t u v w quot -- )
+HINTS: hashes { byte-array fixnum fixnum fixnum } ;
-    p q quot call
-    r s quot call
-    t u quot call
-    v w quot call
-    ; inline
 
 : >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-unsafe ( table point -- value )
-
-:: perlin-noise ( table point -- value )
     point unit-cube :> cube
     point dup vfloor v- :> gradients
     gradients fade :> faded
 
-    table cube hashes {
+    table cube first3 hashes {
-        [ gradients                       grad ]
+        [ gradients first3                                    grad ]
-        [ gradients { -1.0  0.0  0.0 } v+ grad ]
+        [ gradients first3 [ 1.0 - ] [       ] [       ] tri* grad ]
-        [ gradients {  0.0 -1.0  0.0 } v+ grad ]
+        [ gradients first3 [       ] [ 1.0 - ] [       ] tri* grad ]
-        [ gradients { -1.0 -1.0  0.0 } v+ grad ]
+        [ gradients first3 [ 1.0 - ] [ 1.0 - ] [       ] tri* grad ]
-        [ gradients {  0.0  0.0 -1.0 } v+ grad ]
+        [ gradients first3 [       ] [       ] [ 1.0 - ] tri* grad ]
-        [ gradients { -1.0  0.0 -1.0 } v+ grad ]
+        [ gradients first3 [ 1.0 - ] [       ] [ 1.0 - ] tri* grad ]
-        [ gradients {  0.0 -1.0 -1.0 } v+ grad ]
+        [ gradients first3 [       ] [ 1.0 - ] [ 1.0 - ] tri* grad ]
-        [ gradients { -1.0 -1.0 -1.0 } v+ grad ]
+        [ gradients first3 [ 1.0 - ] [ 1.0 - ] [ 1.0 - ] tri* grad ]
     } spread
-    [ faded first lerp ] 2tetra@
+    faded trilerp ;
-    [ faded second lerp ] 2bi@
+
-    faded third lerp ;
+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 ;