-- |
-- Module      : AOC.Challenge.Day23
-- License     : BSD3
--
-- Stability   : experimental
-- Portability : non-portable
--
-- Day 23.  See "AOC.Solver" for the types used in this module!

module AOC.Challenge.Day23 (
    day23a
  , day23b
  ) where

import           AOC.Solver                  ((:~>)(..))
import           Control.Monad               (unless)
import           Control.Monad.Primitive     (PrimMonad, PrimState)
import           Control.Monad.ST            (runST)
import           Control.Monad.Trans.Class   (lift)
import           Data.Char                   (digitToInt, intToDigit)
import           Data.Foldable               (for_)
import           Data.Vector.Unboxed         (Vector)
import           Data.Vector.Unboxed.Mutable (MVector)
import qualified Data.Conduino               as C
import qualified Data.Conduino.Combinators   as C
import qualified Data.Vector.Unboxed         as V
import qualified Data.Vector.Unboxed.Mutable as MV

newtype CrabState s = CrabState { forall s. CrabState s -> MVector s Int
csRight  :: MVector s Int }

sourceCrabState
    :: (PrimMonad m, PrimState m ~ s)
    => CrabState s
    -> Int              -- ^ item to start from
    -> C.Pipe i Int u m ()
sourceCrabState :: forall (m :: * -> *) s i u.
(PrimMonad m, PrimState m ~ s) =>
CrabState s -> Int -> Pipe i Int u m ()
sourceCrabState CrabState{MVector s Int
csRight :: MVector s Int
csRight :: forall s. CrabState s -> MVector s Int
..} Int
i0 = Int -> Pipe i Int u m ()
go Int
i0
  where
    go :: Int -> Pipe i Int u m ()
go Int
i = do
      Int
j <- m Int -> Pipe i Int u m Int
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Int -> Pipe i Int u m Int) -> m Int -> Pipe i Int u m Int
forall a b. (a -> b) -> a -> b
$ MVector (PrimState m) Int -> Int -> m Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
MV.unsafeRead MVector s Int
MVector (PrimState m) Int
csRight Int
i
      Bool -> Pipe i Int u m () -> Pipe i Int u m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i0) (Pipe i Int u m () -> Pipe i Int u m ())
-> Pipe i Int u m () -> Pipe i Int u m ()
forall a b. (a -> b) -> a -> b
$ do
        Int -> Pipe i Int u m ()
forall o i u (m :: * -> *). o -> Pipe i o u m ()
C.yield Int
j
        Int -> Pipe i Int u m ()
go Int
j

step
    :: forall m s. (PrimMonad m, PrimState m ~ s)
    => CrabState s
    -> Int
    -> m Int
step :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
CrabState s -> Int -> m Int
step CrabState{MVector s Int
csRight :: MVector s Int
csRight :: forall s. CrabState s -> MVector s Int
..} Int
lab = do
    (gs :: (Int, Int, Int)
gs@(Int
g1,Int
_,Int
g3),Int
lab') <- Int -> m ((Int, Int, Int), Int)
pull3 Int
lab
    MVector (PrimState m) Int -> Int -> Int -> m ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.unsafeWrite MVector s Int
MVector (PrimState m) Int
csRight Int
lab Int
lab'
    let target :: Int
target = (Int -> Bool) -> (Int -> Int) -> Int -> Int
forall a. (a -> Bool) -> (a -> a) -> a -> a
until ((Int, Int, Int) -> Int -> Bool
forall {a}. Eq a => (a, a, a) -> a -> Bool
notAny (Int, Int, Int)
gs) Int -> Int
subWrap (Int -> Int
subWrap Int
lab)
    Int
aftertarg <- MVector (PrimState m) Int -> Int -> m Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
MV.unsafeRead MVector s Int
MVector (PrimState m) Int
csRight Int
target
    MVector (PrimState m) Int -> Int -> Int -> m ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.unsafeWrite MVector s Int
MVector (PrimState m) Int
csRight Int
target Int
g1
    MVector (PrimState m) Int -> Int -> Int -> m ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.unsafeWrite MVector s Int
MVector (PrimState m) Int
csRight Int
g3 Int
aftertarg
    pure Int
lab'
  where
    n :: Int
n = MVector s Int -> Int
forall a s. Unbox a => MVector s a -> Int
MV.length MVector s Int
csRight
    subWrap :: Int -> Int
subWrap Int
x
      | Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0    = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      | Bool
otherwise = Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    notAny :: (a, a, a) -> a -> Bool
notAny (a
g1,a
g2,a
g3) a
x = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
g1 Bool -> Bool -> Bool
&& a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
g2 Bool -> Bool -> Bool
&& a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
g3
    {-# INLINE notAny #-}
    pull3 :: Int -> m ((Int, Int, Int), Int)
    pull3 :: Int -> m ((Int, Int, Int), Int)
pull3 Int
i0 = do
      Int
i1 <- MVector (PrimState m) Int -> Int -> m Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
MV.unsafeRead MVector s Int
MVector (PrimState m) Int
csRight Int
i0
      Int
i2 <- MVector (PrimState m) Int -> Int -> m Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
MV.unsafeRead MVector s Int
MVector (PrimState m) Int
csRight Int
i1
      Int
i3 <- MVector (PrimState m) Int -> Int -> m Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
MV.unsafeRead MVector s Int
MVector (PrimState m) Int
csRight Int
i2
      Int
i4 <- MVector (PrimState m) Int -> Int -> m Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
MV.unsafeRead MVector s Int
MVector (PrimState m) Int
csRight Int
i3
      pure ((Int
i1,Int
i2,Int
i3),Int
i4)
    {-# INLINE pull3 #-}
{-# INLINE step #-}

initialize
    :: forall m s. (PrimMonad m, PrimState m ~ s)
    => Vector Int
    -> m (Int, CrabState s)      -- ^ initial pointer
initialize :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
Vector Int -> m (Int, CrabState s)
initialize Vector Int
v0 = do
    MVector s Int
csRight <- Int -> m (MVector (PrimState m) Int)
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
Int -> m (MVector (PrimState m) a)
MV.unsafeNew Int
n
    [Int] -> (Int -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Int
0 .. Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> m ()) -> m ()) -> (Int -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Int
i ->
      MVector (PrimState m) Int -> Int -> Int -> m ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.unsafeWrite MVector s Int
MVector (PrimState m) Int
csRight (Vector Int
v0 Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
V.! Int -> Int
subWrap Int
i) (Vector Int
v0 Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
V.! Int
i)
    let i0 :: Int
i0 = Vector Int
v0 Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
V.! Int
0
    (Int, CrabState s) -> m (Int, CrabState s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i0, CrabState :: forall s. MVector s Int -> CrabState s
CrabState{MVector s Int
csRight :: MVector s Int
csRight :: MVector s Int
..})
  where
    n :: Int
n = Vector Int -> Int
forall a. Unbox a => Vector a -> Int
V.length Vector Int
v0
    subWrap :: Int -> Int
subWrap Int
x
      | Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0    = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      | Bool
otherwise = Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
{-# INLINE initialize #-}

run :: (PrimMonad m, PrimState m ~ s)
    => Int
    -> Int
    -> CrabState s
    -> m ()
run :: forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
Int -> Int -> CrabState s -> m ()
run Int
n Int
i0 CrabState s
cs = Int -> Int -> m ()
go Int
0 Int
i0
  where
    go :: Int -> Int -> m ()
go !Int
m !Int
i
      | Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n    = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = Int -> Int -> m ()
go (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> m ()) -> m Int -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CrabState s -> Int -> m Int
forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
CrabState s -> Int -> m Int
step CrabState s
cs Int
i
{-# INLINE run #-}


day23a :: Vector Int :~> [Int]
day23a :: Vector Int :~> [Int]
day23a = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
    { sParse :: String -> Maybe (Vector Int)
sParse = Vector Int -> Maybe (Vector Int)
forall a. a -> Maybe a
Just (Vector Int -> Maybe (Vector Int))
-> (String -> Vector Int) -> String -> Maybe (Vector Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Vector Int
forall a. Unbox a => [a] -> Vector a
V.fromList ([Int] -> Vector Int) -> (String -> [Int]) -> String -> Vector Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Int) -> String -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
toIx
    , sShow :: [Int] -> String
sShow  = (Int -> Char) -> [Int] -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Char
intToDigit
    , sSolve :: (?dyno::DynoMap) => Vector Int -> Maybe [Int]
sSolve = \Vector Int
v0 -> [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just ([Int] -> Maybe [Int]) -> [Int] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ (forall s. ST s [Int]) -> [Int]
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s [Int]) -> [Int])
-> (forall s. ST s [Int]) -> [Int]
forall a b. (a -> b) -> a -> b
$ do
        (Int
i0, CrabState s
cs) <- Vector Int -> ST s (Int, CrabState s)
forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
Vector Int -> m (Int, CrabState s)
initialize Vector Int
v0
        Int -> Int -> CrabState s -> ST s ()
forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
Int -> Int -> CrabState s -> m ()
run Int
100 Int
i0 CrabState s
cs
        Pipe () Void Any (ST s) [Int] -> ST s [Int]
forall (m :: * -> *) u a. Monad m => Pipe () Void u m a -> m a
C.runPipe (Pipe () Void Any (ST s) [Int] -> ST s [Int])
-> Pipe () Void Any (ST s) [Int] -> ST s [Int]
forall a b. (a -> b) -> a -> b
$ CrabState s -> Int -> Pipe () Int Any (ST s) ()
forall (m :: * -> *) s i u.
(PrimMonad m, PrimState m ~ s) =>
CrabState s -> Int -> Pipe i Int u m ()
sourceCrabState CrabState s
cs Int
0
               Pipe () Int Any (ST s) ()
-> Pipe Int Void () (ST s) [Int] -> Pipe () Void Any (ST s) [Int]
forall (m :: * -> *) a b u v c r.
Monad m =>
Pipe a b u m v -> Pipe b c v m r -> Pipe a c u m r
C..| (Int -> Int) -> Pipe Int Int () (ST s) ()
forall i o u (m :: * -> *). (i -> o) -> Pipe i o u m u
C.map Int -> Int
fromIx
               Pipe Int Int () (ST s) ()
-> Pipe Int Void () (ST s) [Int] -> Pipe Int Void () (ST s) [Int]
forall (m :: * -> *) a b u v c r.
Monad m =>
Pipe a b u m v -> Pipe b c v m r -> Pipe a c u m r
C..| Pipe Int Void () (ST s) [Int]
forall i o u (m :: * -> *). Pipe i o u m [i]
C.sinkList
    }

day23b :: Vector Int :~> [Int]
day23b :: Vector Int :~> [Int]
day23b = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
    { sParse :: String -> Maybe (Vector Int)
sParse = Vector Int -> Maybe (Vector Int)
forall a. a -> Maybe a
Just (Vector Int -> Maybe (Vector Int))
-> (String -> Vector Int) -> String -> Maybe (Vector Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int] -> Vector Int
forall a. Unbox a => Int -> [a] -> Vector a
V.fromListN Int
1000000 ([Int] -> Vector Int) -> (String -> [Int]) -> String -> Vector Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
9 .. ]) ([Int] -> [Int]) -> (String -> [Int]) -> String -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Int) -> String -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
toIx
    , sShow :: [Int] -> String
sShow  = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> ([Int] -> Int) -> [Int] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product
    , sSolve :: (?dyno::DynoMap) => Vector Int -> Maybe [Int]
sSolve = \Vector Int
v0 -> [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just ([Int] -> Maybe [Int]) -> [Int] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ (forall s. ST s [Int]) -> [Int]
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s [Int]) -> [Int])
-> (forall s. ST s [Int]) -> [Int]
forall a b. (a -> b) -> a -> b
$ do
        (Int
i0, CrabState s
cs) <- Vector Int -> ST s (Int, CrabState s)
forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
Vector Int -> m (Int, CrabState s)
initialize Vector Int
v0
        Int -> Int -> CrabState s -> ST s ()
forall (m :: * -> *) s.
(PrimMonad m, PrimState m ~ s) =>
Int -> Int -> CrabState s -> m ()
run Int
10000000 Int
i0 CrabState s
cs
        Pipe () Void Any (ST s) [Int] -> ST s [Int]
forall (m :: * -> *) u a. Monad m => Pipe () Void u m a -> m a
C.runPipe (Pipe () Void Any (ST s) [Int] -> ST s [Int])
-> Pipe () Void Any (ST s) [Int] -> ST s [Int]
forall a b. (a -> b) -> a -> b
$ CrabState s -> Int -> Pipe () Int Any (ST s) ()
forall (m :: * -> *) s i u.
(PrimMonad m, PrimState m ~ s) =>
CrabState s -> Int -> Pipe i Int u m ()
sourceCrabState CrabState s
cs Int
0
               Pipe () Int Any (ST s) ()
-> Pipe Int Void () (ST s) [Int] -> Pipe () Void Any (ST s) [Int]
forall (m :: * -> *) a b u v c r.
Monad m =>
Pipe a b u m v -> Pipe b c v m r -> Pipe a c u m r
C..| (Int -> Int) -> Pipe Int Int () (ST s) ()
forall i o u (m :: * -> *). (i -> o) -> Pipe i o u m u
C.map Int -> Int
fromIx
               Pipe Int Int () (ST s) ()
-> Pipe Int Void () (ST s) [Int] -> Pipe Int Void () (ST s) [Int]
forall (m :: * -> *) a b u v c r.
Monad m =>
Pipe a b u m v -> Pipe b c v m r -> Pipe a c u m r
C..| Int -> Pipe Int Int () (ST s) ()
forall i u (m :: * -> *). Int -> Pipe i i u m ()
C.take Int
2
               Pipe Int Int () (ST s) ()
-> Pipe Int Void () (ST s) [Int] -> Pipe Int Void () (ST s) [Int]
forall (m :: * -> *) a b u v c r.
Monad m =>
Pipe a b u m v -> Pipe b c v m r -> Pipe a c u m r
C..| Pipe Int Void () (ST s) [Int]
forall i o u (m :: * -> *). Pipe i o u m [i]
C.sinkList
    }

toIx :: Char -> Int
toIx :: Char -> Int
toIx = Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1 (Int -> Int) -> (Char -> Int) -> Char -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
digitToInt

fromIx :: Int -> Int
fromIx :: Int -> Int
fromIx = (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)