1
{-# LANGUAGE CPP #-}
2
#if __GLASGOW_HASKELL__ >= 702
3
{-# LANGUAGE DeriveGeneric #-}
4
#endif
5
6
-- (c) 1999 - 2002 by Martin Erwig [see file COPYRIGHT]
7
-- | Tree-based implementation of 'Graph' and 'DynGraph'
8
--
9
--   You will probably have better performance using the
10
--   "Data.Graph.Inductive.PatriciaTree" implementation instead.
11
12
module Data.Graph.Inductive.Tree (Gr,UGr) where
13
14
import Data.Graph.Inductive.Graph
15
16
import           Control.Applicative (liftA2)
17
import           Data.List           (foldl', sort)
18
import           Data.Map            (Map)
19
import qualified Data.Map            as M
20
import           Data.Maybe          (fromMaybe)
21
22
#if MIN_VERSION_containers (0,4,2)
23
import Control.DeepSeq (NFData (..))
24
#endif
25
26
#if __GLASGOW_HASKELL__ >= 702
27
import GHC.Generics (Generic)
28
#endif
29
30
#if MIN_VERSION_base (4,8,0)
31
import Data.Bifunctor
32
#else
33
import Control.Arrow (first, second)
34
#endif
35
36
----------------------------------------------------------------------
37
-- GRAPH REPRESENTATION
38
----------------------------------------------------------------------
39
40
newtype Gr a b = Gr (GraphRep a b)
41
#if __GLASGOW_HASKELL__ >= 702
42
  deriving (Generic)
43
#endif
44
45
type GraphRep a b = Map Node (Context' a b)
46
type Context' a b = (Adj b,a,Adj b)
47
48
type UGr = Gr () ()
49
50
----------------------------------------------------------------------
51
-- CLASS INSTANCES
52
----------------------------------------------------------------------
53
54
instance (Eq a, Ord b) => Eq (Gr a b) where
55
  (Gr g1) == (Gr g2) = fmap sortAdj g1 == fmap sortAdj g2
56
    where
57
      sortAdj (p,n,s) = (sort p,n,sort s)
58
59
instance (Show a, Show b) => Show (Gr a b) where
60
  showsPrec d g = showParen (d > 10) $
61
                    showString "mkGraph "
62
                    . shows (labNodes g)
63
                    . showString " "
64
                    . shows (labEdges g)
65
66
instance (Read a, Read b) => Read (Gr a b) where
67
  readsPrec p = readParen (p > 10) $ \ r -> do
68
    ("mkGraph", s) <- lex r
69
    (ns,t) <- reads s
70
    (es,u) <- reads t
71
    return (mkGraph ns es, u)
72
73
-- Graph
74
--
75
instance Graph Gr where
76
  empty             = Gr M.empty
77
78
  isEmpty (Gr g)    = M.null g
79
80
  match v gr@(Gr g) = maybe (Nothing, gr)
81
                            (first Just . uncurry (cleanSplit v))
82
                      . (\(m,g') -> fmap (flip (,) g') m)
83
                      $ M.updateLookupWithKey (const (const Nothing)) v g
84
85
  mkGraph vs es     = insEdges es
86
                      . Gr
87
                      . M.fromList
88
                      . map (second (\l -> ([],l,[])))
89
                      $ vs
90
91
  labNodes (Gr g)   = map (\(v,(_,l,_))->(v,l)) (M.toList g)
92
93
  matchAny (Gr g)   = maybe (error "Match Exception, Empty Graph")
94
                            (uncurry (uncurry cleanSplit))
95
                            (M.minViewWithKey g)
96
97
  noNodes   (Gr g)  = M.size g
98
99
  nodeRange (Gr g)  = fromMaybe (error "nodeRange of empty graph")
100
                      $ liftA2 (,) (ix (M.minViewWithKey g))
101
                                   (ix (M.maxViewWithKey g))
102
    where
103
      ix            = fmap (fst . fst)
104
105
  labEdges  (Gr g)  = concatMap (\(v,(_,_,s))->map (\(l,w)->(v,w,l)) s) (M.toList g)
106
107
-- After a Node (with its corresponding Context') are split out of a
108
-- GraphRep, clean up the remainders.
109
cleanSplit :: Node -> Context' a b -> GraphRep a b
110
              -> (Context a b, Gr a b)
111
cleanSplit v (p,l,s) g = (c, Gr g')
112
  where
113
    -- Note: loops are kept only in successor list
114
    c = (p', v, l, s)
115
    p' = rmLoops p
116
    s' = rmLoops s
117
    rmLoops = filter ((/=v) . snd)
118
119
    g' = updAdj s' (clearPred v) . updAdj p' (clearSucc v) $ g
120
121
-- DynGraph
122
--
123
instance DynGraph Gr where
124
  (p,v,l,s) & (Gr g) = Gr
125
                       . updAdj p (addSucc v)
126
                       . updAdj s (addPred v)
127
                       $ M.alter addCntxt v g
128
    where
129
      addCntxt = maybe (Just cntxt')
130
                       (const (error ("Node Exception, Node: "++show v)))
131
      cntxt' = (p,l,s)
132
133
#if MIN_VERSION_containers (0,4,2)
134
instance (NFData a, NFData b) => NFData (Gr a b) where
135
  rnf (Gr g) = rnf g
136
#endif
137
138
instance Functor (Gr a) where
139
  fmap = emap
140
141
#if MIN_VERSION_base (4,8,0)
142
instance Bifunctor Gr where
143
  bimap = nemap
144
145
  first = nmap
146
147
  second = emap
148
#endif
149
150
----------------------------------------------------------------------
151
-- UTILITIES
152
----------------------------------------------------------------------
153
154
addSucc :: Node -> b -> Context' a b -> Context' a b
155
addSucc v l (p,l',s) = (p,l',(l,v):s)
156
157
addPred :: Node -> b -> Context' a b -> Context' a b
158
addPred v l (p,l',s) = ((l,v):p,l',s)
159
160
clearSucc :: Node -> b -> Context' a b -> Context' a b
161
clearSucc v _ (p,l,s) = (p,l,filter ((/=v).snd) s)
162
163
clearPred :: Node -> b -> Context' a b -> Context' a b
164
clearPred v _ (p,l,s) = (filter ((/=v).snd) p,l,s)
165
166
updAdj :: Adj b -> (b -> Context' a b -> Context' a b) -> GraphRep a b -> GraphRep a b
167
updAdj adj f g = foldl' (\g' (l,v) -> M.adjust (f l) v g') g adj