{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

--------------------------------------------------------------------------------
--  See end of this file for licence information.
--------------------------------------------------------------------------------
-- |
--  Module      :  GraphMatch
--  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin,
--                 2011, 2012, 2016, 2018, 2020, 2022 Douglas Burke
--  License     :  GPL V2
--
--  Maintainer  :  Douglas Burke
--  Stability   :  experimental
--  Portability :  FlexibleInstances, MultiParamTypeClasses
--
--  This module contains graph-matching logic.
--
--  The algorithm used is derived from a paper on RDF graph matching
--  by Jeremy Carroll <http://www.hpl.hp.com/techreports/2001/HPL-2001-293.html>.
--
--------------------------------------------------------------------------------

module Swish.GraphMatch
      ( graphMatch,
        -- * Exported for testing
        LabelMap, GenLabelMap(..), LabelEntry, GenLabelEntry(..),
        ScopedLabel(..), makeScopedLabel, makeScopedArc,
        LabelIndex, EquivalenceClass, nullLabelVal, emptyMap,
        labelIsVar, labelHash,
        mapLabelIndex, setLabelHash, newLabelMap,
        graphLabels, assignLabelMap, newGenerationMap,
        graphMatch1, graphMatch2, equivalenceClasses, reclassify
      ) where

import Swish.GraphClass (Arc(..), ArcSet, Label(..))
import Swish.GraphClass (getComponents, arcLabels, hasLabel, arcToTriple)

import Control.Exception.Base (assert)
import Control.Arrow (second)

import Data.Function (on)
import Data.Hashable (hashWithSalt)
import Data.List (foldl', sortBy, groupBy, partition)
import Data.Ord (comparing)
import Data.Word

import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S

--------------------------
--  Label index value type
--------------------------
--

-- | LabelIndex is a unique value assigned to each label, such that
--  labels with different values are definitely different values
--  in the graph;  e.g. do not map to each other in the graph
--  bijection.  The first member is a generation counter that
--  ensures new values are distinct from earlier passes.

type LabelIndex = (Word32, Word32)

-- | The null, or empty, index value.
nullLabelVal :: LabelIndex
nullLabelVal :: LabelIndex
nullLabelVal = (Word32
0, Word32
0)

-----------------------
--  Label mapping types
-----------------------

-- | A Mapping between a label and a value (e.g. an index
-- value).
data (Label lb) => GenLabelEntry lb lv = LabelEntry lb lv

-- | A label associated with a 'LabelIndex'
type LabelEntry lb = GenLabelEntry lb LabelIndex

instance (Label lb, Show lv) => Show (GenLabelEntry lb lv) where
    show :: GenLabelEntry lb lv -> String
show (LabelEntry lb
k lv
v) = forall a. Show a => a -> String
show lb
k forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show lv
v

instance (Label lb, Eq lv) => Eq (GenLabelEntry lb lv) where
    (LabelEntry lb
k1 lv
v1) == :: GenLabelEntry lb lv -> GenLabelEntry lb lv -> Bool
== (LabelEntry lb
k2 lv
v2) = (lb
k1,lv
v1) forall a. Eq a => a -> a -> Bool
== (lb
k2,lv
v2)

instance (Label lb, Ord lv) => Ord (GenLabelEntry lb lv) where
    (LabelEntry lb
lb1 lv
lv1) compare :: GenLabelEntry lb lv -> GenLabelEntry lb lv -> Ordering
`compare` (LabelEntry lb
lb2 lv
lv2) =
        (lb
lb1, lv
lv1) forall a. Ord a => a -> a -> Ordering
`compare` (lb
lb2, lv
lv2)

-- | Type for label->index lookup table
data (Label lb, Eq lv, Show lv) => GenLabelMap lb lv =
    LabelMap Word32 (M.Map lb lv)

-- | A label lookup table specialized to 'LabelIndex' indices.
type LabelMap lb = GenLabelMap lb LabelIndex

instance (Label lb) => Show (LabelMap lb) where
    show :: LabelMap lb -> String
show = forall lb. Label lb => LabelMap lb -> String
showLabelMap

instance (Label lb) => Eq (LabelMap lb) where
    LabelMap Word32
gen1 Map lb LabelIndex
lmap1 == :: LabelMap lb -> LabelMap lb -> Bool
== LabelMap Word32
gen2 Map lb LabelIndex
lmap2 =
      (Word32
gen1, Map lb LabelIndex
lmap1) forall a. Eq a => a -> a -> Bool
== (Word32
gen2, Map lb LabelIndex
lmap2)

-- | The empty label map table.
emptyMap :: (Label lb) => LabelMap lb
emptyMap :: forall lb. Label lb => LabelMap lb
emptyMap = forall lb lv. Word32 -> Map lb lv -> GenLabelMap lb lv
LabelMap Word32
1 forall k a. Map k a
M.empty

--------------------------
--  Equivalence class type
--------------------------
--

-- | Type for equivalence class description
--  (An equivalence class is a collection of labels with
--  the same 'LabelIndex' value.)

type EquivalenceClass lb = (LabelIndex, [lb])

{-
ecIndex :: EquivalenceClass lb -> LabelIndex
ecIndex = fst
-}

ecLabels :: EquivalenceClass lb -> [lb]
ecLabels :: forall lb. EquivalenceClass lb -> [lb]
ecLabels = forall a b. (a, b) -> b
snd

{-
ecSize :: EquivalenceClass lb -> Int
ecSize = length . ecLabels
-}

ecRemoveLabel :: (Label lb) => EquivalenceClass lb -> lb -> EquivalenceClass lb
ecRemoveLabel :: forall lb.
Label lb =>
EquivalenceClass lb -> lb -> EquivalenceClass lb
ecRemoveLabel EquivalenceClass lb
xs lb
l = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall a. Eq a => a -> [a] -> [a]
L.delete lb
l) EquivalenceClass lb
xs

------------------------------------------------------------
--  Filter, ungroup, sort and group pairs by first member
------------------------------------------------------------

{-
pairSelect :: ((a,b) -> Bool) -> ((a,b) -> c) -> [(a,b)] -> [c]
pairSelect p f as = map f (filter p as)
-}

-- | Ungroup the pairs.
pairUngroup :: 
    (a,[b])    -- ^ Given (a,bs)
    -> [(a,b)] -- ^ Returns (a,b) for all b in bs
pairUngroup :: forall a b. (a, [b]) -> [(a, b)]
pairUngroup (a
a,[b]
bs) = [ (a
a,b
b) | b
b <- [b]
bs ]

-- | Order the pairs based on the first argument.
pairSort :: (Ord a) => [(a,b)] -> [(a,b)]
pairSort :: forall a b. Ord a => [(a, b)] -> [(a, b)]
pairSort = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst)

-- TODO: use set on input

-- | Group the pairs based on the first argument.
pairGroup :: (Ord a) => [(a,b)] -> [(a,[b])]
pairGroup :: forall a b. Ord a => [(a, b)] -> [(a, [b])]
pairGroup = forall a b. (a -> b) -> [a] -> [b]
map (forall {a} {b}. ([a], b) -> (a, b)
factor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy forall {b}. (a, b) -> (a, b) -> Bool
eqFirst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Ord a => [(a, b)] -> [(a, b)]
pairSort 
    where
      -- as is not [] by construction, but would be nice to have
      -- this enforced by the types
      factor :: ([a], b) -> (a, b)
factor ([a]
as, b
bs) = (forall a. [a] -> a
head [a]
as, b
bs)
      eqFirst :: (a, b) -> (a, b) -> Bool
eqFirst = forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst

------------------------------------------------------------
--  Augmented graph label value - for graph matching
------------------------------------------------------------
--
-- | This instance of class label adds a graph identifier to
--  each variable label, so that variable labels from
--  different graphs are always seen as distinct values.
--
--  The essential logic added by this class instance is embodied
--  in the eq and hash functions.  Note that variable label hashes
--  depend only on the graph in which they appear, and non-variable
--  label hashes depend only on the variable.  Label hash values are
--  used when initializing a label equivalence-class map (and, for
--  non-variable labels, also for resolving hash collisions).

data (Label lb) => ScopedLabel lb = ScopedLabel Int lb

-- | Create a scoped label given an identifier and label.
makeScopedLabel :: (Label lb) => Int -> lb -> ScopedLabel lb
makeScopedLabel :: forall lb. Label lb => Int -> lb -> ScopedLabel lb
makeScopedLabel = forall lb. Int -> lb -> ScopedLabel lb
ScopedLabel 

-- | Create an arc containining a scoped label with the given identifier.
makeScopedArc :: (Label lb) => Int -> Arc lb -> Arc (ScopedLabel lb)
makeScopedArc :: forall lb. Label lb => Int -> Arc lb -> Arc (ScopedLabel lb)
makeScopedArc Int
scope = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall lb. Int -> lb -> ScopedLabel lb
ScopedLabel Int
scope)

instance (Label lb) => Label (ScopedLabel lb) where
    getLocal :: ScopedLabel lb -> String
getLocal  ScopedLabel lb
lab    = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"getLocal for ScopedLabel: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ScopedLabel lb
lab
    makeLabel :: String -> ScopedLabel lb
makeLabel String
locnam = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"makeLabel for ScopedLabel: " forall a. [a] -> [a] -> [a]
++ String
locnam
    labelIsVar :: ScopedLabel lb -> Bool
labelIsVar (ScopedLabel Int
_ lb
lab)   = forall lb. Label lb => lb -> Bool
labelIsVar lb
lab
    labelHash :: Int -> ScopedLabel lb -> Int
labelHash Int
seed (ScopedLabel Int
scope lb
lab)
        | forall lb. Label lb => lb -> Bool
labelIsVar lb
lab    = Int
seed forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Int
scope
        | Bool
otherwise         = forall lb. Label lb => Int -> lb -> Int
labelHash Int
seed lb
lab

instance (Label lb) => Eq (ScopedLabel lb) where
    (ScopedLabel Int
s1 lb
l1) == :: ScopedLabel lb -> ScopedLabel lb -> Bool
== (ScopedLabel Int
s2 lb
l2)
        = lb
l1 forall a. Eq a => a -> a -> Bool
== lb
l2 Bool -> Bool -> Bool
&& Int
s1 forall a. Eq a => a -> a -> Bool
== Int
s2

instance (Label lb) => Show (ScopedLabel lb) where
    show :: ScopedLabel lb -> String
show (ScopedLabel Int
s1 lb
l1) = forall a. Show a => a -> String
show Int
s1 forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show lb
l1

instance (Label lb) => Ord (ScopedLabel lb) where
    compare :: ScopedLabel lb -> ScopedLabel lb -> Ordering
compare (ScopedLabel Int
s1 lb
l1) (ScopedLabel Int
s2 lb
l2) =
        case forall a. Ord a => a -> a -> Ordering
compare Int
s1 Int
s2 of
            Ordering
LT -> Ordering
LT
            Ordering
EQ -> forall a. Ord a => a -> a -> Ordering
compare lb
l1 lb
l2
            Ordering
GT -> Ordering
GT

-- QUS: why doesn't this return Maybe (LabelMap (ScopedLabel lb)) ?

-- TODO: Should this use Set (Arc lb) instead of [Arc lb]?

-- | Graph matching function accepting two lists of arcs and
--  returning a node map if successful
--
graphMatch :: (Label lb) =>
    (lb -> lb -> Bool)
    -- ^ a function that tests for additional constraints
    --   that may prevent the matching of a supplied pair
    --   of nodes.  Returns `True` if the supplied nodes may be
    --   matched.  (Used in RDF graph matching for checking
    --   that formula assignments are compatible.)
    -> ArcSet lb -- ^ the first graph to be compared
    -> ArcSet lb -- ^ the second graph to be compared
    -> (Bool, LabelMap (ScopedLabel lb))
    -- ^ If the first element is `True` then the second element maps each label
    --   to an equivalence class identifier, otherwise it is just
    --   `emptyMap`.
    --
graphMatch :: forall lb.
Label lb =>
(lb -> lb -> Bool)
-> ArcSet lb -> ArcSet lb -> (Bool, LabelMap (ScopedLabel lb))
graphMatch lb -> lb -> Bool
matchable ArcSet lb
gs1 ArcSet lb
gs2 =
    let
        sgs1 :: Set (Arc (ScopedLabel lb))
sgs1    = {- trace "sgs1 " $ -} forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (forall lb. Label lb => Int -> Arc lb -> Arc (ScopedLabel lb)
makeScopedArc Int
1) ArcSet lb
gs1
        sgs2 :: Set (Arc (ScopedLabel lb))
sgs2    = {- trace "sgs2 " $ -} forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (forall lb. Label lb => Int -> Arc lb -> Arc (ScopedLabel lb)
makeScopedArc Int
2) ArcSet lb
gs2
        ls1 :: Set (ScopedLabel lb)
ls1     = {- traceShow "ls1 " $ -} forall lb. Label lb => ArcSet lb -> Set lb
graphLabels Set (Arc (ScopedLabel lb))
sgs1
        ls2 :: Set (ScopedLabel lb)
ls2     = {- traceShow "ls2 " $ -} forall lb. Label lb => ArcSet lb -> Set lb
graphLabels Set (Arc (ScopedLabel lb))
sgs2
        lmap :: LabelMap (ScopedLabel lb)
lmap    = {- traceShow "lmap " $ -}
                  forall lb. Label lb => LabelMap lb -> LabelMap lb
newGenerationMap forall a b. (a -> b) -> a -> b
$
                  forall lb. Label lb => Set lb -> LabelMap lb -> LabelMap lb
assignLabelMap Set (ScopedLabel lb)
ls1 forall a b. (a -> b) -> a -> b
$
                  forall lb. Label lb => Set lb -> LabelMap lb -> LabelMap lb
assignLabelMap Set (ScopedLabel lb)
ls2 forall lb. Label lb => LabelMap lb
emptyMap
        ec1 :: [EquivalenceClass (ScopedLabel lb)]
ec1     = {- traceShow "ec1 " $ -} forall lb.
Label lb =>
LabelMap lb -> Set lb -> [EquivalenceClass lb]
equivalenceClasses LabelMap (ScopedLabel lb)
lmap Set (ScopedLabel lb)
ls1
        ec2 :: [EquivalenceClass (ScopedLabel lb)]
ec2     = {- traceShow "ec2 " $ -} forall lb.
Label lb =>
LabelMap lb -> Set lb -> [EquivalenceClass lb]
equivalenceClasses LabelMap (ScopedLabel lb)
lmap Set (ScopedLabel lb)
ls2
        ecpairs :: [(EquivalenceClass (ScopedLabel lb),
  EquivalenceClass (ScopedLabel lb))]
ecpairs = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. Ord a => [(a, b)] -> [(a, b)]
pairSort [EquivalenceClass (ScopedLabel lb)]
ec1) (forall a b. Ord a => [(a, b)] -> [(a, b)]
pairSort [EquivalenceClass (ScopedLabel lb)]
ec2)
        matchableScoped :: ScopedLabel lb -> ScopedLabel lb -> Bool
matchableScoped (ScopedLabel Int
_ lb
l1) (ScopedLabel Int
_ lb
l2) = lb -> lb -> Bool
matchable lb
l1 lb
l2
        match :: (Bool, LabelMap (ScopedLabel lb))
match   = forall lb.
Label lb =>
Bool
-> (lb -> lb -> Bool)
-> ArcSet lb
-> ArcSet lb
-> LabelMap lb
-> [(EquivalenceClass lb, EquivalenceClass lb)]
-> (Bool, LabelMap lb)
graphMatch1 Bool
False ScopedLabel lb -> ScopedLabel lb -> Bool
matchableScoped Set (Arc (ScopedLabel lb))
sgs1 Set (Arc (ScopedLabel lb))
sgs2 LabelMap (ScopedLabel lb)
lmap [(EquivalenceClass (ScopedLabel lb),
  EquivalenceClass (ScopedLabel lb))]
ecpairs
    in
        if forall (t :: * -> *) a. Foldable t => t a -> Int
length [EquivalenceClass (ScopedLabel lb)]
ec1 forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length [EquivalenceClass (ScopedLabel lb)]
ec2 then (Bool
False,forall lb. Label lb => LabelMap lb
emptyMap) else (Bool, LabelMap (ScopedLabel lb))
match

--  TODO:
--
--    * replace Equivalence class pair by @(index,[lb],[lb])@ ?
--
--    * possible optimization:  the @graphMapEq@ test should be
--      needed only if `graphMatch2` has been used to guess a
--      mapping;  either: 
--          a) supply flag saying guess has been used, or
--          b) move test to `graphMatch2` and use different
--             test to prevent rechecking for each guess used.
--

-- | Recursive graph matching function
--
--  This function assumes that no variable label appears in both graphs.
--  (Function `graphMatch`, which calls this, ensures that all variable
--  labels are distinct.)
--

graphMatch1 :: 
  (Label lb) 
  => Bool
  -- ^ `True` if a guess has been used before trying this comparison,
  --   `False` if nodes are being matched without any guesswork
  -> (lb -> lb -> Bool)
  -- ^ Test for additional constraints that may prevent the matching
  --  of a supplied pair of nodes.  Returns `True` if the supplied
  --  nodes may be matched.
  -> ArcSet lb 
  -- ^ (@gs1@ argument)
  --   first of two lists of arcs (triples) to be compared
  -> ArcSet lb
  -- ^ (@gs2@ argument)
  --   secind of two lists of arcs (triples) to be compared
  -> LabelMap lb
  -- ^ the map so far used to map label values to equivalence class
  --   values
  -> [(EquivalenceClass lb,EquivalenceClass lb)]
  -- ^ (the @ecpairs@ argument) list of pairs of corresponding
  --   equivalence classes of nodes from @gs1@ and @gs2@ that have not
  --   been confirmed in 1:1 correspondence with each other.  Each
  --   pair of equivalence classes contains nodes that must be placed
  --   in 1:1 correspondence with each other.
  --
  -> (Bool,LabelMap lb)
  -- ^ the pair @(match, map)@ where @match@ is @True@ if the supplied
  --   sets of arcs can be matched, in which case @map@ is a
  --   corresponding map from labels to equivalence class identifiers.
  --   When @match@ is @False@, @map@ is the most detailed equivalence
  --   class map obtained before a mismatch was detected or a guess
  --   was required -- this is intended to help identify where the
  --   graph mismatch may be.
graphMatch1 :: forall lb.
Label lb =>
Bool
-> (lb -> lb -> Bool)
-> ArcSet lb
-> ArcSet lb
-> LabelMap lb
-> [(EquivalenceClass lb, EquivalenceClass lb)]
-> (Bool, LabelMap lb)
graphMatch1 Bool
guessed lb -> lb -> Bool
matchable ArcSet lb
gs1 ArcSet lb
gs2 LabelMap lb
lmap [(EquivalenceClass lb, EquivalenceClass lb)]
ecpairs =
    let
        ([(EquivalenceClass lb, EquivalenceClass lb)]
secs,[(EquivalenceClass lb, EquivalenceClass lb)]
mecs) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition forall {a} {a} {a} {a}. ((a, [a]), (a, [a])) -> Bool
uniqueEc [(EquivalenceClass lb, EquivalenceClass lb)]
ecpairs
        uniqueEc :: ((a, [a]), (a, [a])) -> Bool
uniqueEc ( (a
_,[a
_])  , (a
_,[a
_])  ) = Bool
True
        uniqueEc (  (a, [a])
_       ,  (a, [a])
_       ) = Bool
False
        
        doMatch :: ((a, [lb]), (a, [lb])) -> Bool
doMatch  ( (a
_,[lb
l1]) , (a
_,[lb
l2]) ) = forall lb.
Label lb =>
(lb -> lb -> Bool) -> LabelMap lb -> lb -> lb -> Bool
labelMatch lb -> lb -> Bool
matchable LabelMap lb
lmap lb
l1 lb
l2
        doMatch  ((a, [lb]), (a, [lb]))
x = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"doMatch failue: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ((a, [lb]), (a, [lb]))
x -- keep -Wall happy

        ecEqSize :: ((a, t a), (a, t a)) -> Bool
ecEqSize ( (a
_,t a
ls1)  , (a
_,t a
ls2)  ) = forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
ls1 forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
ls2
        eSize :: ((a, t a), b) -> Int
eSize    ( (a
_,t a
ls1)  , b
_        ) = forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
ls1
        ecCompareSize :: ((a, [a]), b) -> ((a, [a]), b) -> Ordering
ecCompareSize = forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall {t :: * -> *} {a} {a} {b}.
Foldable t =>
((a, t a), b) -> Int
eSize
        (LabelMap lb
lmap',[(EquivalenceClass lb, EquivalenceClass lb)]
mecs',Bool
newEc,Bool
matchEc) = forall lb.
Label lb =>
ArcSet lb
-> ArcSet lb
-> LabelMap lb
-> [(EquivalenceClass lb, EquivalenceClass lb)]
-> (LabelMap lb, [(EquivalenceClass lb, EquivalenceClass lb)],
    Bool, Bool)
reclassify ArcSet lb
gs1 ArcSet lb
gs2 LabelMap lb
lmap [(EquivalenceClass lb, EquivalenceClass lb)]
mecs
        match2 :: (Bool, LabelMap lb)
match2 = forall lb.
Label lb =>
(lb -> lb -> Bool)
-> ArcSet lb
-> ArcSet lb
-> LabelMap lb
-> [(EquivalenceClass lb, EquivalenceClass lb)]
-> (Bool, LabelMap lb)
graphMatch2 lb -> lb -> Bool
matchable ArcSet lb
gs1 ArcSet lb
gs2 LabelMap lb
lmap forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy forall {a} {a} {b}. ((a, [a]), b) -> ((a, [a]), b) -> Ordering
ecCompareSize [(EquivalenceClass lb, EquivalenceClass lb)]
mecs
    in
        -- trace ("graphMatch1\nsingle ECs:\n"++show secs++
        --                   "\nmultiple ECs:\n"++show mecs++
        --                   "\n\n") $
        --  if mismatch in singleton equivalence classes, fail
        if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall {a} {a}. (Show a, Show a) => ((a, [lb]), (a, [lb])) -> Bool
doMatch [(EquivalenceClass lb, EquivalenceClass lb)]
secs then (Bool
False,LabelMap lb
lmap)
        else
        --  if no multi-member equivalence classes,
        --  check and return label map supplied
        -- trace ("graphMatch1\ngraphMapEq: "++show (graphMapEq lmap gs1 gs2)) $
        if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(EquivalenceClass lb, EquivalenceClass lb)]
mecs then (forall lb.
Label lb =>
LabelMap lb -> ArcSet lb -> ArcSet lb -> Bool
graphMapEq LabelMap lb
lmap ArcSet lb
gs1 ArcSet lb
gs2,LabelMap lb
lmap)
        else
        --  if size mismatch in equivalence classes, fail
        -- trace ("graphMatch1\nall ecEqSize mecs: "++show (all ecEqSize mecs)) $
        
          --  invoke reclassification, and deal with result
          if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall {t :: * -> *} {t :: * -> *} {a} {a} {a} {a}.
(Foldable t, Foldable t) =>
((a, t a), (a, t a)) -> Bool
ecEqSize [(EquivalenceClass lb, EquivalenceClass lb)]
mecs) Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
matchEc
            then (Bool
False, LabelMap lb
lmap)
            else if Bool
newEc
                   then forall lb.
Label lb =>
Bool
-> (lb -> lb -> Bool)
-> ArcSet lb
-> ArcSet lb
-> LabelMap lb
-> [(EquivalenceClass lb, EquivalenceClass lb)]
-> (Bool, LabelMap lb)
graphMatch1 Bool
guessed lb -> lb -> Bool
matchable ArcSet lb
gs1 ArcSet lb
gs2 LabelMap lb
lmap' [(EquivalenceClass lb, EquivalenceClass lb)]
mecs'
                        --  if guess does not result in a match, return supplied label map
                   else if forall a b. (a, b) -> a
fst (Bool, LabelMap lb)
match2 then (Bool, LabelMap lb)
match2 else (Bool
False, LabelMap lb
lmap)

{-
          if not $ all ecEqSize mecs then (False,lmap)
        else
        if not matchEc then (False,lmap)
        else
        if newEc then graphMatch1 guessed matchable gs1 gs2 lmap' mecs'
        else
        if fst match2 then match2 else (False,lmap)
-}

-- | Auxiliary graph matching function
--
--  This function is called when deterministic decomposition of node
--  mapping equivalence classes has run its course.
--
--  It picks a pair of equivalence classes in ecpairs, and arbitrarily matches
--  pairs of nodes in those equivalence classes, recursively calling the
--  graph matching function until a suitable node mapping is discovered
--  (success), or until all such pairs have been tried (failure).
--
--  This function represents a point to which arbitrary choices are backtracked.
--  The list comprehension 'glp' represents the alternative choices at the
--  point of backtracking
--
--  The selected pair of nodes are placed in a new equivalence class based on their
--  original equivalence class value, but with a new NodeVal generation number.

graphMatch2 :: (Label lb) => (lb -> lb -> Bool)
    -> ArcSet lb
    -> ArcSet lb
    -> LabelMap lb 
    -> [(EquivalenceClass lb,EquivalenceClass lb)]
    -> (Bool,LabelMap lb)
graphMatch2 :: forall lb.
Label lb =>
(lb -> lb -> Bool)
-> ArcSet lb
-> ArcSet lb
-> LabelMap lb
-> [(EquivalenceClass lb, EquivalenceClass lb)]
-> (Bool, LabelMap lb)
graphMatch2 lb -> lb -> Bool
_         ArcSet lb
_   ArcSet lb
_   LabelMap lb
_    [] = forall a. HasCallStack => String -> a
error String
"graphMatch2 sent an empty list" -- To keep -Wall happy
graphMatch2 lb -> lb -> Bool
matchable ArcSet lb
gs1 ArcSet lb
gs2 LabelMap lb
lmap ((ec1 :: EquivalenceClass lb
ec1@(LabelIndex
ev1,[lb]
ls1),ec2 :: EquivalenceClass lb
ec2@(LabelIndex
ev2,[lb]
ls2)):[(EquivalenceClass lb, EquivalenceClass lb)]
ecpairs) =
    let
        v1 :: Word32
v1 = forall a b. (a, b) -> b
snd LabelIndex
ev1
        --  Return any equivalence-mapping obtained by matching a pair
        --  of labels in the supplied list, or Nothing.
        try :: [(lb, lb)] -> (Bool, LabelMap lb)
try []            = (Bool
False,LabelMap lb
lmap)
        try ((lb
l1,lb
l2):[(lb, lb)]
lps) = if (Bool, LabelMap lb) -> lb -> lb -> Bool
isEquiv (Bool, LabelMap lb)
try1 lb
l1 lb
l2 then (Bool, LabelMap lb)
try1 else [(lb, lb)] -> (Bool, LabelMap lb)
try [(lb, lb)]
lps
            where
                try1 :: (Bool, LabelMap lb)
try1     = forall lb.
Label lb =>
Bool
-> (lb -> lb -> Bool)
-> ArcSet lb
-> ArcSet lb
-> LabelMap lb
-> [(EquivalenceClass lb, EquivalenceClass lb)]
-> (Bool, LabelMap lb)
graphMatch1 Bool
True lb -> lb -> Bool
matchable ArcSet lb
gs1 ArcSet lb
gs2 LabelMap lb
lmap' [(EquivalenceClass lb, EquivalenceClass lb)]
ecpairs'
                lmap' :: LabelMap lb
lmap'    = forall lb. Label lb => LabelMap lb -> [(lb, Word32)] -> LabelMap lb
newLabelMap LabelMap lb
lmap [(lb
l1,Word32
v1),(lb
l2,Word32
v1)]
                ecpairs' :: [(EquivalenceClass lb, EquivalenceClass lb)]
ecpairs' = ((LabelIndex
ev',[lb
l1]),(LabelIndex
ev',[lb
l2]))forall a. a -> [a] -> [a]
:(EquivalenceClass lb, EquivalenceClass lb)
ec'forall a. a -> [a] -> [a]
:[(EquivalenceClass lb, EquivalenceClass lb)]
ecpairs
                ev' :: LabelIndex
ev'      = forall lb. Label lb => LabelMap lb -> lb -> LabelIndex
mapLabelIndex LabelMap lb
lmap' lb
l1
                ec' :: (EquivalenceClass lb, EquivalenceClass lb)
ec'      = (forall lb.
Label lb =>
EquivalenceClass lb -> lb -> EquivalenceClass lb
ecRemoveLabel EquivalenceClass lb
ec1 lb
l1, forall lb.
Label lb =>
EquivalenceClass lb -> lb -> EquivalenceClass lb
ecRemoveLabel EquivalenceClass lb
ec2 lb
l2)
                -- [[[TODO: replace this: if isJust try ?]]]
                isEquiv :: (Bool, LabelMap lb) -> lb -> lb -> Bool
isEquiv (Bool
False,LabelMap lb
_)   lb
_  lb
_  = Bool
False
                isEquiv (Bool
True,LabelMap lb
lm) lb
x1 lb
x2 =
                    forall lb. Label lb => LabelMap lb -> lb -> LabelIndex
mapLabelIndex LabelMap lb
m1 lb
x1 forall a. Eq a => a -> a -> Bool
== forall lb. Label lb => LabelMap lb -> lb -> LabelIndex
mapLabelIndex LabelMap lb
m2 lb
x2
                    where
                        m1 :: LabelMap lb
m1 = forall lb.
Label lb =>
ArcSet lb -> LabelMap lb -> [lb] -> LabelMap lb
remapLabels ArcSet lb
gs1 LabelMap lb
lm [lb
x1]
                        m2 :: LabelMap lb
m2 = forall lb.
Label lb =>
ArcSet lb -> LabelMap lb -> [lb] -> LabelMap lb
remapLabels ArcSet lb
gs2 LabelMap lb
lm [lb
x2]
        --  glp is a list of label-pair candidates for matching,
        --  selected from the first label-equivalence class.
        --  NOTE:  final test is call of external matchable function
        glp :: [(lb, lb)]
glp = [ (lb
l1,lb
l2) | lb
l1 <- [lb]
ls1 , lb
l2 <- [lb]
ls2 , lb -> lb -> Bool
matchable lb
l1 lb
l2 ]
    in
        forall a. HasCallStack => Bool -> a -> a
assert (LabelIndex
ev1 forall a. Eq a => a -> a -> Bool
== LabelIndex
ev2) -- "GraphMatch2: Equivalence class value mismatch" $
        forall a b. (a -> b) -> a -> b
$ [(lb, lb)] -> (Bool, LabelMap lb)
try [(lb, lb)]
glp

-- this was in Swish.Utils.MiscHelpers along with a simple hash-based function
-- based on Sedgewick, Algorithms in C, p233. As we have now moved to using
-- Data.Hashable it is not clear whether this is still necessary or sensible.
--
hashModulus :: Int
hashModulus :: Int
hashModulus = Int
16000001

-- | Returns a string representation  of a LabelMap value
--
showLabelMap :: (Label lb) => LabelMap lb -> String
showLabelMap :: forall lb. Label lb => LabelMap lb -> String
showLabelMap (LabelMap Word32
gn Map lb LabelIndex
lmap) =
    String
"LabelMap gen=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
Prelude.show Word32
gn forall a. [a] -> [a] -> [a]
++ String
", map=" forall a. [a] -> [a] -> [a]
++
    forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. [a] -> [a] -> [a]
(++) String
"" (forall a b. (a -> b) -> [a] -> [b]
map ((String
"\n    " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
Prelude.show) [(lb, LabelIndex)]
es)
    where
        es :: [(lb, LabelIndex)]
es = forall k a. Map k a -> [(k, a)]
M.toList Map lb LabelIndex
lmap

-- | Map a label to its corresponding label index value in the
--   supplied LabelMap.
--
mapLabelIndex :: (Label lb) => LabelMap lb -> lb -> LabelIndex
mapLabelIndex :: forall lb. Label lb => LabelMap lb -> lb -> LabelIndex
mapLabelIndex (LabelMap Word32
_ Map lb LabelIndex
lxms) lb
lb = forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault LabelIndex
nullLabelVal lb
lb Map lb LabelIndex
lxms

-- | Confirm that a given pair of labels are matchable, and are
--  mapped to the same value by the supplied label map
--
labelMatch :: (Label lb)
    =>  (lb -> lb -> Bool) -> LabelMap lb -> lb -> lb -> Bool
labelMatch :: forall lb.
Label lb =>
(lb -> lb -> Bool) -> LabelMap lb -> lb -> lb -> Bool
labelMatch lb -> lb -> Bool
matchable LabelMap lb
lmap lb
l1 lb
l2 =
    lb -> lb -> Bool
matchable lb
l1 lb
l2 Bool -> Bool -> Bool
&& (forall lb. Label lb => LabelMap lb -> lb -> LabelIndex
mapLabelIndex LabelMap lb
lmap lb
l1 forall a. Eq a => a -> a -> Bool
== forall lb. Label lb => LabelMap lb -> lb -> LabelIndex
mapLabelIndex LabelMap lb
lmap lb
l2)

-- | Replace selected values in a label map with new values from the supplied
--  list of labels and new label index values.  The generation number is
--  supplied from the current label map.  The generation number in the
--  resulting label map is incremented.
--
newLabelMap :: (Label lb) => LabelMap lb -> [(lb, Word32)] -> LabelMap lb
newLabelMap :: forall lb. Label lb => LabelMap lb -> [(lb, Word32)] -> LabelMap lb
newLabelMap LabelMap lb
lmap []       = forall lb. Label lb => LabelMap lb -> LabelMap lb
newGenerationMap LabelMap lb
lmap
newLabelMap LabelMap lb
lmap ((lb, Word32)
lv:[(lb, Word32)]
lvs) = forall lb. Label lb => LabelMap lb -> (lb, Word32) -> LabelMap lb
setLabelHash (forall lb. Label lb => LabelMap lb -> [(lb, Word32)] -> LabelMap lb
newLabelMap LabelMap lb
lmap [(lb, Word32)]
lvs) (lb, Word32)
lv

-- | Replace a label and its associated value in a label map
--  with a new value using the supplied hash value and the current
--  `LabelMap` generation number.  If the key is not found, then no change
--  is made to the label map.

setLabelHash :: (Label lb)
    => LabelMap lb -> (lb, Word32) -> LabelMap lb
setLabelHash :: forall lb. Label lb => LabelMap lb -> (lb, Word32) -> LabelMap lb
setLabelHash  (LabelMap Word32
g Map lb LabelIndex
lmap) (lb
lb,Word32
lh) =
    forall lb lv. Word32 -> Map lb lv -> GenLabelMap lb lv
LabelMap Word32
g forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert lb
lb (Word32
g,Word32
lh) Map lb LabelIndex
lmap

-- | Increment the generation of the label map.
--
--  Returns a new label map identical to the supplied value
--  but with an incremented generation number.
--
newGenerationMap :: (Label lb) => LabelMap lb -> LabelMap lb
newGenerationMap :: forall lb. Label lb => LabelMap lb -> LabelMap lb
newGenerationMap (LabelMap Word32
g Map lb LabelIndex
lvs) = forall lb lv. Word32 -> Map lb lv -> GenLabelMap lb lv
LabelMap (Word32
g forall a. Num a => a -> a -> a
+ Word32
1) Map lb LabelIndex
lvs

-- | Scan label list, assigning initial label map values,
--  adding new values to the label map supplied.
--
--  Label map values are assigned on the basis of the
--  label alone, without regard for it's connectivity in
--  the graph.  (cf. `reclassify`).
--
--  All variable node labels are assigned the same initial
--  value, as they may be matched with each other.
--
assignLabelMap :: (Label lb) => S.Set lb -> LabelMap lb -> LabelMap lb
assignLabelMap :: forall lb. Label lb => Set lb -> LabelMap lb -> LabelMap lb
assignLabelMap Set lb
ns LabelMap lb
lmap = forall a b. (a -> b -> a) -> a -> Set b -> a
S.foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall lb. Label lb => lb -> LabelMap lb -> LabelMap lb
assignLabelMap1) LabelMap lb
lmap Set lb
ns

assignLabelMap1 :: (Label lb) => lb -> LabelMap lb -> LabelMap lb
assignLabelMap1 :: forall lb. Label lb => lb -> LabelMap lb -> LabelMap lb
assignLabelMap1 lb
lab (LabelMap Word32
g Map lb LabelIndex
lvs) = 
    forall lb lv. Word32 -> Map lb lv -> GenLabelMap lb lv
LabelMap Word32
g forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (forall a b. a -> b -> a
const forall a. a -> a
id) lb
lab (Word32
g, forall lb. Label lb => lb -> Word32
initVal lb
lab) Map lb LabelIndex
lvs

--  Calculate initial value for a node

initVal :: (Label lb) => lb -> Word32
initVal :: forall lb. Label lb => lb -> Word32
initVal = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall lb. Label lb => Word32 -> lb -> Int
hashVal Word32
0

hashVal :: (Label lb) => Word32 -> lb -> Int
hashVal :: forall lb. Label lb => Word32 -> lb -> Int
hashVal Word32
seed lb
lab =
  if forall lb. Label lb => lb -> Bool
labelIsVar lb
lab then Int
23 forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Word32
seed else forall lb. Label lb => Int -> lb -> Int
labelHash (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
seed) lb
lab

-- | Return the equivalence classes of the supplied nodes 
-- using the label map.
equivalenceClasses :: 
  (Label lb) 
  => LabelMap lb     -- ^ label map
  -> S.Set lb        -- ^ nodes to be reclassified
  -> [EquivalenceClass lb]
equivalenceClasses :: forall lb.
Label lb =>
LabelMap lb -> Set lb -> [EquivalenceClass lb]
equivalenceClasses LabelMap lb
lmap Set lb
ls =
    forall a b. Ord a => [(a, b)] -> [(a, [b])]
pairGroup forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map lb -> (LabelIndex, lb)
labelPair Set lb
ls
    where
        labelPair :: lb -> (LabelIndex, lb)
labelPair lb
l = (forall lb. Label lb => LabelMap lb -> lb -> LabelIndex
mapLabelIndex LabelMap lb
lmap lb
l,lb
l)

-- | Reclassify labels
--
--  Examines the supplied label equivalence classes (based on the supplied
--  label map), and evaluates new equivalence subclasses based on node
--  values and adjacency (for variable nodes) and rehashing
--  (for non-variable nodes).
--
--  Note, assumes that all all equivalence classes supplied are
--  non-singletons;  i.e. contain more than one label.
--
reclassify :: 
  (Label lb) 
  => ArcSet lb 
  -- ^ (the @gs1@ argument) the first of two sets of arcs to perform a
  --   basis for reclassifying the labels in the first equivalence
  --   class in each pair of @ecpairs@.
  -> ArcSet lb
  -- ^ (the @gs2@ argument) the second of two sets of arcs to perform a
  --   basis for reclassifying the labels in the second equivalence
  --   class in each pair of the @ecpairs@ argument
  -> LabelMap lb 
  -- ^ the label map used for classification of the labels in
  --   the supplied equivalence classes
  -> [(EquivalenceClass lb,EquivalenceClass lb)]
  -- ^ (the @ecpairs@ argument) a list of pairs of corresponding equivalence classes of
  --   nodes from @gs1@ and @gs2@ that have not been confirmed
  --   in 1:1 correspondence with each other.
  -> (LabelMap lb,[(EquivalenceClass lb,EquivalenceClass lb)],Bool,Bool)
  -- ^ The output tuple consists of:
  --
  --  1) a revised label map reflecting the reclassification
  --
  --  2) a new list of equivalence class pairs based on the
  --   new node map
  --
  --  3) if the reclassification partitions any of the
  --     supplied equivalence classes then `True`, else `False`
  --
  --  4) if reclassification results in each equivalence class
  --     being split same-sized equivalence classes in the two graphs,
  --     then `True`, otherwise `False`.

reclassify :: forall lb.
Label lb =>
ArcSet lb
-> ArcSet lb
-> LabelMap lb
-> [(EquivalenceClass lb, EquivalenceClass lb)]
-> (LabelMap lb, [(EquivalenceClass lb, EquivalenceClass lb)],
    Bool, Bool)
reclassify ArcSet lb
gs1 ArcSet lb
gs2 lmap :: LabelMap lb
lmap@(LabelMap Word32
_ Map lb LabelIndex
lm) [(EquivalenceClass lb, EquivalenceClass lb)]
ecpairs =
    forall a. HasCallStack => Bool -> a -> a
assert (Word32
gen1 forall a. Eq a => a -> a -> Bool
== Word32
gen2) -- "Label map generation mismatch"
      (forall lb lv. Word32 -> Map lb lv -> GenLabelMap lb lv
LabelMap Word32
gen1 Map lb LabelIndex
lm',[(EquivalenceClass lb, EquivalenceClass lb)]
ecpairs',Bool
newPart,Bool
matchPart)
    where
        LabelMap Word32
gen1 Map lb LabelIndex
lm1 =
            forall lb.
Label lb =>
ArcSet lb -> LabelMap lb -> [lb] -> LabelMap lb
remapLabels ArcSet lb
gs1 LabelMap lb
lmap forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall lb. EquivalenceClass lb -> [lb]
ecLabels forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(EquivalenceClass lb, EquivalenceClass lb)]
ecpairs
        LabelMap Word32
gen2 Map lb LabelIndex
lm2 =
            forall lb.
Label lb =>
ArcSet lb -> LabelMap lb -> [lb] -> LabelMap lb
remapLabels ArcSet lb
gs2 LabelMap lb
lmap forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall lb. EquivalenceClass lb -> [lb]
ecLabels forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(EquivalenceClass lb, EquivalenceClass lb)]
ecpairs

        lm' :: Map lb LabelIndex
lm' = forall a b. Ord a => Map a b -> Map a b -> Map a b
classifyCombine Map lb LabelIndex
lm forall a b. (a -> b) -> a -> b
$ forall a b. Ord a => Map a b -> Map a b -> Map a b
M.union Map lb LabelIndex
lm1 Map lb LabelIndex
lm2
        
        tmap :: (t -> b) -> (t, t) -> (b, b)
tmap t -> b
f (t
a,t
b) = (t -> b
f t
a, t -> b
f t
b)
        
        -- ecGroups :: [([EquivalenceClass lb],[EquivalenceClass lb])]
        ecGroups :: [([EquivalenceClass lb], [EquivalenceClass lb])]
ecGroups  = forall a b. (a -> b) -> [a] -> [b]
map (forall {t} {b}. (t -> b) -> (t, t) -> (b, b)
tmap forall {a}. (a, [lb]) -> [EquivalenceClass lb]
remapEc) [(EquivalenceClass lb, EquivalenceClass lb)]
ecpairs
        ecpairs' :: [(EquivalenceClass lb, EquivalenceClass lb)]
ecpairs'  = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. [a] -> [b] -> [(a, b)]
zip) [([EquivalenceClass lb], [EquivalenceClass lb])]
ecGroups
        newPart :: Bool
newPart   = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall {a} {a}. (Ord a, Ord a, Num a, Num a) => (a, a) -> Bool
pairG1 [(Int, Int)]
lenGroups
        matchPart :: Bool
matchPart = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int, Int) -> Bool
pairEq [(Int, Int)]
lenGroups
        lenGroups :: [(Int, Int)]
lenGroups = forall a b. (a -> b) -> [a] -> [b]
map (forall {t} {b}. (t -> b) -> (t, t) -> (b, b)
tmap forall (t :: * -> *) a. Foldable t => t a -> Int
length) [([EquivalenceClass lb], [EquivalenceClass lb])]
ecGroups
        pairEq :: (Int, Int) -> Bool
pairEq = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Eq a => a -> a -> Bool
(==)
        pairG1 :: (a, a) -> Bool
pairG1 (a
p1,a
p2) = a
p1 forall a. Ord a => a -> a -> Bool
> a
1 Bool -> Bool -> Bool
|| a
p2 forall a. Ord a => a -> a -> Bool
> a
1
        remapEc :: (a, [lb]) -> [EquivalenceClass lb]
remapEc = forall a b. Ord a => [(a, b)] -> [(a, [b])]
pairGroup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall {b} {a}.
Ord b =>
Map b LabelIndex -> (a, b) -> (LabelIndex, b)
newIndex Map lb LabelIndex
lm') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, [b]) -> [(a, b)]
pairUngroup 
        newIndex :: Map b LabelIndex -> (a, b) -> (LabelIndex, b)
newIndex Map b LabelIndex
x (a
_,b
lab) = (forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault LabelIndex
nullLabelVal b
lab Map b LabelIndex
x,b
lab)

-- Replace the values in lm1 with those from lm2, but do not copy over new
-- keys from lm2
classifyCombine :: (Ord a) => M.Map a b -> M.Map a b -> M.Map a b
classifyCombine :: forall a b. Ord a => Map a b -> Map a b -> Map a b
classifyCombine = forall k a b c.
Ord k =>
(k -> a -> b -> Maybe c)
-> (Map k a -> Map k c)
-> (Map k b -> Map k c)
-> Map k a
-> Map k b
-> Map k c
M.mergeWithKey (\a
_ b
_ b
v -> forall a. a -> Maybe a
Just b
v) forall a. a -> a
id (forall a b. a -> b -> a
const forall k a. Map k a
M.empty)

-- | Calculate a new index value for a supplied set of labels based on the
--  supplied label map and adjacency calculations in the supplied graph
--
remapLabels :: 
  (Label lb) 
  => ArcSet lb -- ^ arcs used for adjacency calculations when remapping
  -> LabelMap lb -- ^ the current label index values
  -> [lb] -- ^ the graph labels for which new mappings are to be created
  -> LabelMap lb
  -- ^ the updated label map containing recalculated label index values
  -- for the given graph labels. The label map generation number is
  -- incremented by 1.
remapLabels :: forall lb.
Label lb =>
ArcSet lb -> LabelMap lb -> [lb] -> LabelMap lb
remapLabels ArcSet lb
gs lmap :: LabelMap lb
lmap@(LabelMap Word32
gen Map lb LabelIndex
_) [lb]
ls =
    forall lb lv. Word32 -> Map lb lv -> GenLabelMap lb lv
LabelMap Word32
gen' forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(lb, LabelIndex)]
newEntries
    where
        gen' :: Word32
gen'                = Word32
gen forall a. Num a => a -> a -> a
+ Word32
1
        newEntries :: [(lb, LabelIndex)]
newEntries          = [ (lb
l, (Word32
gen', forall a b. (Integral a, Num b) => a -> b
fromIntegral (lb -> Int
newIndex lb
l))) | lb
l <- [lb]
ls ]
        -- TODO: should review this given the changes to the hash code
        --       since it was re-written
        newIndex :: lb -> Int
newIndex lb
l
            | forall lb. Label lb => lb -> Bool
labelIsVar lb
l  = lb -> Int
mapAdjacent lb
l    -- adjacency classifies variable labels
            | Bool
otherwise     = forall lb. Label lb => Word32 -> lb -> Int
hashVal Word32
gen lb
l    -- otherwise rehash (to disentangle collisions)  TODO: BRANCH IS UNTESTED

        -- mapAdjacent used to use `rem` hashModulus
        mapAdjacent :: lb -> Int
mapAdjacent lb
l       = Int
hashModulus forall a. Hashable a => Int -> a -> Int
`hashWithSalt` forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (lb -> [Int]
sigsOver lb
l)

        gls :: [Arc lb]
gls = forall a. Set a -> [a]
S.toList ArcSet lb
gs

        sigsOver :: lb -> [Int]
sigsOver lb
l          = forall a b. (a -> Bool) -> [a] -> [b] -> [b]
select (forall lb. Eq lb => lb -> Arc lb -> Bool
hasLabel lb
l) [Arc lb]
gls (forall lb. Label lb => LabelMap lb -> [Arc lb] -> [Int]
arcSignatures LabelMap lb
lmap [Arc lb]
gls)

-- |Select is like filter, except that it tests one list to select
--  elements from a second list.
select :: ( a -> Bool ) -> [a] -> [b] -> [b]
select :: forall a b. (a -> Bool) -> [a] -> [b] -> [b]
select a -> Bool
_ [] []           = []
select a -> Bool
f (a
e1:[a]
l1) (b
e2:[b]
l2)
    | a -> Bool
f a
e1      = b
e2 forall a. a -> [a] -> [a]
: forall a b. (a -> Bool) -> [a] -> [b] -> [b]
select a -> Bool
f [a]
l1 [b]
l2
    | Bool
otherwise = forall a b. (a -> Bool) -> [a] -> [b] -> [b]
select a -> Bool
f [a]
l1 [b]
l2
select a -> Bool
_ [a]
_ [b]
_    = forall a. HasCallStack => String -> a
error String
"select supplied with different length lists"

-- | Return the set of distinct labels used in the graph.

graphLabels :: (Label lb) => ArcSet lb -> S.Set lb
graphLabels :: forall lb. Label lb => ArcSet lb -> Set lb
graphLabels = forall b a. Ord b => (a -> [b]) -> Set a -> Set b
getComponents forall lb. Arc lb -> [lb]
arcLabels

-- TODO: worry about overflow?

-- TODO: should probably return a Set of (Int, Arc lb) or something, 
-- as may be useful for the calling code

-- | Calculate a signature value for each arc that can be used in 
--   constructing an adjacency based value for a node.  The adjacancy
--   value for a label is obtained by summing the signatures of all
--   statements containing that label.
--
arcSignatures :: 
  (Label lb) 
  => LabelMap lb -- ^ the current label index values
  -> [Arc lb] -- ^ calculate signatures for these arcs
  -> [Int] -- ^ the signatures of the arcs
arcSignatures :: forall lb. Label lb => LabelMap lb -> [Arc lb] -> [Int]
arcSignatures LabelMap lb
lmap =
    forall a b. (a -> b) -> [a] -> [b]
map ((lb, lb, lb) -> Int
sigCalc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall lb. Arc lb -> (lb, lb, lb)
arcToTriple) 
    where
        sigCalc :: (lb, lb, lb) -> Int
sigCalc (lb
s,lb
p,lb
o)  =
            Int
hashModulus forall a. Hashable a => Int -> a -> Int
`hashWithSalt`
              ( lb -> Word32
labelVal2 lb
s forall a. Num a => a -> a -> a
+
                lb -> Word32
labelVal2 lb
p forall a. Num a => a -> a -> a
* Word32
3 forall a. Num a => a -> a -> a
+
                lb -> Word32
labelVal2 lb
o forall a. Num a => a -> a -> a
* Word32
5 )
          
        labelVal :: lb -> LabelIndex
labelVal         = forall lb. Label lb => LabelMap lb -> lb -> LabelIndex
mapLabelIndex LabelMap lb
lmap
        labelVal2 :: lb -> Word32
labelVal2        = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Num a => a -> a -> a
(*) forall b c a. (b -> c) -> (a -> b) -> a -> c
. lb -> LabelIndex
labelVal

-- | Return a new graph that is supplied graph with every node/arc
--  mapped to a new value according to the supplied function.
--
--  Used for testing for graph equivalence under a supplied
--  label mapping;  e.g.
--
--  >  if ( graphMap nodeMap gs1 ) == ( graphMap nodeMap gs2 ) then (same)
--
graphMap ::
    (Label lb)
    => LabelMap lb
    -> ArcSet lb
    -> ArcSet LabelIndex
graphMap :: forall lb.
Label lb =>
LabelMap lb -> ArcSet lb -> ArcSet LabelIndex
graphMap = forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall lb. Label lb => LabelMap lb -> lb -> LabelIndex
mapLabelIndex

-- | Compare a pair of graphs for equivalence under a given mapping
--   function.
--
--  This is used to perform the ultimate test that two graphs are
--  indeed equivalent:  guesswork in `graphMatch2` means that it is
--  occasionally possible to construct a node mapping that generates
--  the required singleton equivalence classes, but does not fully
--  reflect the topology of the graphs.

graphMapEq ::
    (Label lb) 
    => LabelMap lb
    -> ArcSet lb
    -> ArcSet lb 
    -> Bool
graphMapEq :: forall lb.
Label lb =>
LabelMap lb -> ArcSet lb -> ArcSet lb -> Bool
graphMapEq LabelMap lb
lmap = forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall lb.
Label lb =>
LabelMap lb -> ArcSet lb -> ArcSet LabelIndex
graphMap LabelMap lb
lmap

--------------------------------------------------------------------------------
--
--  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin,
--    2011, 2012, 2016, 2018, 2020 Douglas Burke
--  All rights reserved.
--
--  This file is part of Swish.
--
--  Swish is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  Swish is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with Swish; if not, write to:
--    The Free Software Foundation, Inc.,
--    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
--
--------------------------------------------------------------------------------