extra/noise/noise.factor

   1 USING: accessors alien.data alien.data.map byte-arrays combinators combinators.short-circuit
   2 fry generalizations images kernel locals math math.constants math.functions
   3 math.libm math.matrices.simd math.vectors math.vectors.conversion math.vectors.simd
   4 memoize random random.mersenne-twister sequences sequences.private specialized-arrays
   5 typed ;
   6 QUALIFIED-WITH: alien.c-types c
   7 SPECIALIZED-ARRAYS: c:float c:uchar float-4 uchar-16 ;
   8 IN: noise
   9
  10 : with-seed ( seed quot -- )
  11     [ <mersenne-twister> ] dip with-random ; inline
  12
  13 : float-map>byte-map ( floats: float-array scale: float bias: float -- bytes: byte-array )
  14     '[
  15         [ _ 255.0 * v*n _ 255.0 * v+n float-4 int-4 vconvert ] 4 napply
  16         [ int-4 short-8 vconvert ] 2bi@
  17         short-8 uchar-16 vconvert
  18     ] data-map( float-4[4] -- uchar-16 ) ; inline
  19
  20 TYPED: byte-map>image ( bytes: byte-array dim -- image: image )
  21     image new
  22         swap >>dim
  23         swap >>bitmap
  24         L >>component-order
  25         ubyte-components >>component-type ;
  26
  27 :: float-map>image ( floats: float-array dim scale: float bias: float -- image: image )
  28     floats scale bias float-map>byte-map dim byte-map>image ; inline
  29
  30 : uniform-noise-image ( seed dim -- image )
  31     [ '[ _ product random-bytes >byte-array ] with-seed ]
  32     [ byte-map>image ] bi ; inline
  33
  34 CONSTANT: normal-noise-pow 2
  35 CONSTANT: normal-noise-count 4
  36
  37 TYPED: normal-noise-map ( seed: integer dim -- bytes )
  38     '[ _ product normal-noise-count * random-bytes >byte-array ] with-seed
  39     [
  40         [ short-8{ 0 0 0 0 0 0 0 0 } short-8{ 0 0 0 0 0 0 0 0 } ] normal-noise-count ndip
  41         [ uchar-16 short-8 vconvert [ v+ ] bi-curry@ bi* ] normal-noise-count napply
  42         [ normal-noise-pow vrshift ] bi@
  43         short-8 uchar-16 vconvert
  44     ] data-map( uchar-16[normal-noise-count] -- uchar-16 ) ; inline
  45
  46 : normal-noise-image ( seed dim -- image )
  47     [ normal-noise-map ] [ byte-map>image ] bi ; inline
  48
  49 ERROR: invalid-perlin-noise-table table ;
  50
  51 : <perlin-noise-table> ( -- table )
  52     256 iota >byte-array randomize dup append ; inline
  53
  54 : validate-table ( table -- table )
  55     dup { [ byte-array? ] [ length 512 >= ] } 1&&
  56     [ invalid-perlin-noise-table ] unless ;
  57
  58 ! XXX doesn't work when v is nan or |v| >= 2^31
  59 : floor-vector ( v -- v' )
  60     [ float-4 int-4 vconvert int-4 float-4 vconvert ]
  61     [ [ v> -1.0 float-4-with vand ] curry keep v+ ] bi ; inline
  62
  63 : unit-cubed ( floats -- ints )
  64     float-4 int-4 vconvert 255 int-4-with vbitand ; inline
  65
  66 : fade ( gradient -- gradient' )
  67     {
  68         [ drop  6.0 ]
  69         [ n*v -15.0 v+n ]
  70         [ v*   10.0 v+n ]
  71         [ v* ]
  72         [ v* ]
  73         [ v* ]
  74     } cleave ; inline
  75
  76 :: hashes ( table x y z -- aaa baa aba bba aab bab abb bbb )
  77     x      table nth-unsafe y + :> a
  78     x  1 + table nth-unsafe y + :> b
  79
  80     a      table nth-unsafe z + :> aa
  81     b      table nth-unsafe z + :> ba
  82     a  1 + table nth-unsafe z + :> ab
  83     b  1 + table nth-unsafe z + :> bb
  84
  85     aa     table nth-unsafe
  86     ba     table nth-unsafe
  87     ab     table nth-unsafe
  88     bb     table nth-unsafe
  89     aa 1 + table nth-unsafe
  90     ba 1 + table nth-unsafe
  91     ab 1 + table nth-unsafe
  92     bb 1 + table nth-unsafe ; inline
  93
  94 :: grad ( hash v -- gradient )
  95     hash 8  bitand zero? [ v first ] [ v second ] if
  96         :> u
  97     hash 12 bitand zero?
  98     [ v second ] [ hash 13 bitand 12 = [ v first ] [ v third ] if ] if
  99         :> v
 100
 101     hash 1 bitand zero? [ u ] [ u neg ] if
 102     hash 2 bitand zero? [ v ] [ v neg ] if + ; inline
 103
 104 TYPED:: perlin-noise ( table: byte-array point: float-4 -- value: float )
 105     point floor-vector :> _point_
 106     _point_ unit-cubed :> cube
 107     point _point_ v- :> gradients
 108     gradients fade :> faded
 109
 110     table cube first3 hashes {
 111         [ gradients                               grad ]
 112         [ gradients float-4{ 1.0 0.0 0.0 0.0 } v- grad ]
 113         [ gradients float-4{ 0.0 1.0 0.0 0.0 } v- grad ]
 114         [ gradients float-4{ 1.0 1.0 0.0 0.0 } v- grad ]
 115         [ gradients float-4{ 0.0 0.0 1.0 0.0 } v- grad ]
 116         [ gradients float-4{ 1.0 0.0 1.0 0.0 } v- grad ]
 117         [ gradients float-4{ 0.0 1.0 1.0 0.0 } v- grad ]
 118         [ gradients float-4{ 1.0 1.0 1.0 0.0 } v- grad ]
 119     } spread
 120     faded trilerp ;
 121
 122 MEMO: perlin-noise-map-coords ( dim -- coords )
 123     first2 iota [| x y | x iota [ y 0.0 0.0 float-4-boa ] float-4-array{ } map-as ] with map concat ;
 124
 125 TYPED:: perlin-noise-map ( table: byte-array transform: matrix4 coords: float-4-array -- map: float-array )
 126     coords [| coord | table transform coord m4.v perlin-noise ] data-map( float-4 -- c:float )
 127     c:float cast-array ;
 128
 129 : perlin-noise-image ( table transform dim -- image )
 130     [ perlin-noise-map-coords perlin-noise-map ] [ 5/7. 0.5 float-map>image ] bi ;