From 44f075be0a9e6b637d93d35b5cea705ca2e1b1f4 Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Wed, 8 Dec 2021 14:24:43 +0000 Subject: [PATCH] Done again with brute force --- advent-of-code21.cabal | 5 ++ advent08/Main-longwinded.hs | 138 ++++++++++++++++++++++++++++++++++++ advent08/Main.hs | 95 +++++++++---------------- 3 files changed, 175 insertions(+), 63 deletions(-) create mode 100644 advent08/Main-longwinded.hs diff --git a/advent-of-code21.cabal b/advent-of-code21.cabal index 82dc2ad..c3b8977 100644 --- a/advent-of-code21.cabal +++ b/advent-of-code21.cabal @@ -119,3 +119,8 @@ executable advent08 import: common-extensions, build-directives main-is: advent08/Main.hs build-depends: text, attoparsec, containers + +executable advent08a + import: common-extensions, build-directives + main-is: advent08/Main-longwinded.hs + build-depends: text, attoparsec, containers diff --git a/advent08/Main-longwinded.hs b/advent08/Main-longwinded.hs new file mode 100644 index 0000000..5e51f28 --- /dev/null +++ b/advent08/Main-longwinded.hs @@ -0,0 +1,138 @@ +-- Writeup at https://work.njae.me.uk/2021/12/04/advent-of-code-2021-day-4/ + +import Data.Text () +import qualified Data.Text.IO as TIO + +import Data.Attoparsec.Text +import Control.Applicative + +import Data.List hiding ((\\)) +import qualified Data.Map.Strict as M +import Data.Map.Strict ((!)) +import qualified Data.Set as S +import Data.Set ((\\)) + +data Display = Display [String] [String] -- patterns, output + deriving (Eq, Show) + +type Assignments = M.Map Segment (S.Set Char) +type Encoding = M.Map Char Segment +type DigitSegments = M.Map (S.Set Segment) Char + +data Segment = Seg1 | Seg2 | Seg3 | Seg4 | Seg5 | Seg6 | Seg7 + deriving (Eq, Ord, Show) + + +main :: IO () +main = + do text <- TIO.readFile "data/advent08.txt" + let displays = successfulParse text + print $ part1 displays + print $ part2 displays + -- let td = successfulParse "acedgfb cdfbe gcdfa fbcad dab cefabd cdfgeb eafb cagedb ab | cdfeb fcadb cdfeb cdbaf" + -- print $ part2 td + +part1 displays = sum $ map countUniques displays + +countUniques (Display _ outputs) = length uniqLens + where outLens = map length outputs + uniqLens = outLens `intersect` uniqueLengths + +uniqueLengths = [2, 3, 4, 7] + +segmentNames = S.fromList "abcdefg" + +digitSegments :: DigitSegments +digitSegments = M.fromList + [ (S.fromList [Seg1, Seg2, Seg3, Seg5, Seg6, Seg7], '0') + , (S.fromList [Seg3, Seg6], '1') + , (S.fromList [Seg1, Seg3, Seg4, Seg5, Seg7], '2') + , (S.fromList [Seg1, Seg3, Seg4, Seg6, Seg7], '3') + , (S.fromList [Seg2, Seg3, Seg4, Seg6], '4') + , (S.fromList [Seg1, Seg2, Seg4, Seg6, Seg7], '5') + , (S.fromList [Seg1, Seg2, Seg4, Seg5, Seg6, Seg7], '6') + , (S.fromList [Seg1, Seg3, Seg6], '7') + , (S.fromList [Seg1, Seg2, Seg3, Seg4, Seg5, Seg6, Seg7], '8') + , (S.fromList [Seg1, Seg2, Seg3, Seg4, Seg6, Seg7], '9') + ] + + +-- combine = M.unionWith intersect + +part2 displays = sum $ map decodeOneDisplay displays + +decodeOneDisplay display = findCode invAllocation display + where allocation = allocate display + invAllocation = invertAssignment allocation + +allocate :: Display -> Assignments +allocate (Display examples _) = assignments6 + where + -- segments 3 and 6 are given by pattern of length 2 (digit 1) + dSegs1 = S.fromList $ head $ filter ((== 2) . length) examples + assignments0 = M.fromList [(Seg3, dSegs1), (Seg6, dSegs1)] + -- segment 1 is the one in pattern of length 3 (digit 7) that's + -- not in segments for digit 1 + dSegs7 = S.fromList $ head $ filter ((== 3) . length) examples + assignments1 = M.insert Seg1 (dSegs7 \\ dSegs1) assignments0 + -- segments 2 and 4 are the ones in pattern of length 4 (digit 4) + -- that aren't in pattern for digit 1 + dSegs4 = (S.fromList $ head $ filter ((== 4) . length) examples) \\ dSegs1 + -- segments 1, 4, 7 are the common ones in digits 2, 3, 5 + dSegs235 = S.fromList $ foldl1' intersect $ filter ((== 5) . length) examples + -- segment 4 is the common one with digit 4 + seg4 = dSegs235 `S.intersection` dSegs4 + -- segment 2 is the other one from digit 4 + seg2 = dSegs4 \\ seg4 + assignments2 = M.union (M.fromList [(Seg2, seg2), (Seg4, seg4)]) assignments1 + -- we now know segments 1 and 4, so deduce segment 7 + seg7 = dSegs235 \\ (S.union (assignments2!Seg1) (assignments2!Seg4)) + assignments3 = M.union (M.singleton Seg7 seg7) assignments2 + -- of the 5-segment digits, segment 2 only in digit 5 + seg2c = head $ S.toList seg2 + dSegs5 = S.fromList $ head $ filter (elem seg2c) $ filter ((== 5) . length) examples + -- remove known values of segments 1, 2, 4, 7 + segs1247 = S.unions $ M.elems $ assignments3 `M.restrictKeys` (S.fromList [Seg1, Seg2, Seg4, Seg7]) + -- segs1247 = S.unions [assignments3!Seg1, assignments3!Seg2, + -- assignments3!Seg4, assignments3!Seg7] + -- what's left is segment 6 + seg6 = dSegs5 \\ segs1247 + assignments4 = M.insert Seg6 seg6 assignments3 + -- segment 3 can't be the same allocation as segment 6 + assignments5 = M.insert Seg3 ((assignments4!Seg3) \\ seg6) assignments4 + -- segment 5 is the only one left + seg5 = segmentNames \\ (S.unions $ M.elems assignments5) + assignments6 = M.insert Seg5 seg5 assignments5 + + +invertAssignment assignment = M.foldrWithKey inv1 M.empty assignment + where inv1 seg vals invMap = M.insert (head $ S.elems vals) seg invMap + + +findDigit :: Encoding -> [Char] -> Char +findDigit segmentAssignments code = digitSegments ! segments + where codeSet = S.fromList code + segmentMap = M.restrictKeys segmentAssignments codeSet + segments = S.fromList $ M.elems segmentMap + +findDigits :: Encoding -> [[Char]] -> [Char] +findDigits segmentAssignments codes = map (findDigit segmentAssignments) codes + +findCode :: Encoding -> Display -> Int +findCode segmentAssignments (Display _ codes) = read $ findDigits segmentAssignments codes + + + +-- Parse the input file + +displaysP = displayP `sepBy` endOfLine +displayP = Display <$> (patternsP <* " | ") <*> patternsP + +patternsP = patternP `sepBy` " " +patternP = many1 letter + +-- successfulParse :: Text -> (Integer, [Maybe Integer]) +successfulParse input = + case parseOnly displaysP input of + Left _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err + Right displays -> displays diff --git a/advent08/Main.hs b/advent08/Main.hs index 5e51f28..6e5c419 100644 --- a/advent08/Main.hs +++ b/advent08/Main.hs @@ -4,23 +4,21 @@ import Data.Text () import qualified Data.Text.IO as TIO import Data.Attoparsec.Text -import Control.Applicative +-- import Control.Applicative -import Data.List hiding ((\\)) +import Data.List import qualified Data.Map.Strict as M import Data.Map.Strict ((!)) import qualified Data.Set as S -import Data.Set ((\\)) data Display = Display [String] [String] -- patterns, output deriving (Eq, Show) -type Assignments = M.Map Segment (S.Set Char) type Encoding = M.Map Char Segment type DigitSegments = M.Map (S.Set Segment) Char data Segment = Seg1 | Seg2 | Seg3 | Seg4 | Seg5 | Seg6 | Seg7 - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Enum, Bounded) main :: IO () @@ -29,18 +27,30 @@ main = let displays = successfulParse text print $ part1 displays print $ part2 displays - -- let td = successfulParse "acedgfb cdfbe gcdfa fbcad dab cefabd cdfgeb eafb cagedb ab | cdfeb fcadb cdfeb cdbaf" - -- print $ part2 td +part1 :: [Display] -> Int part1 displays = sum $ map countUniques displays +part2 :: [Display] -> Int +part2 displays = sum $ map decodeOneDisplay displays + +countUniques :: Display -> Int countUniques (Display _ outputs) = length uniqLens where outLens = map length outputs uniqLens = outLens `intersect` uniqueLengths +uniqueLengths :: [Int] uniqueLengths = [2, 3, 4, 7] -segmentNames = S.fromList "abcdefg" +decodeOneDisplay :: Display -> Int +decodeOneDisplay display = findCode allocation display + where allocation = allocate display + +segmentNames :: [Char] +segmentNames = "abcdefg" + +segments :: [Segment] +segments = [Seg1 .. Seg7] digitSegments :: DigitSegments digitSegments = M.fromList @@ -56,70 +66,29 @@ digitSegments = M.fromList , (S.fromList [Seg1, Seg2, Seg3, Seg4, Seg6, Seg7], '9') ] +allocate :: Display -> Encoding +allocate (Display examples _) = head $ validEncodings + where allEncodings = map (\segs -> M.fromList $ zip segmentNames segs) + $ permutations segments + validEncodings = filter (isValidEncoding examples) allEncodings --- combine = M.unionWith intersect - -part2 displays = sum $ map decodeOneDisplay displays +segmentsOfSignal :: Encoding -> [Char] -> S.Set Segment +segmentsOfSignal encoding signal = S.fromList $ map (encoding ! ) signal -decodeOneDisplay display = findCode invAllocation display - where allocation = allocate display - invAllocation = invertAssignment allocation - -allocate :: Display -> Assignments -allocate (Display examples _) = assignments6 - where - -- segments 3 and 6 are given by pattern of length 2 (digit 1) - dSegs1 = S.fromList $ head $ filter ((== 2) . length) examples - assignments0 = M.fromList [(Seg3, dSegs1), (Seg6, dSegs1)] - -- segment 1 is the one in pattern of length 3 (digit 7) that's - -- not in segments for digit 1 - dSegs7 = S.fromList $ head $ filter ((== 3) . length) examples - assignments1 = M.insert Seg1 (dSegs7 \\ dSegs1) assignments0 - -- segments 2 and 4 are the ones in pattern of length 4 (digit 4) - -- that aren't in pattern for digit 1 - dSegs4 = (S.fromList $ head $ filter ((== 4) . length) examples) \\ dSegs1 - -- segments 1, 4, 7 are the common ones in digits 2, 3, 5 - dSegs235 = S.fromList $ foldl1' intersect $ filter ((== 5) . length) examples - -- segment 4 is the common one with digit 4 - seg4 = dSegs235 `S.intersection` dSegs4 - -- segment 2 is the other one from digit 4 - seg2 = dSegs4 \\ seg4 - assignments2 = M.union (M.fromList [(Seg2, seg2), (Seg4, seg4)]) assignments1 - -- we now know segments 1 and 4, so deduce segment 7 - seg7 = dSegs235 \\ (S.union (assignments2!Seg1) (assignments2!Seg4)) - assignments3 = M.union (M.singleton Seg7 seg7) assignments2 - -- of the 5-segment digits, segment 2 only in digit 5 - seg2c = head $ S.toList seg2 - dSegs5 = S.fromList $ head $ filter (elem seg2c) $ filter ((== 5) . length) examples - -- remove known values of segments 1, 2, 4, 7 - segs1247 = S.unions $ M.elems $ assignments3 `M.restrictKeys` (S.fromList [Seg1, Seg2, Seg4, Seg7]) - -- segs1247 = S.unions [assignments3!Seg1, assignments3!Seg2, - -- assignments3!Seg4, assignments3!Seg7] - -- what's left is segment 6 - seg6 = dSegs5 \\ segs1247 - assignments4 = M.insert Seg6 seg6 assignments3 - -- segment 3 can't be the same allocation as segment 6 - assignments5 = M.insert Seg3 ((assignments4!Seg3) \\ seg6) assignments4 - -- segment 5 is the only one left - seg5 = segmentNames \\ (S.unions $ M.elems assignments5) - assignments6 = M.insert Seg5 seg5 assignments5 - - -invertAssignment assignment = M.foldrWithKey inv1 M.empty assignment - where inv1 seg vals invMap = M.insert (head $ S.elems vals) seg invMap +isValidEncoding :: [[Char]] -> Encoding -> Bool +isValidEncoding examples encoding = + all (\e -> M.member e digitSegments) exampleSegments + where exampleSegments = map (segmentsOfSignal encoding) examples findDigit :: Encoding -> [Char] -> Char -findDigit segmentAssignments code = digitSegments ! segments - where codeSet = S.fromList code - segmentMap = M.restrictKeys segmentAssignments codeSet - segments = S.fromList $ M.elems segmentMap +findDigit encoding code = digitSegments ! (segmentsOfSignal encoding code) findDigits :: Encoding -> [[Char]] -> [Char] -findDigits segmentAssignments codes = map (findDigit segmentAssignments) codes +findDigits encoding codes = map (findDigit encoding) codes findCode :: Encoding -> Display -> Int -findCode segmentAssignments (Display _ codes) = read $ findDigits segmentAssignments codes +findCode encoding (Display _ codes) = read $ findDigits encoding codes -- 2.34.1