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 Satyros.BellmanFord.Effect (BellmanFord, negativeCycleCheck, negativeCycleFind, negativeCyclePass) import Satyros.BellmanFord.Storage (IDLGraph, PositiveInfiniteInt (Finite), addPositiveInfiniteInt) 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, PositiveInfiniteInt df) <- LensLike' (Const (IDLGraphVertex, PositiveInfiniteInt)) Storage (Maybe (IDLGraphVertex, PositiveInfiniteInt)) -> (Maybe (IDLGraphVertex, PositiveInfiniteInt) -> (IDLGraphVertex, PositiveInfiniteInt)) -> BellmanFord (IDLGraphVertex, PositiveInfiniteInt) 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, PositiveInfiniteInt) -> (IDLGraphVertex, PositiveInfiniteInt) forall a. HasCallStack => Maybe a -> a fromJust (IDLGraphVertex _, PositiveInfiniteInt dt) <- LensLike' (Const (IDLGraphVertex, PositiveInfiniteInt)) Storage (Maybe (IDLGraphVertex, PositiveInfiniteInt)) -> (Maybe (IDLGraphVertex, PositiveInfiniteInt) -> (IDLGraphVertex, PositiveInfiniteInt)) -> BellmanFord (IDLGraphVertex, PositiveInfiniteInt) 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, PositiveInfiniteInt) -> (IDLGraphVertex, PositiveInfiniteInt) forall a. HasCallStack => Maybe a -> a fromJust Bool -> BellmanFord () -> BellmanFord () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (PositiveInfiniteInt -> PositiveInfiniteInt -> PositiveInfiniteInt addPositiveInfiniteInt PositiveInfiniteInt df (Int -> PositiveInfiniteInt Finite Int w) PositiveInfiniteInt -> PositiveInfiniteInt -> Bool forall a. Ord a => a -> a -> Bool < PositiveInfiniteInt dt) (BellmanFord () -> BellmanFord ()) -> BellmanFord () -> BellmanFord () forall a b. (a -> b) -> a -> b $ do [Expressed] clc <- IDLGraphVertex -> IDLGraphVertex -> IDLGraphVertex -> BellmanFord [Expressed] getCycleFrom IDLGraphVertex f IDLGraphVertex pf IDLGraphVertex f [Expressed] -> BellmanFord () negativeCycleFind [Expressed] clc BellmanFord () negativeCyclePass where getCycleFrom :: IDLGraphVertex -> IDLGraphVertex -> IDLGraphVertex -> BellmanFord [Expressed] getCycleFrom 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, PositiveInfiniteInt _) <- LensLike' (Const (IDLGraphVertex, PositiveInfiniteInt)) Storage (Maybe (IDLGraphVertex, PositiveInfiniteInt)) -> (Maybe (IDLGraphVertex, PositiveInfiniteInt) -> (IDLGraphVertex, PositiveInfiniteInt)) -> BellmanFord (IDLGraphVertex, PositiveInfiniteInt) 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, PositiveInfiniteInt) -> (IDLGraphVertex, PositiveInfiniteInt) 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] getCycleFrom IDLGraphVertex f IDLGraphVertex pp IDLGraphVertex p