about summary refs log tree commit diff
path: root/src/Xanthous/Generators/CaveAutomata.hs
blob: e885f4ed1aadbec7fb350c655f2fb880fa62e742 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

module Xanthous.Generators.CaveAutomata
  ( Params(..)
  , defaultParams
  , parseParams
  , generate
  ) where

import Xanthous.Prelude
import Control.Monad.Random (RandomGen, runRandT)
import Data.Array.ST
import Data.Array.Unboxed
import qualified Options.Applicative as Opt

import Xanthous.Util (between)
import Xanthous.Data (Dimensions, width, height)
import Xanthous.Generators.Util

data Params = Params
  { _aliveStartChance :: Double
  , _birthLimit :: Word
  , _deathLimit :: Word
  , _steps :: Word
  }
  deriving stock (Show, Eq, Generic)
makeLenses ''Params

defaultParams :: Params
defaultParams = Params
  { _aliveStartChance = 0.6
  , _birthLimit = 3
  , _deathLimit = 4
  , _steps = 4
  }

parseParams :: Opt.Parser Params
parseParams = Params
  <$> Opt.option parseChance
      ( Opt.long "alive-start-chance"
      <> Opt.value (defaultParams ^. aliveStartChance)
      <> Opt.showDefault
      <> Opt.help ( "Chance for each cell to start alive at the beginning of "
                 <> "the cellular automata"
                 )
      <> Opt.metavar "CHANCE"
      )
  <*> Opt.option parseNeighbors
      ( Opt.long "birth-limit"
      <> Opt.value (defaultParams ^. birthLimit)
      <> Opt.showDefault
      <> Opt.help "Minimum neighbor count required for birth of a cell"
      <> Opt.metavar "NEIGHBORS"
      )
  <*> Opt.option parseNeighbors
      ( Opt.long "death-limit"
      <> Opt.value (defaultParams ^. deathLimit)
      <> Opt.showDefault
      <> Opt.help "Maximum neighbor count required for death of a cell"
      <> Opt.metavar "NEIGHBORS"
      )
  <*> Opt.option Opt.auto
      ( Opt.long "steps"
      <> Opt.value (defaultParams ^. steps)
      <> Opt.showDefault
      <> Opt.help "Number of generations to run the automata for"
      <> Opt.metavar "STEPS"
      )
  where
    readWithGuard predicate errmsg = do
      res <- Opt.auto
      unless (predicate res)
        $ Opt.readerError
        $ errmsg res
      pure res

    parseChance = readWithGuard
      (between 0 1)
      $ \res -> "Chance must be in the range [0,1], got: " <> show res

    parseNeighbors = readWithGuard
      (between 0 8)
      $ \res -> "Neighbors must be in the range [0,8], got: " <> show res

generate :: RandomGen g => Params -> Dimensions -> g -> UArray (Word, Word) Bool
generate params dims gen
  = runSTUArray
  $ fmap fst
  $ flip runRandT gen
  $ generate' params dims

generate' :: RandomGen g => Params -> Dimensions -> CellM g s (MCells s)
generate' params dims = do
  cells <- randInitialize dims $ params ^. aliveStartChance
  let steps' = params ^. steps
  when (steps' > 0)
   $ for_ [0 .. pred steps'] . const $ stepAutomata cells dims params
  -- Remove all but the largest contiguous region of unfilled space
  (_: smallerRegions) <- lift $ regions @UArray . amap not <$> freeze cells
  lift $ fillAllM (fold smallerRegions) cells
  lift $ fillOuterEdgesM cells
  pure cells

stepAutomata :: forall s g. MCells s -> Dimensions -> Params -> CellM g s ()
stepAutomata cells dims params = do
  origCells <- lift $ cloneMArray @_ @(STUArray s) cells
  for_ (range ((0, 0), (dims ^. width, dims ^. height))) $ \pos -> do
    neighs <- lift $ numAliveNeighborsM origCells pos
    origValue <- lift $ readArray origCells pos
    lift . writeArray cells pos
      $ if origValue
        then neighs >= params ^. deathLimit
        else neighs > params ^. birthLimit