Refactor 2015 Day 07

2015/day07/day07.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
+
 import Aoc
 import Data.Char ( isDigit )
 import Data.Bits
@@ -22,27 +24,27 @@ eval AND = (.&.)
 eval SHIFTR = shiftR
 eval SHIFTL = shiftL
 eval CONST = const
-eval NOT = \a _-> complement a
+eval NOT = const' complement
 
-eval' :: Op -> Int -> Int -> Int
-eval' op arg1 arg2 = (.&. 0xFFFF) $ eval op arg1 arg2
-
-eval'' :: [(String, (Op, String, String))] -> [(String, Int)] -> String -> (Int, [(String, Int)])
-eval'' wires memos label = case lookup label memos of
-    Just value -> (value, memos)
-    Nothing -> case lookup label wires of
+evalM :: [(String, (Op, String, String))] -> MemoF String Int
+evalM wires = memoise $ \values label ->
+    case lookup label wires of
         Just (op, arg1, arg2) ->
-            let (val1, memos1) = eval'' wires memos arg1 in
-            let (val2, memos2) = eval'' wires memos1 arg2 in
-            let val = eval' op val1 val2 in
-            (val, (label, val):memos2)
-        Nothing -> (if all isDigit label then read label else undefined, memos) -- if null label then 0 else 
+            let 
+                (arg1', values') = evalM wires values arg1 
+                (arg2', values'') = evalM wires values' arg2
+            in
+                (eval op arg1' arg2' .&. 0xFFFF, values'')
+        Nothing ->
+            if all isDigit label 
+                then (read label, values)
+                else error label
 
 part1 :: [(String, (Op, String, String))] -> Int
-part1 wires = fst $ eval'' wires [] "a"
+part1 wires = unmemo (evalM wires) "a"
 
 part2 :: [(String, (Op, String, String))] -> Int -> Int
-part2 wires part1Answer = fst $ eval'' wires [("b", part1Answer)] "a"
+part2 wires part1Answer = fst $ evalM wires [("b", part1Answer)] "a"
 
 main :: IO ()
 main = aocMain' parseFile (dup . part1) part2

2024/day05/day05.hs

@@ -0,0 +1,45 @@
+import Aoc
+import Data.List.Split ( splitOn )
+import Control.Arrow ( second, first )
+import Data.List ( nub, partition, sort )
+import Data.Maybe ( fromMaybe )
+
+parseFile :: [String] -> ([(Int, [Int])], [[Int]])
+parseFile lines =
+    let 
+        [rules, pages] = splitOn [""] lines
+        rules' = map (pair . map read . splitOn "|") rules
+        mentioned = nub $ concatMap unpair rules'
+        getAll a = map snd $ filter ((==a) . fst) rules' 
+    in
+    (zip mentioned (map getAll mentioned), map (map read . splitOn ",") pages)
+    
+takeMiddle :: [a] -> a
+takeMiddle xs = xs !! (length xs `div` 2)
+
+isSafe :: [(Int, [Int])] -> [Int] -> Bool
+isSafe rules = fst . foldl isSafe' (True, [])
+    where
+        isSafe' (False, prev) _ = (False, prev)
+        isSafe' (True, prev) a = (fromMaybe True $ not . any (`elem` prev) <$> lookup a rules, a:prev)
+
+part1 :: ([(Int, [Int])], [[Int]]) -> (Int, [[Int]])
+part1 (rules, pages) = first (sum . map takeMiddle) $ partition (isSafe rules) pages
+
+part2 :: ([(Int, [Int])], [[Int]]) -> [[Int]] -> Int
+part2 (rules, _) = sum . map (takeMiddle . reorder)
+    where
+        getPosM rules = memoise $ \values n ->
+            let ns = fromMaybe [] $ lookup n rules in
+            if null ns 
+                then (0, values)
+                else
+                    let (ns', values') = memoMap (getPosM rules) values ns in
+                    (maximum ns' + 1, values')
+
+        reorder ns =
+            let rules' = map (second $ filter (`elem` ns)) $ filter ((`elem` ns) . fst) rules in
+            map snd $ sort $ zip (unmemo (memoMap $ getPosM rules') ns) ns
+
+main :: IO ()
+main = aocMain' parseFile part1 part2

aoc.hs

@@ -60,6 +60,8 @@ starsAndBars 0 b = [replicate (b+1) 0]
 starsAndBars n 0 = [[n]]
 starsAndBars n b = map (0:) (starsAndBars n (b-1)) ++ map (\xs -> head xs + 1 : tail xs) (starsAndBars (n-1) b)
 
+-- Kernel
+
 kernelMapRow' :: ([[a]] -> b) -> Maybe a -> [a] -> [a] -> [a] -> [b]
 kernelMapRow' kernel x
     (a:r0@(b:c:_))
@@ -81,3 +83,23 @@ kernelMap' kernel Nothing [_, _] = []
 kernelMap :: ([[a]] -> b) -> Maybe a -> [[a]] -> [[b]]
 kernelMap kernel (Just x) as = kernelMap' kernel (Just x) ((map (const x) (head as)):as)
 kernelMap kernel Nothing as = kernelMap' kernel Nothing as
+
+-- Memoisation
+
+type MemoF' a b a' b' = Eq a' => [(a', b')] -> a -> (b, [(a', b')])
+type MemoF a b = MemoF' a b a b
+
+memoise :: Eq a => MemoF a b -> MemoF a b
+memoise f values a = case lookup a values of
+    Just b -> (b, values)
+    Nothing -> let (b, values') = f values a in (b, (a, b):values')
+
+memoMap :: MemoF' a b a' b' -> MemoF' [a] [b] a' b'
+memoMap f values [] = ([], values)
+memoMap f values (a:as) =
+    let (b, values') = f values a in
+    let (bs, values'') = memoMap f values' as in
+    (b:bs, values'')
+
+unmemo :: Eq a' => MemoF' a b a' b' -> a -> b
+unmemo f = fst . f []