more vector operations; perlin noise vocab

diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor
index f93a5f2b1ec16ba054e34091c6b5dc46ce062922..eb203a5f12be9372cb01626195715de1d6358e09 100644 (file)
--- a/basis/math/vectors/vectors.factor
+++ b/basis/math/vectors/vectors.factor
@@ -6,6 +6,11 @@ IN: math.vectors
 
 : vneg ( u -- v ) [ neg ] map ;
 
+: v+n ( u n -- v ) [ + ] curry map ;
+: n+v ( n u -- v ) [ + ] with map ;
+: v-n ( u n -- v ) [ - ] curry map ;
+: n-v ( n u -- v ) [ - ] with map ;
+
 : v*n ( u n -- v ) [ * ] curry map ;
 : n*v ( n u -- v ) [ * ] with map ;
 : v/n ( u n -- v ) [ / ] curry map ;
@@ -19,6 +24,10 @@ IN: math.vectors
 : vmax ( u v -- w ) [ max ] 2map ;
 : vmin ( u v -- w ) [ min ] 2map ;
 
+: vfloor    ( v -- _v_ ) [ floor    ] map ;
+: vceiling  ( v -- ^v^ ) [ ceiling  ] map ;
+: vtruncate ( v -- -v- ) [ truncate ] map ;
+
 : vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ; 
 : vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ; 
 

diff --git a/extra/perlin-noise/perlin-noise.factor b/extra/perlin-noise/perlin-noise.factor
new file mode 100644 (file)
index 0000000..e662202
--- /dev/null
+++ b/extra/perlin-noise/perlin-noise.factor
@@ -0,0 +1,83 @@
+USING: byte-arrays combinators images kernel locals math
+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 scale dim -- map ) 
+    [ iota ] map [ v* 0.0 suffix noise ] with with product-map ;
+
+: normalize ( sequence -- sequence' )
+    [ supremum ] [ infimum [ - ] keep ] [ ] tri
+    [ swap - ] with map [ swap / ] with map ;
+
+: noise-image ( table scale dim -- image )
+    [ noise-map normalize [ 255.0 * >fixnum ] B{ } map-as ]
+    [ swap [ L f ] dip image boa ] bi ;
+