PatriciaTree.icl 6.95 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
// |An efficient implementation of `Data.Graph.Inductive.Graph.Graph`
// using big-endian patricia tree (i.e. "Data.IntMap").
//
// This module provides the following specialised functions to gain
// more performance, using GHC`s RULES pragma:
//
// * `Data.Graph.Inductive.Graph.insNode`
//
// * `Data.Graph.Inductive.Graph.insEdge`
//
// * `Data.Graph.Inductive.Graph.gmap`
//
// * `Data.Graph.Inductive.Graph.nmap`
//
// * `Data.Graph.Inductive.Graph.emap`

implementation module Data.Graph.Inductive.PatriciaTree
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
18 19 20

import Data.Graph.Inductive.Graph

21
from Control.Monad import class Monad (..), >>=, instance Monad []
22
from           Control.Applicative import liftA2, class Applicative (..)
23 24 25
import Data.Functor
from           Data.IntMap.Strict         import :: IntMap, instance == (IntMap a), instance Functor IntMap
import qualified Data.IntMap.Strict       as IM
26
from Data.List import instance Functor [], instance Applicative []
27 28 29 30
import qualified Data.List as DL
import StdList, StdTuple, StdMisc, StdOrdList
import StdClass, StdFunc, StdOverloaded
import Data.Maybe
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
31

32
import Control.Arrow
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
33

34 35 36
//--------------------------------------------------------------------
// GRAPH REPRESENTATION
//--------------------------------------------------------------------
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
37

38
:: Gr a b = Gr (GraphRep a b)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
39

40 41
:: GraphRep a b :== IntMap (Context` a b)
:: Context` a b :== (IntMap [b], a, IntMap [b])
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
42

43
:: UGr :== Gr () ()
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
44

45 46 47
//--------------------------------------------------------------------
// CLASS INSTANCES
//--------------------------------------------------------------------
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
48

49 50 51 52 53 54
// TODO
//instance == (Gr a b) | == a & == b & Ord a & Ord b where
  //(==) (Gr g1) (Gr g2) = 'IM'.map sortAdj g1 == 'IM'.map sortAdj g2
    //where
      //sortAdj :: (Context` a b) -> Context` a b | == a & == b & Ord a & Ord b
      //sortAdj (p,n,s) = ('IM'.map sort p,n,'IM'.map sort s)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
55

56 57 58 59 60 61
//instance (Show a, Show b) => Show (Gr a b) where
  //showsPrec d g = showParen (d > 10) $
                    //showString "mkGraph "
                    //. shows (labNodes g)
                    //. showString " "
                    //. shows (labEdges g)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
62 63

instance Graph Gr where
64
  emptyGraph           = Gr 'IM'.empty
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
65

66
  isEmptyGraph (Gr g)  = 'IM'.null g
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
67

68
  match x y          = matchGr x y
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
69

70 71 72 73 74
  mkGraph vs es   = (insEdges es
                    o Gr
                    o 'IM'.fromList
                    o 'DL'.map (second (\l -> ('IM'.empty,l,'IM'.empty))))
                    vs
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
75

76 77
  labNodes (Gr g) = [ (node, label)
                          \\ (node, (_, label, _)) <- 'IM'.toList g ]
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
78

79
  noNodes   (Gr g) = 'IM'.size g
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
80

81 82 83 84 85
  nodeRange (Gr g) = fromMaybe (abort "nodeRange of empty graph")
                     (liftA2 (\x y -> (x, y)) (ix ('IM'.minViewWithKey g))
                                  (ix ('IM'.maxViewWithKey g)))
    where
      ix = fmap (fst o fst)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
86

87 88 89 90
  labEdges (Gr g) =                       'IM'.toList g
                >>= \(node, (_, _, s)) -> 'IM'.toList s
                >>= \(next, labels)    -> labels
                >>= \label             -> pure (node, next, label)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
91

92
  matchAny g = defMatchAny g
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
93

94 95 96 97 98 99
instance DynGraph Gr where
  <&> (p, v, l, s) (Gr g)
        #! g1 = 'IM'.insert v (fromAdj p, l, fromAdj s) g
        #! g2 = addSucc g1 v p
        #! g3 = addPred g2 v s
        = Gr g3
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
100

101
matchGr :: Node (Gr a b) -> Decomp Gr a b
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
102
matchGr node (Gr g)
103
    = case 'IM'.lookup node g of
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
104
        Nothing
105
            = (Nothing, Gr g)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
106 107

        Just (p, label, s)
108 109 110 111 112 113 114 115 116 117 118 119 120
            #! g1 = 'IM'.delete node g
            #! p` = 'IM'.delete node p
            #! s` = 'IM'.delete node s
            #! g2 = clearPred g1 node ('IM'.keys s`)
            #! g3 = clearSucc g2 node ('IM'.keys p`)
            = (Just (toAdj p`, node, label, toAdj s), Gr g3)

//--------------------------------------------------------------------
// OVERRIDING FUNCTIONS
//--------------------------------------------------------------------

fastInsNode :: (LNode a) !(Gr a b) -> Gr a b
fastInsNode (v, l) (Gr g) = Gr g`
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
121
  where
122
    g` = 'IM'.insert v ('IM'.empty, l, 'IM'.empty) g
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
123

124 125 126 127 128
fastInsEdge :: (LEdge b) !(Gr a b) -> Gr a b
fastInsEdge (v, w, l) (Gr g)
  #! g1 = 'IM'.adjust addSucc` v g
  #! g2 = 'IM'.adjust addPred` w g1
  = Gr g2
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
129
  where
130 131
  addSucc` (ps, l`, ss) = (ps, l`, 'IM'.insertWith addLists w [l] ss)
  addPred` (ps, l`, ss) = ('IM'.insertWith addLists v [l] ps, l`, ss)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
132

133 134
fastGMap :: ((Context a b) -> Context c d) (Gr a b) -> Gr c d
fastGMap f (Gr g) = Gr ('IM'.mapWithKey f` g)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
135
  where
136 137 138 139 140
    //f` :: Node (Context` a b) -> Context` c d
    f` n c = ((\x -> (fromContext o f) o x) o toContext) n c

fastNMap :: (a -> c) (Gr a b) -> Gr c b
fastNMap f (Gr g) = Gr ('IM'.map f` g)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
141
  where
142 143 144 145 146
    //f` :: (Context` a b) -> Context` c b
    f` (ps, a, ss) = (ps, f a, ss)

fastEMap :: (b -> c) (Gr a b) -> Gr a c
fastEMap f (Gr g) = Gr ('IM'.map f` g)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
147
  where
148 149 150 151 152
    //f` :: (Context` a b) -> Context` a c
    f` (ps, a, ss) = ('IM'.map ('DL'.map f) ps, a, 'IM'.map ('DL'.map f) ss)

fastNEMap :: (a -> c) (b -> d) (Gr a b) -> Gr c d
fastNEMap fn fe (Gr g) = Gr ('IM'.map f g)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
153
  where
154 155
    //f :: (Context` a b) -> Context` c d
    f (ps, a, ss) = ('IM'.map ('DL'.map fe) ps, fn a, 'IM'.map ('DL'.map fe) ss)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
156

157 158 159
//--------------------------------------------------------------------
// UTILITIES
//--------------------------------------------------------------------
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
160

161 162
toAdj :: (IntMap [b]) -> Adj b
toAdj m = ('DL'.concatMap expand o 'IM'.toList) m
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
163
  where
164
    expand (n,ls) = 'DL'.map (flip (\x y -> (x,y)) n) ls
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
165

166 167
fromAdj :: (Adj b) -> IntMap [b]
fromAdj a = ('IM'.fromListWith addLists o 'DL'.map (second pure o swap)) a
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
168

169
toContext :: Node (Context` a b) -> Context a b
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
170 171
toContext v (ps, a, ss) = (toAdj ps, v, a, toAdj ss)

172
fromContext :: (Context a b) -> Context` a b
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
173 174 175 176 177
fromContext (ps, _, a, ss) = (fromAdj ps, a, fromAdj ss)

swap :: (a, b) -> (b, a)
swap (a, b) = (b, a)

178 179 180 181 182 183 184
// A version of @++@ where order isn`t important, so @xs ++ [x]@
// becomes @x:xs@.  Used when we have to have a function of type @[a]
// -> [a] -> [a]@ but one of the lists is just going to be a single
// element (and it isn`t possible to tell which).
addLists :: [a] [a] -> [a]
addLists [a] as  = [a : as]
addLists as  [a] = [a : as]
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
185 186
addLists xs  ys  = xs ++ ys

187
addSucc :: (GraphRep a b) Node [(b, Node)] -> GraphRep a b
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
188
addSucc g _ []              = g
189
addSucc g v [(l, p) : rest] = addSucc g` v rest
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
190
    where
191 192
      g` = 'IM'.adjust f p g
      f (ps, l`, ss) = (ps, l`, 'IM'.insertWith addLists v [l] ss)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
193 194


195
addPred :: (GraphRep a b) Node [(b, Node)] -> GraphRep a b
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
196
addPred g _ []              = g
197
addPred g v [(l, s) : rest] = addPred g` v rest
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
198
  where
199 200
    g` = 'IM'.adjust f s g
    f (ps, l`, ss) = ('IM'.insertWith addLists v [l] ps, l`, ss)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
201 202


203
clearSucc :: (GraphRep a b) Node [Node] -> GraphRep a b
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
204
clearSucc g _ []       = g
205
clearSucc g v [p:rest] = clearSucc g` v rest
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
206
  where
207 208
    g` = 'IM'.adjust f p g
    f (ps, l, ss) = (ps, l, 'IM'.delete v ss)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
209 210


211
clearPred :: (GraphRep a b) Node [Node] -> GraphRep a b
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
212
clearPred g _ []       = g
213
clearPred g v [s:rest] = clearPred g` v rest
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
214
  where
215 216
    g` = 'IM'.adjust f s g
    f (ps, l, ss) = ('IM'.delete v ps, l, ss)