{-# 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.IntMap (IntMap)
import Data.IntMap qualified as IntMapInt
import Data.List (permutations, sort, foldl')
import Data.Map (Map)
import Data.Map qualified as Map

-- | >>> :main
-- 355
-- 983030
main :: IO ()
main :: IO ()
main =
 do [([String], [String])]
inp <- [format|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 (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 (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. 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. [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)
traverse String -> Maybe Int
rewire [String]
xs Maybe [Int] -> Maybe [Int] -> Maybe [Int]
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)
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 (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