module Satyros.BellmanFord.NegativeCycle where import Control.Lens (at, uses) import Control.Monad (forM_, when) import qualified Data.Map as Map import Data.Maybe (fromJust) import qualified Data.Set as Set import Satyros.BellmanFord.Effect (BellmanFord, negativeCycleCheck, negativeCycleFind, negativeCyclePass) import Satyros.BellmanFord.Storage (IDLGraph) import qualified Satyros.QFIDL as QFIDL negativeCycle :: IDLGraph -> BellmanFord () negativeCycle :: IDLGraph -> BellmanFord () negativeCycle IDLGraph graph = do [((IDLGraphVertex, IDLGraphVertex), Int)] -> (((IDLGraphVertex, IDLGraphVertex), Int) -> BellmanFord ()) -> BellmanFord () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ (IDLGraph -> [((IDLGraphVertex, IDLGraphVertex), Int)] forall k a. Map k a -> [(k, a)] Map.toList IDLGraph graph) ((((IDLGraphVertex, IDLGraphVertex), Int) -> BellmanFord ()) -> BellmanFord ()) -> (((IDLGraphVertex, IDLGraphVertex), Int) -> BellmanFord ()) -> BellmanFord () forall a b. (a -> b) -> a -> b $ \((IDLGraphVertex f, IDLGraphVertex t), Int w) -> do (IDLGraphVertex, IDLGraphVertex) -> BellmanFord () negativeCycleCheck (IDLGraphVertex f, IDLGraphVertex t) (IDLGraphVertex pf, Int df) <- LensLike' (Const (IDLGraphVertex, Int)) Storage (Maybe (IDLGraphVertex, Int)) -> (Maybe (IDLGraphVertex, Int) -> (IDLGraphVertex, Int)) -> BellmanFord (IDLGraphVertex, Int) forall s (m :: * -> *) r a. MonadState s m => LensLike' (Const r) s a -> (a -> r) -> m r uses (Index Storage -> Lens' Storage (Maybe (IxValue Storage)) forall m. At m => Index m -> Lens' m (Maybe (IxValue m)) at IDLGraphVertex Index Storage f) Maybe (IDLGraphVertex, Int) -> (IDLGraphVertex, Int) forall a. HasCallStack => Maybe a -> a fromJust (IDLGraphVertex _, Int dt) <- LensLike' (Const (IDLGraphVertex, Int)) Storage (Maybe (IDLGraphVertex, Int)) -> (Maybe (IDLGraphVertex, Int) -> (IDLGraphVertex, Int)) -> BellmanFord (IDLGraphVertex, Int) forall s (m :: * -> *) r a. MonadState s m => LensLike' (Const r) s a -> (a -> r) -> m r uses (Index Storage -> Lens' Storage (Maybe (IxValue Storage)) forall m. At m => Index m -> Lens' m (Maybe (IxValue m)) at IDLGraphVertex Index Storage t) Maybe (IDLGraphVertex, Int) -> (IDLGraphVertex, Int) forall a. HasCallStack => Maybe a -> a fromJust Bool -> BellmanFord () -> BellmanFord () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Int df Int -> Int -> Int forall a. Num a => a -> a -> a + Int w Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < Int dt) (BellmanFord () -> BellmanFord ()) -> BellmanFord () -> BellmanFord () forall a b. (a -> b) -> a -> b $ do [Expressed] clc <- Set IDLGraphVertex -> IDLGraphVertex -> BellmanFord [Expressed] getCycleFrom (IDLGraphVertex -> Set IDLGraphVertex forall a. a -> Set a Set.singleton IDLGraphVertex f) IDLGraphVertex pf [Expressed] -> BellmanFord () negativeCycleFind [Expressed] clc BellmanFord () negativeCyclePass where getCycleFrom :: Set IDLGraphVertex -> IDLGraphVertex -> BellmanFord [Expressed] getCycleFrom Set IDLGraphVertex visited IDLGraphVertex p | IDLGraphVertex -> Set IDLGraphVertex -> Bool forall a. Ord a => a -> Set a -> Bool Set.member IDLGraphVertex p Set IDLGraphVertex visited = do (IDLGraphVertex pp, Int _) <- LensLike' (Const (IDLGraphVertex, Int)) Storage (Maybe (IDLGraphVertex, Int)) -> (Maybe (IDLGraphVertex, Int) -> (IDLGraphVertex, Int)) -> BellmanFord (IDLGraphVertex, Int) forall s (m :: * -> *) r a. MonadState s m => LensLike' (Const r) s a -> (a -> r) -> m r uses (Index Storage -> Lens' Storage (Maybe (IxValue Storage)) forall m. At m => Index m -> Lens' m (Maybe (IxValue m)) at IDLGraphVertex Index Storage p) Maybe (IDLGraphVertex, Int) -> (IDLGraphVertex, Int) forall a. HasCallStack => Maybe a -> a fromJust IDLGraphVertex -> IDLGraphVertex -> IDLGraphVertex -> BellmanFord [Expressed] go IDLGraphVertex p IDLGraphVertex pp IDLGraphVertex p | Bool otherwise = do (IDLGraphVertex pp, Int _) <- LensLike' (Const (IDLGraphVertex, Int)) Storage (Maybe (IDLGraphVertex, Int)) -> (Maybe (IDLGraphVertex, Int) -> (IDLGraphVertex, Int)) -> BellmanFord (IDLGraphVertex, Int) forall s (m :: * -> *) r a. MonadState s m => LensLike' (Const r) s a -> (a -> r) -> m r uses (Index Storage -> Lens' Storage (Maybe (IxValue Storage)) forall m. At m => Index m -> Lens' m (Maybe (IxValue m)) at IDLGraphVertex Index Storage p) Maybe (IDLGraphVertex, Int) -> (IDLGraphVertex, Int) forall a. HasCallStack => Maybe a -> a fromJust Set IDLGraphVertex -> IDLGraphVertex -> BellmanFord [Expressed] getCycleFrom (IDLGraphVertex -> Set IDLGraphVertex -> Set IDLGraphVertex forall a. Ord a => a -> Set a -> Set a Set.insert IDLGraphVertex p Set IDLGraphVertex visited) IDLGraphVertex pp go :: IDLGraphVertex -> IDLGraphVertex -> IDLGraphVertex -> BellmanFord [Expressed] go IDLGraphVertex f IDLGraphVertex p IDLGraphVertex n | IDLGraphVertex f IDLGraphVertex -> IDLGraphVertex -> Bool forall a. Eq a => a -> a -> Bool == IDLGraphVertex p = [Expressed] -> BellmanFord [Expressed] forall (f :: * -> *) a. Applicative f => a -> f a pure [Variable -> Variable -> Int -> Expressed QFIDL.LessThanEqualTo (IDLGraphVertex -> Variable forall a. HasCallStack => Maybe a -> a fromJust IDLGraphVertex p) (IDLGraphVertex -> Variable forall a. HasCallStack => Maybe a -> a fromJust IDLGraphVertex n) (IDLGraph graph IDLGraph -> (IDLGraphVertex, IDLGraphVertex) -> Int forall k a. Ord k => Map k a -> k -> a Map.! (IDLGraphVertex p, IDLGraphVertex n))] | Bool otherwise = do (IDLGraphVertex pp, Int _) <- LensLike' (Const (IDLGraphVertex, Int)) Storage (Maybe (IDLGraphVertex, Int)) -> (Maybe (IDLGraphVertex, Int) -> (IDLGraphVertex, Int)) -> BellmanFord (IDLGraphVertex, Int) forall s (m :: * -> *) r a. MonadState s m => LensLike' (Const r) s a -> (a -> r) -> m r uses (Index Storage -> Lens' Storage (Maybe (IxValue Storage)) forall m. At m => Index m -> Lens' m (Maybe (IxValue m)) at IDLGraphVertex Index Storage p) Maybe (IDLGraphVertex, Int) -> (IDLGraphVertex, Int) forall a. HasCallStack => Maybe a -> a fromJust (Variable -> Variable -> Int -> Expressed QFIDL.LessThanEqualTo (IDLGraphVertex -> Variable forall a. HasCallStack => Maybe a -> a fromJust IDLGraphVertex p) (IDLGraphVertex -> Variable forall a. HasCallStack => Maybe a -> a fromJust IDLGraphVertex n) (IDLGraph graph IDLGraph -> (IDLGraphVertex, IDLGraphVertex) -> Int forall k a. Ord k => Map k a -> k -> a Map.! (IDLGraphVertex p, IDLGraphVertex n)) Expressed -> [Expressed] -> [Expressed] forall a. a -> [a] -> [a] :) ([Expressed] -> [Expressed]) -> BellmanFord [Expressed] -> BellmanFord [Expressed] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> IDLGraphVertex -> IDLGraphVertex -> IDLGraphVertex -> BellmanFord [Expressed] go IDLGraphVertex f IDLGraphVertex pp IDLGraphVertex p