From 51cb2314a8b15ac22d7e3abc9235ef9ac50c211f Mon Sep 17 00:00:00 2001 From: Samae Date: Sat, 14 Dec 2024 21:42:11 +0200 Subject: [PATCH] Day 10 --- .gitignore | 2 + Main.hs | 7 +- flake.lock | 4 +- inputs/day10.input | 54 +++++++++ package.yaml | 3 +- src/Day10.hs | 273 +++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 338 insertions(+), 5 deletions(-) create mode 100644 inputs/day10.input create mode 100644 src/Day10.hs diff --git a/.gitignore b/.gitignore index 06637ce..1bd6332 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,5 @@ result* dist-newstyle *.eventlog *.prof +*.dot +*.pdf diff --git a/Main.hs b/Main.hs index 5143fac..f96fb48 100644 --- a/Main.hs +++ b/Main.hs @@ -11,6 +11,7 @@ import Day6 import Day7 import Day8 import Day9 +import Day10 main :: IO () main = do @@ -31,5 +32,7 @@ main = do -- Day7.main -- putStrLn "Day 8" -- Day8.main - putStrLn "Day 9" - Day9.main + -- putStrLn "Day 9" + -- Day9.main + putStrLn "Day 10" + Day10.main diff --git a/flake.lock b/flake.lock index e3bdb55..c213aa8 100644 --- a/flake.lock +++ b/flake.lock @@ -3,8 +3,8 @@ "nixpkgs": { "locked": { "lastModified": 1, - "narHash": "sha256-y/MEyuJ5oBWrWAic/14LaIr/u5E0wRVzyYsouYY3W6w=", - "path": "/nix/store/zx63r1p2sg7w4vicnxlmh2assabvpzc7-c9wv7i0af6mysmy65x6nvyfw5izzxv4g-source", + "narHash": "sha256-AKU6qqskl0yf2+JdRdD0cfxX4b9x3KKV5RqA6wijmPM=", + "path": "/nix/store/r06xpql4r58fkhzq6np83zhpm7gdmwjv-22r7q7s9552gn1vpjigkbhfgcvhsrz68-source", "type": "path" }, "original": { diff --git a/inputs/day10.input b/inputs/day10.input new file mode 100644 index 0000000..3f29526 --- /dev/null +++ b/inputs/day10.input @@ -0,0 +1,54 @@ +212521982345455432198898732343201001454321076767899872 +101430671156766718089087001432102122367410789898721701 +234549560049859809670106126549893432198523650127630652 +345678432132343218543215437456784543007694540134544543 +434989010101034567894326458941089656912784343296531014 +123968523218954326287478947032178767843895256787432543 +037879654305869210156565432142189626756706101208956632 +010968760456778981432101943443076212389617890312347701 +323459821678765476583201875654561003476526345423698801 +011234734569012345694112766743432876565430256784510932 +010345654554212014785073450898101986676321100898929841 +143456703623103423456787321287632987685672901289838750 +212769812514398512987896544379443456894589874356745669 +301898453405487600121095434568543670123601065105210178 +498782345654676321436784323877612589010892110234312321 +567101908723521030545654012981003438756763323987603430 +323877819810437841690343021542312321065654332109544543 +014966521923456956781252120455401487654505445678037652 +565455430810398105898763214345566590123218764789128781 +678321876760567234237454905216697687689439653234569390 +549050945651456340145667876107788014578321342106778434 +432167834512301254206758989038979123065430211067884521 +212058723003456763219843210123460132104321203458990690 +103449012124567895430764505674321043895650432143021788 +214530101013098986721256034985452344786766501032134659 +345621232322121234890340125676965435689897865401235678 +238789985421030345234543234767876105476101974321945234 +129376576534781676167652149866765256785232389450876165 +023403456215696787018967019875454343494341071265210074 +016512567304345698101278112562343852014556780374391189 +187876458412234598790349603401438961025698895489580543 +098962389561103347685456784876547873234767216785671672 +123451049870101256576545692910687210189854306894502981 +212945432943232345677834501431296332182344345663213870 +301876501854569431988925232321345345091103216756344561 +676510345763078520123810123410543456780234109865432150 +783401256762107019654320294567632109876542106776843001 +892313879856234198734521287678932323438943769089987612 +341054965447895287645632789456541010567659858123656543 +250123832332196014532745610367692101298365647654567698 +167814001541087123691821001298789854303234737843238787 +078905123456789234780934789656730763214159826943129898 +980876432965410165690695678749821278934067015652010789 +801986501874321074321783265637832123653458234761001656 +212567988965010787210654104521945034562109101891012347 +123498677654321298323545003010876453078045610123456798 +034014576103432186789276512123289342199236769032347810 +145623985412545085652189467898100256787100898741016921 +898767234307696198543011056967221105107231239653455430 +745678101268987585654322343254339012218774381012768741 +234989089456789676789113698107448763329783498019889650 +101345674301410566541004567898758954458692567325676341 +013216765210323455632123476127667763067501101234765432 +322109876323454556789012981034554892155432101289876501 diff --git a/package.yaml b/package.yaml index 045fe24..1eb715d 100644 --- a/package.yaml +++ b/package.yaml @@ -16,6 +16,7 @@ dependencies: - linear - matrix - parallel + - recursion-schemes - safe - scientific - split @@ -48,7 +49,7 @@ library: - Day7 - Day8 - Day9 - # - Day10 + - Day10 # - Day11 # - Day12 # - Day13 diff --git a/src/Day10.hs b/src/Day10.hs new file mode 100644 index 0000000..32b0b20 --- /dev/null +++ b/src/Day10.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} + +module Day10 where + +import qualified Algebra.Graph as D +import qualified Algebra.Graph.AdjacencyMap as A +import qualified Algebra.Graph.AdjacencyMap.Algorithm as A +import qualified Algebra.Graph.Class as C +import Algebra.Graph.Export +import Algebra.Graph.Export.Dot (exportViaShow) +import Algebra.Graph.ToGraph +import qualified Algebra.Graph.Undirected as U +import Data.Attoparsec.Text (Parser, digit, many1', parseOnly, sepBy, space) +import Data.Bifunctor (bimap) +import Data.Either (fromRight) +import qualified Data.Foldable as F +import Data.Functor.Base (TreeF (..)) +import Data.Functor.Foldable +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (mapMaybe) +import Data.Monoid (Sum (..)) +import Data.Set (Set) +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Traversable as T +import qualified Data.Vector as V +import Debug.Trace +import GHC.Generics (Generic, Generic1) + +type Pos = Int +type Height = Int +type Score = Sum Int +type NodeV = (Pos, Height) +type NodeVS = (Pos, Height, Score) + +-- Recursion scheme thingies (why not?) +-- Isomorphic to Algebra.Graph.Graph +data GraF a b + = EmptyF + | VertexF a + | -- (V1, E1) + (V2, E2) = (V1 ∪ V2, E1 ∪ E2) + OverlayF b b + | -- (V1, E1) × (V2, E2) = (V1 ∪ V2, E1 ∪ E2 ∪ V1 × V2) + ConnectF b b + deriving + (Eq, Ord, Show, Read, Generic, Generic1, Functor, F.Foldable, T.Traversable) +type instance Base (D.Graph a) = GraF a +instance Recursive (D.Graph a) where + project D.Empty = EmptyF + project (D.Vertex v) = VertexF v + project (D.Overlay g1 g2) = OverlayF g1 g2 + project (D.Connect g1 g2) = ConnectF g1 g2 + +instance Corecursive (D.Graph a) where + embed EmptyF = D.Empty + embed (VertexF v) = D.Vertex v + embed (OverlayF g1 g2) = D.Overlay g1 g2 + embed (ConnectF g1 g2) = D.Connect g1 g2 + +-- Our own recursive Tree-like datatype +-- That type just happens to correspond to what adjacencyList returns! +newtype Treeish a = Treeish (a, [Treeish a]) + +-- I swear it's like a recursive Tree Functor +type instance Base (Treeish a) = TreeF a + +-- Now the "hard" part +instance Recursive (Treeish a) where + project (Treeish (x, xs)) = NodeF x xs + +instance Corecursive (Treeish a) where + embed (NodeF x xs) = Treeish (x, xs) + +myShow :: (Show a) => D.Graph a -> String +myShow = para $ \case + EmptyF -> "ε" + VertexF v -> show v + OverlayF (D.Vertex v1, _) (D.Vertex v2, _) -> + "(" <> show v1 <> "+" <> show v2 <> ")" + OverlayF (_, g1) (_, g2) -> "(" <> g1 <> "---" <> g2 <> ")" + ConnectF (D.Vertex v1, _) (D.Vertex v2, _) -> + "<" <> show v1 <> "×" <> show v2 <> ">" + ConnectF (_, g1) (_, g2) -> "<" <> g1 <> " × " <> g2 <> ">" + +legit :: D.Graph NodeV -> Bool +legit = para $ \case + EmptyF -> False + VertexF _v -> True + OverlayF (_, r1) (_, r2) -> r1 && r2 + ConnectF (D.Vertex (_, h1), _) (D.Vertex (_, h2), _) -> h2 == h1 + 1 + ConnectF (_, r1) (_, r2) -> r1 && r2 + +countStuff :: D.Graph NodeV -> Sum Int +countStuff g = foldMap go $ S.filter (\(_, h) -> h == 0) $ D.vertexSet g + where + go :: NodeV -> Sum Int + go v = Sum . length . filter (\(_, h) -> h == 9) $ reachable g v + +-- Part B + +countStuffB :: [(NodeV, [NodeV])] -> Int +countStuffB = extractSum . annotate10 + +annotate10 :: [(NodeV, [NodeV])] -> Map NodeV (Sum Int) +annotate10 xs = + annotate 0 xs -- ^ + . annotate 1 xs -- | + . annotate 2 xs -- | Walk back + . annotate 3 xs -- | from height 9 + . annotate 4 xs -- | to height 0 + . annotate 5 xs -- | + . annotate 6 xs -- | counting how many + . annotate 7 xs -- | ways to get to 9 + . annotate 8 xs -- | + . annotate 9 xs -- | + $ mempty + +annotate :: + Height -> [(NodeV, [NodeV])] -> Map NodeV (Sum Int) -> Map NodeV (Sum Int) +annotate 9 xs _ = + M.fromList . map ((,Sum 1) . fst) . filter ((== 9) . snd . fst) $ xs +annotate h xs acc = + foldr go' acc . filter ((== h) . snd . fst) $ xs + where + go' :: (NodeV, [NodeV]) -> Map NodeV (Sum Int) -> Map NodeV (Sum Int) + go' (v, nx) = + M.insert v (F.fold $ M.restrictKeys acc (S.fromList nx)) + +extractSum :: Map NodeV (Sum Int) -> Int +extractSum = getSum . M.foldrWithKey go mempty + where + go :: NodeV -> Sum Int -> Sum Int -> Sum Int + go (_, 0) s acc = s <> acc + go _ _ acc = acc + +-- From Algebra.Graph.* +showGraph :: + (Show a, Ord a, C.Graph g, ToGraph g, ToVertex g ~ a) => g -> String +showGraph = render . export vDoc eDoc + where + vDoc x = literal (show x) <> "\n" + eDoc x y = literal (show x) <> " - " <> literal (show y) <> "\n" + +writeGraphOut :: + (Show a, Ord a, C.Graph g, ToGraph g, ToVertex g ~ a) => g -> IO () +writeGraphOut = writeFile "graph.dot" . exportViaShow + +-- "Newton" neighboring topology were two points from a 2D grid are neighbors +-- if they are on the same line or column (up,down,left,right) +-- (the name comes from http://mgs.lacl.fr/Online_Manual/Collections.html) +-- Pos is the indexing order from "bottom" to "top", "left" to "right" +-- +-- Example for newtonNeighboring 3: +-- 6-7-8 +-- | | | "4" has 4 neighbors [1,3,7,5] +-- 3-4-5 -> "2" has 2 neighbors [1,5] +-- | | | "7" has 3 neighbors [4,6,8] +-- 0-1-2 +newtonNeighboring :: Int -> U.Graph Pos +newtonNeighboring n = + U.edges $ + concatMap + ( filter (\(x, x') -> x >= 0 && x < n2 && x' >= 0 && x' < n2) + . indexFromCoord + . coordFromIndex + ) + [0 .. n2 - 1] + where + n2 = n * n + coordFromIndex :: Int -> [((Int, Int), (Int, Int))] + coordFromIndex i = + [ ((x, y), (x, y + 1)) -- up + , ((x, y), (x, y - 1)) -- down + , ((x, y), (x + 1, y)) -- right + , ((x, y), (x - 1, y)) -- left + ] + where + x = i `mod` n + y = i `div` n + indexFromCoord :: [((Int, Int), (Int, Int))] -> [(Int, Int)] + indexFromCoord = mapMaybe go + where + go (c1, c2) = do + i1 <- c2i c1 + i2 <- c2i c2 + pure (i1, i2) + c2i (x, y) | x >= 0 && x < n = Just $ y * n + x + c2i _ = Nothing + +parseInput :: Parser (Int, V.Vector Int) +parseInput = do + p <- many1' parseDigit `sepBy` space + let l = length . (!! 0) $ p + let v = V.fromList . concat $ p + pure (l, v) + +parseDigit :: Parser Int +parseDigit = read . (: []) <$> digit + +buildNewtonGraph :: Int -> V.Vector Int -> U.Graph (Pos, Int) +buildNewtonGraph n v = fmap setValue ng + where + ng = newtonNeighboring n + setValue :: Pos -> (Pos, Int) + setValue p = (p, v V.! p) + +buildGraph :: T.Text -> D.Graph (Int, Int) +buildGraph txt = g' + where + (n, vals) = + fromRight (0, V.empty) . parseOnly parseInput . T.unlines . reverse . T.lines $ + txt + g = U.fromUndirected $ buildNewtonGraph n vals + g' = D.edges (filter isHikingTrail $ D.edgeList g) + isHikingTrail ((_, v1), (_, v2)) = v2 == v1 + 1 + +solveB :: (Show a) => a -> a +solveB = undefined + +inputEx :: T.Text +inputEx = + T.unlines + [ "89010123" + , "78121874" + , "87430965" + , "96549874" + , "45678903" + , "32019012" + , "01329801" + , "10456732" + ] + +otherInputEx :: T.Text +otherInputEx = + T.unlines + [ "1011911" -- 42 43 44 45 46 47 48 + , "2111811" -- 35 36 37 38 39 40 41 + , "3111711" -- 28 29 30 31 32 33 34 + , "4567654" -- 21 22 23 24 25 26 27 + , "1118113" -- 14 15 16 17 18 19 20 + , "1119112" -- 07 08 09 10 11 12 13 + , "1111101" -- 00 01 02 03 04 05 06 + ] + +smallInputEx :: T.Text +smallInputEx = + T.unlines + [ "210" -- 06 07 08 + , "121" -- 03 04 05 + , "032" -- 00 01 02 + ] + +main :: IO () +main = do + input <- T.readFile "inputs/day10.input" + putStrLn "Part 1" + let g = buildGraph input + print . countStuff $ g + putStrLn "Part 2" + print . countStuffB $ D.adjacencyList g + +-- print $ solveB input