1 USING: accessors alien.data alien.data.map
2 byte-arrays combinators combinators.short-circuit
3 generalizations images kernel math math.matrices.simd
4 math.vectors math.vectors.conversion math.vectors.simd random
5 random.mersenne-twister sequences sequences.private
6 specialized-arrays typed ;
7 QUALIFIED-WITH: alien.c-types c
8 SPECIALIZED-ARRAYS: c:float c:uchar float-4 uchar-16 ;
11 : with-seed ( seed quot -- )
12 [ <mersenne-twister> ] dip with-random ; inline
14 : float-map>byte-map ( floats: float-array scale: float bias: float -- bytes: byte-array )
16 [ _ 255.0 * v*n _ 255.0 * v+n float-4 int-4 vconvert ] 4 napply
17 [ int-4 short-8 vconvert ] 2bi@
18 short-8 uchar-16 vconvert
19 ] data-map( float-4[4] -- uchar-16 ) ; inline
21 TYPED: byte-map>image ( bytes: byte-array dim -- image: image )
26 ubyte-components >>component-type ;
28 :: float-map>image ( floats: float-array dim scale: float bias: float -- image: image )
29 floats scale bias float-map>byte-map dim byte-map>image ; inline
31 : uniform-noise-image ( seed dim -- image )
32 [ '[ _ product random-bytes >byte-array ] with-seed ]
33 [ byte-map>image ] bi ; inline
35 CONSTANT: normal-noise-pow 2
36 CONSTANT: normal-noise-count 4
38 TYPED: normal-noise-map ( seed: integer dim -- bytes )
39 '[ _ product normal-noise-count * random-bytes >byte-array ] with-seed
41 [ short-8{ 0 0 0 0 0 0 0 0 } short-8{ 0 0 0 0 0 0 0 0 } ] normal-noise-count ndip
42 [ uchar-16 short-8 vconvert [ v+ ] bi-curry@ bi* ] normal-noise-count napply
43 [ normal-noise-pow vrshift ] bi@
44 short-8 uchar-16 vconvert
45 ] data-map( uchar-16[normal-noise-count] -- uchar-16 ) ; inline
47 : normal-noise-image ( seed dim -- image )
48 [ normal-noise-map ] [ byte-map>image ] bi ; inline
50 ERROR: invalid-perlin-noise-table table ;
52 : <perlin-noise-table> ( -- table )
53 256 <iota> >byte-array randomize dup append ; inline
55 : validate-table ( table -- table )
56 dup { [ byte-array? ] [ length 512 >= ] } 1&&
57 [ invalid-perlin-noise-table ] unless ;
59 ! XXX doesn't work when v is nan or |v| >= 2^31
60 : floor-vector ( v -- v' )
61 [ float-4 int-4 vconvert int-4 float-4 vconvert ]
62 [ [ v> -1.0 float-4-with vand ] keepd v+ ] bi ; inline
64 : unit-cubed ( floats -- ints )
65 float-4 int-4 vconvert 255 int-4-with vbitand ; inline
67 : fade ( gradient -- gradient' )
77 :: hashes ( table x y z -- aaa baa aba bba aab bab abb bbb )
78 x table nth-unsafe y + :> a
79 x 1 + table nth-unsafe y + :> b
81 a table nth-unsafe z + :> aa
82 b table nth-unsafe z + :> ba
83 a 1 + table nth-unsafe z + :> ab
84 b 1 + table nth-unsafe z + :> bb
90 aa 1 + table nth-unsafe
91 ba 1 + table nth-unsafe
92 ab 1 + table nth-unsafe
93 bb 1 + table nth-unsafe ; inline
95 :: grad ( hash v -- gradient )
96 hash 8 bitand zero? [ v first ] [ v second ] if
99 [ v second ] [ hash 13 bitand 12 = [ v first ] [ v third ] if ] if
102 hash 1 bitand zero? [ u ] [ u neg ] if
103 hash 2 bitand zero? [ v ] [ v neg ] if + ; inline
105 TYPED:: perlin-noise ( table: byte-array point: float-4 -- value: float )
106 point floor-vector :> _point_
107 _point_ unit-cubed :> cube
108 point _point_ v- :> gradients
109 gradients fade :> faded
111 table cube first3 hashes {
113 [ gradients float-4{ 1.0 0.0 0.0 0.0 } v- grad ]
114 [ gradients float-4{ 0.0 1.0 0.0 0.0 } v- grad ]
115 [ gradients float-4{ 1.0 1.0 0.0 0.0 } v- grad ]
116 [ gradients float-4{ 0.0 0.0 1.0 0.0 } v- grad ]
117 [ gradients float-4{ 1.0 0.0 1.0 0.0 } v- grad ]
118 [ gradients float-4{ 0.0 1.0 1.0 0.0 } v- grad ]
119 [ gradients float-4{ 1.0 1.0 1.0 0.0 } v- grad ]
123 MEMO: perlin-noise-map-coords ( dim -- coords )
124 first2 <iota> [| x y | x <iota> [ y 0.0 0.0 float-4-boa ] float-4-array{ } map-as ] with map concat ;
126 TYPED:: perlin-noise-map ( table: byte-array transform: matrix4 coords: float-4-array -- map: float-array )
127 coords [| coord | table transform coord m4.v perlin-noise ] data-map( float-4 -- c:float )
130 : perlin-noise-image ( table transform dim -- image )
131 [ perlin-noise-map-coords perlin-noise-map ] [ 5/7. 0.5 float-map>image ] bi ;