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
-> 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)
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)