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