Day 10

.gitignore

@@ -3,3 +3,5 @@ result*
 dist-newstyle
 *.eventlog
 *.prof
+*.dot
+*.pdf

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

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": {

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

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

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