extra/terrain/generation/generation.factor

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