{-

Copyright (c) 2014 Joachim Breitner

A data structure for undirected graphs of variables
(or in plain terms: Sets of unordered pairs of numbers)


This is very specifically tailored for the use in CallArity. In particular it
stores the graph as a union of complete and complete bipartite graph, which
would be very expensive to store as sets of edges or as adjanceny lists.

It does not normalize the graphs. This means that g `unionUnVarGraph` g is
equal to g, but twice as expensive and large.

-}
module GHC.Data.Graph.UnVar
    ( UnVarSet
    , emptyUnVarSet, mkUnVarSet, unionUnVarSet, unionUnVarSets
    , extendUnVarSet, extendUnVarSetList, delUnVarSet, delUnVarSetList
    , elemUnVarSet, isEmptyUnVarSet
    , UnVarGraph
    , emptyUnVarGraph
    , unionUnVarGraph, unionUnVarGraphs
    , completeGraph, completeBipartiteGraph
    , neighbors
    , hasLoopAt
    , delNode
    , domUFMUnVarSet
    ) where

import GHC.Prelude

import GHC.Types.Unique.FM( UniqFM, ufmToSet_Directly )
import GHC.Types.Var
import GHC.Utils.Outputable
import GHC.Types.Unique

import qualified Data.IntSet as S

-- We need a type for sets of variables (UnVarSet).
-- We do not use VarSet, because for that we need to have the actual variable
-- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet.
-- Therefore, use a IntSet directly (which is likely also a bit more efficient).

-- Set of uniques, i.e. for adjacent nodes
newtype UnVarSet = UnVarSet (S.IntSet)
    deriving UnVarSet -> UnVarSet -> Bool
(UnVarSet -> UnVarSet -> Bool)
-> (UnVarSet -> UnVarSet -> Bool) -> Eq UnVarSet
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnVarSet -> UnVarSet -> Bool
== :: UnVarSet -> UnVarSet -> Bool
$c/= :: UnVarSet -> UnVarSet -> Bool
/= :: UnVarSet -> UnVarSet -> Bool
Eq

k :: Var -> Int
k :: Var -> Int
k Var
v = Unique -> Int
getKey (Var -> Unique
forall a. Uniquable a => a -> Unique
getUnique Var
v)

domUFMUnVarSet :: UniqFM key elt -> UnVarSet
domUFMUnVarSet :: forall key elt. UniqFM key elt -> UnVarSet
domUFMUnVarSet UniqFM key elt
ae = IntSet -> UnVarSet
UnVarSet (IntSet -> UnVarSet) -> IntSet -> UnVarSet
forall a b. (a -> b) -> a -> b
$ UniqFM key elt -> IntSet
forall key elt. UniqFM key elt -> IntSet
ufmToSet_Directly UniqFM key elt
ae

emptyUnVarSet :: UnVarSet
emptyUnVarSet :: UnVarSet
emptyUnVarSet = IntSet -> UnVarSet
UnVarSet IntSet
S.empty

elemUnVarSet :: Var -> UnVarSet -> Bool
elemUnVarSet :: Var -> UnVarSet -> Bool
elemUnVarSet Var
v (UnVarSet IntSet
s) = Var -> Int
k Var
v Int -> IntSet -> Bool
`S.member` IntSet
s


isEmptyUnVarSet :: UnVarSet -> Bool
isEmptyUnVarSet :: UnVarSet -> Bool
isEmptyUnVarSet (UnVarSet IntSet
s) = IntSet -> Bool
S.null IntSet
s

delUnVarSet :: UnVarSet -> Var -> UnVarSet
delUnVarSet :: UnVarSet -> Var -> UnVarSet
delUnVarSet (UnVarSet IntSet
s) Var
v = IntSet -> UnVarSet
UnVarSet (IntSet -> UnVarSet) -> IntSet -> UnVarSet
forall a b. (a -> b) -> a -> b
$ Var -> Int
k Var
v Int -> IntSet -> IntSet
`S.delete` IntSet
s

delUnVarSetList :: UnVarSet -> [Var] -> UnVarSet
delUnVarSetList :: UnVarSet -> [Var] -> UnVarSet
delUnVarSetList UnVarSet
s [Var]
vs = UnVarSet
s UnVarSet -> UnVarSet -> UnVarSet
`minusUnVarSet` [Var] -> UnVarSet
mkUnVarSet [Var]
vs

minusUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet
minusUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet
minusUnVarSet (UnVarSet IntSet
s) (UnVarSet IntSet
s') = IntSet -> UnVarSet
UnVarSet (IntSet -> UnVarSet) -> IntSet -> UnVarSet
forall a b. (a -> b) -> a -> b
$ IntSet
s IntSet -> IntSet -> IntSet
`S.difference` IntSet
s'

sizeUnVarSet :: UnVarSet -> Int
sizeUnVarSet :: UnVarSet -> Int
sizeUnVarSet (UnVarSet IntSet
s) = IntSet -> Int
S.size IntSet
s

mkUnVarSet :: [Var] -> UnVarSet
mkUnVarSet :: [Var] -> UnVarSet
mkUnVarSet [Var]
vs = IntSet -> UnVarSet
UnVarSet (IntSet -> UnVarSet) -> IntSet -> UnVarSet
forall a b. (a -> b) -> a -> b
$ [Int] -> IntSet
S.fromList ([Int] -> IntSet) -> [Int] -> IntSet
forall a b. (a -> b) -> a -> b
$ (Var -> Int) -> [Var] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Int
k [Var]
vs

extendUnVarSet :: Var -> UnVarSet -> UnVarSet
extendUnVarSet :: Var -> UnVarSet -> UnVarSet
extendUnVarSet Var
v (UnVarSet IntSet
s) = IntSet -> UnVarSet
UnVarSet (IntSet -> UnVarSet) -> IntSet -> UnVarSet
forall a b. (a -> b) -> a -> b
$ Int -> IntSet -> IntSet
S.insert (Var -> Int
k Var
v) IntSet
s

extendUnVarSetList :: [Var] -> UnVarSet -> UnVarSet
extendUnVarSetList :: [Var] -> UnVarSet -> UnVarSet
extendUnVarSetList [Var]
vs UnVarSet
s = UnVarSet
s UnVarSet -> UnVarSet -> UnVarSet
`unionUnVarSet` [Var] -> UnVarSet
mkUnVarSet [Var]
vs

unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet
unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet
unionUnVarSet (UnVarSet IntSet
set1) (UnVarSet IntSet
set2) = IntSet -> UnVarSet
UnVarSet (IntSet
set1 IntSet -> IntSet -> IntSet
`S.union` IntSet
set2)

unionUnVarSets :: [UnVarSet] -> UnVarSet
unionUnVarSets :: [UnVarSet] -> UnVarSet
unionUnVarSets = (UnVarSet -> UnVarSet -> UnVarSet)
-> UnVarSet -> [UnVarSet] -> UnVarSet
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((UnVarSet -> UnVarSet -> UnVarSet)
-> UnVarSet -> UnVarSet -> UnVarSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip UnVarSet -> UnVarSet -> UnVarSet
unionUnVarSet) UnVarSet
emptyUnVarSet

instance Outputable UnVarSet where
    ppr :: UnVarSet -> SDoc
ppr (UnVarSet IntSet
s) = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
        [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma [ Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Int -> Unique
forall a. Uniquable a => a -> Unique
getUnique Int
i) | Int
i <- IntSet -> [Int]
S.toList IntSet
s]

data UnVarGraph = CBPG  !UnVarSet !UnVarSet -- ^ complete bipartite graph
                | CG    !UnVarSet           -- ^ complete graph
                | Union UnVarGraph UnVarGraph
                | Del   !UnVarSet UnVarGraph

emptyUnVarGraph :: UnVarGraph
emptyUnVarGraph :: UnVarGraph
emptyUnVarGraph = UnVarSet -> UnVarGraph
CG UnVarSet
emptyUnVarSet

unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph
{-
Premature optimisation, it seems.
unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])
    | s1 == s3 && s2 == s4
    = pprTrace "unionUnVarGraph fired" empty $
      completeGraph (s1 `unionUnVarSet` s2)
unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])
    | s2 == s3 && s1 == s4
    = pprTrace "unionUnVarGraph fired2" empty $
      completeGraph (s1 `unionUnVarSet` s2)
-}
unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph
unionUnVarGraph UnVarGraph
a UnVarGraph
b
  | UnVarGraph -> Bool
is_null UnVarGraph
a = UnVarGraph
b
  | UnVarGraph -> Bool
is_null UnVarGraph
b = UnVarGraph
a
  | Bool
otherwise = UnVarGraph -> UnVarGraph -> UnVarGraph
Union UnVarGraph
a UnVarGraph
b

unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph
unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph
unionUnVarGraphs = (UnVarGraph -> UnVarGraph -> UnVarGraph)
-> UnVarGraph -> [UnVarGraph] -> UnVarGraph
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' UnVarGraph -> UnVarGraph -> UnVarGraph
unionUnVarGraph UnVarGraph
emptyUnVarGraph

-- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B }
completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph
completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph
completeBipartiteGraph UnVarSet
s1 UnVarSet
s2 = UnVarGraph -> UnVarGraph
prune (UnVarGraph -> UnVarGraph) -> UnVarGraph -> UnVarGraph
forall a b. (a -> b) -> a -> b
$ UnVarSet -> UnVarSet -> UnVarGraph
CBPG UnVarSet
s1 UnVarSet
s2

completeGraph :: UnVarSet -> UnVarGraph
completeGraph :: UnVarSet -> UnVarGraph
completeGraph UnVarSet
s = UnVarGraph -> UnVarGraph
prune (UnVarGraph -> UnVarGraph) -> UnVarGraph -> UnVarGraph
forall a b. (a -> b) -> a -> b
$ UnVarSet -> UnVarGraph
CG UnVarSet
s

-- (v' ∈ neighbors G v) <=> v--v' ∈ G
neighbors :: UnVarGraph -> Var -> UnVarSet
neighbors :: UnVarGraph -> Var -> UnVarSet
neighbors = UnVarGraph -> Var -> UnVarSet
go
  where
    go :: UnVarGraph -> Var -> UnVarSet
go (Del UnVarSet
d UnVarGraph
g) Var
v
      | Var
v Var -> UnVarSet -> Bool
`elemUnVarSet` UnVarSet
d = UnVarSet
emptyUnVarSet
      | Bool
otherwise          = UnVarGraph -> Var -> UnVarSet
go UnVarGraph
g Var
v UnVarSet -> UnVarSet -> UnVarSet
`minusUnVarSet` UnVarSet
d
    go (Union UnVarGraph
g1 UnVarGraph
g2) Var
v     = UnVarGraph -> Var -> UnVarSet
go UnVarGraph
g1 Var
v UnVarSet -> UnVarSet -> UnVarSet
`unionUnVarSet` UnVarGraph -> Var -> UnVarSet
go UnVarGraph
g2 Var
v
    go (CG UnVarSet
s) Var
v            = if Var
v Var -> UnVarSet -> Bool
`elemUnVarSet` UnVarSet
s then UnVarSet
s else UnVarSet
emptyUnVarSet
    go (CBPG UnVarSet
s1 UnVarSet
s2) Var
v      = (if Var
v Var -> UnVarSet -> Bool
`elemUnVarSet` UnVarSet
s1 then UnVarSet
s2 else UnVarSet
emptyUnVarSet) UnVarSet -> UnVarSet -> UnVarSet
`unionUnVarSet`
                             (if Var
v Var -> UnVarSet -> Bool
`elemUnVarSet` UnVarSet
s2 then UnVarSet
s1 else UnVarSet
emptyUnVarSet)

-- hasLoopAt G v <=> v--v ∈ G
hasLoopAt :: UnVarGraph -> Var -> Bool
hasLoopAt :: UnVarGraph -> Var -> Bool
hasLoopAt = UnVarGraph -> Var -> Bool
go
  where
    go :: UnVarGraph -> Var -> Bool
go (Del UnVarSet
d UnVarGraph
g) Var
v
      | Var
v Var -> UnVarSet -> Bool
`elemUnVarSet` UnVarSet
d  = Bool
False
      | Bool
otherwise           = UnVarGraph -> Var -> Bool
go UnVarGraph
g Var
v
    go (Union UnVarGraph
g1 UnVarGraph
g2) Var
v      = UnVarGraph -> Var -> Bool
go UnVarGraph
g1 Var
v Bool -> Bool -> Bool
|| UnVarGraph -> Var -> Bool
go UnVarGraph
g2 Var
v
    go (CG UnVarSet
s) Var
v             = Var
v Var -> UnVarSet -> Bool
`elemUnVarSet` UnVarSet
s
    go (CBPG UnVarSet
s1 UnVarSet
s2) Var
v       = Var
v Var -> UnVarSet -> Bool
`elemUnVarSet` UnVarSet
s1 Bool -> Bool -> Bool
&& Var
v Var -> UnVarSet -> Bool
`elemUnVarSet` UnVarSet
s2

delNode :: UnVarGraph -> Var -> UnVarGraph
delNode :: UnVarGraph -> Var -> UnVarGraph
delNode (Del UnVarSet
d UnVarGraph
g) Var
v = UnVarSet -> UnVarGraph -> UnVarGraph
Del (Var -> UnVarSet -> UnVarSet
extendUnVarSet Var
v UnVarSet
d) UnVarGraph
g
delNode UnVarGraph
g         Var
v
  | UnVarGraph -> Bool
is_null UnVarGraph
g       = UnVarGraph
emptyUnVarGraph
  | Bool
otherwise       = UnVarSet -> UnVarGraph -> UnVarGraph
Del ([Var] -> UnVarSet
mkUnVarSet [Var
v]) UnVarGraph
g

-- | Resolves all `Del`, by pushing them in, and simplifies `∅ ∪ … = …`
prune :: UnVarGraph -> UnVarGraph
prune :: UnVarGraph -> UnVarGraph
prune = UnVarSet -> UnVarGraph -> UnVarGraph
go UnVarSet
emptyUnVarSet
  where
    go :: UnVarSet -> UnVarGraph -> UnVarGraph
    go :: UnVarSet -> UnVarGraph -> UnVarGraph
go UnVarSet
dels (Del UnVarSet
dels' UnVarGraph
g) = UnVarSet -> UnVarGraph -> UnVarGraph
go (UnVarSet
dels UnVarSet -> UnVarSet -> UnVarSet
`unionUnVarSet` UnVarSet
dels') UnVarGraph
g
    go UnVarSet
dels (Union UnVarGraph
g1 UnVarGraph
g2)
      | UnVarGraph -> Bool
is_null UnVarGraph
g1' = UnVarGraph
g2'
      | UnVarGraph -> Bool
is_null UnVarGraph
g2' = UnVarGraph
g1'
      | Bool
otherwise   = UnVarGraph -> UnVarGraph -> UnVarGraph
Union UnVarGraph
g1' UnVarGraph
g2'
      where
        g1' :: UnVarGraph
g1' = UnVarSet -> UnVarGraph -> UnVarGraph
go UnVarSet
dels UnVarGraph
g1
        g2' :: UnVarGraph
g2' = UnVarSet -> UnVarGraph -> UnVarGraph
go UnVarSet
dels UnVarGraph
g2
    go UnVarSet
dels (CG UnVarSet
s)        = UnVarSet -> UnVarGraph
CG (UnVarSet
s UnVarSet -> UnVarSet -> UnVarSet
`minusUnVarSet` UnVarSet
dels)
    go UnVarSet
dels (CBPG UnVarSet
s1 UnVarSet
s2)  = UnVarSet -> UnVarSet -> UnVarGraph
CBPG (UnVarSet
s1 UnVarSet -> UnVarSet -> UnVarSet
`minusUnVarSet` UnVarSet
dels) (UnVarSet
s2 UnVarSet -> UnVarSet -> UnVarSet
`minusUnVarSet` UnVarSet
dels)

-- | Shallow empty check.
is_null :: UnVarGraph -> Bool
is_null :: UnVarGraph -> Bool
is_null (CBPG UnVarSet
s1 UnVarSet
s2)  = UnVarSet -> Bool
isEmptyUnVarSet UnVarSet
s1 Bool -> Bool -> Bool
|| UnVarSet -> Bool
isEmptyUnVarSet UnVarSet
s2
is_null (CG   UnVarSet
s)      = UnVarSet -> Bool
isEmptyUnVarSet UnVarSet
s
is_null UnVarGraph
_             = Bool
False

instance Outputable UnVarGraph where
    ppr :: UnVarGraph -> SDoc
ppr (Del UnVarSet
d UnVarGraph
g) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Del" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UnVarSet -> Int
sizeUnVarSet UnVarSet
d) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (UnVarGraph -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnVarGraph
g)
    ppr (Union UnVarGraph
a UnVarGraph
b) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Union" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (UnVarGraph -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnVarGraph
a) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (UnVarGraph -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnVarGraph
b)
    ppr (CG UnVarSet
s) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CG" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UnVarSet -> Int
sizeUnVarSet UnVarSet
s)
    ppr (CBPG UnVarSet
a UnVarSet
b) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CBPG" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UnVarSet -> Int
sizeUnVarSet UnVarSet
a) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UnVarSet -> Int
sizeUnVarSet UnVarSet
b)