rename perlin-noise to noise; add words for uniform and normal noise

diff --git a/extra/noise/noise.factor b/extra/noise/noise.factor
new file mode 100644 (file)
index 0000000..f2ca8ad
--- /dev/null
+++ b/extra/noise/noise.factor
@@ -0,0 +1,121 @@
+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 ;
+
+<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
+
+: 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 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 ;

diff --git a/extra/perlin-noise/perlin-noise.factor b/extra/perlin-noise/perlin-noise.factor
deleted file mode 100644 (file)
index 0a12eef..0000000
--- a/extra/perlin-noise/perlin-noise.factor
+++ /dev/null
@@ -1,83 +0,0 @@
-USING: byte-arrays combinators images kernel locals math math.affine-transforms
-math.functions math.polynomials math.vectors random sequences
-sequences.product ;
-IN: perlin-noise
-
-: <noise-table> ( -- table )
-    256 iota >byte-array randomize dup append ;
-
-: 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
-
-:: 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 ;
-
-: noise-map ( table transform dim -- map ) 
-    [ iota ] map [ a.v 0.0 suffix noise ] with with product-map ;
-
-: normalize-0-1 ( sequence -- sequence' )
-    [ supremum ] [ infimum [ - ] keep ] [ ] tri
-    [ swap - ] with map [ swap / ] with map ;
-
-: noise-image ( table transform dim -- image )
-    [ noise-map normalize-0-1 [ 255.0 * >fixnum ] B{ } map-as ]
-    [ swap [ L f ] dip image boa ] bi ;
-