{-# 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.

-}
module Main (main) where

import Advent (countBy, format, fromDigits)
import Data.Bits (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 [([String], [String])]
inp <- [format|2021 8 (%s&  %| %s& %n)*|]
    let outs :: [[Int]]
outs = (([String], [String]) -> [Int])
-> [([String], [String])] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map ([String], [String]) -> [Int]
solve [([String], [String])]
inp
    Int -> IO ()
forall a. Show a => a -> IO ()
print ((Int -> Bool) -> [Int] -> Int
forall (f :: * -> *) a. Foldable f => (a -> Bool) -> f a -> Int
countBy (Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
1,Int
4,Int
7,Int
8]) ([[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Int]]
outs))
    Int -> IO ()
forall a. Show a => a -> IO ()
print ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (([Int] -> Int) -> [[Int]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [Int] -> Int
forall a. (HasCallStack, Integral a) => a -> [a] -> a
fromDigits Int
10) [[Int]]
outs))

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

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