{-# 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 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) = lb -> String
forall a. Show a => a -> String
show lb
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ lv -> String
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) (lb, lv) -> (lb, lv) -> Bool
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) (lb, lv) -> (lb, lv) -> Ordering
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 = LabelMap lb -> String
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) (Word32, Map lb LabelIndex) -> (Word32, Map lb LabelIndex) -> Bool
forall a. Eq a => a -> a -> Bool
== (Word32
gen2, Map lb LabelIndex
lmap2)

-- | The empty label map table.
emptyMap :: (Label lb) => LabelMap lb
emptyMap :: LabelMap lb
emptyMap = Word32 -> Map lb LabelIndex -> LabelMap lb
forall lb lv. Word32 -> Map lb lv -> GenLabelMap lb lv
LabelMap Word32
1 Map lb LabelIndex
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 :: EquivalenceClass lb -> [lb]
ecLabels = EquivalenceClass lb -> [lb]
forall a b. (a, b) -> b
snd

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

ecRemoveLabel :: (Label lb) => EquivalenceClass lb -> lb -> EquivalenceClass lb
ecRemoveLabel :: EquivalenceClass lb -> lb -> EquivalenceClass lb
ecRemoveLabel EquivalenceClass lb
xs lb
l = ([lb] -> [lb]) -> EquivalenceClass lb -> EquivalenceClass lb
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (lb -> [lb] -> [lb]
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 :: (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 :: [(a, b)] -> [(a, b)]
pairSort = ((a, b) -> (a, b) -> Ordering) -> [(a, b)] -> [(a, b)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((a, b) -> a) -> (a, b) -> (a, b) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (a, b) -> a
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 :: [(a, b)] -> [(a, [b])]
pairGroup = ([(a, b)] -> (a, [b])) -> [[(a, b)]] -> [(a, [b])]
forall a b. (a -> b) -> [a] -> [b]
map (([a], [b]) -> (a, [b])
forall a b. ([a], b) -> (a, b)
factor (([a], [b]) -> (a, [b]))
-> ([(a, b)] -> ([a], [b])) -> [(a, b)] -> (a, [b])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, b)] -> ([a], [b])
forall a b. [(a, b)] -> ([a], [b])
unzip) ([[(a, b)]] -> [(a, [b])])
-> ([(a, b)] -> [[(a, b)]]) -> [(a, b)] -> [(a, [b])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> (a, b) -> Bool) -> [(a, b)] -> [[(a, b)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (a, b) -> (a, b) -> Bool
forall b. (a, b) -> (a, b) -> Bool
eqFirst ([(a, b)] -> [[(a, b)]])
-> ([(a, b)] -> [(a, b)]) -> [(a, b)] -> [[(a, b)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, b)] -> [(a, b)]
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) = ([a] -> a
forall a. [a] -> a
head [a]
as, b
bs)
      eqFirst :: (a, b) -> (a, b) -> Bool
eqFirst = a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) (a -> a -> Bool) -> ((a, b) -> a) -> (a, b) -> (a, b) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (a, b) -> a
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 :: Int -> lb -> ScopedLabel lb
makeScopedLabel = Int -> lb -> ScopedLabel lb
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 :: Int -> Arc lb -> Arc (ScopedLabel lb)
makeScopedArc Int
scope = (lb -> ScopedLabel lb) -> Arc lb -> Arc (ScopedLabel lb)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> lb -> ScopedLabel lb
forall lb. Int -> lb -> ScopedLabel lb
ScopedLabel Int
scope)

instance (Label lb) => Label (ScopedLabel lb) where
    getLocal :: ScopedLabel lb -> String
getLocal  ScopedLabel lb
lab    = ShowS
forall a. HasCallStack => String -> a
error ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"getLocal for ScopedLabel: "String -> ShowS
forall a. [a] -> [a] -> [a]
++ScopedLabel lb -> String
forall a. Show a => a -> String
show ScopedLabel lb
lab
    makeLabel :: String -> ScopedLabel lb
makeLabel String
locnam = String -> ScopedLabel lb
forall a. HasCallStack => String -> a
error (String -> ScopedLabel lb) -> String -> ScopedLabel lb
forall a b. (a -> b) -> a -> b
$ String
"makeLabel for ScopedLabel: "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
locnam
    labelIsVar :: ScopedLabel lb -> Bool
labelIsVar (ScopedLabel Int
_ lb
lab)   = lb -> Bool
forall lb. Label lb => lb -> Bool
labelIsVar lb
lab
    labelHash :: Int -> ScopedLabel lb -> Int
labelHash Int
seed (ScopedLabel Int
scope lb
lab)
        | lb -> Bool
forall lb. Label lb => lb -> Bool
labelIsVar lb
lab    = Int
seed Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Int
scope
        | Bool
otherwise         = Int -> lb -> Int
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 lb -> lb -> Bool
forall a. Eq a => a -> a -> Bool
== lb
l2 Bool -> Bool -> Bool
&& Int
s1 Int -> Int -> Bool
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) = Int -> String
forall a. Show a => a -> String
show Int
s1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ lb -> String
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 Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
s1 Int
s2 of
            Ordering
LT -> Ordering
LT
            Ordering
EQ -> lb -> lb -> Ordering
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 :: (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 " $ -} (Arc lb -> Arc (ScopedLabel lb))
-> ArcSet lb -> Set (Arc (ScopedLabel lb))
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (Int -> Arc lb -> Arc (ScopedLabel lb)
forall lb. Label lb => Int -> Arc lb -> Arc (ScopedLabel lb)
makeScopedArc Int
1) ArcSet lb
gs1
        sgs2 :: Set (Arc (ScopedLabel lb))
sgs2    = {- trace "sgs2 " $ -} (Arc lb -> Arc (ScopedLabel lb))
-> ArcSet lb -> Set (Arc (ScopedLabel lb))
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (Int -> Arc lb -> Arc (ScopedLabel lb)
forall lb. Label lb => Int -> Arc lb -> Arc (ScopedLabel lb)
makeScopedArc Int
2) ArcSet lb
gs2
        ls1 :: Set (ScopedLabel lb)
ls1     = {- traceShow "ls1 " $ -} Set (Arc (ScopedLabel lb)) -> Set (ScopedLabel lb)
forall lb. Label lb => ArcSet lb -> Set lb
graphLabels Set (Arc (ScopedLabel lb))
sgs1
        ls2 :: Set (ScopedLabel lb)
ls2     = {- traceShow "ls2 " $ -} Set (Arc (ScopedLabel lb)) -> Set (ScopedLabel lb)
forall lb. Label lb => ArcSet lb -> Set lb
graphLabels Set (Arc (ScopedLabel lb))
sgs2
        lmap :: LabelMap (ScopedLabel lb)
lmap    = {- traceShow "lmap " $ -}
                  LabelMap (ScopedLabel lb) -> LabelMap (ScopedLabel lb)
forall lb. Label lb => LabelMap lb -> LabelMap lb
newGenerationMap (LabelMap (ScopedLabel lb) -> LabelMap (ScopedLabel lb))
-> LabelMap (ScopedLabel lb) -> LabelMap (ScopedLabel lb)
forall a b. (a -> b) -> a -> b
$
                  Set (ScopedLabel lb)
-> LabelMap (ScopedLabel lb) -> LabelMap (ScopedLabel lb)
forall lb. Label lb => Set lb -> LabelMap lb -> LabelMap lb
assignLabelMap Set (ScopedLabel lb)
ls1 (LabelMap (ScopedLabel lb) -> LabelMap (ScopedLabel lb))
-> LabelMap (ScopedLabel lb) -> LabelMap (ScopedLabel lb)
forall a b. (a -> b) -> a -> b
$
                  Set (ScopedLabel lb)
-> LabelMap (ScopedLabel lb) -> LabelMap (ScopedLabel lb)
forall lb. Label lb => Set lb -> LabelMap lb -> LabelMap lb
assignLabelMap Set (ScopedLabel lb)
ls2 LabelMap (ScopedLabel lb)
forall lb. Label lb => LabelMap lb
emptyMap
        ec1 :: [EquivalenceClass (ScopedLabel lb)]
ec1     = {- traceShow "ec1 " $ -} LabelMap (ScopedLabel lb)
-> Set (ScopedLabel lb) -> [EquivalenceClass (ScopedLabel lb)]
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 " $ -} LabelMap (ScopedLabel lb)
-> Set (ScopedLabel lb) -> [EquivalenceClass (ScopedLabel lb)]
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 = [EquivalenceClass (ScopedLabel lb)]
-> [EquivalenceClass (ScopedLabel lb)]
-> [(EquivalenceClass (ScopedLabel lb),
     EquivalenceClass (ScopedLabel lb))]
forall a b. [a] -> [b] -> [(a, b)]
zip ([EquivalenceClass (ScopedLabel lb)]
-> [EquivalenceClass (ScopedLabel lb)]
forall a b. Ord a => [(a, b)] -> [(a, b)]
pairSort [EquivalenceClass (ScopedLabel lb)]
ec1) ([EquivalenceClass (ScopedLabel lb)]
-> [EquivalenceClass (ScopedLabel lb)]
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   = Bool
-> (ScopedLabel lb -> ScopedLabel lb -> Bool)
-> Set (Arc (ScopedLabel lb))
-> Set (Arc (ScopedLabel lb))
-> LabelMap (ScopedLabel lb)
-> [(EquivalenceClass (ScopedLabel lb),
     EquivalenceClass (ScopedLabel lb))]
-> (Bool, LabelMap (ScopedLabel lb))
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 [EquivalenceClass (ScopedLabel lb)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EquivalenceClass (ScopedLabel lb)]
ec1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [EquivalenceClass (ScopedLabel lb)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EquivalenceClass (ScopedLabel lb)]
ec2 then (Bool
False,LabelMap (ScopedLabel lb)
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 :: 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) = ((EquivalenceClass lb, EquivalenceClass lb) -> Bool)
-> [(EquivalenceClass lb, EquivalenceClass lb)]
-> ([(EquivalenceClass lb, EquivalenceClass lb)],
    [(EquivalenceClass lb, EquivalenceClass lb)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (EquivalenceClass lb, EquivalenceClass lb) -> Bool
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]) ) = (lb -> lb -> Bool) -> LabelMap lb -> lb -> lb -> Bool
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 = String -> Bool
forall a. HasCallStack => String -> a
error (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
"doMatch failue: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ((a, [lb]), (a, [lb])) -> String
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)  ) = t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
ls1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
ls2
        eSize :: ((a, t a), b) -> Int
eSize    ( (a
_,t a
ls1)  , b
_        ) = t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
ls1
        ecCompareSize :: ((a, [a]), b) -> ((a, [a]), b) -> Ordering
ecCompareSize = (((a, [a]), b) -> Int)
-> ((a, [a]), b) -> ((a, [a]), b) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((a, [a]), b) -> Int
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) = ArcSet lb
-> ArcSet lb
-> LabelMap lb
-> [(EquivalenceClass lb, EquivalenceClass lb)]
-> (LabelMap lb, [(EquivalenceClass lb, EquivalenceClass lb)],
    Bool, Bool)
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 = (lb -> lb -> Bool)
-> ArcSet lb
-> ArcSet lb
-> LabelMap lb
-> [(EquivalenceClass lb, EquivalenceClass lb)]
-> (Bool, LabelMap lb)
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 ([(EquivalenceClass lb, EquivalenceClass lb)]
 -> (Bool, LabelMap lb))
-> [(EquivalenceClass lb, EquivalenceClass lb)]
-> (Bool, LabelMap lb)
forall a b. (a -> b) -> a -> b
$ ((EquivalenceClass lb, EquivalenceClass lb)
 -> (EquivalenceClass lb, EquivalenceClass lb) -> Ordering)
-> [(EquivalenceClass lb, EquivalenceClass lb)]
-> [(EquivalenceClass lb, EquivalenceClass lb)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (EquivalenceClass lb, EquivalenceClass lb)
-> (EquivalenceClass lb, EquivalenceClass lb) -> Ordering
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ((EquivalenceClass lb, EquivalenceClass lb) -> Bool)
-> [(EquivalenceClass lb, EquivalenceClass lb)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (EquivalenceClass lb, EquivalenceClass lb) -> Bool
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 [(EquivalenceClass lb, EquivalenceClass lb)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(EquivalenceClass lb, EquivalenceClass lb)]
mecs then (LabelMap lb -> ArcSet lb -> ArcSet lb -> Bool
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 (((EquivalenceClass lb, EquivalenceClass lb) -> Bool)
-> [(EquivalenceClass lb, EquivalenceClass lb)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (EquivalenceClass lb, EquivalenceClass lb) -> Bool
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 Bool
-> (lb -> lb -> Bool)
-> ArcSet lb
-> ArcSet lb
-> LabelMap lb
-> [(EquivalenceClass lb, EquivalenceClass lb)]
-> (Bool, LabelMap lb)
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 (Bool, LabelMap lb) -> Bool
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 :: (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
_    [] = String -> (Bool, 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 = LabelIndex -> Word32
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     = Bool
-> (lb -> lb -> Bool)
-> ArcSet lb
-> ArcSet lb
-> LabelMap lb
-> [(EquivalenceClass lb, EquivalenceClass lb)]
-> (Bool, LabelMap lb)
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'    = LabelMap lb -> [(lb, Word32)] -> LabelMap lb
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]))(EquivalenceClass lb, EquivalenceClass lb)
-> [(EquivalenceClass lb, EquivalenceClass lb)]
-> [(EquivalenceClass lb, EquivalenceClass lb)]
forall a. a -> [a] -> [a]
:(EquivalenceClass lb, EquivalenceClass lb)
ec'(EquivalenceClass lb, EquivalenceClass lb)
-> [(EquivalenceClass lb, EquivalenceClass lb)]
-> [(EquivalenceClass lb, EquivalenceClass lb)]
forall a. a -> [a] -> [a]
:[(EquivalenceClass lb, EquivalenceClass lb)]
ecpairs
                ev' :: LabelIndex
ev'      = LabelMap lb -> lb -> LabelIndex
forall lb. Label lb => LabelMap lb -> lb -> LabelIndex
mapLabelIndex LabelMap lb
lmap' lb
l1
                ec' :: (EquivalenceClass lb, EquivalenceClass lb)
ec'      = (EquivalenceClass lb -> lb -> EquivalenceClass lb
forall lb.
Label lb =>
EquivalenceClass lb -> lb -> EquivalenceClass lb
ecRemoveLabel EquivalenceClass lb
ec1 lb
l1, EquivalenceClass lb -> lb -> EquivalenceClass lb
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 =
                    LabelMap lb -> lb -> LabelIndex
forall lb. Label lb => LabelMap lb -> lb -> LabelIndex
mapLabelIndex LabelMap lb
m1 lb
x1 LabelIndex -> LabelIndex -> Bool
forall a. Eq a => a -> a -> Bool
== LabelMap lb -> lb -> LabelIndex
forall lb. Label lb => LabelMap lb -> lb -> LabelIndex
mapLabelIndex LabelMap lb
m2 lb
x2
                    where
                        m1 :: LabelMap lb
m1 = ArcSet lb -> LabelMap lb -> [lb] -> LabelMap lb
forall lb.
Label lb =>
ArcSet lb -> LabelMap lb -> [lb] -> LabelMap lb
remapLabels ArcSet lb
gs1 LabelMap lb
lm [lb
x1]
                        m2 :: LabelMap lb
m2 = ArcSet lb -> LabelMap lb -> [lb] -> LabelMap lb
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
        Bool -> (Bool, LabelMap lb) -> (Bool, LabelMap lb)
forall a. HasCallStack => Bool -> a -> a
assert (LabelIndex
ev1LabelIndex -> LabelIndex -> Bool
forall a. Eq a => a -> a -> Bool
==LabelIndex
ev2) -- "GraphMatch2: Equivalence class value mismatch" $
        ((Bool, LabelMap lb) -> (Bool, LabelMap lb))
-> (Bool, LabelMap lb) -> (Bool, LabelMap lb)
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 :: LabelMap lb -> String
showLabelMap (LabelMap Word32
gn Map lb LabelIndex
lmap) =
    String
"LabelMap gen="String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
Prelude.show Word32
gn String -> ShowS
forall a. [a] -> [a] -> [a]
++String
", map="String -> ShowS
forall a. [a] -> [a] -> [a]
++
    (String -> ShowS) -> String -> [String] -> String
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
"" (((lb, LabelIndex) -> String) -> [(lb, LabelIndex)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"\n    "String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ((lb, LabelIndex) -> String) -> (lb, LabelIndex) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (lb, LabelIndex) -> String
forall a. Show a => a -> String
Prelude.show) [(lb, LabelIndex)]
es)
    where
        es :: [(lb, LabelIndex)]
es = Map lb LabelIndex -> [(lb, LabelIndex)]
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 :: LabelMap lb -> lb -> LabelIndex
mapLabelIndex (LabelMap Word32
_ Map lb LabelIndex
lxms) lb
lb = LabelIndex -> lb -> Map lb LabelIndex -> LabelIndex
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 :: (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
&& (LabelMap lb -> lb -> LabelIndex
forall lb. Label lb => LabelMap lb -> lb -> LabelIndex
mapLabelIndex LabelMap lb
lmap lb
l1 LabelIndex -> LabelIndex -> Bool
forall a. Eq a => a -> a -> Bool
== LabelMap lb -> lb -> LabelIndex
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 :: LabelMap lb -> [(lb, Word32)] -> LabelMap lb
newLabelMap LabelMap lb
lmap []       = LabelMap lb -> LabelMap lb
forall lb. Label lb => LabelMap lb -> LabelMap lb
newGenerationMap LabelMap lb
lmap
newLabelMap LabelMap lb
lmap ((lb, Word32)
lv:[(lb, Word32)]
lvs) = LabelMap lb -> (lb, Word32) -> LabelMap lb
forall lb. Label lb => LabelMap lb -> (lb, Word32) -> LabelMap lb
setLabelHash (LabelMap lb -> [(lb, Word32)] -> LabelMap lb
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 :: LabelMap lb -> (lb, Word32) -> LabelMap lb
setLabelHash  (LabelMap Word32
g Map lb LabelIndex
lmap) (lb
lb,Word32
lh) =
    Word32 -> Map lb LabelIndex -> LabelMap lb
forall lb lv. Word32 -> Map lb lv -> GenLabelMap lb lv
LabelMap Word32
g (Map lb LabelIndex -> LabelMap lb)
-> Map lb LabelIndex -> LabelMap lb
forall a b. (a -> b) -> a -> b
$ lb -> LabelIndex -> Map lb LabelIndex -> Map lb LabelIndex
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 :: LabelMap lb -> LabelMap lb
newGenerationMap (LabelMap Word32
g Map lb LabelIndex
lvs) = Word32 -> Map lb LabelIndex -> LabelMap lb
forall lb lv. Word32 -> Map lb lv -> GenLabelMap lb lv
LabelMap (Word32
gWord32 -> Word32 -> Word32
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 :: Set lb -> LabelMap lb -> LabelMap lb
assignLabelMap Set lb
ns LabelMap lb
lmap = (LabelMap lb -> lb -> LabelMap lb)
-> LabelMap lb -> Set lb -> LabelMap lb
forall a b. (a -> b -> a) -> a -> Set b -> a
S.foldl' ((lb -> LabelMap lb -> LabelMap lb)
-> LabelMap lb -> lb -> LabelMap lb
forall a b c. (a -> b -> c) -> b -> a -> c
flip lb -> LabelMap lb -> LabelMap lb
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 :: lb -> LabelMap lb -> LabelMap lb
assignLabelMap1 lb
lab (LabelMap Word32
g Map lb LabelIndex
lvs) = 
    Word32 -> Map lb LabelIndex -> LabelMap lb
forall lb lv. Word32 -> Map lb lv -> GenLabelMap lb lv
LabelMap Word32
g (Map lb LabelIndex -> LabelMap lb)
-> Map lb LabelIndex -> LabelMap lb
forall a b. (a -> b) -> a -> b
$ (LabelIndex -> LabelIndex -> LabelIndex)
-> lb -> LabelIndex -> Map lb LabelIndex -> Map lb LabelIndex
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith ((LabelIndex -> LabelIndex)
-> LabelIndex -> LabelIndex -> LabelIndex
forall a b. a -> b -> a
const LabelIndex -> LabelIndex
forall a. a -> a
id) lb
lab (Word32
g, lb -> Word32
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 :: lb -> Word32
initVal = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> (lb -> Int) -> lb -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> lb -> Int
forall lb. Label lb => Word32 -> lb -> Int
hashVal Word32
0

hashVal :: (Label lb) => Word32 -> lb -> Int
hashVal :: Word32 -> lb -> Int
hashVal Word32
seed lb
lab =
  if lb -> Bool
forall lb. Label lb => lb -> Bool
labelIsVar lb
lab then Int
23 Int -> Word32 -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Word32
seed else Int -> lb -> Int
forall lb. Label lb => Int -> lb -> Int
labelHash (Word32 -> Int
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 :: LabelMap lb -> Set lb -> [EquivalenceClass lb]
equivalenceClasses LabelMap lb
lmap Set lb
ls =
    [(LabelIndex, lb)] -> [EquivalenceClass lb]
forall a b. Ord a => [(a, b)] -> [(a, [b])]
pairGroup ([(LabelIndex, lb)] -> [EquivalenceClass lb])
-> [(LabelIndex, lb)] -> [EquivalenceClass lb]
forall a b. (a -> b) -> a -> b
$ Set (LabelIndex, lb) -> [(LabelIndex, lb)]
forall a. Set a -> [a]
S.toList (Set (LabelIndex, lb) -> [(LabelIndex, lb)])
-> Set (LabelIndex, lb) -> [(LabelIndex, lb)]
forall a b. (a -> b) -> a -> b
$ (lb -> (LabelIndex, lb)) -> Set lb -> Set (LabelIndex, lb)
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 = (LabelMap lb -> lb -> LabelIndex
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 :: 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 =
    Bool
-> (LabelMap lb, [(EquivalenceClass lb, EquivalenceClass lb)],
    Bool, Bool)
-> (LabelMap lb, [(EquivalenceClass lb, EquivalenceClass lb)],
    Bool, Bool)
forall a. HasCallStack => Bool -> a -> a
assert (Word32
gen1Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==Word32
gen2) -- "Label map generation mismatch"
      (Word32 -> Map lb LabelIndex -> LabelMap lb
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 =
            ArcSet lb -> LabelMap lb -> [lb] -> LabelMap lb
forall lb.
Label lb =>
ArcSet lb -> LabelMap lb -> [lb] -> LabelMap lb
remapLabels ArcSet lb
gs1 LabelMap lb
lmap ([lb] -> LabelMap lb) -> [lb] -> LabelMap lb
forall a b. (a -> b) -> a -> b
$ ([lb] -> [lb] -> [lb]) -> [[lb]] -> [lb]
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 [lb] -> [lb] -> [lb]
forall a. [a] -> [a] -> [a]
(++) ([[lb]] -> [lb]) -> [[lb]] -> [lb]
forall a b. (a -> b) -> a -> b
$ ((EquivalenceClass lb, EquivalenceClass lb) -> [lb])
-> [(EquivalenceClass lb, EquivalenceClass lb)] -> [[lb]]
forall a b. (a -> b) -> [a] -> [b]
map (EquivalenceClass lb -> [lb]
forall lb. EquivalenceClass lb -> [lb]
ecLabels (EquivalenceClass lb -> [lb])
-> ((EquivalenceClass lb, EquivalenceClass lb)
    -> EquivalenceClass lb)
-> (EquivalenceClass lb, EquivalenceClass lb)
-> [lb]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EquivalenceClass lb, EquivalenceClass lb) -> EquivalenceClass lb
forall a b. (a, b) -> a
fst) [(EquivalenceClass lb, EquivalenceClass lb)]
ecpairs
        LabelMap Word32
gen2 Map lb LabelIndex
lm2 =
            ArcSet lb -> LabelMap lb -> [lb] -> LabelMap lb
forall lb.
Label lb =>
ArcSet lb -> LabelMap lb -> [lb] -> LabelMap lb
remapLabels ArcSet lb
gs2 LabelMap lb
lmap ([lb] -> LabelMap lb) -> [lb] -> LabelMap lb
forall a b. (a -> b) -> a -> b
$ ([lb] -> [lb] -> [lb]) -> [[lb]] -> [lb]
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 [lb] -> [lb] -> [lb]
forall a. [a] -> [a] -> [a]
(++) ([[lb]] -> [lb]) -> [[lb]] -> [lb]
forall a b. (a -> b) -> a -> b
$ ((EquivalenceClass lb, EquivalenceClass lb) -> [lb])
-> [(EquivalenceClass lb, EquivalenceClass lb)] -> [[lb]]
forall a b. (a -> b) -> [a] -> [b]
map (EquivalenceClass lb -> [lb]
forall lb. EquivalenceClass lb -> [lb]
ecLabels (EquivalenceClass lb -> [lb])
-> ((EquivalenceClass lb, EquivalenceClass lb)
    -> EquivalenceClass lb)
-> (EquivalenceClass lb, EquivalenceClass lb)
-> [lb]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EquivalenceClass lb, EquivalenceClass lb) -> EquivalenceClass lb
forall a b. (a, b) -> b
snd) [(EquivalenceClass lb, EquivalenceClass lb)]
ecpairs

        lm' :: Map lb LabelIndex
lm' = Map lb LabelIndex -> Map lb LabelIndex -> Map lb LabelIndex
forall a b. Ord a => Map a b -> Map a b -> Map a b
classifyCombine Map lb LabelIndex
lm (Map lb LabelIndex -> Map lb LabelIndex)
-> Map lb LabelIndex -> Map lb LabelIndex
forall a b. (a -> b) -> a -> b
$ Map lb LabelIndex -> Map lb LabelIndex -> Map lb LabelIndex
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  = ((EquivalenceClass lb, EquivalenceClass lb)
 -> ([EquivalenceClass lb], [EquivalenceClass lb]))
-> [(EquivalenceClass lb, EquivalenceClass lb)]
-> [([EquivalenceClass lb], [EquivalenceClass lb])]
forall a b. (a -> b) -> [a] -> [b]
map ((EquivalenceClass lb -> [EquivalenceClass lb])
-> (EquivalenceClass lb, EquivalenceClass lb)
-> ([EquivalenceClass lb], [EquivalenceClass lb])
forall t b. (t -> b) -> (t, t) -> (b, b)
tmap EquivalenceClass lb -> [EquivalenceClass lb]
forall a. (a, [lb]) -> [EquivalenceClass lb]
remapEc) [(EquivalenceClass lb, EquivalenceClass lb)]
ecpairs
        ecpairs' :: [(EquivalenceClass lb, EquivalenceClass lb)]
ecpairs'  = (([EquivalenceClass lb], [EquivalenceClass lb])
 -> [(EquivalenceClass lb, EquivalenceClass lb)])
-> [([EquivalenceClass lb], [EquivalenceClass lb])]
-> [(EquivalenceClass lb, EquivalenceClass lb)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([EquivalenceClass lb]
 -> [EquivalenceClass lb]
 -> [(EquivalenceClass lb, EquivalenceClass lb)])
-> ([EquivalenceClass lb], [EquivalenceClass lb])
-> [(EquivalenceClass lb, EquivalenceClass lb)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [EquivalenceClass lb]
-> [EquivalenceClass lb]
-> [(EquivalenceClass lb, EquivalenceClass lb)]
forall a b. [a] -> [b] -> [(a, b)]
zip) [([EquivalenceClass lb], [EquivalenceClass lb])]
ecGroups
        newPart :: Bool
newPart   = ((Int, Int) -> Bool) -> [(Int, Int)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Int, Int) -> Bool
forall a a. (Ord a, Ord a, Num a, Num a) => (a, a) -> Bool
pairG1 [(Int, Int)]
lenGroups
        matchPart :: Bool
matchPart = ((Int, Int) -> Bool) -> [(Int, Int)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int, Int) -> Bool
pairEq [(Int, Int)]
lenGroups
        lenGroups :: [(Int, Int)]
lenGroups = (([EquivalenceClass lb], [EquivalenceClass lb]) -> (Int, Int))
-> [([EquivalenceClass lb], [EquivalenceClass lb])] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (([EquivalenceClass lb] -> Int)
-> ([EquivalenceClass lb], [EquivalenceClass lb]) -> (Int, Int)
forall t b. (t -> b) -> (t, t) -> (b, b)
tmap [EquivalenceClass lb] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [([EquivalenceClass lb], [EquivalenceClass lb])]
ecGroups
        pairEq :: (Int, Int) -> Bool
pairEq = (Int -> Int -> Bool) -> (Int, Int) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==)
        pairG1 :: (a, a) -> Bool
pairG1 (a
p1,a
p2) = a
p1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
1 Bool -> Bool -> Bool
|| a
p2 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
1
        remapEc :: (a, [lb]) -> [EquivalenceClass lb]
remapEc = [(LabelIndex, lb)] -> [EquivalenceClass lb]
forall a b. Ord a => [(a, b)] -> [(a, [b])]
pairGroup ([(LabelIndex, lb)] -> [EquivalenceClass lb])
-> ((a, [lb]) -> [(LabelIndex, lb)])
-> (a, [lb])
-> [EquivalenceClass lb]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, lb) -> (LabelIndex, lb)) -> [(a, lb)] -> [(LabelIndex, lb)]
forall a b. (a -> b) -> [a] -> [b]
map (Map lb LabelIndex -> (a, lb) -> (LabelIndex, lb)
forall b a. Ord b => Map b LabelIndex -> (a, b) -> (LabelIndex, b)
newIndex Map lb LabelIndex
lm') ([(a, lb)] -> [(LabelIndex, lb)])
-> ((a, [lb]) -> [(a, lb)]) -> (a, [lb]) -> [(LabelIndex, lb)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, [lb]) -> [(a, lb)]
forall a b. (a, [b]) -> [(a, b)]
pairUngroup 
        newIndex :: Map b LabelIndex -> (a, b) -> (LabelIndex, b)
newIndex Map b LabelIndex
x (a
_,b
lab) = (LabelIndex -> b -> Map b LabelIndex -> LabelIndex
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 :: Map a b -> Map a b -> Map a b
classifyCombine = (a -> b -> b -> Maybe b)
-> (Map a b -> Map a b)
-> (Map a b -> Map a b)
-> Map a b
-> Map a b
-> Map a b
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 -> b -> Maybe b
forall a. a -> Maybe a
Just b
v) Map a b -> Map a b
forall a. a -> a
id (Map a b -> Map a b -> Map a b
forall a b. a -> b -> a
const Map a b
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 :: ArcSet lb -> LabelMap lb -> [lb] -> LabelMap lb
remapLabels ArcSet lb
gs lmap :: LabelMap lb
lmap@(LabelMap Word32
gen Map lb LabelIndex
_) [lb]
ls =
    Word32 -> Map lb LabelIndex -> LabelMap lb
forall lb lv. Word32 -> Map lb lv -> GenLabelMap lb lv
LabelMap Word32
gen' (Map lb LabelIndex -> LabelMap lb)
-> Map lb LabelIndex -> LabelMap lb
forall a b. (a -> b) -> a -> b
$ [(lb, LabelIndex)] -> Map lb LabelIndex
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(lb, LabelIndex)]
newEntries
    where
        gen' :: Word32
gen'                = Word32
genWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
1
        newEntries :: [(lb, LabelIndex)]
newEntries          = [ (lb
l, (Word32
gen', Int -> Word32
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
            | lb -> Bool
forall lb. Label lb => lb -> Bool
labelIsVar lb
l  = lb -> Int
mapAdjacent lb
l                 -- adjacency classifies variable labels
            | Bool
otherwise     = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Word32 -> lb -> Int
forall lb. Label lb => Word32 -> lb -> Int
hashVal Word32
gen lb
l  -- otherwise rehash (to disentangle collisions)

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

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

        sigsOver :: lb -> [Int]
sigsOver lb
l          = (Arc lb -> Bool) -> [Arc lb] -> [Int] -> [Int]
forall a b. (a -> Bool) -> [a] -> [b] -> [b]
select (lb -> Arc lb -> Bool
forall lb. Eq lb => lb -> Arc lb -> Bool
hasLabel lb
l) [Arc lb]
gls (LabelMap lb -> [Arc lb] -> [Int]
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 :: (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 b -> [b] -> [b]
forall a. a -> [a] -> [a]
: (a -> Bool) -> [a] -> [b] -> [b]
forall a b. (a -> Bool) -> [a] -> [b] -> [b]
select a -> Bool
f [a]
l1 [b]
l2
    | Bool
otherwise = (a -> Bool) -> [a] -> [b] -> [b]
forall a b. (a -> Bool) -> [a] -> [b] -> [b]
select a -> Bool
f [a]
l1 [b]
l2
select a -> Bool
_ [a]
_ [b]
_    = String -> [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 :: ArcSet lb -> Set lb
graphLabels = (Arc lb -> [lb]) -> ArcSet lb -> Set lb
forall b a. Ord b => (a -> [b]) -> Set a -> Set b
getComponents Arc lb -> [lb]
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 :: LabelMap lb -> [Arc lb] -> [Int]
arcSignatures LabelMap lb
lmap =
    (Arc lb -> Int) -> [Arc lb] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((lb, lb, lb) -> Int
sigCalc ((lb, lb, lb) -> Int) -> (Arc lb -> (lb, lb, lb)) -> Arc lb -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arc lb -> (lb, lb, lb)
forall lb. Arc lb -> (lb, lb, lb)
arcToTriple) 
    where
        sigCalc :: (lb, lb, lb) -> Int
sigCalc (lb
s,lb
p,lb
o)  =
            Int
hashModulus Int -> Word32 -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt`
              ( lb -> Word32
labelVal2 lb
s Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+
                lb -> Word32
labelVal2 lb
p Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
3 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+
                lb -> Word32
labelVal2 lb
o Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
5 )
          
        labelVal :: lb -> LabelIndex
labelVal         = LabelMap lb -> lb -> LabelIndex
forall lb. Label lb => LabelMap lb -> lb -> LabelIndex
mapLabelIndex LabelMap lb
lmap
        labelVal2 :: lb -> Word32
labelVal2        = (Word32 -> Word32 -> Word32) -> LabelIndex -> Word32
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
(*) (LabelIndex -> Word32) -> (lb -> LabelIndex) -> lb -> Word32
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 :: LabelMap lb -> ArcSet lb -> ArcSet LabelIndex
graphMap = (Arc lb -> Arc LabelIndex) -> ArcSet lb -> ArcSet LabelIndex
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map ((Arc lb -> Arc LabelIndex) -> ArcSet lb -> ArcSet LabelIndex)
-> (LabelMap lb -> Arc lb -> Arc LabelIndex)
-> LabelMap lb
-> ArcSet lb
-> ArcSet LabelIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (lb -> LabelIndex) -> Arc lb -> Arc LabelIndex
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((lb -> LabelIndex) -> Arc lb -> Arc LabelIndex)
-> (LabelMap lb -> lb -> LabelIndex)
-> LabelMap lb
-> Arc lb
-> Arc LabelIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelMap lb -> lb -> LabelIndex
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 :: LabelMap lb -> ArcSet lb -> ArcSet lb -> Bool
graphMapEq LabelMap lb
lmap = ArcSet LabelIndex -> ArcSet LabelIndex -> Bool
forall a. Eq a => a -> a -> Bool
(==) (ArcSet LabelIndex -> ArcSet LabelIndex -> Bool)
-> (ArcSet lb -> ArcSet LabelIndex)
-> ArcSet lb
-> ArcSet lb
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` LabelMap lb -> ArcSet lb -> ArcSet LabelIndex
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
--
--------------------------------------------------------------------------------