122 lines
3.4 KiB
Factor
122 lines
3.4 KiB
Factor
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 ;
|
|
IN: noise
|
|
|
|
: <perlin-noise-table> ( -- table )
|
|
256 iota >byte-array randomize dup append ;
|
|
|
|
: 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 ;
|
|
|
|
:: grad ( hash gradients -- gradient )
|
|
hash 8 bitand zero? [ gradients first ] [ gradients second ] if
|
|
:> u
|
|
hash 12 bitand zero?
|
|
[ gradients second ]
|
|
[ 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 + ;
|
|
|
|
: unit-cube ( point -- cube )
|
|
[ floor >fixnum 256 mod ] 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
|
|
|
|
a table nth z + :> aa
|
|
b table nth z + :> ba
|
|
a 1 + table nth z + :> ab
|
|
b 1 + table nth z + :> 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 ;
|
|
|
|
:: 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
|
|
|
|
: >byte-map ( floats -- bytes )
|
|
[ 255.0 * >fixnum ] B{ } map-as ;
|
|
|
|
: >image ( bytes dim -- image )
|
|
swap [ L f ] dip image boa ;
|
|
|
|
PRIVATE>
|
|
|
|
:: perlin-noise ( 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 ]
|
|
} spread
|
|
[ faded first lerp ] 2tetra@
|
|
[ faded second lerp ] 2bi@
|
|
faded third lerp ;
|
|
|
|
: normalize-0-1 ( sequence -- sequence' )
|
|
[ supremum ] [ infimum [ - ] keep ] [ ] tri
|
|
[ swap - ] with map [ swap / ] with map ;
|
|
|
|
: clamp-0-1 ( sequence -- sequence' )
|
|
[ 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 ;
|
|
|
|
: perlin-noise-byte-map ( table transform dim -- map )
|
|
perlin-noise-map normalize-0-1 >byte-map ;
|
|
|
|
: perlin-noise-image ( table transform dim -- image )
|
|
[ perlin-noise-byte-map ] [ >image ] bi ;
|
|
|
|
: uniform-noise-map ( seed dim -- map )
|
|
[ product [ 0.0 1.0 uniform-random-float ] replicate ]
|
|
curry with-seed ;
|
|
|
|
: uniform-noise-byte-map ( seed dim -- map )
|
|
uniform-noise-map >byte-map ;
|
|
|
|
: uniform-noise-image ( seed dim -- image )
|
|
[ uniform-noise-byte-map ] [ >image ] bi ;
|
|
|
|
: normal-noise-map ( seed sigma dim -- map )
|
|
swap '[ _ product [ 0.5 _ normal-random-float ] replicate ]
|
|
with-seed ;
|
|
|
|
: normal-noise-byte-map ( seed sigma dim -- map )
|
|
normal-noise-map clamp-0-1 >byte-map ;
|
|
|
|
: normal-noise-image ( seed sigma dim -- image )
|
|
[ normal-noise-byte-map ] [ >image ] bi ;
|