extra/noise/noise.factor

   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 ;
   9 IN: noise
  10
  11 : with-seed ( seed quot -- )
  12     [ <mersenne-twister> ] dip with-random ; inline
  13
  14 : float-map>byte-map ( floats: float-array scale: float bias: float -- bytes: byte-array )
  15     '[
  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
  20
  21 TYPED: byte-map>image ( bytes: byte-array dim -- image: image )
  22     image new
  23         swap >>dim
  24         swap >>bitmap
  25         L >>component-order
  26         ubyte-components >>component-type ;
  27
  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
  30
  31 : uniform-noise-image ( seed dim -- image )
  32     [ '[ _ product random-bytes >byte-array ] with-seed ]
  33     [ byte-map>image ] bi ; inline
  34
  35 CONSTANT: normal-noise-pow 2
  36 CONSTANT: normal-noise-count 4
  37
  38 TYPED: normal-noise-map ( seed: integer dim -- bytes )
  39     '[ _ product normal-noise-count * random-bytes >byte-array ] with-seed
  40     [
  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
  46
  47 : normal-noise-image ( seed dim -- image )
  48     [ normal-noise-map ] [ byte-map>image ] bi ; inline
  49
  50 ERROR: invalid-perlin-noise-table table ;
  51
  52 : <perlin-noise-table> ( -- table )
  53     256 <iota> >byte-array randomize dup append ; inline
  54
  55 : validate-table ( table -- table )
  56     dup { [ byte-array? ] [ length 512 >= ] } 1&&
  57     [ invalid-perlin-noise-table ] unless ;
  58
  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
  63
  64 : unit-cubed ( floats -- ints )
  65     float-4 int-4 vconvert 255 int-4-with vbitand ; inline
  66
  67 : fade ( gradient -- gradient' )
  68     {
  69         [ drop  6.0 ]
  70         [ n*v -15.0 v+n ]
  71         [ v*   10.0 v+n ]
  72         [ v* ]
  73         [ v* ]
  74         [ v* ]
  75     } cleave ; inline
  76
  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
  80
  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
  85
  86     aa     table nth-unsafe
  87     ba     table nth-unsafe
  88     ab     table nth-unsafe
  89     bb     table nth-unsafe
  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
  94
  95 :: grad ( hash v -- gradient )
  96     hash 8  bitand zero? [ v first ] [ v second ] if
  97         :> u
  98     hash 12 bitand zero?
  99     [ v second ] [ hash 13 bitand 12 = [ v first ] [ v third ] if ] if
 100         :> v
 101
 102     hash 1 bitand zero? [ u ] [ u neg ] if
 103     hash 2 bitand zero? [ v ] [ v neg ] if + ; inline
 104
 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
 110
 111     table cube first3 hashes {
 112         [ gradients                               grad ]
 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 ]
 120     } spread
 121     faded trilerp ;
 122
 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 ;
 125
 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 )
 128     c:float cast-array ;
 129
 130 : perlin-noise-image ( table transform dim -- image )
 131     [ perlin-noise-map-coords perlin-noise-map ] [ 5/7. 0.5 float-map>image ] bi ;