From dd1deef80ef62982bd6c014e1a38d28190c53961 Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Sat, 5 Dec 2020 20:45:17 +0000 Subject: [PATCH] Finally done day 24 --- advent24/package.yaml | 49 ++++++++++++-------- advent24/src/advent24b.hs | 80 ++++++++++++++++++++++++++++++++ advent24/src/advent24map.hs | 2 +- advent24/src/advent24tape.hs | 89 ++++++++++++++++++++++++++++++++++++ 4 files changed, 199 insertions(+), 21 deletions(-) create mode 100644 advent24/src/advent24b.hs create mode 100644 advent24/src/advent24tape.hs diff --git a/advent24/package.yaml b/advent24/package.yaml index 5f8e76f..e2d06cd 100644 --- a/advent24/package.yaml +++ b/advent24/package.yaml @@ -29,6 +29,7 @@ default-extensions: - MonoLocalBinds - MultiParamTypeClasses - MultiWayIf +- NamedFieldPuns - NegativeLiterals - NumDecimals # - OverloadedLists @@ -64,20 +65,15 @@ executables: - adjunctions - distributive - advent24map: - main: advent24map.hs + advent24b: + main: advent24b.hs source-dirs: src dependencies: - base >= 2 && < 6 - - finite-typelits - containers - - mtl - - comonad - - adjunctions - - distributive - # advent24zip: - # main: advent24zip.hs + # advent24map: + # main: advent24map.hs # source-dirs: src # dependencies: # - base >= 2 && < 6 @@ -88,14 +84,27 @@ executables: # - adjunctions # - distributive - advent24v: - main: advent24v.hs - source-dirs: src - dependencies: - - base >= 2 && < 6 - - finite-typelits - - mtl - - vector - - comonad - - adjunctions - - distributive \ No newline at end of file + # advent24tape: + # main: advent24tape.hs + # source-dirs: src + # dependencies: + # - base >= 2 && < 6 + # - finite-typelits + # - containers + # - mtl + # - comonad + # - adjunctions + # - distributive + # - free + + # advent24v: + # main: advent24v.hs + # source-dirs: src + # dependencies: + # - base >= 2 && < 6 + # - finite-typelits + # - mtl + # - vector + # - comonad + # - adjunctions + # - distributive \ No newline at end of file diff --git a/advent24/src/advent24b.hs b/advent24/src/advent24b.hs new file mode 100644 index 0000000..1b173b7 --- /dev/null +++ b/advent24/src/advent24b.hs @@ -0,0 +1,80 @@ +import Debug.Trace + +import qualified Data.Set as S + +data Cell = Cell { level :: Int + , row :: Int + , column :: Int + } deriving (Show, Eq, Ord) +type Grid = S.Set Cell + + +gridSize = 5 + +main :: IO () +main = + do grid0 <- readGrid + print grid0 + let finalGrid = head $ drop 200 $ iterate update grid0 + print $ S.size finalGrid + + +readGrid = + do gs <- readFile "data/advent24.txt" + let grid = lines gs + let isBug r c = (grid!!(r - 1))!!(c - 1) == '#' + let level = 0 + return $ S.fromList [Cell {..} | row <- [1..gridSize], column <- [1..gridSize], isBug row column] + +neighbourSpaces :: Cell -> Grid +neighbourSpaces cell = + ( (neighbourSpacesLeft cell) + <> (neighbourSpacesRight cell) + <> (neighbourSpacesAbove cell) + <> (neighbourSpacesBelow cell) + ) + +neighbourSpacesLeft :: Cell -> Grid +neighbourSpacesLeft (Cell {..}) + | column == 4 && row == 3 = S.fromList [ Cell { level = (level + 1), row = r, column = 5} | r <- [1..gridSize] ] + | column == 1 = S.singleton ( Cell { level = (level - 1), row = 3, column = 2}) + | otherwise = S.singleton ( Cell { level, row, column = (column - 1)}) + +neighbourSpacesRight :: Cell -> Grid +neighbourSpacesRight (Cell {..}) + | column == 2 && row == 3 = S.fromList [ Cell { level = (level + 1), row = r, column = 1} | r <- [1..gridSize] ] + | column == 5 = S.singleton ( Cell { level = (level - 1), row = 3, column = 4}) + | otherwise = S.singleton ( Cell { level, row, column = (column + 1)}) + +neighbourSpacesAbove :: Cell -> Grid +neighbourSpacesAbove (Cell {..}) + | row == 4 && column == 3 = S.fromList [ Cell { level = (level + 1), row = 5, column = c} | c <- [1..gridSize] ] + | row == 1 = S.singleton ( Cell { level = (level - 1), row = 2, column = 3}) + | otherwise = S.singleton ( Cell { level, row = (row - 1), column}) + +neighbourSpacesBelow :: Cell -> Grid +neighbourSpacesBelow (Cell {..}) + | row == 2 && column == 3 = S.fromList [ Cell { level = (level + 1), row = 1, column = c} | c <- [1..gridSize] ] + | row == 5 = S.singleton ( Cell { level = (level - 1), row = 4, column = 3}) + | otherwise = S.singleton ( Cell { level, row = (row + 1), column}) + + +countOccupiedNeighbours :: Cell -> Grid -> Int +countOccupiedNeighbours cell grid = S.size $ S.intersection grid $ neighbourSpaces cell + +bugSurvives :: Grid -> Cell -> Bool +bugSurvives grid cell = alive && oneNeighbour + where alive = cell `S.member` grid + oneNeighbour = (countOccupiedNeighbours cell grid) == 1 + +bugBorn :: Grid -> Cell -> Bool +bugBorn grid cell = dead && (nNbrs == 1 || nNbrs == 2) + where dead = cell `S.notMember` grid + nNbrs = countOccupiedNeighbours cell grid + +update :: Grid -> Grid +update grid = S.union (S.filter (bugSurvives grid) bugs) (S.filter (bugBorn grid) empties) + where bugs = grid + empties = (S.foldr mergeEmpties S.empty grid) `S.difference` bugs + mergeEmpties cell acc = S.union acc $ neighbourSpaces cell + diff --git a/advent24/src/advent24map.hs b/advent24/src/advent24map.hs index 596bdb2..69ed0f6 100644 --- a/advent24/src/advent24map.hs +++ b/advent24/src/advent24map.hs @@ -98,7 +98,7 @@ mkGrid xs = store (`elem` xs) (Ongrid 1 1) unGrid :: StoredGrid -> Grid Bool -- unGrid (StoreT (Identity g) _) = g unGrid grid = Grid False $ M.fromList gridList - where (sgf, _sgl) = runStore grid + where (sgf, _sgl) = runStore grid -- return pair is function for extracting elements, and current focus gridList = [((Ongrid r c), sgf (Ongrid r c)) | c <- [1..gridSize], r <- [1..gridSize]] diff --git a/advent24/src/advent24tape.hs b/advent24/src/advent24tape.hs new file mode 100644 index 0000000..8f6ce96 --- /dev/null +++ b/advent24/src/advent24tape.hs @@ -0,0 +1,89 @@ + +-- import Debug.Trace + + +import Data.Bool (bool) +import Data.Distributive (Distributive(..)) +import Data.Functor.Rep (Representable(..), distributeRep) +import Data.Functor.Identity (Identity(..)) +import Control.Comonad.Representable.Store (Store(..), StoreT(..), store, experiment, runStore) +import Control.Comonad (Comonad(..)) + +import Data.Maybe +import Data.List +import qualified Data.Set as S +import qualified Data.Map as M + +import Control.Concurrent (threadDelay) +import Control.Monad (forM_) + +import Control.Comonad +import Control.Comonad.Cofree +import Data.Distributive +import Data.Functor.Rep +import qualified Data.Sequence as Q +import qualified Data.List.NonEmpty as NE + + +data TPossible a = TPossible + { leftward :: a + , rightward :: a + , above :: a + , below :: a + } deriving (Show, Eq, Functor) + +data TChoice = L | R | U | D + deriving (Show, Eq) + +instance Distributive TPossible where + distribute :: Functor f => f (TPossible a) -> TPossible (f a) + distribute fga = TPossible (fmap leftward fga) (fmap rightward fga) + (fmap above fga) (fmap below fga) + +instance Representable TPossible where + type Rep TPossible = TChoice + + index :: TPossible a -> TChoice -> a + index here L = leftward here + index here R = rightward here + index here U = above here + index here D = below here + + tabulate :: (TChoice -> a) -> TPossible a + tabulate describe = TPossible (describe L) (describe R) + (describe U) (describe D) + +relativePosition :: Q.Seq TChoice -> Int +relativePosition = sum . fmap valOf + where + valOf L = (-1) + valOf R = 1 + valOf U = (-10) + valOf D = 10 + +numberLine :: Cofree TPossible Int +numberLine = tabulate relativePosition + +project :: NE.NonEmpty a -> Cofree TPossible a +project l = tabulate describe + where + describe = (l NE.!!) . foldl go 0 + maxIndex = length l - 1 + minIndex = 0 + go n L = max minIndex (n - 1) + go n R = min maxIndex (n + 1) + go n U = max minIndex (n - 1) + go n D = min maxIndex (n + 1) + +elems :: NE.NonEmpty String +elems = "one" NE.:| ["two", "three"] + +path :: Q.Seq TChoice +path = Q.fromList [R, R, R, R, L] + +moveTo :: Q.Seq TChoice -> Cofree TPossible a -> Cofree TPossible a +moveTo ind = extend (\cfr -> index cfr ind) + +main :: IO () +main = print $ index (project elems) path +-- main = print elems -- 2.34.1