{-# Language ImportQualifiedPost, QuasiQuotes #-}
{-|
Module      : Main
Description : Day 8 solution
Copyright   : (c) Eric Mertens, 2021
License     : ISC
Maintainer  : emertens@gmail.com

<https://adventofcode.com/2021/day/8>

Figure out how the miswired segment display works.

>>> :{
:main +
"acedgfb cdfbe gcdfa fbcad dab cefabd cdfgeb eafb cagedb ab | cdfeb fcadb cdfeb cdbaf
"
:}
0
5353

>>> :{
:main +
"be cfbegad cbdgef fgaecd cgeb fdcge agebfd fecdb fabcd edb | fdgacbe cefdb cefbgd gcbe
edbfga begcd cbg gc gcadebf fbgde acbgfd abcde gfcbed gfec | fcgedb cgb dgebacf gc
fgaebd cg bdaec gdafb agbcfd gdcbef bgcad gfac gcb cdgabef | cg cg fdcagb cbg
fbegcd cbd adcefb dageb afcb bc aefdc ecdab fgdeca fcdbega | efabcd cedba gadfec cb
aecbfdg fbg gf bafeg dbefa fcge gcbea fcaegb dgceab fcbdga | gecf egdcabf bgf bfgea
fgeab ca afcebg bdacfeg cfaedg gcfdb baec bfadeg bafgc acf | gebdcfa ecba ca fadegcb
dbcfg fgd bdegcaf fgec aegbdf ecdfab fbedc dacgb gdcebf gf | cefg dcbef fcge gbcadfe
bdfegc cbegaf gecbf dfcage bdacg ed bedf ced adcbefg gebcd | ed bcgafe cdgba cbgef
egadfb cdbfeg cegd fecab cgb gbdefca cg fgcdab egfdb bfceg | gbdfcae bgc cg cgb
gcafb gcf dcaebfg ecagb gf abcdeg gaef cafbge fdbac fegbdc | fgae cfgab fg bagce
"
:}
26
61229

-}
module Main (main) where

import Advent (countBy, format, fromDigits)
import Data.Bits (setBit)
import Data.Char (ord)
import Data.List (permutations, foldl')
import Data.Map (Map)
import Data.Map qualified as Map

-- | >>> :main
-- 355
-- 983030
main :: IO ()
IO ()
main =
 do inp <- [format|2021 8 ((%s )*%|( %s)*%n)*|]
    let outs = (([String], [String]) -> [Int])
-> [([String], [String])] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map ([String], [String]) -> [Int]
solve [([String], [String])]
inp
    print (countBy (`elem` [1,4,7,8]) (concat outs))
    print (sum (map (fromDigits 10) outs))

wires :: String
wires :: String
wires = [Char
'a'..Char
'g']

-- | Mapping from active line segments to digits using this arrangement.
--
-- @
--   0:      1:      2:      3:      4:
--  aaaa    ....    aaaa    aaaa    ....
-- b    c  .    c  .    c  .    c  b    c
-- b    c  .    c  .    c  .    c  b    c
--  ....    ....    dddd    dddd    dddd
-- e    f  .    f  e    .  .    f  .    f
-- e    f  .    f  e    .  .    f  .    f
--  gggg    ....    gggg    gggg    ....
--
--   5:      6:      7:      8:      9:
--  aaaa    aaaa    aaaa    aaaa    aaaa
-- b    .  b    .  .    c  b    c  b    c
-- b    .  b    .  .    c  b    c  b    c
--  dddd    dddd    ....    dddd    dddd
-- .    f  e    f  .    f  e    f  .    f
-- .    f  e    f  .    f  e    f  .    f
--  gggg    gggg    ....    gggg    gggg
-- @
digits :: Map String Int
digits :: Map String Int
digits = [(String, Int)] -> Map String Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([String] -> [Int] -> [(String, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String
"abcefg",String
"cf",String
"acdeg",String
"acdfg",String
"bcdf",String
"abdfg",String
"abdefg",String
"acf",String
"abcdefg",String
"abcdfg"] [Int
0..Int
9])

-- | All the possible reassignments of wires
mappings :: [Map Int Int]
mappings :: [Map Int Int]
mappings =
  [ (String -> Int) -> Map String Int -> Map Int Int
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys (String -> Int
toBitMask (String -> Int) -> (String -> String) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (Map Char Char
assignment Map Char Char -> Char -> Char
forall k a. Ord k => Map k a -> k -> a
Map.!)) Map String Int
digits
    | String
wires' <- String -> [String]
forall a. [a] -> [[a]]
permutations String
wires
    , let assignment :: Map Char Char
assignment = [(Char, Char)] -> Map Char Char
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (String -> String -> [(Char, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip String
wires String
wires')
  ]

-- | Given a list of segment examples and outputs decode the outputs.
solve :: ([String], [String]) -> [Int]
solve :: ([String], [String]) -> [Int]
solve ([String]
xs, [String]
ys) = [[Int]] -> [Int]
forall a. HasCallStack => [a] -> a
head
  [ [Int]
out
  | Map Int Int
mapping <- [Map Int Int]
mappings
  , let rewire :: String -> Maybe Int
rewire String
x = Int -> Map Int Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (String -> Int
toBitMask String
x) Map Int Int
mapping
  , Just [Int]
out <- [(String -> Maybe Int) -> [String] -> Maybe [Int]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse String -> Maybe Int
rewire [String]
xs Maybe [Int] -> Maybe [Int] -> Maybe [Int]
forall a b. Maybe a -> Maybe b -> Maybe b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (String -> Maybe Int) -> [String] -> Maybe [Int]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse String -> Maybe Int
rewire [String]
ys]
  ]

-- | Convert the segment labels to a more efficient characteristic 'Int'
toBitMask :: String -> Int
toBitMask :: String -> Int
toBitMask = (Int -> Char -> Int) -> Int -> String -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
acc Char
x -> Int -> Int -> Int
forall a. Bits a => a -> Int -> a
setBit Int
acc (Char -> Int
ord Char
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'a')) Int
0