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