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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2009-05-06 16:15:59 -05:00
parent c93d876075 1d88d0f51b
commit cb4d8c7ea4
1 changed files with 50 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
extra/perlin-noise/perlin-noise.factor → extra/noise/noise.factor
View File

@ -1,11 +1,14 @@
USING: byte-arrays combinators images kernel locals math math.affine-transforms USING: byte-arrays combinators fry images kernel locals math
math.functions math.polynomials math.vectors random sequences math.affine-transforms math.functions math.order
sequences.product ; math.polynomials math.vectors random random.mersenne-twister
IN: perlin-noise sequences sequences.product ;
IN: noise
: <noise-table> ( -- table ) : <perlin-noise-table> ( -- table )
256 iota >byte-array randomize dup append ; 256 iota >byte-array randomize dup append ;
<PRIVATE
: fade ( point -- point' ) : fade ( point -- point' )
{ 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 } swap [ polyval ] with map ;
@ -51,7 +54,18 @@ IN: perlin-noise
v w quot call v w quot call
; inline ; inline
:: noise ( table point -- value ) : with-seed ( seed quot -- )
[ <mersenne-twister> ] dip with-random ; 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 unit-cube :> cube
point dup vfloor v- :> gradients point dup vfloor v- :> gradients
gradients fade :> faded gradients fade :> faded
@ -70,14 +84,38 @@ IN: perlin-noise
[ faded second lerp ] 2bi@ [ faded second lerp ] 2bi@
faded third lerp ; faded third lerp ;
: noise-map ( table transform dim -- map )
[ iota ] map [ a.v 0.0 suffix noise ] with with product-map ;
: normalize-0-1 ( sequence -- sequence' ) : normalize-0-1 ( sequence -- sequence' )
[ supremum ] [ infimum [ - ] keep ] [ ] tri [ supremum ] [ infimum [ - ] keep ] [ ] tri
[ swap - ] with map [ swap / ] with map ; [ swap - ] with map [ swap / ] with map ;
: noise-image ( table transform dim -- image ) : clamp-0-1 ( sequence -- sequence' )
[ noise-map normalize-0-1 [ 255.0 * >fixnum ] B{ } map-as ] [ 0.0 max 1.0 min ] map ;
[ swap [ L f ] dip image boa ] bi ;
: 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 ;