{-# LANGUAGE CPP #-}

#if (__GLASGOW_HASKELL__ >= 802)
{-# LANGUAGE DerivingStrategies #-}
#endif

--------------------------------------------------------------------------------
--  See end of this file for licence information.
--------------------------------------------------------------------------------
-- |
--  Module      :  GraphPartition
--  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2022 Douglas Burke
--  License     :  GPL V2
--
--  Maintainer  :  Douglas Burke
--  Stability   :  experimental
--  Portability :  CPP, DerivingStrategies
--
--  This module contains functions for partitioning a graph into subgraphs
--  that rooted from different subject nodes.
--
--------------------------------------------------------------------------------

module Swish.GraphPartition
    ( PartitionedGraph(..), getArcs, getPartitions
    , GraphPartition(..), node, toArcs
    , partitionGraph, comparePartitions
    , partitionShowP
    )
where

import Swish.GraphClass (Label(..), Arc(..))

import Control.Monad.State (MonadState(..), State)
import Control.Monad.State (evalState)

import Data.List (foldl', partition)
import Data.List.NonEmpty (NonEmpty(..), (<|))
import Data.Maybe (mapMaybe)

import qualified Data.List.NonEmpty as NE

------------------------------------------------------------
--  Data type for a partitioned graph
------------------------------------------------------------

-- |Representation of a graph as a collection of (possibly nested)
--  partitions.  Each node in the graph appears at least once as the
--  root value of a 'GraphPartition' value:
--
--  * Nodes that are the subject of at least one statement appear as
--    the first value of exactly one 'PartSub' constructor, and may
--    also appear in any number of 'PartObj' constructors.
--
--  * Nodes appearing only as objects of statements appear only in
--    'PartObj' constructors.

data PartitionedGraph lb = PartitionedGraph [GraphPartition lb]
    deriving
#if (__GLASGOW_HASKELL__ >= 802)
      stock
#endif
      (PartitionedGraph lb -> PartitionedGraph lb -> Bool
forall lb.
Label lb =>
PartitionedGraph lb -> PartitionedGraph lb -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PartitionedGraph lb -> PartitionedGraph lb -> Bool
$c/= :: forall lb.
Label lb =>
PartitionedGraph lb -> PartitionedGraph lb -> Bool
== :: PartitionedGraph lb -> PartitionedGraph lb -> Bool
$c== :: forall lb.
Label lb =>
PartitionedGraph lb -> PartitionedGraph lb -> Bool
Eq, Int -> PartitionedGraph lb -> ShowS
forall lb. Label lb => Int -> PartitionedGraph lb -> ShowS
forall lb. Label lb => [PartitionedGraph lb] -> ShowS
forall lb. Label lb => PartitionedGraph lb -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PartitionedGraph lb] -> ShowS
$cshowList :: forall lb. Label lb => [PartitionedGraph lb] -> ShowS
show :: PartitionedGraph lb -> String
$cshow :: forall lb. Label lb => PartitionedGraph lb -> String
showsPrec :: Int -> PartitionedGraph lb -> ShowS
$cshowsPrec :: forall lb. Label lb => Int -> PartitionedGraph lb -> ShowS
Show)

-- | Returns all the arcs in the partitioned graph.
getArcs :: PartitionedGraph lb -> [Arc lb]
getArcs :: forall lb. PartitionedGraph lb -> [Arc lb]
getArcs (PartitionedGraph [GraphPartition lb]
ps) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall lb. GraphPartition lb -> [Arc lb]
toArcs [GraphPartition lb]
ps

-- | Returns a list of partitions.
getPartitions :: PartitionedGraph lb -> [GraphPartition lb]
getPartitions :: forall lb. PartitionedGraph lb -> [GraphPartition lb]
getPartitions (PartitionedGraph [GraphPartition lb]
ps) = [GraphPartition lb]
ps

-- Note: do not use the LabelledPartition local type here since we do
-- not want it to appear in the documentation.

-- | Represent a partition of a graph by a node and (optional) contents.
data GraphPartition lb
    = PartObj lb
    | PartSub lb (NonEmpty (lb,GraphPartition lb))

-- | Returns the node for the partition.
node :: GraphPartition lb -> lb
node :: forall lb. GraphPartition lb -> lb
node (PartObj lb
ob)   = lb
ob
node (PartSub lb
sb NonEmpty (lb, GraphPartition lb)
_) = lb
sb

-- | Creates a list of arcs from the partition. The empty
-- list is returned for `PartObj`.
toArcs :: GraphPartition lb -> [Arc lb]
toArcs :: forall lb. GraphPartition lb -> [Arc lb]
toArcs (PartObj lb
_)      = []
toArcs (PartSub lb
sb NonEmpty (lb, GraphPartition lb)
prs) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (lb, GraphPartition lb) -> [Arc lb]
toArcs1 forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty (lb, GraphPartition lb)
prs
    where
        toArcs1 :: (lb, GraphPartition lb) -> [Arc lb]
toArcs1 (lb
pr,GraphPartition lb
ob) = forall lb. lb -> lb -> lb -> Arc lb
Arc lb
sb lb
pr (forall lb. GraphPartition lb -> lb
node GraphPartition lb
ob) forall a. a -> [a] -> [a]
: forall lb. GraphPartition lb -> [Arc lb]
toArcs GraphPartition lb
ob

-- | Equality is based on total structural equivalence
-- rather than graph equality.
instance (Label lb) => Eq (GraphPartition lb) where
    (PartObj lb
o1)    == :: GraphPartition lb -> GraphPartition lb -> Bool
== (PartObj lb
o2)    = lb
o1 forall a. Eq a => a -> a -> Bool
== lb
o2
    (PartSub lb
s1 NonEmpty (lb, GraphPartition lb)
p1) == (PartSub lb
s2 NonEmpty (lb, GraphPartition lb)
p2) = lb
s1 forall a. Eq a => a -> a -> Bool
== lb
s2 Bool -> Bool -> Bool
&& NonEmpty (lb, GraphPartition lb)
p1 forall a. Eq a => a -> a -> Bool
== NonEmpty (lb, GraphPartition lb)
p2
    GraphPartition lb
_               == GraphPartition lb
_               = Bool
False

-- Chose ordering to be "more information" first/smaller (arbitrary choice).
instance (Label lb) => Ord (GraphPartition lb) where
    (PartSub lb
s1 NonEmpty (lb, GraphPartition lb)
p1) compare :: GraphPartition lb -> GraphPartition lb -> Ordering
`compare` (PartSub lb
s2 NonEmpty (lb, GraphPartition lb)
p2) = (lb
s1,NonEmpty (lb, GraphPartition lb)
p1) forall a. Ord a => a -> a -> Ordering
`compare` (lb
s2,NonEmpty (lb, GraphPartition lb)
p2)
    (PartObj lb
o1)    `compare` (PartObj lb
o2)    = lb
o1 forall a. Ord a => a -> a -> Ordering
`compare` lb
o2
    (PartSub lb
_ NonEmpty (lb, GraphPartition lb)
_)   `compare` GraphPartition lb
_               = Ordering
LT
    GraphPartition lb
_               `compare` (PartSub lb
_ NonEmpty (lb, GraphPartition lb)
_)   = Ordering
GT

instance (Label lb) => Show (GraphPartition lb) where
    show :: GraphPartition lb -> String
show = forall lb. Label lb => GraphPartition lb -> String
partitionShow

-- can we just say 
--  partitionShow = partitionShowP ""
-- ?
partitionShow :: (Label lb) => GraphPartition lb -> String
partitionShow :: forall lb. Label lb => GraphPartition lb -> String
partitionShow (PartObj lb
ob)             = forall a. Show a => a -> String
show lb
ob
partitionShow (PartSub lb
sb ((lb, GraphPartition lb)
pr :| [(lb, GraphPartition lb)]
prs)) =
    String
"(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show lb
sb forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall {a} {a}. (Show a, Show a) => (a, a) -> String
showpr (lb, GraphPartition lb)
pr forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String
" ; " forall a. [a] -> [a] -> [a]
++)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall {a} {a}. (Show a, Show a) => (a, a) -> String
showpr) [(lb, GraphPartition lb)]
prs forall a. [a] -> [a] -> [a]
++ String
")"
    where
        showpr :: (a, a) -> String
showpr (a
a,a
b) = forall a. Show a => a -> String
show a
a forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
b

-- only used in Swish.Commands  

-- | Convert a partition into a string with a leading separator string.
partitionShowP :: 
    (Label lb) => 
    String 
    -> GraphPartition lb 
    -> String
partitionShowP :: forall lb. Label lb => String -> GraphPartition lb -> String
partitionShowP String
_    (PartObj lb
ob)             = forall a. Show a => a -> String
show lb
ob
partitionShowP String
pref (PartSub lb
sb ((lb, GraphPartition lb)
pr :| [(lb, GraphPartition lb)]
prs)) =
    String
pref forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show lb
sb forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall {lb} {a}.
(Label lb, Show a) =>
(a, GraphPartition lb) -> String
showpr (lb, GraphPartition lb)
pr forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((String
pref forall a. [a] -> [a] -> [a]
++ String
"  ; ") forall a. [a] -> [a] -> [a]
++ )forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall {lb} {a}.
(Label lb, Show a) =>
(a, GraphPartition lb) -> String
showpr) [(lb, GraphPartition lb)]
prs forall a. [a] -> [a] -> [a]
++ String
")"
    where
        showpr :: (a, GraphPartition lb) -> String
showpr (a
a,GraphPartition lb
b) = forall a. Show a => a -> String
show a
a forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall lb. Label lb => String -> GraphPartition lb -> String
partitionShowP (String
pref forall a. [a] -> [a] -> [a]
++ String
"  ") GraphPartition lb
b

------------------------------------------------------------
--  Creating partitioned graphs
------------------------------------------------------------
--
-- |Turning a partitioned graph into a flat graph is easy.
--  The interesting challenge is to turn a flat graph into a
--  partitioned graph that is more useful for certain purposes.
--  Currently, I'm interested in:
--        
--  (1) isolating differences between graphs
--        
--  (2) pretty-printing graphs
--
--  For (1), the goal is to separate subgraphs that are known
--  to be equivalent from subgraphs that are known to be different,
--  such that: 
--
--  * different sub-graphs are minimized,
--
--  * different
--  sub-graphs are placed into 1:1 correspondence (possibly with null
--  subgraphs), and
--
--  * only deterministic matching decisions are made.
--
--  For (2), the goal is to decide when a subgraph is to be treated
--  as nested in another partition, or treated as a new top-level partition.
--  If a subgraph is referenced by exactly one graph partition, it should
--  be nested in that partition, otherwise it should be a new top-level
--  partition.
--
--  Strategy.  Examining just subject and object nodes:
--
--  * all non-blank subject nodes are the root of a top-level partition
--
--  * blank subject nodes that are not the object of exactly one statement
--     are the root of a top-level partition.
--
--  * blank nodes referenced as the object of exactly 1 statement
--     of an existing partition are the root of a sub-partition of the
--     refering partition.
--
--  * what remain are circular chains of blank nodes not referenced
--     elsewhere:  for each such chain, pick a root node arbitrarily.
--
partitionGraph :: (Label lb) => [Arc lb] -> PartitionedGraph lb
partitionGraph :: forall lb. Label lb => [Arc lb] -> PartitionedGraph lb
partitionGraph [] = forall lb. [GraphPartition lb] -> PartitionedGraph lb
PartitionedGraph []
partitionGraph [Arc lb]
arcs =
    forall lb.
Eq lb =>
[LabelledArcs lb]
-> [LabelledArcs lb] -> [LabelledArcs lb] -> PartitionedGraph lb
makePartitions [(lb, NonEmpty (Arc lb))]
fixs [(lb, NonEmpty (Arc lb))]
topv1 [(lb, NonEmpty (Arc lb))]
intv1
    where
        ([(lb, NonEmpty (Arc lb))]
fixs,[(lb, NonEmpty (Arc lb))]
vars)  = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition forall {b}. (lb, b) -> Bool
isNonVar forall a b. (a -> b) -> a -> b
$ forall b a. Eq b => (a -> b) -> [a] -> [(b, NonEmpty a)]
collect forall lb. Arc lb -> lb
arcSubj [Arc lb]
arcs
        vars1 :: [(lb, (NonEmpty (Arc lb), [Arc lb]))]
vars1        = forall b a c.
Eq b =>
(a -> b) -> [a] -> [(b, c)] -> [(b, (c, [a]))]
collectMore forall lb. Arc lb -> lb
arcObj [Arc lb]
arcs [(lb, NonEmpty (Arc lb))]
vars
        ([(lb, (NonEmpty (Arc lb), [Arc lb]))]
intv,[(lb, (NonEmpty (Arc lb), [Arc lb]))]
topv)  = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition forall {a} {a} {a}. (a, (a, [a])) -> Bool
objOnce [(lb, (NonEmpty (Arc lb), [Arc lb]))]
vars1
        intv1 :: [(lb, NonEmpty (Arc lb))]
intv1        = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {b}. (a, (b, b)) -> (a, b)
stripObj [(lb, (NonEmpty (Arc lb), [Arc lb]))]
intv
        topv1 :: [(lb, NonEmpty (Arc lb))]
topv1        = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {b}. (a, (b, b)) -> (a, b)
stripObj [(lb, (NonEmpty (Arc lb), [Arc lb]))]
topv
        isNonVar :: (lb, b) -> Bool
isNonVar     = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall lb. Label lb => lb -> Bool
labelIsVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
        objOnce :: (a, (a, [a])) -> Bool
objOnce      = forall {a}. [a] -> Bool
isSingle forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
        isSingle :: [a] -> Bool
isSingle [a
_] = Bool
True
        isSingle [a]
_   = Bool
False
        stripObj :: (a, (b, b)) -> (a, b)
stripObj (a
k,(b
s,b
_)) = (a
k,b
s)

-- Local state type for partitioning function
type LabelledArcs lb = (lb, NonEmpty (Arc lb))
type LabelledPartition lb = (lb, GraphPartition lb)
type MakePartitionState lb = ([LabelledArcs lb], [LabelledArcs lb], [LabelledArcs lb])
type PState lb = State (MakePartitionState lb)

makePartitions :: 
    (Eq lb) =>
    [LabelledArcs lb]
    -> [LabelledArcs lb]
    -> [LabelledArcs lb]
    -> PartitionedGraph lb
makePartitions :: forall lb.
Eq lb =>
[LabelledArcs lb]
-> [LabelledArcs lb] -> [LabelledArcs lb] -> PartitionedGraph lb
makePartitions [LabelledArcs lb]
fixs [LabelledArcs lb]
topv [LabelledArcs lb]
intv =
    forall lb. [GraphPartition lb] -> PartitionedGraph lb
PartitionedGraph forall a b. (a -> b) -> a -> b
$ forall s a. State s a -> s -> a
evalState (forall lb.
Eq lb =>
[LabelledArcs lb] -> PState lb [GraphPartition lb]
makePartitions1 []) ([LabelledArcs lb]
fixs,[LabelledArcs lb]
topv,[LabelledArcs lb]
intv)

-- Use a state monad to keep track of arcs that have been incorporated into
-- the resulting list of graph partitions.  The collections of arcs used to
-- generate the list of partitions are supplied as the initial state of the
-- monad (see call of evalState above).
--
makePartitions1 :: 
    (Eq lb) =>
    [LabelledArcs lb] 
    -> PState lb [GraphPartition lb]
makePartitions1 :: forall lb.
Eq lb =>
[LabelledArcs lb] -> PState lb [GraphPartition lb]
makePartitions1 [] = do
    [LabelledArcs lb]
s <- forall lb. PState lb [LabelledArcs lb]
pickNextSubject
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LabelledArcs lb]
s then forall (m :: * -> *) a. Monad m => a -> m a
return [] else forall lb.
Eq lb =>
[LabelledArcs lb] -> PState lb [GraphPartition lb]
makePartitions1 [LabelledArcs lb]
s
makePartitions1 (LabelledArcs lb
sub:[LabelledArcs lb]
subs) = do
    [GraphPartition lb]
ph <- forall lb.
Eq lb =>
LabelledArcs lb -> PState lb [GraphPartition lb]
makePartitions2 LabelledArcs lb
sub
    [GraphPartition lb]
pt <- forall lb.
Eq lb =>
[LabelledArcs lb] -> PState lb [GraphPartition lb]
makePartitions1 [LabelledArcs lb]
subs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [GraphPartition lb]
ph forall a. [a] -> [a] -> [a]
++ [GraphPartition lb]
pt

makePartitions2 :: 
    (Eq lb) =>
    LabelledArcs lb
    -> PState lb [GraphPartition lb]
makePartitions2 :: forall lb.
Eq lb =>
LabelledArcs lb -> PState lb [GraphPartition lb]
makePartitions2 LabelledArcs lb
subs = do
    (GraphPartition lb
part,[LabelledArcs lb]
moresubs) <- forall lb.
Eq lb =>
LabelledArcs lb -> PState lb (GraphPartition lb, [LabelledArcs lb])
makeStatements LabelledArcs lb
subs
    [GraphPartition lb]
moreparts <- if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LabelledArcs lb]
moresubs
                 then forall (m :: * -> *) a. Monad m => a -> m a
return []
                 else forall lb.
Eq lb =>
[LabelledArcs lb] -> PState lb [GraphPartition lb]
makePartitions1 [LabelledArcs lb]
moresubs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ GraphPartition lb
partforall a. a -> [a] -> [a]
:[GraphPartition lb]
moreparts

makeStatements :: 
    (Eq lb) =>
    LabelledArcs lb
    -> PState lb (GraphPartition lb, [LabelledArcs lb])
makeStatements :: forall lb.
Eq lb =>
LabelledArcs lb -> PState lb (GraphPartition lb, [LabelledArcs lb])
makeStatements (lb
sub,NonEmpty (Arc lb)
stmts) = do
    [(LabelledPartition lb, [(lb, NonEmpty (Arc lb))])]
propmore <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall lb.
Eq lb =>
Arc lb -> PState lb (LabelledPartition lb, [LabelledArcs lb])
makeStatement (forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Arc lb)
stmts)
    let ([LabelledPartition lb]
props,[[(lb, NonEmpty (Arc lb))]]
moresubs) = forall a b. [(a, b)] -> ([a], [b])
unzip [(LabelledPartition lb, [(lb, NonEmpty (Arc lb))])]
propmore
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall lb.
lb -> NonEmpty (lb, GraphPartition lb) -> GraphPartition lb
PartSub lb
sub (forall a. [a] -> NonEmpty a
NE.fromList [LabelledPartition lb]
props), forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(lb, NonEmpty (Arc lb))]]
moresubs)
    -- return (PartSub sub props, concat moresubs)

makeStatement :: 
    (Eq lb) =>
    Arc lb
    -> PState lb (LabelledPartition lb, [LabelledArcs lb])
makeStatement :: forall lb.
Eq lb =>
Arc lb -> PState lb (LabelledPartition lb, [LabelledArcs lb])
makeStatement (Arc lb
_ lb
prop lb
obj) = do
    [LabelledArcs lb]
intobj <- forall lb. Eq lb => lb -> PState lb [LabelledArcs lb]
pickIntSubject lb
obj
    (GraphPartition lb
gpobj, [LabelledArcs lb]
moresubs) <- if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LabelledArcs lb]
intobj
                         then do
                             [LabelledArcs lb]
ms <- forall lb. Eq lb => lb -> PState lb [LabelledArcs lb]
pickVarSubject lb
obj
                             forall (m :: * -> *) a. Monad m => a -> m a
return (forall lb. lb -> GraphPartition lb
PartObj lb
obj,[LabelledArcs lb]
ms)
                         else forall lb.
Eq lb =>
LabelledArcs lb -> PState lb (GraphPartition lb, [LabelledArcs lb])
makeStatements (forall a. [a] -> a
head [LabelledArcs lb]
intobj)
    forall (m :: * -> *) a. Monad m => a -> m a
return ((lb
prop,GraphPartition lb
gpobj), [LabelledArcs lb]
moresubs)

pickNextSubject :: PState lb [LabelledArcs lb]
pickNextSubject :: forall lb. PState lb [LabelledArcs lb]
pickNextSubject = do
    ([LabelledArcs lb]
a1,[LabelledArcs lb]
a2,[LabelledArcs lb]
a3) <- forall s (m :: * -> *). MonadState s m => m s
get
    let ([LabelledArcs lb]
s,MakePartitionState lb
st) = case ([LabelledArcs lb]
a1,[LabelledArcs lb]
a2,[LabelledArcs lb]
a3) of
                   (LabelledArcs lb
s1h:[LabelledArcs lb]
s1t,[LabelledArcs lb]
s2,[LabelledArcs lb]
s3) -> ([LabelledArcs lb
s1h],([LabelledArcs lb]
s1t,[LabelledArcs lb]
s2,[LabelledArcs lb]
s3))
                   ([],LabelledArcs lb
s2h:[LabelledArcs lb]
s2t,[LabelledArcs lb]
s3) -> ([LabelledArcs lb
s2h],([],[LabelledArcs lb]
s2t,[LabelledArcs lb]
s3))
                   ([],[],LabelledArcs lb
s3h:[LabelledArcs lb]
s3t) -> ([LabelledArcs lb
s3h],([],[],[LabelledArcs lb]
s3t))
                   ([],[],[])      -> ([]   ,([],[],[] ))
    forall s (m :: * -> *). MonadState s m => s -> m ()
put MakePartitionState lb
st
    forall (m :: * -> *) a. Monad m => a -> m a
return [LabelledArcs lb]
s

pickIntSubject :: (Eq lb) =>
    lb 
    -> PState lb [LabelledArcs lb]
pickIntSubject :: forall lb. Eq lb => lb -> PState lb [LabelledArcs lb]
pickIntSubject lb
sub = do
    ([LabelledArcs lb]
s1,[LabelledArcs lb]
s2,[LabelledArcs lb]
s3) <- forall s (m :: * -> *). MonadState s m => m s
get
    let varsub :: Maybe (LabelledArcs lb, [LabelledArcs lb])
varsub = forall b a. (b -> a -> Bool) -> b -> [a] -> Maybe (a, [a])
removeBy (\lb
x -> (lb
x forall a. Eq a => a -> a -> Bool
==)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> a
fst) lb
sub [LabelledArcs lb]
s3
    case Maybe (LabelledArcs lb, [LabelledArcs lb])
varsub of
        Just (LabelledArcs lb
vs, [LabelledArcs lb]
s3new) -> forall s (m :: * -> *). MonadState s m => s -> m ()
put ([LabelledArcs lb]
s1,[LabelledArcs lb]
s2,[LabelledArcs lb]
s3new) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [LabelledArcs lb
vs]
        Maybe (LabelledArcs lb, [LabelledArcs lb])
Nothing          -> forall (m :: * -> *) a. Monad m => a -> m a
return []

pickVarSubject :: 
    (Eq lb) =>
    lb -> 
    PState lb [LabelledArcs lb]
pickVarSubject :: forall lb. Eq lb => lb -> PState lb [LabelledArcs lb]
pickVarSubject lb
sub = do
    ([LabelledArcs lb]
s1,[LabelledArcs lb]
s2,[LabelledArcs lb]
s3) <- forall s (m :: * -> *). MonadState s m => m s
get
    let varsub :: Maybe (LabelledArcs lb, [LabelledArcs lb])
varsub = forall b a. (b -> a -> Bool) -> b -> [a] -> Maybe (a, [a])
removeBy (\lb
x -> (lb
x forall a. Eq a => a -> a -> Bool
==)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> a
fst) lb
sub [LabelledArcs lb]
s2
    case Maybe (LabelledArcs lb, [LabelledArcs lb])
varsub of
        Just (LabelledArcs lb
vs, [LabelledArcs lb]
s2new) -> forall s (m :: * -> *). MonadState s m => s -> m ()
put ([LabelledArcs lb]
s1,[LabelledArcs lb]
s2new,[LabelledArcs lb]
s3) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [LabelledArcs lb
vs]
        Maybe (LabelledArcs lb, [LabelledArcs lb])
_                -> forall (m :: * -> *) a. Monad m => a -> m a
return []

------------------------------------------------------------
--  Other useful functions
------------------------------------------------------------

-- | Create a list of pairs of corresponding Partitions that
--  are unequal.
comparePartitions :: (Label lb) =>
    PartitionedGraph lb 
    -> PartitionedGraph lb
    -> [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
comparePartitions :: forall lb.
Label lb =>
PartitionedGraph lb
-> PartitionedGraph lb
-> [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
comparePartitions (PartitionedGraph [GraphPartition lb]
gp1) (PartitionedGraph [GraphPartition lb]
gp2) =
    forall lb.
Label lb =>
[GraphPartition lb]
-> [GraphPartition lb]
-> [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
comparePartitions1 (forall a. [a] -> [a]
reverse [GraphPartition lb]
gp1) (forall a. [a] -> [a]
reverse [GraphPartition lb]
gp2)

comparePartitions1 :: (Label lb) =>
    [GraphPartition lb] 
    -> [GraphPartition lb]
    -> [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))]
comparePartitions1 :: forall lb.
Label lb =>
[GraphPartition lb]
-> [GraphPartition lb]
-> [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
comparePartitions1 [GraphPartition lb]
pg1 [GraphPartition lb]
pg2 =
        [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
ds forall a. [a] -> [a] -> [a]
++ [ (forall a. a -> Maybe a
Just GraphPartition lb
r1p,forall a. Maybe a
Nothing) | GraphPartition lb
r1p<-[GraphPartition lb]
r1 ]
           forall a. [a] -> [a] -> [a]
++ [ (forall a. Maybe a
Nothing,forall a. a -> Maybe a
Just GraphPartition lb
r2p) | GraphPartition lb
r2p<-[GraphPartition lb]
r2 ]
    where
        ([(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
ds,[GraphPartition lb]
r1,[GraphPartition lb]
r2) = forall a d. (a -> a -> Maybe [d]) -> [a] -> [a] -> ([d], [a], [a])
listDifferences forall lb.
Label lb =>
GraphPartition lb
-> GraphPartition lb
-> Maybe [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
comparePartitions2 [GraphPartition lb]
pg1 [GraphPartition lb]
pg2

--  Compare two graph partitions, with three possible outcomes:
--    Nothing    -> no match
--    Just []    -> total match
--    Just [...] -> partial match, with mismatched sub-partitions listed.
--
--  A partial match occurs when the leading nodes are non-variable and
--  equal, but something else in the partition does not match.
--
--  A complete match can be achieved with variable nodes that have
--  different labels
--
comparePartitions2 :: (Label lb) =>
    GraphPartition lb 
    -> GraphPartition lb
    -> Maybe [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
comparePartitions2 :: forall lb.
Label lb =>
GraphPartition lb
-> GraphPartition lb
-> Maybe [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
comparePartitions2 (PartObj lb
l1) (PartObj lb
l2) =
    if forall lb. Label lb => lb -> lb -> Bool
matchNodes lb
l1 lb
l2 then forall a. a -> Maybe a
Just [] else forall a. Maybe a
Nothing
comparePartitions2 pg1 :: GraphPartition lb
pg1@(PartSub lb
l1 NonEmpty (lb, GraphPartition lb)
p1s) pg2 :: GraphPartition lb
pg2@(PartSub lb
l2 NonEmpty (lb, GraphPartition lb)
p2s) =
    if Bool
match then Maybe [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
comp1 else forall a. Maybe a
Nothing
    where
        comp1 :: Maybe [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
comp1  = case forall lb.
Label lb =>
lb
-> lb
-> NonEmpty (LabelledPartition lb)
-> NonEmpty (LabelledPartition lb)
-> Maybe [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
comparePartitions3 lb
l1 lb
l2 NonEmpty (lb, GraphPartition lb)
p1s NonEmpty (lb, GraphPartition lb)
p2s of
                    Maybe [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
Nothing -> if Bool
matchVar then forall a. Maybe a
Nothing
                                           else forall a. a -> Maybe a
Just [(forall a. a -> Maybe a
Just GraphPartition lb
pg1,forall a. a -> Maybe a
Just GraphPartition lb
pg2)]
                    Just [] -> forall a. a -> Maybe a
Just []
                    Just [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
ps -> {- if matchVar then Nothing else -} forall a. a -> Maybe a
Just [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
ps
        matchVar :: Bool
matchVar = forall lb. Label lb => lb -> Bool
labelIsVar lb
l1 Bool -> Bool -> Bool
&& forall lb. Label lb => lb -> Bool
labelIsVar lb
l2
        match :: Bool
match    = Bool
matchVar Bool -> Bool -> Bool
|| lb
l1 forall a. Eq a => a -> a -> Bool
== lb
l2
comparePartitions2 GraphPartition lb
pg1 GraphPartition lb
pg2 =
    if Bool -> Bool
not (forall lb. Label lb => lb -> Bool
labelIsVar lb
l1) Bool -> Bool -> Bool
&& lb
l1 forall a. Eq a => a -> a -> Bool
== lb
l2
        then forall a. a -> Maybe a
Just [(forall a. a -> Maybe a
Just GraphPartition lb
pg1,forall a. a -> Maybe a
Just GraphPartition lb
pg2)]
        else forall a. Maybe a
Nothing
    where
        l1 :: lb
l1 = forall lb. GraphPartition lb -> lb
node GraphPartition lb
pg1
        l2 :: lb
l2 = forall lb. GraphPartition lb -> lb
node GraphPartition lb
pg2

comparePartitions3 :: (Label lb) =>
    lb 
    -> lb 
    -> NonEmpty (LabelledPartition lb)
    -> NonEmpty (LabelledPartition lb)
    -> Maybe [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))]
comparePartitions3 :: forall lb.
Label lb =>
lb
-> lb
-> NonEmpty (LabelledPartition lb)
-> NonEmpty (LabelledPartition lb)
-> Maybe [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
comparePartitions3 lb
l1 lb
l2 NonEmpty (LabelledPartition lb)
s1s NonEmpty (LabelledPartition lb)
s2s = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
        [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
ds forall a. [a] -> [a] -> [a]
++ [ (forall a. a -> Maybe a
Just (forall lb.
lb -> NonEmpty (lb, GraphPartition lb) -> GraphPartition lb
PartSub lb
l1 (LabelledPartition lb
r1p forall a. a -> [a] -> NonEmpty a
:| [])),forall a. Maybe a
Nothing) | LabelledPartition lb
r1p<-[LabelledPartition lb]
r1 ]
           forall a. [a] -> [a] -> [a]
++ [ (forall a. Maybe a
Nothing,forall a. a -> Maybe a
Just (forall lb.
lb -> NonEmpty (lb, GraphPartition lb) -> GraphPartition lb
PartSub lb
l2 (LabelledPartition lb
r2p forall a. a -> [a] -> NonEmpty a
:| []))) | LabelledPartition lb
r2p<-[LabelledPartition lb]
r2 ]
    where
        ([(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
ds,[LabelledPartition lb]
r1,[LabelledPartition lb]
r2) = forall a d. (a -> a -> Maybe [d]) -> [a] -> [a] -> ([d], [a], [a])
listDifferences 
                     (forall lb.
Label lb =>
lb
-> lb
-> LabelledPartition lb
-> LabelledPartition lb
-> Maybe [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
comparePartitions4 lb
l1 lb
l2) 
                     (forall a. NonEmpty a -> [a]
NE.toList NonEmpty (LabelledPartition lb)
s1s)
                     (forall a. NonEmpty a -> [a]
NE.toList NonEmpty (LabelledPartition lb)
s2s)

comparePartitions4 :: (Label lb) =>
    lb 
    -> lb 
    -> LabelledPartition lb 
    -> LabelledPartition lb
    -> Maybe [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))]
comparePartitions4 :: forall lb.
Label lb =>
lb
-> lb
-> LabelledPartition lb
-> LabelledPartition lb
-> Maybe [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
comparePartitions4 lb
_ lb
_ (lb
p1,GraphPartition lb
o1) (lb
p2,GraphPartition lb
o2) =
    if forall lb. Label lb => lb -> lb -> Bool
matchNodes lb
p1 lb
p2 then Maybe [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
comp1 else forall a. Maybe a
Nothing
    where
        comp1 :: Maybe [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
comp1   = case forall lb.
Label lb =>
GraphPartition lb
-> GraphPartition lb
-> Maybe [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
comparePartitions2 GraphPartition lb
o1 GraphPartition lb
o2 of
                    Maybe [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
Nothing -> forall a. a -> Maybe a
Just [(forall a. a -> Maybe a
Just GraphPartition lb
o1,forall a. a -> Maybe a
Just GraphPartition lb
o2)]
                    Maybe [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
ds      -> Maybe [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))]
ds

matchNodes :: (Label lb) => lb -> lb -> Bool
matchNodes :: forall lb. Label lb => lb -> lb -> Bool
matchNodes lb
l1 lb
l2
    | forall lb. Label lb => lb -> Bool
labelIsVar lb
l1 = forall lb. Label lb => lb -> Bool
labelIsVar lb
l2
    | Bool
otherwise     = lb
l1 forall a. Eq a => a -> a -> Bool
== lb
l2


------------------------------------------------------------
--  Helpers
------------------------------------------------------------

-- |Collect a list of items by some comparison of a selected component
--  or other derived value.
--
--  cmp     a comparison function that determines if a pair of values
--          should be grouped together
--  sel     a function that selects a value from any item
--
--  Example:    collect fst [(1,'a'),(2,'b'),(1,'c')] =
--                  [(1,[(1,'a'),(1,'c')]),(2,[(2,'b')])]
--
collect :: (Eq b) => (a->b) -> [a] -> [(b, NonEmpty a)]
collect :: forall b a. Eq b => (a -> b) -> [a] -> [(b, NonEmpty a)]
collect = forall b a.
(b -> b -> Bool) -> (a -> b) -> [a] -> [(b, NonEmpty a)]
collectBy forall a. Eq a => a -> a -> Bool
(==)

collectBy :: (b->b->Bool) -> (a->b) -> [a] -> [(b, NonEmpty a)]
collectBy :: forall b a.
(b -> b -> Bool) -> (a -> b) -> [a] -> [(b, NonEmpty a)]
collectBy b -> b -> Bool
cmp a -> b
sel = forall a b. (a -> b) -> [a] -> [b]
map forall b a. (b, NonEmpty a) -> (b, NonEmpty a)
reverseCollection forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a.
(b -> b -> Bool)
-> (a -> b) -> [(b, NonEmpty a)] -> [a] -> [(b, NonEmpty a)]
collectBy1 b -> b -> Bool
cmp a -> b
sel []

collectBy1 :: (b->b->Bool) -> (a->b) -> [(b, NonEmpty a)] -> [a] -> [(b, NonEmpty a)]
collectBy1 :: forall b a.
(b -> b -> Bool)
-> (a -> b) -> [(b, NonEmpty a)] -> [a] -> [(b, NonEmpty a)]
collectBy1 b -> b -> Bool
_   a -> b
_   [(b, NonEmpty a)]
sofar []     = [(b, NonEmpty a)]
sofar
collectBy1 b -> b -> Bool
cmp a -> b
sel [(b, NonEmpty a)]
sofar (a
a:[a]
as) =
    forall b a.
(b -> b -> Bool)
-> (a -> b) -> [(b, NonEmpty a)] -> [a] -> [(b, NonEmpty a)]
collectBy1 b -> b -> Bool
cmp a -> b
sel (forall b a.
(b -> b -> Bool)
-> (a -> b) -> a -> [(b, NonEmpty a)] -> [(b, NonEmpty a)]
collectBy2 b -> b -> Bool
cmp a -> b
sel a
a [(b, NonEmpty a)]
sofar) [a]
as

collectBy2 :: (b->b->Bool) -> (a->b) -> a -> [(b, NonEmpty a)] -> [(b, NonEmpty a)]
collectBy2 :: forall b a.
(b -> b -> Bool)
-> (a -> b) -> a -> [(b, NonEmpty a)] -> [(b, NonEmpty a)]
collectBy2 b -> b -> Bool
_   a -> b
sel a
a [] = [(a -> b
sel a
a, a
a forall a. a -> [a] -> NonEmpty a
:| [])]
collectBy2 b -> b -> Bool
cmp a -> b
sel a
a (col :: (b, NonEmpty a)
col@(b
k,NonEmpty a
as) : [(b, NonEmpty a)]
cols)
    | b -> b -> Bool
cmp b
ka b
k  = (b
k, a
a forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty a
as) forall a. a -> [a] -> [a]
: [(b, NonEmpty a)]
cols
    | Bool
otherwise = (b, NonEmpty a)
col forall a. a -> [a] -> [a]
: forall b a.
(b -> b -> Bool)
-> (a -> b) -> a -> [(b, NonEmpty a)] -> [(b, NonEmpty a)]
collectBy2 b -> b -> Bool
cmp a -> b
sel a
a [(b, NonEmpty a)]
cols
    where
        ka :: b
ka = a -> b
sel a
a

reverseCollection :: (b, NonEmpty a) -> (b, NonEmpty a)
reverseCollection :: forall b a. (b, NonEmpty a) -> (b, NonEmpty a)
reverseCollection (b
k,NonEmpty a
as) = (b
k, forall a. NonEmpty a -> NonEmpty a
NE.reverse NonEmpty a
as)

{-
-- Example/test:
testCollect1 :: [(Int, [(Int, Char)])]
testCollect1 = collect fst [(1,'a'),(2,'b'),(1,'c'),(1,'d'),(2,'d'),(3,'d')]

testCollect2 :: Bool
testCollect2 = testCollect1
                == [ (1,[(1,'a'),(1,'c'),(1,'d')])
                   , (2,[(2,'b'),(2,'d')])
                   , (3,[(3,'d')])
                   ]
-}

-- |Add new values to an existing list of collections.
--  The list of collections is not extended, but each collection is
--  augmented with a further list of values from the supplied list,
--  each of which are related to the existing collection in some way.
--
--  NOTE: the basic pattern of @collect@ and @collectMore@ is similar,
--  and might be generalized into a common set of core functions.
--
collectMore :: (Eq b) => (a->b) -> [a] -> [(b,c)] -> [(b,(c,[a]))]
collectMore :: forall b a c.
Eq b =>
(a -> b) -> [a] -> [(b, c)] -> [(b, (c, [a]))]
collectMore = forall b a c.
(b -> b -> Bool) -> (a -> b) -> [a] -> [(b, c)] -> [(b, (c, [a]))]
collectMoreBy forall a. Eq a => a -> a -> Bool
(==)

collectMoreBy ::
    (b->b->Bool) -> (a->b) -> [a] -> [(b,c)] -> [(b,(c,[a]))]
collectMoreBy :: forall b a c.
(b -> b -> Bool) -> (a -> b) -> [a] -> [(b, c)] -> [(b, (c, [a]))]
collectMoreBy b -> b -> Bool
cmp a -> b
sel [a]
as [(b, c)]
cols =
    forall a b. (a -> b) -> [a] -> [b]
map forall b c a. (b, (c, [a])) -> (b, (c, [a]))
reverseMoreCollection forall a b. (a -> b) -> a -> b
$
    forall b a c.
(b -> b -> Bool)
-> (a -> b) -> [a] -> [(b, (c, [a]))] -> [(b, (c, [a]))]
collectMoreBy1 b -> b -> Bool
cmp a -> b
sel [a]
as (forall a b. (a -> b) -> [a] -> [b]
map (\ (b
b,c
cs) -> (b
b,(c
cs,[])) ) [(b, c)]
cols)

collectMoreBy1 ::
    (b->b->Bool) -> (a->b) -> [a] -> [(b,(c,[a]))] -> [(b,(c,[a]))]
collectMoreBy1 :: forall b a c.
(b -> b -> Bool)
-> (a -> b) -> [a] -> [(b, (c, [a]))] -> [(b, (c, [a]))]
collectMoreBy1 b -> b -> Bool
_   a -> b
_   []     [(b, (c, [a]))]
cols = [(b, (c, [a]))]
cols
collectMoreBy1 b -> b -> Bool
cmp a -> b
sel (a
a:[a]
as) [(b, (c, [a]))]
cols =
    forall b a c.
(b -> b -> Bool)
-> (a -> b) -> [a] -> [(b, (c, [a]))] -> [(b, (c, [a]))]
collectMoreBy1 b -> b -> Bool
cmp a -> b
sel [a]
as (forall b a c.
(b -> b -> Bool)
-> (a -> b) -> a -> [(b, (c, [a]))] -> [(b, (c, [a]))]
collectMoreBy2 b -> b -> Bool
cmp a -> b
sel a
a [(b, (c, [a]))]
cols)

collectMoreBy2 ::
    (b->b->Bool) -> (a->b) -> a -> [(b,(c,[a]))] -> [(b,(c,[a]))]
collectMoreBy2 :: forall b a c.
(b -> b -> Bool)
-> (a -> b) -> a -> [(b, (c, [a]))] -> [(b, (c, [a]))]
collectMoreBy2 b -> b -> Bool
_   a -> b
_   a
_ [] = []
collectMoreBy2 b -> b -> Bool
cmp a -> b
sel a
a (col :: (b, (c, [a]))
col@(b
k,(c
b,[a]
as)):[(b, (c, [a]))]
cols)
    | b -> b -> Bool
cmp (a -> b
sel a
a) b
k = (b
k,(c
b, a
aforall a. a -> [a] -> [a]
:[a]
as))forall a. a -> [a] -> [a]
:[(b, (c, [a]))]
cols
    | Bool
otherwise     = (b, (c, [a]))
colforall a. a -> [a] -> [a]
:forall b a c.
(b -> b -> Bool)
-> (a -> b) -> a -> [(b, (c, [a]))] -> [(b, (c, [a]))]
collectMoreBy2 b -> b -> Bool
cmp a -> b
sel a
a [(b, (c, [a]))]
cols

reverseMoreCollection :: (b,(c,[a])) -> (b,(c,[a]))
reverseMoreCollection :: forall b c a. (b, (c, [a])) -> (b, (c, [a]))
reverseMoreCollection (b
k,(c
c,[a]
as)) = (b
k,(c
c,forall a. [a] -> [a]
reverse [a]
as))

{-
-- Example/test:
testCollectMore1 =
    collectMore snd [(111,1),(112,1),(211,2),(311,3),(411,4)] testCollect1

testCollectMore2 :: Bool
testCollectMore2 = testCollectMore1
                == [ (1,([(1,'a'),(1,'c'),(1,'d')],[(111,1),(112,1)]))
                   , (2,([(2,'b'),(2,'d')],[(211,2)]))
                   , (3,([(3,'d')],[(311,3)]))
                   ]
-}

-- |Remove supplied element from a list using the supplied test
--  function, and return Just the element removed and the
--  remaining list, or Nothing if no element was matched for removal.
--
{-
remove :: (Eq a) => a -> [a] -> Maybe (a,[a])
remove = removeBy (==)

testRemove1  = remove 3 [1,2,3,4,5]
testRemove2  = testRemove1 == Just (3,[1,2,4,5])
testRemove3  = remove 3 [1,2,4,5]
testRemove4  = testRemove3 == Nothing
testRemove5  = remove 5 [1,2,4,5]
testRemove6  = testRemove5 == Just (5,[1,2,4])
testRemove7  = remove 1 [1,2,4]
testRemove8  = testRemove7 == Just (1,[2,4])
testRemove9  = remove 2 [2]
testRemove10 = testRemove9 == Just (2,[])

-}

removeBy :: (b->a->Bool) -> b -> [a] -> Maybe (a,[a])
removeBy :: forall b a. (b -> a -> Bool) -> b -> [a] -> Maybe (a, [a])
removeBy b -> a -> Bool
cmp b
a0 [a]
as = forall b a. (b -> a -> Bool) -> b -> [a] -> [a] -> Maybe (a, [a])
removeBy1 b -> a -> Bool
cmp b
a0 [a]
as []

removeBy1 :: (b->a->Bool) -> b -> [a] -> [a] -> Maybe (a,[a])
removeBy1 :: forall b a. (b -> a -> Bool) -> b -> [a] -> [a] -> Maybe (a, [a])
removeBy1 b -> a -> Bool
_   b
_  []     [a]
_     = forall a. Maybe a
Nothing
removeBy1 b -> a -> Bool
cmp b
a0 (a
a:[a]
as) [a]
sofar
    | b -> a -> Bool
cmp b
a0 a
a  = forall a. a -> Maybe a
Just (a
a,forall a. [a] -> [a] -> [a]
reverseTo [a]
sofar [a]
as)
    | Bool
otherwise = forall b a. (b -> a -> Bool) -> b -> [a] -> [a] -> Maybe (a, [a])
removeBy1 b -> a -> Bool
cmp b
a0 [a]
as (a
aforall a. a -> [a] -> [a]
:[a]
sofar)

-- |Reverse first argument, prepending the result to the second argument
--
reverseTo :: [a] -> [a] -> [a]
reverseTo :: forall a. [a] -> [a] -> [a]
reverseTo [a]
front [a]
back = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [a]
back [a]
front

-- |Remove each element from a list, returning a list of pairs,
--  each of which is the element removed and the list remaining.
--
removeEach :: [a] -> [(a,[a])]
removeEach :: forall a. [a] -> [(a, [a])]
removeEach [] = []
removeEach (a
a:[a]
as) = (a
a,[a]
as)forall a. a -> [a] -> [a]
:[ (a
a1,a
aforall a. a -> [a] -> [a]
:[a]
a1s) | (a
a1,[a]
a1s) <- forall a. [a] -> [(a, [a])]
removeEach [a]
as ]

{-
testRemoveEach1 = removeEach [1,2,3,4,5]
testRemoveEach2 = testRemoveEach1 ==
    [ (1,[2,3,4,5])
    , (2,[1,3,4,5])
    , (3,[1,2,4,5])
    , (4,[1,2,3,5])
    , (5,[1,2,3,4])
    ]
-}

-- |List differences between the members of two lists, where corresponding
--  elements may appear at arbitrary locations in the corresponding lists.
--
--  Elements are compared using the function 'cmp', which returns:
--  * Nothing  if the elements are completely unrelated
--  * Just []  if the elements are identical
--  * Just ds  if the elements are related but not identical, in which case
--             ds is a list of values describing differences between them.
--
--  Returns (ds,u1,u2), where:
--  ds is null if the related elements from each list are identical,
--  otherwise is a list of differences between the related elements.
--  u1 is a list of elements in a1 not related to elements in a2.
--  u2 is a list of elements in a2 not related to elements in a1.
--
listDifferences :: (a->a->Maybe [d]) -> [a] -> [a] -> ([d],[a],[a])
listDifferences :: forall a d. (a -> a -> Maybe [d]) -> [a] -> [a] -> ([d], [a], [a])
listDifferences a -> a -> Maybe [d]
_   []       [a]
a2s = ([],[],[a]
a2s)
listDifferences a -> a -> Maybe [d]
cmp (a
a1:[a]
a1t) [a]
a2s =
    case Maybe ([d], [a])
mcomp of
        Maybe ([d], [a])
Nothing       -> [d] -> [a] -> [a] -> [a] -> ([d], [a], [a])
morediffs [] [a
a1] [a]
a1t [a]
a2s
        Just ([d]
ds,[a]
a2t) -> [d] -> [a] -> [a] -> [a] -> ([d], [a], [a])
morediffs [d]
ds []   [a]
a1t [a]
a2t
    where
        -- mcomp finds identical match, if there is one, or
        -- the first element in a2s related to a1, or Nothing
        -- [choose was listToMaybe,
        --  but that didn't handle repeated properties well]
        mcomp :: Maybe ([d], [a])
mcomp = forall {a} {b}. [([a], b)] -> Maybe ([a], b)
choose forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a} {b}. (Maybe a, b) -> Maybe (a, b)
maybeResult [(Maybe [d], [a])]
comps
        comps :: [(Maybe [d], [a])]
comps = [ (a -> a -> Maybe [d]
cmp a
a1 a
a2,[a]
a2t) | (a
a2,[a]
a2t) <- forall a. [a] -> [(a, [a])]
removeEach [a]
a2s ]
        maybeResult :: (Maybe a, b) -> Maybe (a, b)
maybeResult (Maybe a
Nothing,b
_)   = forall a. Maybe a
Nothing
        maybeResult (Just a
ds,b
a2t) = forall a. a -> Maybe a
Just (a
ds,b
a2t)
        morediffs :: [d] -> [a] -> [a] -> [a] -> ([d], [a], [a])
morediffs [d]
xds [a]
xa1h [a]
xa1t [a]
xa2t  = ([d]
xds forall a. [a] -> [a] -> [a]
++ [d]
xds1, [a]
xa1h forall a. [a] -> [a] -> [a]
++ [a]
xa1r, [a]
xa2r)
            where
                ([d]
xds1,[a]
xa1r,[a]
xa2r) = forall a d. (a -> a -> Maybe [d]) -> [a] -> [a] -> ([d], [a], [a])
listDifferences a -> a -> Maybe [d]
cmp [a]
xa1t [a]
xa2t
        choose :: [([a], b)] -> Maybe ([a], b)
choose  []       = forall a. Maybe a
Nothing
        choose  ds :: [([a], b)]
ds@(([a], b)
d:[([a], b)]
_) = forall {a} {b}. ([a], b) -> [([a], b)] -> Maybe ([a], b)
choose1 ([a], b)
d [([a], b)]
ds
        choose1 :: ([a], b) -> [([a], b)] -> Maybe ([a], b)
choose1 ([a], b)
_ (d :: ([a], b)
d@([],b
_):[([a], b)]
_)  = forall a. a -> Maybe a
Just ([a], b)
d
        choose1 ([a], b)
d []            = forall a. a -> Maybe a
Just ([a], b)
d
        choose1 ([a], b)
d (([a], b)
_:[([a], b)]
ds)        = ([a], b) -> [([a], b)] -> Maybe ([a], b)
choose1 ([a], b)
d [([a], b)]
ds

{-
testcmp (l1,h1) (l2,h2)
    | (l1 >= h2) || (l2 >= h1) = Nothing
    | (l1 == l2) && (h1 == h2) = Just []
    | otherwise                = Just [((l1,h1),(l2,h2))]

testdiff1 = listDifferences testcmp
                [(12,15),(1,2),(3,4),(5,8),(10,11)]
                [(10,11),(0,1),(3,4),(6,9),(13,15)]
testdiff2 = testdiff1 == ([((12,15),(13,15)),((5,8),(6,9))],[(1,2)],[(0,1)])
-}

--------------------------------------------------------------------------------
--
--  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin,
--    2011, 2012, 2022 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
--
--------------------------------------------------------------------------------