steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

cut perlin-noise time in half

db4
Joe Groff 2009-05-10 10:41:50 -05:00
parent 7584b30755
commit d90bb0f336
5 changed files with 85 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
basis/math/polynomials/polynomials-docs.factor
View File

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

12
basis/math/polynomials/polynomials.factor
View File

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

10
basis/math/vectors/vectors.factor
View File

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

2
extra/math/affine-transforms/affine-transforms.factor
View File

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

105
extra/noise/noise.factor
View File

@ -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' )
{ 0.0 0.0 0.0 10.0 -15.0 6.0 } swap [ polyval ] with map ;
: (fade) ( x y z -- x' y' z' )
[ { 0.0 0.0 0.0 10.0 -15.0 6.0 } polyval* ] tri@ ;
:: grad ( hash gradients -- gradient )
hash 8 bitand zero? [ gradients first ] [ gradients second ] if
HINTS: (fade) { float float float } ;
: 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 ]
[ 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 ;