Finally done day 24

diff --git a/advent24/package.yaml b/advent24/package.yaml
index 5f8e76f85acb50df0e2c7ed4c0fb1ada170a2524..e2d06cd2f0a248976974400053b7a40c8faeb726 100644 (file)
--- a/advent24/package.yaml
+++ b/advent24/package.yaml
@@ -29,6 +29,7 @@ default-extensions:
 - MonoLocalBinds
 - MultiParamTypeClasses
 - MultiWayIf
 - MonoLocalBinds
 - MultiParamTypeClasses
 - MultiWayIf

+- NamedFieldPuns

 - NegativeLiterals
 - NumDecimals
 # - OverloadedLists
 - NegativeLiterals
 - NumDecimals
 # - OverloadedLists


@@ -64,20 +65,15 @@ executables:
     - adjunctions
     - distributive
 
     - adjunctions
     - distributive
 

-  advent24map:
-    main: advent24map.hs
+  advent24b:
+    main: advent24b.hs

     source-dirs: src
     dependencies:
     - base >= 2 && < 6
     source-dirs: src
     dependencies:
     - base >= 2 && < 6

-    - finite-typelits

     - containers
     - containers

-    - mtl
-    - comonad
-    - adjunctions
-    - distributive

 
 

-  # advent24zip:
-  #   main: advent24zip.hs
+  # advent24map:
+  #   main: advent24map.hs

   #   source-dirs: src
   #   dependencies:
   #   - base >= 2 && < 6
   #   source-dirs: src
   #   dependencies:
   #   - base >= 2 && < 6


@@ -88,14 +84,27 @@ executables:
   #   - adjunctions
   #   - distributive
 
   #   - 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 (file)
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 596bdb224375ef36bf576ecafef0f26612a38563..69ed0f6d35f568914cb612b5db19e430def60341 100644 (file)
--- 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
 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]]
 
 
           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 (file)
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