module Funcons.Operations.Graphs where

import Funcons.Operations.Internal
import Funcons.Operations.Booleans (tobool)
import qualified Data.Map as M
import qualified Data.Set as S
import Data.List ((\\))

library :: (HasValues t, Ord t) => Library t
library :: Library t
library = [(OP, ValueOp t)] -> Library t
forall t. [(OP, ValueOp t)] -> Library t
libFromList [
    (OP
"is-cyclic", UnaryExpr t -> ValueOp t
forall t. UnaryExpr t -> ValueOp t
UnaryExpr UnaryExpr t
forall t. (Ord t, HasValues t) => OpExpr t -> OpExpr t
is_cyclic)
  , (OP
"topological-sort", UnaryExpr t -> ValueOp t
forall t. UnaryExpr t -> ValueOp t
UnaryExpr UnaryExpr t
forall t. (Ord t, HasValues t) => OpExpr t -> OpExpr t
topological_sort)
  ]

is_cyclic_ :: (Ord t, HasValues t) => [OpExpr t] -> OpExpr t
is_cyclic_ :: [OpExpr t] -> OpExpr t
is_cyclic_ = UnaryExpr t -> [OpExpr t] -> OpExpr t
forall t. UnaryExpr t -> [OpExpr t] -> OpExpr t
unaryOp UnaryExpr t
forall t. (Ord t, HasValues t) => OpExpr t -> OpExpr t
is_cyclic
is_cyclic :: (Ord t, HasValues t) => OpExpr t -> OpExpr t
is_cyclic :: OpExpr t -> OpExpr t
is_cyclic = OP -> UnaryVOp t -> OpExpr t -> OpExpr t
forall t. HasValues t => OP -> UnaryVOp t -> OpExpr t -> OpExpr t
vUnaryOp OP
"is-cyclic" UnaryVOp t
forall t t. (Ord t, HasValues t) => Values t -> Result t
op
  where op :: Values t -> Result t
op Values t
mm | Just Graph (Values t)
m <- Values t -> Maybe (Graph (Values t))
forall t. Ord t => Values t -> Maybe (Graph (Values t))
toGraph Values t
mm = t -> Result t
forall t. t -> Result t
Normal (t -> Result t) -> t -> Result t
forall a b. (a -> b) -> a -> b
$ Values t -> t
forall t. HasValues t => Values t -> t
inject (Values t -> t) -> Values t -> t
forall a b. (a -> b) -> a -> b
$ Bool -> Values t
forall t. Bool -> Values t
tobool (Graph (Values t) -> Bool
forall e. Ord e => Graph e -> Bool
cyclic Graph (Values t)
m)
        op Values t
_ = OP -> Result t
forall t. OP -> Result t
SortErr OP
"is-cyclic not applied to a graph" 

topological_sort_ :: (Ord t, HasValues t) => [OpExpr t] -> OpExpr t
topological_sort_ :: [OpExpr t] -> OpExpr t
topological_sort_ = UnaryExpr t -> [OpExpr t] -> OpExpr t
forall t. UnaryExpr t -> [OpExpr t] -> OpExpr t
unaryOp UnaryExpr t
forall t. (Ord t, HasValues t) => OpExpr t -> OpExpr t
topological_sort
topological_sort :: (Ord t, HasValues t) => OpExpr t -> OpExpr t
topological_sort :: OpExpr t -> OpExpr t
topological_sort = OP -> UnaryVOp t -> OpExpr t -> OpExpr t
forall t. HasValues t => OP -> UnaryVOp t -> OpExpr t -> OpExpr t
vUnaryOp OP
"topological-sort" UnaryVOp t
forall t. (Ord t, HasValues t) => Values t -> Result t
op
  where op :: Values t -> Result t
op Values t
mm | Just Graph (Values t)
m <- Values t -> Maybe (Graph (Values t))
forall t. Ord t => Values t -> Maybe (Graph (Values t))
toGraph Values t
mm = t -> Result t
forall t. t -> Result t
Normal (t -> Result t) -> t -> Result t
forall a b. (a -> b) -> a -> b
$ Values t -> t
forall t. HasValues t => Values t -> t
inject (Values t -> t) -> Values t -> t
forall a b. (a -> b) -> a -> b
$ [t] -> Values t
forall t. HasValues t => [t] -> Values t
multi ([t] -> Values t) -> [t] -> Values t
forall a b. (a -> b) -> a -> b
$ (Values t -> t) -> [Values t] -> [t]
forall a b. (a -> b) -> [a] -> [b]
map Values t -> t
forall t. HasValues t => Values t -> t
inject ([Values t] -> [t]) -> [Values t] -> [t]
forall a b. (a -> b) -> a -> b
$ ([Values t], Graph (Values t)) -> [Values t]
forall a b. (a, b) -> a
fst (Graph (Values t) -> ([Values t], Graph (Values t))
forall e. Ord e => Graph e -> ([e], Graph e)
schedule Graph (Values t)
m)
        op Values t
_ = OP -> Result t
forall t. OP -> Result t
SortErr OP
"topological-sort not applied to a graph"

toGraph :: (Ord t) => Values t -> Maybe (Graph (Values t))
toGraph :: Values t -> Maybe (Graph (Values t))
toGraph (Map ValueMaps (Values t)
m) = (Values t
 -> [Values t]
 -> Maybe (Graph (Values t))
 -> Maybe (Graph (Values t)))
-> Maybe (Graph (Values t))
-> ValueMaps (Values t)
-> Maybe (Graph (Values t))
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey Values t
-> [Values t]
-> Maybe (Graph (Values t))
-> Maybe (Graph (Values t))
forall k t.
Ord k =>
k
-> [Values t]
-> Maybe (Map k (ValueSets (Values t)))
-> Maybe (Map k (ValueSets (Values t)))
combine (Graph (Values t) -> Maybe (Graph (Values t))
forall a. a -> Maybe a
Just Graph (Values t)
forall k a. Map k a
M.empty) ValueMaps (Values t)
m
  where combine :: k
-> [Values t]
-> Maybe (Map k (ValueSets (Values t)))
-> Maybe (Map k (ValueSets (Values t)))
combine k
k [Set ValueSets (Values t)
s] Maybe (Map k (ValueSets (Values t)))
mm = (Map k (ValueSets (Values t)) -> Map k (ValueSets (Values t)))
-> Maybe (Map k (ValueSets (Values t)))
-> Maybe (Map k (ValueSets (Values t)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (k
-> ValueSets (Values t)
-> Map k (ValueSets (Values t))
-> Map k (ValueSets (Values t))
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
k ValueSets (Values t)
s) Maybe (Map k (ValueSets (Values t)))
mm
        combine k
_ [Values t]
_ Maybe (Map k (ValueSets (Values t)))
_ = Maybe (Map k (ValueSets (Values t)))
forall a. Maybe a
Nothing
toGraph Values t
_ = Maybe (Graph (Values t))
forall a. Maybe a
Nothing 

-- small graph library
type Graph e = M.Map e (S.Set e)

-- | Get the entry points of the graph
entries :: Eq e => Graph e -> [e]
entries :: Graph e -> [e]
entries Graph e
m = Graph e -> [e]
forall k a. Map k a -> [k]
M.keys Graph e
m [e] -> [e] -> [e]
forall a. Eq a => [a] -> [a] -> [a]
\\ [e]
withIncoming
  where withIncoming :: [e]
withIncoming = (Set e -> [e]) -> [Set e] -> [e]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Set e -> [e]
forall a. Set a -> [a]
S.toList (Graph e -> [Set e]
forall k a. Map k a -> [a]
M.elems Graph e
m)

-- | Delete a node from the graph
delete :: Ord e => e -> Graph e -> Graph e
delete :: e -> Graph e -> Graph e
delete e
n Graph e
m = (Set e -> Set e) -> Graph e -> Graph e
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (e -> Set e -> Set e
forall a. Ord a => a -> Set a -> Set a
S.delete e
n) (Graph e -> Graph e) -> Graph e -> Graph e
forall a b. (a -> b) -> a -> b
$ e -> Graph e -> Graph e
forall k a. Ord k => k -> Map k a -> Map k a
M.delete e
n Graph e
m 

-- | Return all nodes in the graph such that if `a -> b` in the graph
-- then `a` occurs before `b` in the result
-- Also returns a graph which, if cyclic, contains all the cycles in the 
-- original graph, corresponding to nodes not in the schedule.
schedule :: (Ord e) => Graph e -> ([e], Graph e)
schedule :: Graph e -> ([e], Graph e)
schedule Graph e
gr = Graph e -> [e] -> [e] -> ([e], Graph e)
forall e. Ord e => Graph e -> [e] -> [e] -> ([e], Graph e)
schedule' Graph e
gr (Graph e -> [e]
forall e. Eq e => Graph e -> [e]
entries Graph e
gr) []
  where schedule' :: Graph e -> [e] -> [e] -> ([e], Graph e)
schedule' Graph e
gr []     [e]
uset = ([e]
uset, Graph e
gr)
        schedule' Graph e
gr (e
e:[e]
es) [e]
uset = Graph e -> [e] -> [e] -> ([e], Graph e)
schedule' Graph e
gr' (Graph e -> [e]
forall e. Eq e => Graph e -> [e]
entries Graph e
gr') [e]
uset' 
          where uset' :: [e]
uset'       = [e]
uset [e] -> [e] -> [e]
forall a. [a] -> [a] -> [a]
++ [e
e]
                gr' :: Graph e
gr'         = e -> Graph e -> Graph e
forall e. Ord e => e -> Graph e -> Graph e
delete e
e Graph e
gr

-- | Checks whether the given grammar contains cycles
cyclic :: (Ord e) => Graph e -> Bool
cyclic :: Graph e -> Bool
cyclic Graph e
gr = Bool -> Bool
not (Graph e -> Bool
forall k a. Map k a -> Bool
is_empty (([e], Graph e) -> Graph e
forall a b. (a, b) -> b
snd (Graph e -> ([e], Graph e)
forall e. Ord e => Graph e -> ([e], Graph e)
schedule Graph e
gr)))

-- | Checks whether the given graph is empty
is_empty :: Map k a -> Bool
is_empty Map k a
gr = Map k a -> Bool
forall k a. Map k a -> Bool
M.null Map k a
gr