--- Writeup at https://work.njae.me.uk/2021/12/04/advent-of-code-2021-day-4/
+-- Writeup at https://work.njae.me.uk/2021/12/09/advent-of-code-2021-day-8/
+
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)
-
-
-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
+ deriving (Eq, Ord, Show, Enum, Bounded)
-countUniques (Display _ outputs) = length uniqLens
- where outLens = map length outputs
- uniqLens = outLens `intersect` uniqueLengths
+type Encoding = M.Map Char Segment
+type DigitSegments = M.Map (S.Set Segment) Char
-uniqueLengths = [2, 3, 4, 7]
+-- some constants
+segmentNames :: [Char]
+segmentNames = "abcdefg"
-segmentNames = S.fromList "abcdefg"
+segments :: [Segment]
+segments = [Seg1 .. Seg7]
digitSegments :: DigitSegments
digitSegments = M.fromList
]
--- combine = M.unionWith intersect
+main :: IO ()
+main =
+ do text <- TIO.readFile "data/advent08.txt"
+ let displays = successfulParse text
+ print $ part1 displays
+ print $ part2 displays
+
+part1 :: [Display] -> Int
+part1 displays = sum $ map countUniques displays
+part2 :: [Display] -> Int
part2 displays = sum $ map decodeOneDisplay displays
-decodeOneDisplay display = findCode invAllocation display
+countUniques :: Display -> Int
+countUniques (Display _ outputs) = length uniqLens
+ where outLens = map length outputs
+ uniqLens = outLens `intersect` uniqueLengths
+
+uniqueLengths :: [Int]
+uniqueLengths = [2, 3, 4, 7]
+
+decodeOneDisplay :: Display -> Int
+decodeOneDisplay display = findCode allocation 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
+
+
+
+allocate :: Display -> Encoding
+allocate (Display examples _) = head $ validEncodings
+ where allEncodings = map (\segs -> M.fromList $ zip segmentNames segs)
+ $ permutations segments
+ validEncodings = filter (isValidEncoding examples) allEncodings
+
+segmentsOfSignal :: Encoding -> [Char] -> S.Set Segment
+segmentsOfSignal encoding signal = S.fromList $ map (encoding ! ) signal
+
+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
-- Parse the input file
projects / advent-of-code-21.git / blobdiff