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

<https://adventofcode.com/2019/day/22>

>>> let shuffleTest cmds = invert (techsToLinearFn cmds) `withModulus` 10 <$> [0..9]

>>> shuffleTest [DealNew]
[9,8,7,6,5,4,3,2,1,0]

>>> shuffleTest [Cut 3]
[3,4,5,6,7,8,9,0,1,2]

>>> shuffleTest [Cut (-4)]
[6,7,8,9,0,1,2,3,4,5]

>>> shuffleTest [DealInc 3]
[0,7,4,1,8,5,2,9,6,3]

>>> shuffleTest [DealInc 7, DealNew, DealNew]
[0,3,6,9,2,5,8,1,4,7]

>>> shuffleTest [Cut 6, DealInc 7, DealNew]
[3,0,7,4,1,8,5,2,9,6]

>>> shuffleTest [DealInc 7, DealInc 9, Cut (-2)]
[6,3,0,7,4,1,8,5,2,9]

>>> shuffleTest [DealNew, Cut (-2), DealInc 7, Cut 8, Cut (-4), DealInc 7, Cut 3, DealInc 9, DealInc 3, Cut (-1)]
[9,2,5,8,1,4,7,0,3,6]

-}
module Main (main) where

import Advent                         (format)
import Control.Applicative            ((<|>))
import Data.Semigroup                 (stimes)
import GHC.Natural                    (Natural)
import GHC.TypeNats                   (KnownNat, SomeNat(..), someNatVal)
import Math.NumberTheory.Moduli.Class (Mod, getNatVal)

------------------------------------------------------------------------
-- Parsing
------------------------------------------------------------------------

data Technique
  = Cut     Integer -- ^ cut N cards
  | DealInc Integer -- ^ deal with increment N
  | DealNew         -- ^ deal into new stack
  deriving Int -> Technique -> ShowS
[Technique] -> ShowS
Technique -> String
(Int -> Technique -> ShowS)
-> (Technique -> String)
-> ([Technique] -> ShowS)
-> Show Technique
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Technique -> ShowS
showsPrec :: Int -> Technique -> ShowS
$cshow :: Technique -> String
show :: Technique -> String
$cshowList :: [Technique] -> ShowS
showList :: [Technique] -> ShowS
Show

toTechnique :: Maybe (Either Integer Integer) -> Technique
toTechnique (Just (Left Integer
n)) = Integer -> Technique
Cut Integer
n
toTechnique (Just (Right Integer
n)) = Integer -> Technique
DealInc Integer
n
toTechnique Maybe (Either Integer Integer)
Nothing = Technique
DealNew

------------------------------------------------------------------------
-- Shuffles
------------------------------------------------------------------------

-- | Compute function for a shuffle instruction mapping cards
-- in the shuffled deck to positions in the shuffled deck.
techToLinearFn :: KnownNat n => Technique -> LinearFn (Mod n)
techToLinearFn :: forall (n :: Natural). KnownNat n => Technique -> LinearFn (Mod n)
techToLinearFn Technique
DealNew     = Mod n -> Mod n -> LinearFn (Mod n)
forall a. a -> a -> LinearFn a
LinearFn (-Mod n
1) (-Mod n
1)          -- λx. -x-1
techToLinearFn (Cut     Integer
i) = Mod n -> Mod n -> LinearFn (Mod n)
forall a. a -> a -> LinearFn a
LinearFn Mod n
1 (-Integer -> Mod n
forall a. Num a => Integer -> a
fromInteger Integer
i) -- λx. x-i
techToLinearFn (DealInc Integer
i) = Mod n -> Mod n -> LinearFn (Mod n)
forall a. a -> a -> LinearFn a
LinearFn (Integer -> Mod n
forall a. Num a => Integer -> a
fromInteger Integer
i) Mod n
0  -- λx. ix

-- | Construts the linear function corresponding to applying the
-- given shuffles in order from left to right.
techsToLinearFn :: KnownNat n => [Technique] -> LinearFn (Mod n)
techsToLinearFn :: forall (n :: Natural).
KnownNat n =>
[Technique] -> LinearFn (Mod n)
techsToLinearFn = (Technique -> LinearFn (Mod n)) -> [Technique] -> LinearFn (Mod n)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Technique -> LinearFn (Mod n)
forall (n :: Natural). KnownNat n => Technique -> LinearFn (Mod n)
techToLinearFn

------------------------------------------------------------------------
-- Linear functions
------------------------------------------------------------------------

-- | Linear functions: @Linear a b ~ λx. ax+b@
data LinearFn a = LinearFn !a !a
  deriving Int -> LinearFn a -> ShowS
[LinearFn a] -> ShowS
LinearFn a -> String
(Int -> LinearFn a -> ShowS)
-> (LinearFn a -> String)
-> ([LinearFn a] -> ShowS)
-> Show (LinearFn a)
forall a. Show a => Int -> LinearFn a -> ShowS
forall a. Show a => [LinearFn a] -> ShowS
forall a. Show a => LinearFn a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> LinearFn a -> ShowS
showsPrec :: Int -> LinearFn a -> ShowS
$cshow :: forall a. Show a => LinearFn a -> String
show :: LinearFn a -> String
$cshowList :: forall a. Show a => [LinearFn a] -> ShowS
showList :: [LinearFn a] -> ShowS
Show

apply :: Num a => LinearFn a -> a -> a
apply :: forall a. Num a => LinearFn a -> a -> a
apply (LinearFn a
a a
b) a
x = a
a a -> a -> a
forall a. Num a => a -> a -> a
* a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
b

invert :: Fractional a => LinearFn a -> LinearFn a
invert :: forall a. Fractional a => LinearFn a -> LinearFn a
invert (LinearFn a
a a
b) = a -> a -> LinearFn a
forall a. a -> a -> LinearFn a
LinearFn (a
1a -> a -> a
forall a. Fractional a => a -> a -> a
/a
a) (-a
ba -> a -> a
forall a. Fractional a => a -> a -> a
/a
a)

-- | Reverse-composition of linear functions
--
-- >>> let f = LinearFn 1 2
-- >>> let g = LinearFn 3 4
-- >>> (f <> g) `apply` 10
-- 40
-- >>> g `apply` (f `apply` 10)
-- 40
instance Num a => Semigroup (LinearFn a) where
  LinearFn a
c a
d <> :: LinearFn a -> LinearFn a -> LinearFn a
<> LinearFn a
a a
b = a -> a -> LinearFn a
forall a. a -> a -> LinearFn a
LinearFn (a
aa -> a -> a
forall a. Num a => a -> a -> a
*a
c) (a
b a -> a -> a
forall a. Num a => a -> a -> a
+ a
aa -> a -> a
forall a. Num a => a -> a -> a
*a
d)

instance Num a => Monoid (LinearFn a) where
  mempty :: LinearFn a
mempty = a -> a -> LinearFn a
forall a. a -> a -> LinearFn a
LinearFn a
1 a
0

------------------------------------------------------------------------
-- Driver code
------------------------------------------------------------------------

-- | >>> :main
-- 1252
-- 46116012647793
main :: IO ()
IO ()
main =
  do [Technique]
techniques <- (Maybe (Either Integer Integer) -> Technique)
-> [Maybe (Either Integer Integer)] -> [Technique]
forall a b. (a -> b) -> [a] -> [b]
map Maybe (Either Integer Integer) -> Technique
toTechnique ([Maybe (Either Integer Integer)] -> [Technique])
-> IO [Maybe (Either Integer Integer)] -> IO [Technique]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [format|2019 22
      (cut %ld%n
      |deal with increment %ld%n
      |deal into new stack%n
      )*|]

     let shuffle :: KnownNat n => LinearFn (Mod n)
         shuffle :: forall (n :: Natural). KnownNat n => LinearFn (Mod n)
shuffle = [Technique] -> LinearFn (Mod n)
forall (n :: Natural).
KnownNat n =>
[Technique] -> LinearFn (Mod n)
techsToLinearFn [Technique]
techniques

     Natural -> IO ()
forall a. Show a => a -> IO ()
print ((LinearFn (Mod n)
forall (n :: Natural). KnownNat n => LinearFn (Mod n)
shuffle (forall (n :: Natural). KnownNat n => LinearFn (Mod n))
-> Natural -> Natural -> Natural
`withModulus` Natural
10007) Natural
2019)

     let iterations :: Int
iterations  = Int
101741582076661 :: Int
         decksize :: Natural
decksize    = Natural
119315717514047
     Natural -> IO ()
forall a. Show a => a -> IO ()
print ((Int -> LinearFn (Mod n) -> LinearFn (Mod n)
forall b. Integral b => b -> LinearFn (Mod n) -> LinearFn (Mod n)
forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes Int
iterations (LinearFn (Mod n) -> LinearFn (Mod n)
forall a. Fractional a => LinearFn a -> LinearFn a
invert LinearFn (Mod n)
forall (n :: Natural). KnownNat n => LinearFn (Mod n)
shuffle) (forall (n :: Natural). KnownNat n => LinearFn (Mod n))
-> Natural -> Natural -> Natural
`withModulus` Natural
decksize) Natural
2020)

withModulus ::
  (forall n. KnownNat n => LinearFn (Mod n)) ->
  Natural -> Natural -> Natural
forall (n :: Natural). KnownNat n => LinearFn (Mod n)
f withModulus :: (forall (n :: Natural). KnownNat n => LinearFn (Mod n))
-> Natural -> Natural -> Natural
`withModulus` Natural
modulus =
  case Natural -> SomeNat
someNatVal Natural
modulus of
    SomeNat Proxy n
p -> Mod n -> Natural
forall (m :: Natural). Mod m -> Natural
getNatVal (Mod n -> Natural) -> (Natural -> Mod n) -> Natural -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy n -> Mod n -> Mod n
forall (proxy :: Natural -> *) (n :: Natural).
proxy n -> Mod n -> Mod n
asMod Proxy n
p (Mod n -> Mod n) -> (Natural -> Mod n) -> Natural -> Mod n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinearFn (Mod n) -> Mod n -> Mod n
forall a. Num a => LinearFn a -> a -> a
apply LinearFn (Mod n)
forall (n :: Natural). KnownNat n => LinearFn (Mod n)
f (Mod n -> Mod n) -> (Natural -> Mod n) -> Natural -> Mod n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Mod n
forall a b. (Integral a, Num b) => a -> b
fromIntegral

asMod :: proxy n -> Mod n -> Mod n
asMod :: forall (proxy :: Natural -> *) (n :: Natural).
proxy n -> Mod n -> Mod n
asMod proxy n
_ Mod n
x = Mod n
x