134 lines
4.2 KiB
Factor
134 lines
4.2 KiB
Factor
USING: accessors arrays byte-arrays combinators
|
|
combinators.short-circuit fry hints images kernel locals math
|
|
math.affine-transforms math.functions math.order
|
|
math.polynomials math.private math.vectors random
|
|
random.mersenne-twister sequences sequences.private
|
|
sequences.product ;
|
|
IN: noise
|
|
|
|
: <perlin-noise-table> ( -- table )
|
|
256 iota >byte-array randomize dup append ; inline
|
|
|
|
: with-seed ( seed quot -- )
|
|
[ <mersenne-twister> ] dip with-random ; inline
|
|
|
|
<PRIVATE
|
|
|
|
: (fade) ( x y z -- x' y' z' )
|
|
[ { 0.0 0.0 0.0 10.0 -15.0 6.0 } polyval* ] tri@ ;
|
|
|
|
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?
|
|
[ 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 rem ] map ;
|
|
|
|
:: 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-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-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
|
|
|
|
HINTS: hashes { byte-array fixnum fixnum fixnum } ;
|
|
|
|
: >byte-map ( floats -- bytes )
|
|
[ 255.0 * >fixnum ] B{ } map-as ;
|
|
|
|
: >image ( bytes dim -- image )
|
|
image new
|
|
swap >>dim
|
|
swap >>bitmap
|
|
L >>component-order
|
|
ubyte-components >>component-type ;
|
|
|
|
:: perlin-noise-unsafe ( table point -- value )
|
|
point unit-cube :> cube
|
|
point dup vfloor v- :> gradients
|
|
gradients fade :> faded
|
|
|
|
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 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
|
|
[ 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 )
|
|
[ 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 ;
|
|
|
|
: 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 ;
|