module Satyros.BellmanFord.Effect where import Control.Monad.State.Strict (MonadState, State, runState) import Control.Monad.Trans.Free (FreeF, FreeT (runFreeT), MonadFree (wrap), hoistFreeT) import Data.Bifunctor (first) import Data.Functor.Classes (Show1 (liftShowsPrec), showsBinaryWith, showsPrec1, showsUnaryWith) import Data.Functor.Const (Const (Const)) import Satyros.BellmanFord.IDLGraph (IDLGraphVertex, IDLWeightMap, PositiveInfiniteInt) import qualified Satyros.QFIDL as QFIDL import Satyros.Util (showsTernaryWith) type BellmanFordStore = IDLWeightMap newtype BellmanFord a = BellmanFord{ BellmanFord a -> FreeT BellmanFordF (State BellmanFordStore) a runBellmanFord :: FreeT BellmanFordF (State BellmanFordStore) a } deriving newtype (a -> BellmanFord b -> BellmanFord a (a -> b) -> BellmanFord a -> BellmanFord b (forall a b. (a -> b) -> BellmanFord a -> BellmanFord b) -> (forall a b. a -> BellmanFord b -> BellmanFord a) -> Functor BellmanFord forall a b. a -> BellmanFord b -> BellmanFord a forall a b. (a -> b) -> BellmanFord a -> BellmanFord b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f <$ :: a -> BellmanFord b -> BellmanFord a $c<$ :: forall a b. a -> BellmanFord b -> BellmanFord a fmap :: (a -> b) -> BellmanFord a -> BellmanFord b $cfmap :: forall a b. (a -> b) -> BellmanFord a -> BellmanFord b Functor, Functor BellmanFord a -> BellmanFord a Functor BellmanFord -> (forall a. a -> BellmanFord a) -> (forall a b. BellmanFord (a -> b) -> BellmanFord a -> BellmanFord b) -> (forall a b c. (a -> b -> c) -> BellmanFord a -> BellmanFord b -> BellmanFord c) -> (forall a b. BellmanFord a -> BellmanFord b -> BellmanFord b) -> (forall a b. BellmanFord a -> BellmanFord b -> BellmanFord a) -> Applicative BellmanFord BellmanFord a -> BellmanFord b -> BellmanFord b BellmanFord a -> BellmanFord b -> BellmanFord a BellmanFord (a -> b) -> BellmanFord a -> BellmanFord b (a -> b -> c) -> BellmanFord a -> BellmanFord b -> BellmanFord c forall a. a -> BellmanFord a forall a b. BellmanFord a -> BellmanFord b -> BellmanFord a forall a b. BellmanFord a -> BellmanFord b -> BellmanFord b forall a b. BellmanFord (a -> b) -> BellmanFord a -> BellmanFord b forall a b c. (a -> b -> c) -> BellmanFord a -> BellmanFord b -> BellmanFord c forall (f :: * -> *). Functor f -> (forall a. a -> f a) -> (forall a b. f (a -> b) -> f a -> f b) -> (forall a b c. (a -> b -> c) -> f a -> f b -> f c) -> (forall a b. f a -> f b -> f b) -> (forall a b. f a -> f b -> f a) -> Applicative f <* :: BellmanFord a -> BellmanFord b -> BellmanFord a $c<* :: forall a b. BellmanFord a -> BellmanFord b -> BellmanFord a *> :: BellmanFord a -> BellmanFord b -> BellmanFord b $c*> :: forall a b. BellmanFord a -> BellmanFord b -> BellmanFord b liftA2 :: (a -> b -> c) -> BellmanFord a -> BellmanFord b -> BellmanFord c $cliftA2 :: forall a b c. (a -> b -> c) -> BellmanFord a -> BellmanFord b -> BellmanFord c <*> :: BellmanFord (a -> b) -> BellmanFord a -> BellmanFord b $c<*> :: forall a b. BellmanFord (a -> b) -> BellmanFord a -> BellmanFord b pure :: a -> BellmanFord a $cpure :: forall a. a -> BellmanFord a $cp1Applicative :: Functor BellmanFord Applicative, Applicative BellmanFord a -> BellmanFord a Applicative BellmanFord -> (forall a b. BellmanFord a -> (a -> BellmanFord b) -> BellmanFord b) -> (forall a b. BellmanFord a -> BellmanFord b -> BellmanFord b) -> (forall a. a -> BellmanFord a) -> Monad BellmanFord BellmanFord a -> (a -> BellmanFord b) -> BellmanFord b BellmanFord a -> BellmanFord b -> BellmanFord b forall a. a -> BellmanFord a forall a b. BellmanFord a -> BellmanFord b -> BellmanFord b forall a b. BellmanFord a -> (a -> BellmanFord b) -> BellmanFord b forall (m :: * -> *). Applicative m -> (forall a b. m a -> (a -> m b) -> m b) -> (forall a b. m a -> m b -> m b) -> (forall a. a -> m a) -> Monad m return :: a -> BellmanFord a $creturn :: forall a. a -> BellmanFord a >> :: BellmanFord a -> BellmanFord b -> BellmanFord b $c>> :: forall a b. BellmanFord a -> BellmanFord b -> BellmanFord b >>= :: BellmanFord a -> (a -> BellmanFord b) -> BellmanFord b $c>>= :: forall a b. BellmanFord a -> (a -> BellmanFord b) -> BellmanFord b $cp1Monad :: Applicative BellmanFord Monad, MonadFree BellmanFordF, MonadState BellmanFordStore) instance Show1 BellmanFord where liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> BellmanFord a -> ShowS liftShowsPrec Int -> a -> ShowS sp [a] -> ShowS slp Int d = (Int -> FreeT BellmanFordF (Const [Char]) a -> ShowS) -> [Char] -> Int -> FreeT BellmanFordF (Const [Char]) a -> ShowS forall a. (Int -> a -> ShowS) -> [Char] -> Int -> a -> ShowS showsUnaryWith ((Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> FreeT BellmanFordF (Const [Char]) a -> ShowS forall (f :: * -> *) a. Show1 f => (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS liftShowsPrec Int -> a -> ShowS sp [a] -> ShowS slp) [Char] "BellmanFord" Int d (FreeT BellmanFordF (Const [Char]) a -> ShowS) -> (BellmanFord a -> FreeT BellmanFordF (Const [Char]) a) -> BellmanFord a -> ShowS forall b c a. (b -> c) -> (a -> b) -> a -> c . (forall a. State BellmanFordStore a -> Const [Char] a) -> FreeT BellmanFordF (State BellmanFordStore) a -> FreeT BellmanFordF (Const [Char]) a forall (m :: * -> *) (f :: * -> *) (n :: * -> *) b. (Monad m, Functor f) => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b hoistFreeT (Const [Char] a -> State BellmanFordStore a -> Const [Char] a forall a b. a -> b -> a const (Const [Char] a -> State BellmanFordStore a -> Const [Char] a) -> Const [Char] a -> State BellmanFordStore a -> Const [Char] a forall a b. (a -> b) -> a -> b $ [Char] -> Const [Char] a forall k a (b :: k). a -> Const a b Const [Char] "<stateful computation>") (FreeT BellmanFordF (State BellmanFordStore) a -> FreeT BellmanFordF (Const [Char]) a) -> (BellmanFord a -> FreeT BellmanFordF (State BellmanFordStore) a) -> BellmanFord a -> FreeT BellmanFordF (Const [Char]) a forall b c a. (b -> c) -> (a -> b) -> a -> c . BellmanFord a -> FreeT BellmanFordF (State BellmanFordStore) a forall a. BellmanFord a -> FreeT BellmanFordF (State BellmanFordStore) a runBellmanFord instance (Show a) => Show (BellmanFord a) where showsPrec :: Int -> BellmanFord a -> ShowS showsPrec = Int -> BellmanFord a -> ShowS forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS showsPrec1 stepBellmanFord :: BellmanFord a -> BellmanFordStore -> (FreeF BellmanFordF a (BellmanFord a), BellmanFordStore) stepBellmanFord :: BellmanFord a -> BellmanFordStore -> (FreeF BellmanFordF a (BellmanFord a), BellmanFordStore) stepBellmanFord BellmanFord a d BellmanFordStore s = (FreeF BellmanFordF a (FreeT BellmanFordF (State BellmanFordStore) a) -> FreeF BellmanFordF a (BellmanFord a)) -> (FreeF BellmanFordF a (FreeT BellmanFordF (State BellmanFordStore) a), BellmanFordStore) -> (FreeF BellmanFordF a (BellmanFord a), BellmanFordStore) forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first ((FreeT BellmanFordF (State BellmanFordStore) a -> BellmanFord a) -> FreeF BellmanFordF a (FreeT BellmanFordF (State BellmanFordStore) a) -> FreeF BellmanFordF a (BellmanFord a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap FreeT BellmanFordF (State BellmanFordStore) a -> BellmanFord a forall a. FreeT BellmanFordF (State BellmanFordStore) a -> BellmanFord a BellmanFord) ((FreeF BellmanFordF a (FreeT BellmanFordF (State BellmanFordStore) a), BellmanFordStore) -> (FreeF BellmanFordF a (BellmanFord a), BellmanFordStore)) -> (FreeF BellmanFordF a (FreeT BellmanFordF (State BellmanFordStore) a), BellmanFordStore) -> (FreeF BellmanFordF a (BellmanFord a), BellmanFordStore) forall a b. (a -> b) -> a -> b $ State BellmanFordStore (FreeF BellmanFordF a (FreeT BellmanFordF (State BellmanFordStore) a)) -> BellmanFordStore -> (FreeF BellmanFordF a (FreeT BellmanFordF (State BellmanFordStore) a), BellmanFordStore) forall s a. State s a -> s -> (a, s) runState (FreeT BellmanFordF (State BellmanFordStore) a -> State BellmanFordStore (FreeF BellmanFordF a (FreeT BellmanFordF (State BellmanFordStore) a)) forall (f :: * -> *) (m :: * -> *) a. FreeT f m a -> m (FreeF f a (FreeT f m a)) runFreeT (BellmanFord a -> FreeT BellmanFordF (State BellmanFordStore) a forall a. BellmanFord a -> FreeT BellmanFordF (State BellmanFordStore) a runBellmanFord BellmanFord a d)) BellmanFordStore s {-# INLINE stepBellmanFord #-} data BellmanFordF r = PropagationCheck (IDLGraphVertex, IDLGraphVertex) r | PropagationFindShorter IDLGraphVertex (IDLGraphVertex, PositiveInfiniteInt) r | PropagationNth Int r | PropagationEnd | NegativeCycleCheck (IDLGraphVertex, IDLGraphVertex) r | NegativeCycleFind [QFIDL.Expressed] | NegativeCyclePass deriving stock (Int -> BellmanFordF r -> ShowS [BellmanFordF r] -> ShowS BellmanFordF r -> [Char] (Int -> BellmanFordF r -> ShowS) -> (BellmanFordF r -> [Char]) -> ([BellmanFordF r] -> ShowS) -> Show (BellmanFordF r) forall r. Show r => Int -> BellmanFordF r -> ShowS forall r. Show r => [BellmanFordF r] -> ShowS forall r. Show r => BellmanFordF r -> [Char] forall a. (Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a showList :: [BellmanFordF r] -> ShowS $cshowList :: forall r. Show r => [BellmanFordF r] -> ShowS show :: BellmanFordF r -> [Char] $cshow :: forall r. Show r => BellmanFordF r -> [Char] showsPrec :: Int -> BellmanFordF r -> ShowS $cshowsPrec :: forall r. Show r => Int -> BellmanFordF r -> ShowS Show, a -> BellmanFordF b -> BellmanFordF a (a -> b) -> BellmanFordF a -> BellmanFordF b (forall a b. (a -> b) -> BellmanFordF a -> BellmanFordF b) -> (forall a b. a -> BellmanFordF b -> BellmanFordF a) -> Functor BellmanFordF forall a b. a -> BellmanFordF b -> BellmanFordF a forall a b. (a -> b) -> BellmanFordF a -> BellmanFordF b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f <$ :: a -> BellmanFordF b -> BellmanFordF a $c<$ :: forall a b. a -> BellmanFordF b -> BellmanFordF a fmap :: (a -> b) -> BellmanFordF a -> BellmanFordF b $cfmap :: forall a b. (a -> b) -> BellmanFordF a -> BellmanFordF b Functor) instance Show1 BellmanFordF where liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> BellmanFordF a -> ShowS liftShowsPrec Int -> a -> ShowS sp [a] -> ShowS _ Int d (PropagationCheck (IDLGraphVertex, IDLGraphVertex) vs a r) = (Int -> (IDLGraphVertex, IDLGraphVertex) -> ShowS) -> (Int -> a -> ShowS) -> [Char] -> Int -> (IDLGraphVertex, IDLGraphVertex) -> a -> ShowS forall a b. (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> [Char] -> Int -> a -> b -> ShowS showsBinaryWith Int -> (IDLGraphVertex, IDLGraphVertex) -> ShowS forall a. Show a => Int -> a -> ShowS showsPrec Int -> a -> ShowS sp [Char] "PropagationCheck" Int d (IDLGraphVertex, IDLGraphVertex) vs a r liftShowsPrec Int -> a -> ShowS sp [a] -> ShowS _ Int d (PropagationFindShorter IDLGraphVertex v (IDLGraphVertex, PositiveInfiniteInt) p a r) = (Int -> IDLGraphVertex -> ShowS) -> (Int -> (IDLGraphVertex, PositiveInfiniteInt) -> ShowS) -> (Int -> a -> ShowS) -> [Char] -> Int -> IDLGraphVertex -> (IDLGraphVertex, PositiveInfiniteInt) -> a -> ShowS forall a b c. (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> (Int -> c -> ShowS) -> [Char] -> Int -> a -> b -> c -> ShowS showsTernaryWith Int -> IDLGraphVertex -> ShowS forall a. Show a => Int -> a -> ShowS showsPrec Int -> (IDLGraphVertex, PositiveInfiniteInt) -> ShowS forall a. Show a => Int -> a -> ShowS showsPrec Int -> a -> ShowS sp [Char] "PropagationFindShorter" Int d IDLGraphVertex v (IDLGraphVertex, PositiveInfiniteInt) p a r liftShowsPrec Int -> a -> ShowS sp [a] -> ShowS _ Int d (PropagationNth Int n a r) = (Int -> Int -> ShowS) -> (Int -> a -> ShowS) -> [Char] -> Int -> Int -> a -> ShowS forall a b. (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> [Char] -> Int -> a -> b -> ShowS showsBinaryWith Int -> Int -> ShowS forall a. Show a => Int -> a -> ShowS showsPrec Int -> a -> ShowS sp [Char] "PropagationNth" Int d Int n a r liftShowsPrec Int -> a -> ShowS _ [a] -> ShowS _ Int _ BellmanFordF a PropagationEnd = [Char] -> ShowS showString [Char] "PropagationEnd" liftShowsPrec Int -> a -> ShowS sp [a] -> ShowS _ Int d (NegativeCycleCheck (IDLGraphVertex, IDLGraphVertex) vs a r) = (Int -> (IDLGraphVertex, IDLGraphVertex) -> ShowS) -> (Int -> a -> ShowS) -> [Char] -> Int -> (IDLGraphVertex, IDLGraphVertex) -> a -> ShowS forall a b. (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> [Char] -> Int -> a -> b -> ShowS showsBinaryWith Int -> (IDLGraphVertex, IDLGraphVertex) -> ShowS forall a. Show a => Int -> a -> ShowS showsPrec Int -> a -> ShowS sp [Char] "NegativeCycleCheck" Int d (IDLGraphVertex, IDLGraphVertex) vs a r liftShowsPrec Int -> a -> ShowS _ [a] -> ShowS _ Int d (NegativeCycleFind [Expressed] path) = (Int -> [Expressed] -> ShowS) -> [Char] -> Int -> [Expressed] -> ShowS forall a. (Int -> a -> ShowS) -> [Char] -> Int -> a -> ShowS showsUnaryWith Int -> [Expressed] -> ShowS forall a. Show a => Int -> a -> ShowS showsPrec [Char] "NegativeCycleFind" Int d [Expressed] path liftShowsPrec Int -> a -> ShowS _ [a] -> ShowS _ Int _ BellmanFordF a NegativeCyclePass = [Char] -> ShowS showString [Char] "NegativeCyclePass" propagationCheck :: (IDLGraphVertex, IDLGraphVertex) -> BellmanFord () propagationCheck :: (IDLGraphVertex, IDLGraphVertex) -> BellmanFord () propagationCheck (IDLGraphVertex, IDLGraphVertex) vs = BellmanFordF (BellmanFord ()) -> BellmanFord () forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => f (m a) -> m a wrap (BellmanFordF (BellmanFord ()) -> BellmanFord ()) -> (BellmanFord () -> BellmanFordF (BellmanFord ())) -> BellmanFord () -> BellmanFord () forall b c a. (b -> c) -> (a -> b) -> a -> c . (IDLGraphVertex, IDLGraphVertex) -> BellmanFord () -> BellmanFordF (BellmanFord ()) forall r. (IDLGraphVertex, IDLGraphVertex) -> r -> BellmanFordF r PropagationCheck (IDLGraphVertex, IDLGraphVertex) vs (BellmanFord () -> BellmanFord ()) -> BellmanFord () -> BellmanFord () forall a b. (a -> b) -> a -> b $ () -> BellmanFord () forall (f :: * -> *) a. Applicative f => a -> f a pure () {-# INLINE propagationCheck #-} propagationFindShorter :: IDLGraphVertex -> (IDLGraphVertex, PositiveInfiniteInt) -> BellmanFord () propagationFindShorter :: IDLGraphVertex -> (IDLGraphVertex, PositiveInfiniteInt) -> BellmanFord () propagationFindShorter IDLGraphVertex v (IDLGraphVertex, PositiveInfiniteInt) p = BellmanFordF (BellmanFord ()) -> BellmanFord () forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => f (m a) -> m a wrap (BellmanFordF (BellmanFord ()) -> BellmanFord ()) -> (BellmanFord () -> BellmanFordF (BellmanFord ())) -> BellmanFord () -> BellmanFord () forall b c a. (b -> c) -> (a -> b) -> a -> c . IDLGraphVertex -> (IDLGraphVertex, PositiveInfiniteInt) -> BellmanFord () -> BellmanFordF (BellmanFord ()) forall r. IDLGraphVertex -> (IDLGraphVertex, PositiveInfiniteInt) -> r -> BellmanFordF r PropagationFindShorter IDLGraphVertex v (IDLGraphVertex, PositiveInfiniteInt) p (BellmanFord () -> BellmanFord ()) -> BellmanFord () -> BellmanFord () forall a b. (a -> b) -> a -> b $ () -> BellmanFord () forall (f :: * -> *) a. Applicative f => a -> f a pure () {-# INLINE propagationFindShorter #-} propagationNth :: Int -> BellmanFord () propagationNth :: Int -> BellmanFord () propagationNth Int n = BellmanFordF (BellmanFord ()) -> BellmanFord () forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => f (m a) -> m a wrap (BellmanFordF (BellmanFord ()) -> BellmanFord ()) -> (BellmanFord () -> BellmanFordF (BellmanFord ())) -> BellmanFord () -> BellmanFord () forall b c a. (b -> c) -> (a -> b) -> a -> c . Int -> BellmanFord () -> BellmanFordF (BellmanFord ()) forall r. Int -> r -> BellmanFordF r PropagationNth Int n (BellmanFord () -> BellmanFord ()) -> BellmanFord () -> BellmanFord () forall a b. (a -> b) -> a -> b $ () -> BellmanFord () forall (f :: * -> *) a. Applicative f => a -> f a pure () {-# INLINE propagationNth #-} propagationEnd :: BellmanFord () propagationEnd :: BellmanFord () propagationEnd = BellmanFordF (BellmanFord ()) -> BellmanFord () forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => f (m a) -> m a wrap BellmanFordF (BellmanFord ()) forall r. BellmanFordF r PropagationEnd {-# INLINE propagationEnd #-} negativeCycleCheck :: (IDLGraphVertex, IDLGraphVertex) -> BellmanFord () negativeCycleCheck :: (IDLGraphVertex, IDLGraphVertex) -> BellmanFord () negativeCycleCheck (IDLGraphVertex, IDLGraphVertex) vs = BellmanFordF (BellmanFord ()) -> BellmanFord () forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => f (m a) -> m a wrap (BellmanFordF (BellmanFord ()) -> BellmanFord ()) -> (BellmanFord () -> BellmanFordF (BellmanFord ())) -> BellmanFord () -> BellmanFord () forall b c a. (b -> c) -> (a -> b) -> a -> c . (IDLGraphVertex, IDLGraphVertex) -> BellmanFord () -> BellmanFordF (BellmanFord ()) forall r. (IDLGraphVertex, IDLGraphVertex) -> r -> BellmanFordF r NegativeCycleCheck (IDLGraphVertex, IDLGraphVertex) vs (BellmanFord () -> BellmanFord ()) -> BellmanFord () -> BellmanFord () forall a b. (a -> b) -> a -> b $ () -> BellmanFord () forall (f :: * -> *) a. Applicative f => a -> f a pure () {-# INLINE negativeCycleCheck #-} negativeCycleFind :: [QFIDL.Expressed] -> BellmanFord () negativeCycleFind :: [Expressed] -> BellmanFord () negativeCycleFind = BellmanFordF (BellmanFord ()) -> BellmanFord () forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => f (m a) -> m a wrap (BellmanFordF (BellmanFord ()) -> BellmanFord ()) -> ([Expressed] -> BellmanFordF (BellmanFord ())) -> [Expressed] -> BellmanFord () forall b c a. (b -> c) -> (a -> b) -> a -> c . [Expressed] -> BellmanFordF (BellmanFord ()) forall r. [Expressed] -> BellmanFordF r NegativeCycleFind {-# INLINE negativeCycleFind #-} negativeCyclePass :: BellmanFord () negativeCyclePass :: BellmanFord () negativeCyclePass = BellmanFordF (BellmanFord ()) -> BellmanFord () forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => f (m a) -> m a wrap BellmanFordF (BellmanFord ()) forall r. BellmanFordF r NegativeCyclePass {-# INLINE negativeCyclePass #-}