extra/terrain/generation/generation.factor

   1 USING: accessors alien.data.map byte-arrays combinators grouping
   2 images kernel math math.matrices.simd math.order math.vectors
   3 math.vectors.simd noise random sequences typed ;
   4 FROM: alien.c-types => float uchar ;
   5 IN: terrain.generation
   6
   7 CONSTANT: terrain-segment-size { 512 512 }
   8 CONSTANT: terrain-segment-size-vector float-4{ 512.0 512.0 1.0 1.0 }
   9 CONSTANT: terrain-big-noise-scale float-4{ 0.002 0.002 0.002 0.002 }
  10 CONSTANT: terrain-small-noise-scale float-4{ 0.05 0.05 0.05 0.05 }
  11
  12 TUPLE: terrain
  13     { big-noise-table byte-array }
  14     { small-noise-table byte-array }
  15     { tiny-noise-seed integer } ;
  16
  17 : <terrain> ( -- terrain )
  18     <perlin-noise-table> <perlin-noise-table>
  19     32 random-bits terrain boa ;
  20
  21 : seed-at ( seed at -- seed' )
  22     first2 [ >integer ] bi@ [ + ] dip [ 32 random-bits + ] curry with-seed ;
  23
  24 : big-noise-segment ( terrain at -- bytes )
  25     [ big-noise-table>> terrain-big-noise-scale scale-matrix4 ] dip
  26     terrain-segment-size-vector v* translation-matrix4 m4.
  27     terrain-segment-size perlin-noise-image bitmap>> ; inline
  28 : small-noise-segment ( terrain at -- bytes )
  29     [ small-noise-table>> terrain-small-noise-scale scale-matrix4 ] dip
  30     terrain-segment-size-vector v* translation-matrix4 m4.
  31     terrain-segment-size perlin-noise-image bitmap>> ; inline
  32 : tiny-noise-segment ( terrain at -- bytes )
  33     [ tiny-noise-seed>> ] dip seed-at
  34     terrain-segment-size normal-noise-image bitmap>> ; inline
  35 : padding ( terrain at -- padding )
  36     2drop terrain-segment-size product 255 <repetition> >byte-array ; inline
  37
  38 TUPLE: segment image ;
  39
  40 : fold-rgba-planes ( r g b a -- rgba )
  41     [ vmerge-transpose vmerge-transpose ]
  42     data-map( uchar-16 uchar-16 uchar-16 uchar-16 -- uchar-16[4] ) ;
  43
  44 : <terrain-image> ( big small tiny padding -- image )
  45     fold-rgba-planes
  46     <image>
  47         swap >>bitmap
  48         RGBA >>component-order
  49         ubyte-components >>component-type
  50         terrain-segment-size >>dim ;
  51
  52 TYPED: terrain-segment ( terrain: terrain at: float-4 -- image )
  53     {
  54         [ big-noise-segment ]
  55         [ small-noise-segment ]
  56         [ tiny-noise-segment ]
  57         [ padding ]
  58     } 2cleave <terrain-image> ;
  59
  60 : 4max ( a b c d -- max )
  61     max max max ; inline
  62
  63 : mipmap ( pixels quot: ( aa ab ba bb -- c ) -- pixels' )
  64     [ [ 2 <groups> ] map 2 <groups> ] dip
  65     '[ first2 [ [ first2 ] bi@ @ ] 2map ] map ; inline
  66
  67 : group-pixels ( bitmap dim -- scanlines )
  68     [ 4 <groups> ] [ first <groups> ] bi* ;
  69
  70 : concat-pixels ( scanlines -- bitmap )
  71     [ concat ] map concat ;
  72
  73 : segment-mipmap ( image -- image' )
  74     [ clone ] [ bitmap>> ] [ dim>> ] tri
  75     group-pixels [ 4max ] mipmap concat-pixels >>bitmap
  76     [ 2 v/n ] change-dim ;