{-

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 GHC.Word

import qualified GHC.Data.Word64Set 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.Word64Set
    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 -> Word64
k :: Var -> Word64
k Var
v = Unique -> Word64
getKey (Var -> Unique
forall a. Uniquable a => a -> Unique
getUnique Var
v)

domUFMUnVarSet :: UniqFM key elt -> UnVarSet
domUFMUnVarSet :: forall {k} (key :: k) elt. UniqFM key elt -> UnVarSet
domUFMUnVarSet UniqFM key elt
ae = Word64Set -> UnVarSet
UnVarSet (Word64Set -> UnVarSet) -> Word64Set -> UnVarSet
forall a b. (a -> b) -> a -> b
$ UniqFM key elt -> Word64Set
forall {k} (key :: k) elt. UniqFM key elt -> Word64Set
ufmToSet_Directly UniqFM key elt
ae

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

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


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

delUnVarSet :: UnVarSet -> Var -> UnVarSet
delUnVarSet :: UnVarSet -> Var -> UnVarSet
delUnVarSet (UnVarSet Word64Set
s) Var
v = Word64Set -> UnVarSet
UnVarSet (Word64Set -> UnVarSet) -> Word64Set -> UnVarSet
forall a b. (a -> b) -> a -> b
$ Var -> Word64
k Var
v Word64 -> Word64Set -> Word64Set
`S.delete` Word64Set
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 Word64Set
s) (UnVarSet Word64Set
s') = Word64Set -> UnVarSet
UnVarSet (Word64Set -> UnVarSet) -> Word64Set -> UnVarSet
forall a b. (a -> b) -> a -> b
$ Word64Set
s Word64Set -> Word64Set -> Word64Set
`S.difference` Word64Set
s'

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

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

extendUnVarSet :: Var -> UnVarSet -> UnVarSet
extendUnVarSet :: Var -> UnVarSet -> UnVarSet
extendUnVarSet Var
v (UnVarSet Word64Set
s) = Word64Set -> UnVarSet
UnVarSet (Word64Set -> UnVarSet) -> Word64Set -> UnVarSet
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64Set -> Word64Set
S.insert (Var -> Word64
k Var
v) Word64Set
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 Word64Set
set1) (UnVarSet Word64Set
set2) = Word64Set -> UnVarSet
UnVarSet (Word64Set
set1 Word64Set -> Word64Set -> Word64Set
`S.union` Word64Set
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 Word64Set
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 (Word64 -> Unique
mkUniqueGrimily Word64
i) | Word64
i <- Word64Set -> [Word64]
S.toList Word64Set
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)