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

--------------------------------------------------------------------------------
--  See end of this file for licence information.
--------------------------------------------------------------------------------
-- |
--  Module      :  GraphMem
--  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin,
--                 2011, 2012, 2014, 2016, 2018 Douglas Burke
--  License     :  GPL V2
--
--  Maintainer  :  Douglas Burke
--  Stability   :  experimental
--  Portability :  CPP, FlexibleInstances, MultiParamTypeClasses
--
--  This module defines a simple memory-based graph instance.
--
--------------------------------------------------------------------------------

------------------------------------------------------------
-- Simple labelled directed graph value
------------------------------------------------------------

module Swish.GraphMem
    ( GraphMem(..)
    , LabelMem(..)
    , setArcs, getArcs, addGraphs, delete, extract, labels
    , labelIsVar, labelHash
      -- For debug/test:
    , matchGraphMem
    ) where

import qualified Data.Set as S

import Swish.GraphClass
import Swish.GraphMatch

import Data.Hashable (Hashable(..))
#if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710)
import Data.Monoid (Monoid(..))
#endif
import Data.Ord (comparing)

#if !(MIN_VERSION_base(4, 11, 0))
import Data.Semigroup
#endif

-- | Simple memory-based graph type. 

data GraphMem lb = GraphMem { forall lb. GraphMem lb -> ArcSet lb
arcs :: ArcSet lb }

instance LDGraph GraphMem lb where
    emptyGraph :: GraphMem lb
emptyGraph   = ArcSet lb -> GraphMem lb
forall lb. ArcSet lb -> GraphMem lb
GraphMem ArcSet lb
forall a. Set a
S.empty
    getArcs :: GraphMem lb -> ArcSet lb
getArcs      = GraphMem lb -> ArcSet lb
forall lb. GraphMem lb -> ArcSet lb
arcs
    setArcs :: GraphMem lb -> ArcSet lb -> GraphMem lb
setArcs GraphMem lb
g ArcSet lb
as = GraphMem lb
g { arcs=as }

instance (Label lb) => Eq (GraphMem lb) where
    == :: GraphMem lb -> GraphMem lb -> Bool
(==) = GraphMem lb -> GraphMem lb -> Bool
forall lb. Label lb => GraphMem lb -> GraphMem lb -> Bool
graphEq

instance (Label lb) => Ord (GraphMem lb) where
    compare :: GraphMem lb -> GraphMem lb -> Ordering
compare = (GraphMem lb -> ArcSet lb)
-> GraphMem lb -> GraphMem lb -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing GraphMem lb -> ArcSet lb
forall (lg :: * -> *) lb. LDGraph lg lb => lg lb -> ArcSet lb
getArcs

instance (Label lb) => Show (GraphMem lb) where
    show :: GraphMem lb -> String
show = GraphMem lb -> String
forall lb. Label lb => GraphMem lb -> String
graphShow

instance (Label lb) => Semigroup (GraphMem lb) where
    <> :: GraphMem lb -> GraphMem lb -> GraphMem lb
(<>) = GraphMem lb -> GraphMem lb -> GraphMem lb
forall (lg :: * -> *) lb.
(LDGraph lg lb, Ord lb) =>
lg lb -> lg lb -> lg lb
addGraphs

instance (Label lb) => Monoid (GraphMem lb) where
    mempty :: GraphMem lb
mempty  = GraphMem lb
forall (lg :: * -> *) lb. LDGraph lg lb => lg lb
emptyGraph
#if !(MIN_VERSION_base(4, 11, 0))
    mappend = (<>)
#endif

graphShow   :: (Label lb) => GraphMem lb -> String
graphShow :: forall lb. Label lb => GraphMem lb -> String
graphShow GraphMem lb
g = String
"Graph:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Arc lb -> ShowS) -> String -> Set (Arc lb) -> String
forall a b. (a -> b -> b) -> b -> Set a -> b
S.foldr (String -> ShowS
forall a. [a] -> [a] -> [a]
(++) (String -> ShowS) -> (Arc lb -> String) -> Arc lb -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"\n    " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (Arc lb -> String) -> Arc lb -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arc lb -> String
forall a. Show a => a -> String
show) String
"" (GraphMem lb -> Set (Arc lb)
forall lb. GraphMem lb -> ArcSet lb
arcs GraphMem lb
g)

-- |  Return Boolean graph equality

graphEq :: (Label lb) => GraphMem lb -> GraphMem lb -> Bool
graphEq :: forall lb. Label lb => GraphMem lb -> GraphMem lb -> Bool
graphEq GraphMem lb
g1 GraphMem lb
g2 = (Bool, LabelMap (ScopedLabel lb)) -> Bool
forall a b. (a, b) -> a
fst ( GraphMem lb -> GraphMem lb -> (Bool, LabelMap (ScopedLabel lb))
forall lb.
Label lb =>
GraphMem lb -> GraphMem lb -> (Bool, LabelMap (ScopedLabel lb))
matchGraphMem GraphMem lb
g1 GraphMem lb
g2 )

-- | GraphMem matching function accepting GraphMem value and returning
--  node map if successful
--
matchGraphMem ::
  (Label lb)
  => GraphMem lb 
  -> GraphMem lb
  -> (Bool,LabelMap (ScopedLabel lb))
  -- ^ if the first element is @True@ then the second value is a label
  --   map that maps each label to an equivalence-class identifier,
  --   otherwise `emptyMap`.
  --
matchGraphMem :: forall lb.
Label lb =>
GraphMem lb -> GraphMem lb -> (Bool, LabelMap (ScopedLabel lb))
matchGraphMem GraphMem lb
g1 GraphMem lb
g2 =
    let
        gs1 :: ArcSet lb
gs1     = GraphMem lb -> ArcSet lb
forall lb. GraphMem lb -> ArcSet lb
arcs GraphMem lb
g1
        gs2 :: ArcSet lb
gs2     = GraphMem lb -> ArcSet lb
forall lb. GraphMem lb -> ArcSet lb
arcs GraphMem lb
g2
        matchable :: a -> a -> Bool
matchable a
l1 a
l2
            | a -> Bool
forall lb. Label lb => lb -> Bool
labelIsVar a
l1 Bool -> Bool -> Bool
&& a -> Bool
forall lb. Label lb => lb -> Bool
labelIsVar a
l2 = Bool
True
            | a -> Bool
forall lb. Label lb => lb -> Bool
labelIsVar a
l1 Bool -> Bool -> Bool
|| a -> Bool
forall lb. Label lb => lb -> Bool
labelIsVar a
l2 = Bool
False
            | Bool
otherwise                      = a
l1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
l2
    in
        (lb -> lb -> Bool)
-> ArcSet lb -> ArcSet lb -> (Bool, LabelMap (ScopedLabel lb))
forall lb.
Label lb =>
(lb -> lb -> Bool)
-> ArcSet lb -> ArcSet lb -> (Bool, LabelMap (ScopedLabel lb))
graphMatch lb -> lb -> Bool
forall {a}. Label a => a -> a -> Bool
matchable ArcSet lb
gs1 ArcSet lb
gs2

{-
-- |  Return bijection between two graphs, or empty list
graphBiject :: (Label lb) => GraphMem lb -> GraphMem lb -> [(lb,lb)]
graphBiject g1 g2 = if null lmap then [] else zip (sortedls g1) (sortedls g2)
    where
        lmap        = graphMatch g1 g2
        sortedls g  = map snd $
                      (sortBy indexComp) $
                      equivalenceClasses (graphLabels $ arcs g) lmap
        classComp ec1 ec2 = indexComp (classIndexVal ec1) (classIndexVal ec2)
        indexComp (g1,v1) (g2,v2)
            | g1 == g2  = compare v1 v2
            | otherwise = compare g1 g2
-}

-- |  Minimal graph label value - for testing

data LabelMem
    = LF String
    | LV String

instance Hashable LabelMem where
  hashWithSalt :: Int -> LabelMem -> Int
hashWithSalt Int
salt (LF String
l) = Int
salt Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
1::Int) Int -> String -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` String
l
  hashWithSalt Int
salt (LV String
l) = Int
salt Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
2::Int) Int -> String -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` String
l
#if !MIN_VERSION_hashable(1,2,0)
  hash (LF l) = 1 `hashWithSalt` l
  hash (LV l) = 2 `hashWithSalt` l
#endif

instance Label LabelMem where
    labelIsVar :: LabelMem -> Bool
labelIsVar (LV String
_)   = Bool
True
    labelIsVar LabelMem
_        = Bool
False
    getLocal :: LabelMem -> String
getLocal   (LV String
loc) = String
loc
    getLocal   LabelMem
lab      = ShowS
forall a. HasCallStack => String -> a
error String
"getLocal of non-variable label: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ LabelMem -> String
forall a. Show a => a -> String
show LabelMem
lab
    makeLabel :: String -> LabelMem
makeLabel           = String -> LabelMem
LV 
    labelHash :: Int -> LabelMem -> Int
labelHash = Int -> LabelMem -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt

instance Eq LabelMem where
    (LF String
l1) == :: LabelMem -> LabelMem -> Bool
== (LF String
l2)  = String
l1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
l2
    (LV String
l1) == (LV String
l2)  = String
l1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
l2
    LabelMem
_ == LabelMem
_              = Bool
False

instance Ord LabelMem where
    (LF String
l1) compare :: LabelMem -> LabelMem -> Ordering
`compare` (LF String
l2) = String
l1 String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` String
l2
    (LV String
l1) `compare` (LV String
l2) = String
l1 String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` String
l2
    (LF String
_)  `compare` LabelMem
_       = Ordering
LT
    LabelMem
_       `compare` (LF String
_)  = Ordering
GT

instance Show LabelMem where
    show :: LabelMem -> String
show (LF String
l1)        = Char
'!' Char -> ShowS
forall a. a -> [a] -> [a]
: String
l1
    show (LV String
l2)        = Char
'?' Char -> ShowS
forall a. a -> [a] -> [a]
: String
l2

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