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

more vector operations; perlin noise vocab

db4
Joe Groff 2009-05-05 22:17:04 -05:00
parent ec1918aaa8
commit 4b64d9a5e5
2 changed files with 92 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
basis/math/vectors/vectors.factor
View File

@ -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 ;

83
extra/perlin-noise/perlin-noise.factor Normal file
View File

@ -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 ;