advent24/src/advent24map.hs

   1 -- import Debug.Trace
   2
   3
   4 import Data.Finite (Finite, modulo, getFinite)
   5 import GHC.TypeNats (KnownNat)
   6
   7
   8 -- import Data.Functor.Compose (Compose(..))
   9 -- import Data.Matrix (Matrix, matrix, safeGet, (!), prettyMatrix, mapPos, fromList, toList)
  10 -- import qualified Data.Matrix as X
  11 import Data.Bool (bool)
  12 import Data.Distributive (Distributive(..))
  13 import Data.Functor.Rep (Representable(..), distributeRep)
  14 import Data.Functor.Identity (Identity(..))
  15 import Control.Comonad.Representable.Store (Store(..), StoreT(..), store, experiment, runStore)
  16 import Control.Comonad (Comonad(..))
  17
  18 import Data.Maybe
  19 import Data.List
  20 import qualified Data.Set as S
  21 import qualified Data.Map.Strict as M
  22
  23 import Control.Concurrent (threadDelay)
  24 import Control.Monad (forM_)
  25
  26
  27 data Coord = Ongrid Int Int | Offgrid deriving (Show, Eq, Ord)
  28 data Grid a = Grid a (M.Map Coord a) deriving (Show, Eq, Ord)
  29 type StoredGrid = Store Grid Bool
  30 type Rule = StoredGrid -> Bool
  31
  32 type GridCache = S.Set (Grid Bool)
  33
  34
  35 instance Functor Grid where
  36   fmap f (Grid a m) = Grid (f a) (fmap f m)
  37
  38 instance Distributive Grid where
  39   distribute = distributeRep
  40
  41 instance Representable Grid where
  42   type Rep Grid = Coord
  43   index (Grid a m) Offgrid = a
  44   index (Grid a m) here = M.findWithDefault a here m
  45   tabulate f =
  46     Grid (f Offgrid)
  47       (M.union (M.singleton c (f c))
  48                 (M.unions (fmap (mapOfGrid . tabulate)
  49                                (fmap (f . ) (fmap addCoords neighbourCoords)))
  50                                -- (fmap (f . addCoords . ) neighbourCoords))
  51                 )
  52       )
  53     where
  54       c = (Ongrid 1 1)
  55       mapOfGrid (Grid _ m) = m
  56
  57 gridSize :: Int
  58 gridSize = 5
  59
  60 -- validCoord :: Coord -> Bool
  61 -- validCoord (r, c) = r >= 1 && r <= gridSize && c >= 1 && c <= gridSize
  62
  63 boundCoord :: Coord -> Coord
  64 boundCoord Offgrid = Offgrid
  65 boundCoord (Ongrid r c)
  66   | r >= 1 && r <= gridSize && c >= 1 && c <= gridSize = Ongrid r c
  67   | otherwise = Offgrid
  68
  69 neighbourCoords :: [Coord]
  70 -- neighbourCoords = [(x, y) | x <- [-1, 0, 1], y <- [-1, 0, 1], (x, y) /= (0, 0)]
  71 neighbourCoords = [(Ongrid -1 0), (Ongrid 1 0), (Ongrid 0 -1), (Ongrid 0 1)]
  72
  73 addCoords :: Coord -> Coord -> Coord
  74 addCoords Offgrid _ = Offgrid
  75 addCoords _ Offgrid = Offgrid
  76 addCoords (Ongrid x y) (Ongrid x' y') = boundCoord $ Ongrid (x + x') (y + y')
  77
  78 basicRule :: Rule
  79 basicRule g = (alive && numNeighboursAlive == 1) || ((not alive) && (numNeighboursAlive == 1 || numNeighboursAlive == 2))
  80   where
  81     alive = extract g
  82     neighbours = experiment ((map boundCoord) . (at neighbourCoords)) g
  83     numNeighboursAlive = length (filter id neighbours)
  84
  85 step :: Rule -> StoredGrid -> StoredGrid
  86 step = extend
  87
  88 render :: StoredGrid -> String
  89 -- render (StoreT (Identity g) _) = foldMap ((++ "\n") . foldMap (bool "." "#")) g
  90 -- render grid = X.prettyMatrix $ X.mapPos (\_ c -> bool "." "#" c) g
  91 --     where g = unGrid grid
  92 render grid = show $ unGrid grid
  93
  94
  95 mkGrid :: [Coord] -> StoredGrid
  96 mkGrid xs = store (`elem` xs) (Ongrid 1 1)
  97
  98 unGrid :: StoredGrid -> Grid Bool
  99 -- unGrid (StoreT (Identity g) _) = g
 100 unGrid grid = Grid False $ M.fromList gridList
 101     where (sgf, _sgl) = runStore grid -- return pair is function for extracting elements, and current focus
 102           gridList = [((Ongrid r c), sgf (Ongrid r c)) | c <- [1..gridSize], r <- [1..gridSize]]
 103
 104
 105 at :: [Coord] -> Coord -> [Coord]
 106 coords `at` origin = map (addCoords origin) coords
 107
 108 -- glider, blinker, beacon :: [Coord]
 109 -- glider = [(1, 0), (2, 1), (0, 2), (1, 2), (2, 2)]
 110 -- blinker = [(0, 0), (1, 0), (2, 0)]
 111 -- beacon = [(0, 0), (1, 0), (0, 1), (3, 2), (2, 3), (3, 3)]
 112
 113
 114 tickTime :: Int
 115 tickTime = 200000
 116
 117 start :: IO StoredGrid
 118 start = do coords <- readGrid
 119            return $ mkGrid coords
 120   --    glider `at` (1, 1)
 121   -- ++ beacon `at` (15, 5)
 122
 123 main :: IO ()
 124 main =
 125     do sG <- start
 126        -- print $ part1 sG
 127        let grids = map unGrid $ iterate (step basicRule) sG
 128        forM_ (take 5 $ iterate (step basicRule) sG) $ \grid -> do
 129             putStr "\ESC[2J" -- Clear terminal screen
 130             putStrLn (render grid)
 131             threadDelay tickTime
 132
 133
 134 readGrid =
 135     do  gs <- readFile "data/advent24.txt"
 136         let grid = lines gs
 137         let isBug r c = (grid!!r)!!c == '#'
 138         let ng = gridSize - 1
 139         return [Ongrid (r + 1) (c + 1) | r <- [0..ng], c <- [0..ng], isBug r c]
 140
 141
 142 -- part1 :: Grid -> [Grid]
 143 part1 :: StoredGrid -> Integer
 144 -- part1 startingGrid = map fst $ takeWhile (uncurry . S.notMember) (zip grids gridCache)
 145 -- part1 startingGrid = map fst $ takeWhile (\(g, c) -> S.notMember g c) (zip grids gridCache)
 146 -- part1 startingGrid = fst $ head $ dropWhile (\(g, c) -> S.notMember g c) (zip grids gridCache)
 147 part1 startingGrid = bioDiversity firstRepeat
 148     where
 149           -- grids = map unGrid $ iterate (step basicRule) startingGrid
 150           -- gridCache = scanl' (flip . S.insert) S.empty grids
 151           grids = fGrids startingGrid
 152           gridCache = fGridCache grids
 153           firstRepeat = fst $ head $ dropWhile (uncurry S.notMember) (zip grids gridCache)
 154
 155 fGrids :: StoredGrid -> [Grid Bool]
 156 fGrids stG = map unGrid $ iterate (step basicRule) stG
 157
 158 fGridCache :: [Grid Bool] -> [S.Set (Grid Bool)]
 159 fGridCache gs = scanl' (flip S.insert) S.empty gs
 160 -- fGridCache gs = scanl' (\s g -> S.insert g s) S.empty gs
 161
 162
 163 bioDiversity :: (Grid Bool) -> Integer
 164 bioDiversity (Grid _ g) = sum $ map snd $ filter (id . fst) $ zip bugs $ iterate ( * 2) 1
 165     where bugs = [ M.findWithDefault False (Ongrid r c) g
 166                  | c <- [1..gridSize]
 167                  , r <- [1..gridSize]
 168                  ]