{-# 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, 2024 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 qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S

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

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

-- Avoid messages added in GHC 9.10 about foldl' import from Data.List
-- being redundant.
import Prelude hiding (Foldable(..))

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

--------------------------
--  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 :: forall lb. Label lb => LabelMap lb
emptyMap = Word32 -> Map lb LabelIndex -> GenLabelMap lb LabelIndex
forall lb lv.
(Label lb, Eq lv, Show 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 :: forall lb. EquivalenceClass lb -> [lb]
ecLabels = (LabelIndex, [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 :: forall lb.
Label lb =>
EquivalenceClass lb -> lb -> EquivalenceClass lb
ecRemoveLabel EquivalenceClass lb
xs lb
l = ([lb] -> [lb]) -> EquivalenceClass lb -> EquivalenceClass lb
forall b c d. (b -> c) -> (d, b) -> (d, c)
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 :: 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 = ((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 :: forall a b. Ord a => [(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 ([], b
_) = String -> (a, b)
forall a. HasCallStack => String -> a
error String
"internal error"
      factor (a
a:[a]
_, b
bs) = (a
a, 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 :: forall lb. Label lb => Int -> lb -> ScopedLabel lb
makeScopedLabel = Int -> lb -> ScopedLabel lb
forall lb. Label 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 = (lb -> ScopedLabel lb) -> Arc lb -> Arc (ScopedLabel lb)
forall a b. (a -> b) -> Arc a -> Arc b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> lb -> ScopedLabel lb
forall lb. Label 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 :: 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 " $ -} (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 a. [a] -> 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 a. [a] -> 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 :: 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) = ((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 a. 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 a. 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 a. 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 a. [a] -> 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 :: 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
_    [] = 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
ev1 LabelIndex -> 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 :: forall lb. Label lb => 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 b a. (b -> a -> b) -> b -> [a] -> b
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 :: forall lb. Label lb => 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 :: 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
&& (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 :: forall lb. Label lb => 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 :: forall lb. Label lb => LabelMap lb -> (lb, Word32) -> LabelMap lb
setLabelHash  (LabelMap Word32
g Map lb LabelIndex
lmap) (lb
lb,Word32
lh) =
    Word32 -> Map lb LabelIndex -> GenLabelMap lb LabelIndex
forall lb lv.
(Label lb, Eq lv, Show lv) =>
Word32 -> Map lb lv -> GenLabelMap lb lv
LabelMap Word32
g (Map lb LabelIndex -> GenLabelMap lb LabelIndex)
-> Map lb LabelIndex -> GenLabelMap lb LabelIndex
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 :: forall lb. Label lb => LabelMap lb -> LabelMap lb
newGenerationMap (LabelMap Word32
g Map lb LabelIndex
lvs) = Word32 -> Map lb LabelIndex -> GenLabelMap lb LabelIndex
forall lb lv.
(Label lb, Eq lv, Show lv) =>
Word32 -> Map lb lv -> GenLabelMap lb lv
LabelMap (Word32
g Word32 -> 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 :: forall lb. Label lb => 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 :: forall lb. Label lb => lb -> LabelMap lb -> LabelMap lb
assignLabelMap1 lb
lab (LabelMap Word32
g Map lb LabelIndex
lvs) = 
    Word32 -> Map lb LabelIndex -> GenLabelMap lb LabelIndex
forall lb lv.
(Label lb, Eq lv, Show lv) =>
Word32 -> Map lb lv -> GenLabelMap lb lv
LabelMap Word32
g (Map lb LabelIndex -> GenLabelMap lb LabelIndex)
-> Map lb LabelIndex -> GenLabelMap lb LabelIndex
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 :: forall lb. Label lb => 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 :: forall lb. Label lb => 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 :: forall lb.
Label lb =>
LabelMap lb -> Set lb -> [EquivalenceClass lb]
equivalenceClasses LabelMap lb
lmap Set lb
ls =
    [(LabelIndex, lb)] -> [(LabelIndex, [lb])]
forall a b. Ord a => [(a, b)] -> [(a, [b])]
pairGroup ([(LabelIndex, lb)] -> [(LabelIndex, [lb])])
-> [(LabelIndex, lb)] -> [(LabelIndex, [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 :: 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 =
    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
gen1 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
gen2) -- "Label map generation mismatch"
      (Word32 -> Map lb LabelIndex -> LabelMap lb
forall lb lv.
(Label lb, Eq lv, Show 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 a. (a -> a -> a) -> [a] -> a
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 a. (a -> a -> a) -> [a] -> a
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 a. [a] -> 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 :: forall a b. Ord a => 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 :: 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 =
    Word32 -> Map lb LabelIndex -> LabelMap lb
forall lb lv.
(Label lb, Eq lv, Show 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
gen Word32 -> 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     = Word32 -> lb -> Int
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 Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` [Int] -> Int
forall a. Num a => [a] -> a
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 :: 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 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 :: forall lb. Label lb => ArcSet lb -> Set lb
graphLabels = (Arc lb -> [lb]) -> Set (Arc 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 :: forall lb. Label lb => 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 :: forall lb.
Label lb =>
LabelMap lb -> ArcSet lb -> ArcSet LabelIndex
graphMap = (Arc lb -> Arc LabelIndex) -> Set (Arc lb) -> ArcSet LabelIndex
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map ((Arc lb -> Arc LabelIndex) -> Set (Arc lb) -> ArcSet LabelIndex)
-> (LabelMap lb -> Arc lb -> Arc LabelIndex)
-> LabelMap lb
-> Set (Arc lb)
-> ArcSet LabelIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (lb -> LabelIndex) -> Arc lb -> Arc LabelIndex
forall a b. (a -> b) -> Arc a -> Arc b
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 :: forall lb.
Label lb =>
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, 2022, 2024 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
--
--------------------------------------------------------------------------------