{-|
Module:         Day13
Description:    <https://adventofcode.com/2021/day/13 Day 13: Transparent Origami>
-}
{-# LANGUAGE FlexibleContexts, OverloadedStrings, TupleSections, TypeApplications, TypeFamilies #-}
module Day13 (day13a, day13b) where

import Control.Arrow ((&&&), (***))
import Data.Array.Unboxed (UArray, accumArray, elems)
import Data.List.Split (chunksOf)
import Data.Semigroup (Max(..), Min(..))
import qualified Data.Set as Set (fromList, size)
import Data.String (IsString)
import Data.Text (Text)
import Data.Void (Void)
import Text.Megaparsec (MonadParsec, ParseErrorBundle, Token, Tokens, (<|>), chunk, eof, parse, sepEndBy, sepEndBy1, single)
import Text.Megaparsec.Char (newline)
import Text.Megaparsec.Char.Lexer (decimal)

parsePair :: (Num a, MonadParsec e s m, Token s ~ Char) => m (a, a)
parsePair :: m (a, a)
parsePair = (a -> a -> (a, a)) -> a -> a -> (a, a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) (a -> a -> (a, a)) -> m a -> m (a -> (a, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal m (a -> (a, a)) -> m Char -> m (a -> (a, a))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token s -> m (Token s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token s
',' m (a -> (a, a)) -> m a -> m (a, a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m a
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal

parseFold :: (Num a, Ord a, MonadParsec e s m, Token s ~ Char, IsString (Tokens s)) => m ((a, a) -> (a, a))
parseFold :: m ((a, a) -> (a, a))
parseFold = Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens s
"fold along " m (Tokens s)
-> m (a -> (a, a) -> (a, a)) -> m (a -> (a, a) -> (a, a))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (a -> (a, a) -> (a, a)
forall a. (Num a, Ord a) => a -> (a, a) -> (a, a)
foldX (a -> (a, a) -> (a, a)) -> m Char -> m (a -> (a, a) -> (a, a))
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token s -> m (Token s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token s
'x' m (a -> (a, a) -> (a, a))
-> m (a -> (a, a) -> (a, a)) -> m (a -> (a, a) -> (a, a))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> (a, a) -> (a, a)
forall a. (Num a, Ord a) => a -> (a, a) -> (a, a)
foldY (a -> (a, a) -> (a, a)) -> m Char -> m (a -> (a, a) -> (a, a))
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token s -> m (Token s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token s
'y') m (a -> (a, a) -> (a, a)) -> m a -> m ((a, a) -> (a, a))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Token s -> m (Token s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token s
'=' m Char -> m a -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m a
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal)

foldX, foldY :: (Num a, Ord a) => a -> (a, a) -> (a, a)
foldX :: a -> (a, a) -> (a, a)
foldX a
x' (a
y, a
x) = (a
y, a
x' a -> a -> a
forall a. Num a => a -> a -> a
- a -> a
forall a. Num a => a -> a
abs (a
x a -> a -> a
forall a. Num a => a -> a -> a
- a
x'))
foldY :: a -> (a, a) -> (a, a)
foldY a
y' (a
y, a
x) = (a
y' a -> a -> a
forall a. Num a => a -> a -> a
- a -> a
forall a. Num a => a -> a
abs (a
y a -> a -> a
forall a. Num a => a -> a -> a
- a
y'), a
x)

day13a :: Text -> Either (ParseErrorBundle Text Void) Int
day13a :: Text -> Either (ParseErrorBundle Text Void) Int
day13a Text
input = do
    ([(Int, Int)]
points, (Int, Int) -> (Int, Int)
fold) <- Parsec Void Text ([(Int, Int)], (Int, Int) -> (Int, Int))
-> String
-> Text
-> Either
     (ParseErrorBundle Text Void)
     ([(Int, Int)], (Int, Int) -> (Int, Int))
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parsec Void Text ([(Int, Int)], (Int, Int) -> (Int, Int))
parser String
"" Text
input
    Int -> Either (ParseErrorBundle Text Void) Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Either (ParseErrorBundle Text Void) Int)
-> Int -> Either (ParseErrorBundle Text Void) Int
forall a b. (a -> b) -> a -> b
$ Set (Int, Int) -> Int
forall a. Set a -> Int
Set.size (Set (Int, Int) -> Int) -> Set (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ [(Int, Int)] -> Set (Int, Int)
forall a. Ord a => [a] -> Set a
Set.fromList ([(Int, Int)] -> Set (Int, Int)) -> [(Int, Int)] -> Set (Int, Int)
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> (Int, Int)
fold ((Int, Int) -> (Int, Int)) -> [(Int, Int)] -> [(Int, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Int)]
points
  where parser :: Parsec Void Text ([(Int, Int)], (Int, Int) -> (Int, Int))
parser = (,) ([(Int, Int)]
 -> ((Int, Int) -> (Int, Int))
 -> ([(Int, Int)], (Int, Int) -> (Int, Int)))
-> ParsecT Void Text Identity [(Int, Int)]
-> ParsecT
     Void
     Text
     Identity
     (((Int, Int) -> (Int, Int))
      -> ([(Int, Int)], (Int, Int) -> (Int, Int)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a e s (m :: * -> *).
(Num a, MonadParsec e s m, Token s ~ Char) =>
m (a, a)
forall e s (m :: * -> *).
(Num Int, MonadParsec e s m, Token s ~ Char) =>
m (Int, Int)
parsePair @Int ParsecT Void Text Identity (Int, Int)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity [(Int, Int)]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepEndBy` ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline ParsecT
  Void
  Text
  Identity
  (((Int, Int) -> (Int, Int))
   -> ([(Int, Int)], (Int, Int) -> (Int, Int)))
-> ParsecT Void Text Identity Char
-> ParsecT
     Void
     Text
     Identity
     (((Int, Int) -> (Int, Int))
      -> ([(Int, Int)], (Int, Int) -> (Int, Int)))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline ParsecT
  Void
  Text
  Identity
  (((Int, Int) -> (Int, Int))
   -> ([(Int, Int)], (Int, Int) -> (Int, Int)))
-> ParsecT Void Text Identity ((Int, Int) -> (Int, Int))
-> Parsec Void Text ([(Int, Int)], (Int, Int) -> (Int, Int))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity ((Int, Int) -> (Int, Int))
forall a e s (m :: * -> *).
(Num a, Ord a, MonadParsec e s m, Token s ~ Char,
 IsString (Tokens s)) =>
m ((a, a) -> (a, a))
parseFold

day13b :: Text -> Either (ParseErrorBundle Text Void) [String]
day13b :: Text -> Either (ParseErrorBundle Text Void) [String]
day13b Text
input = do
    ([(Int, Int)]
points, [(Int, Int) -> (Int, Int)]
folds) <- Parsec Void Text ([(Int, Int)], [(Int, Int) -> (Int, Int)])
-> String
-> Text
-> Either
     (ParseErrorBundle Text Void)
     ([(Int, Int)], [(Int, Int) -> (Int, Int)])
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parsec Void Text ([(Int, Int)], [(Int, Int) -> (Int, Int)])
parser String
"" Text
input
    let points' :: [(Int, Int)]
points' = (((Int, Int) -> (Int, Int))
 -> ((Int, Int) -> (Int, Int)) -> (Int, Int) -> (Int, Int))
-> ((Int, Int) -> (Int, Int))
-> [(Int, Int) -> (Int, Int)]
-> (Int, Int)
-> (Int, Int)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((((Int, Int) -> (Int, Int))
 -> ((Int, Int) -> (Int, Int)) -> (Int, Int) -> (Int, Int))
-> ((Int, Int) -> (Int, Int))
-> ((Int, Int) -> (Int, Int))
-> (Int, Int)
-> (Int, Int)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Int, Int) -> (Int, Int))
-> ((Int, Int) -> (Int, Int)) -> (Int, Int) -> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)) (Int, Int) -> (Int, Int)
forall a. a -> a
id [(Int, Int) -> (Int, Int)]
folds ((Int, Int) -> (Int, Int)) -> [(Int, Int)] -> [(Int, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Int)]
points
        ((Min Int
y0, Min Int
x0), (Max Int
y1, Max Int
x1)) = [((Min Int, Min Int), (Max Int, Max Int))]
-> ((Min Int, Min Int), (Max Int, Max Int))
forall a. Monoid a => [a] -> a
mconcat ([((Min Int, Min Int), (Max Int, Max Int))]
 -> ((Min Int, Min Int), (Max Int, Max Int)))
-> [((Min Int, Min Int), (Max Int, Max Int))]
-> ((Min Int, Min Int), (Max Int, Max Int))
forall a b. (a -> b) -> a -> b
$ ((Int -> Min Int
forall a. a -> Min a
Min (Int -> Min Int)
-> (Int -> Min Int) -> (Int, Int) -> (Min Int, Min Int)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Int -> Min Int
forall a. a -> Min a
Min) ((Int, Int) -> (Min Int, Min Int))
-> ((Int, Int) -> (Max Int, Max Int))
-> (Int, Int)
-> ((Min Int, Min Int), (Max Int, Max Int))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Int -> Max Int
forall a. a -> Max a
Max (Int -> Max Int)
-> (Int -> Max Int) -> (Int, Int) -> (Max Int, Max Int)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Int -> Max Int
forall a. a -> Max a
Max)) ((Int, Int) -> ((Min Int, Min Int), (Max Int, Max Int)))
-> [(Int, Int)] -> [((Min Int, Min Int), (Max Int, Max Int))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Int)]
points'
        bitmap :: UArray (Int, Int) Char
bitmap = (Char -> Char -> Char)
-> Char
-> ((Int, Int), (Int, Int))
-> [((Int, Int), Char)]
-> UArray (Int, Int) Char
forall (a :: * -> * -> *) e i e'.
(IArray a e, Ix i) =>
(e -> e' -> e) -> e -> (i, i) -> [(i, e')] -> a i e
accumArray @UArray ((Char -> Char) -> Char -> Char -> Char
forall a b. a -> b -> a
const Char -> Char
forall a. a -> a
id) Char
'\x2591' ((Int
y0, Int
x0), (Int
y1, Int
x1)) ([((Int, Int), Char)] -> UArray (Int, Int) Char)
-> [((Int, Int), Char)] -> UArray (Int, Int) Char
forall a b. (a -> b) -> a -> b
$ (, Char
'\x2593') ((Int, Int) -> ((Int, Int), Char))
-> [(Int, Int)] -> [((Int, Int), Char)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Int)]
points'
    [String] -> Either (ParseErrorBundle Text Void) [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> Either (ParseErrorBundle Text Void) [String])
-> [String] -> Either (ParseErrorBundle Text Void) [String]
forall a b. (a -> b) -> a -> b
$ Int -> String -> [String]
forall e. Int -> [e] -> [[e]]
chunksOf (Int
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ UArray (Int, Int) Char -> String
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems UArray (Int, Int) Char
bitmap
  where parser :: Parsec Void Text ([(Int, Int)], [(Int, Int) -> (Int, Int)])
parser = (,) ([(Int, Int)]
 -> [(Int, Int) -> (Int, Int)]
 -> ([(Int, Int)], [(Int, Int) -> (Int, Int)]))
-> ParsecT Void Text Identity [(Int, Int)]
-> ParsecT
     Void
     Text
     Identity
     ([(Int, Int) -> (Int, Int)]
      -> ([(Int, Int)], [(Int, Int) -> (Int, Int)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a e s (m :: * -> *).
(Num a, MonadParsec e s m, Token s ~ Char) =>
m (a, a)
forall e s (m :: * -> *).
(Num Int, MonadParsec e s m, Token s ~ Char) =>
m (Int, Int)
parsePair @Int ParsecT Void Text Identity (Int, Int)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity [(Int, Int)]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepEndBy1` ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline ParsecT
  Void
  Text
  Identity
  ([(Int, Int) -> (Int, Int)]
   -> ([(Int, Int)], [(Int, Int) -> (Int, Int)]))
-> ParsecT Void Text Identity Char
-> ParsecT
     Void
     Text
     Identity
     ([(Int, Int) -> (Int, Int)]
      -> ([(Int, Int)], [(Int, Int) -> (Int, Int)]))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline ParsecT
  Void
  Text
  Identity
  ([(Int, Int) -> (Int, Int)]
   -> ([(Int, Int)], [(Int, Int) -> (Int, Int)]))
-> ParsecT Void Text Identity [(Int, Int) -> (Int, Int)]
-> Parsec Void Text ([(Int, Int)], [(Int, Int) -> (Int, Int)])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity ((Int, Int) -> (Int, Int))
forall a e s (m :: * -> *).
(Num a, Ord a, MonadParsec e s m, Token s ~ Char,
 IsString (Tokens s)) =>
m ((a, a) -> (a, a))
parseFold ParsecT Void Text Identity ((Int, Int) -> (Int, Int))
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity [(Int, Int) -> (Int, Int)]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepEndBy` ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline Parsec Void Text ([(Int, Int)], [(Int, Int) -> (Int, Int)])
-> ParsecT Void Text Identity ()
-> Parsec Void Text ([(Int, Int)], [(Int, Int) -> (Int, Int)])
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof