Compare commits

..

No commits in common. "0e049e7b83aef394c960328e8ddc26dcd5c250c0" and "8719522be0ea5fc9a2a4eacde104d8d3c39b3e3b" have entirely different histories.

3 changed files with 15 additions and 84 deletions

View File

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

View File

@ -1,45 +0,0 @@
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

22
aoc.hs
View File

@ -60,8 +60,6 @@ starsAndBars 0 b = [replicate (b+1) 0]
starsAndBars n 0 = [[n]] starsAndBars n 0 = [[n]]
starsAndBars n b = map (0:) (starsAndBars n (b-1)) ++ map (\xs -> head xs + 1 : tail xs) (starsAndBars (n-1) b) 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' :: ([[a]] -> b) -> Maybe a -> [a] -> [a] -> [a] -> [b]
kernelMapRow' kernel x kernelMapRow' kernel x
(a:r0@(b:c:_)) (a:r0@(b:c:_))
@ -83,23 +81,3 @@ kernelMap' kernel Nothing [_, _] = []
kernelMap :: ([[a]] -> b) -> Maybe a -> [[a]] -> [[b]] kernelMap :: ([[a]] -> b) -> Maybe a -> [[a]] -> [[b]]
kernelMap kernel (Just x) as = kernelMap' kernel (Just x) ((map (const x) (head as)):as) kernelMap kernel (Just x) as = kernelMap' kernel (Just x) ((map (const x) (head as)):as)
kernelMap kernel Nothing as = kernelMap' kernel Nothing 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 []