In Haskell's Functional Graph Library (FGL), most of the graph algorithms depend on the 'match' function, which, given a Node n and a Graph g, returns c & g', where c is the Context of the n, and g' is the rest of the graph (which contains no references to n).
The only way I can see of doing this is be examining each of the contexts in g and removing any edges which refer to n and adding them to the context c. This would take linear time, I believe.
Martin Erwig, who wrote the library, suggests in this paper that this transformation can be done in constant or at least sub-linear time. Can anyone explain to me how this is accomplished?
match is defined in the Graph typeclass, so the implementation of that function depends on the datatype that implements the typeclass.
The package comes with two implementations, one using Patricia trees, one using regular trees. You can view the source for either yourself.
For example, the Patricia tree implementation:
import Data.Graph.Inductive.Graph
import Data.IntMap (IntMap)
import qualified Data.IntMap as IM
import Data.List
import Data.Maybe
import Control.Arrow(second)
newtype Gr a b = Gr (GraphRep a b)
type GraphRep a b = IntMap (Context' a b)
type Context' a b = (IntMap [b], a, IntMap [b])
type UGr = Gr () ()
instance Graph Gr where
-- ...
match = matchGr
-- ...
matchGr :: Node -> Gr a b -> Decomp Gr a b
matchGr node (Gr g)
= case IM.lookup node g of
Nothing
-> (Nothing, Gr g)
Just (p, label, s)
-> let !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')
in
(Just (toAdj p', node, label, toAdj s), Gr g3)
lookup and delete on IntMaps have O(min(n,W)) runtime, which is effectively constant on a given machine with a set integer width (W).
So that just leaves clearPred, clearSucc, and toAdj:
clearSucc :: GraphRep a b -> Node -> [Node] -> GraphRep a b
clearSucc g _ [] = g
clearSucc g v (p:rest) = clearSucc g' v rest
where
g' = IM.adjust f p g
f (ps, l, ss) = (ps, l, IM.delete v ss)
clearPred :: GraphRep a b -> Node -> [Node] -> GraphRep a b
clearPred g _ [] = g
clearPred g v (s:rest) = clearPred g' v rest
where
g' = IM.adjust f s g
f (ps, l, ss) = (IM.delete v ps, l, ss)
adjust is also O(min(n,W)), so we don't need to worry about that. Both clearSucc and clearPred recurse through each element in the adjacency list, though, so that's O(degree) combined.
toAdj :: IntMap [b] -> Adj b
toAdj = concatMap expand . IM.toList
where
expand (n,ls) = map (flip (,) n) ls
toAdj creates a new edge list, which is O(max(|V|,|E|)), but this is constructed lazily, so we don't need to worry about this unless it's used.
Related
Using the function mapEither for multiset's I can turn a MultiSet into a pair of two multisets. When f is returning Left the element is inserted into the first Multiset of the pair, and if f is returning Right the element is inserted into the second MultiSet of the pair.
How can I insert the same element into both MultiSets at the same time, as if f were returning Right and Left at the same time?
f:: LocalType -> Either LocalType LocalType
f (Sometype lt) = Left lt -- And Right lt
f lt = Left lt
parRule :: (MultiSet LocalType) -> (MultiSet LocalType)
parRule sequent = do
let list = MultiSet.mapEither f sequent
For reference, I use Data.Multiset package, https://hackage.haskell.org/package/multiset-0.3.4.3/docs/Data-MultiSet.html.
You can use a type like These to capture the ability to return both. You can then use toAscOccurList and fromOccurList (or fromAscOccurList if your function is monotonic) to compute the new MultiSet.
You could use These as Daniel Wagner suggests, but I would use a slightly different function to start with, which seems like a slightly better match to the library API. Furthermore, I would recommend a different implementation strategy for performance.
data SP a b = SP !a !b
toPair :: SP a b -> (a, b)
toPair (SP a b) = (a, b)
mapPairOcc :: (Ord b, Ord c) => (a -> Occur -> ((b, Occur), (c, Occur))) -> MultiSet a -> (MultiSet b, MultiSet c)
mapPairOcc f = toPair . mapPairOcc' f
mapPairOcc' :: (Ord b, Ord c) => (a -> Occur -> ((b, Occur), (c, Occur))) -> MultiSet a -> SP (MultiSet b) (MultiSet c)
mapPairOcc' f = foldl' go (SP empty empty) . toAscOccurList
where
go (SP bs cs) a
| ((b, bn), (c, cn)) <- f a
= SP (insertMany b bn bs) (insertMany c cn cs)
When you know that f is strictly monotone in the sense that
a < a' ==> fst (f a) < fst (f a') /\ snd (f a) < snd (f a')
it's possible to do better, building the results in O(n) time. The best way to do this seems to be to use Data.Map internals. I'll reuse the SP type from above.
import Data.Map.Lazy (Map)
import Data.MultiSet (MultiSet, Occur)
import qualified Data.MultiSet as MS
import qualified Data.Map.Internal as M
import Control.Monad (guard)
-- | Map over the keys and values in a map, producing
-- two maps with new keys and values. The passed function
-- must be strictly monotone in the keys in the sense
-- described above.
mapMaybeWithKey2Mono :: (k -> a -> (Maybe (l,b), Maybe (m,c))) -> Map k a -> (Map l b, Map m c)
mapMaybeWithKey2Mono f = toPair . mapMaybeWithKey2Mono' f
mapMaybeWithKey2Mono' :: (k -> a -> (Maybe (l,b), Maybe (m,c))) -> Map k a -> SP (Map l b) (Map m c)
mapMaybeWithKey2Mono' _ M.Tip = SP M.Tip M.Tip
mapMaybeWithKey2Mono' f (M.Bin _ kx x l r)
| (fl, fr) <- f kx x
= SP (groink fl mfl1 mfr1) (groink fr mfl2 mfr2)
where
groink :: Maybe (q, x) -> Map q x -> Map q x -> Map q x
groink m n o = case m of
Just (k', y) -> M.link k' y n o
Nothing -> M.link2 n o
SP mfl1 mfl2 = mapMaybeWithKey2Mono' f l
SP mfr1 mfr2 = mapMaybeWithKey2Mono' f r
Using this new general Map function, we can define the function we want on multisets:
mapPairAscOcc :: (a -> Occur -> ((b, Occur), (c, Occur))) -> MultiSet a -> (MultiSet b, MultiSet c)
mapPairAscOcc f m
| (p, q) <- mapMaybeWithKey2Mono go . MS.toMap $ m
= (MS.fromOccurMap p, MS.fromOccurMap q)
where
-- a -> Occur -> (Maybe (b, Occur), Maybe (c, Occur))
go a aocc
| ((b, bocc), (c, cocc)) <- f a aocc
= ( (b, bocc) <$ guard (bocc > 0)
, (c, cocc) <$ guard (cocc > 0) )
I took the function mapEither from the Data.MultiSet and modified it such that it supports These type.
-- | /O(n)/. Map and separate the 'This' and 'That' or 'These' results
-- modified function of mapEither to map both cases in case f return These
-- code of mapEither found in source code,
mapThese :: (Ord b, Ord c) => (a -> These b c) -> MultiSet a -> (MultiSet b, MultiSet c)
mapThese f = (\(ls,rs) -> (MultiSet.fromOccurList ls, MultiSet.fromOccurList rs)) . mapThese' . MultiSet.toOccurList
where mapThese' [] = ([],[])
mapThese' ((x,n):xs) = case f x of
This l -> let (ls,rs) = mapThese' xs in ((l,n):ls, rs)
That r -> let (ls,rs) = mapThese' xs in (ls, (r,n):rs)
These u i -> let (ls,rs) = mapThese' xs in ((u,n):ls, (i,n):rs)
In the case f returns These, both MultiSet's have an added element.
I really like the repmin problem:
Write down repmin :: Tree Int -> Tree Int, which replaces all the numbers in the tree by their minimum in a single pass.
If I were writing something like this in python, I would go for passing values by their reference (let's say one-element lists instead of numbers is good enough):
def repmin(tree, wrapped_min_link=None):
x, subforest = tree
if wrapped_min_link is None:
wrapped_min_link = [x]
else:
[m] = wrapped_min_link
wrapped_min_link = [min(m, x)]
n = len(subforest)
subforest_min = [None] * n
for i in range(n):
if subforest[i]:
subforest_min[i] = repmin(subforest[i], wrapped_min_link)
return (wrapped_min_link, subforest_min)
It seems to me like a fitting way to wrap one's head around the knot-tying solution in Haskell (I wrote this one for rose trees from Data.Tree):
copyRose :: Tree Int -> Int -> (Tree Int, Int)
copyRose (Node x []) m = (Node m [], x)
copyRose (Node x fo) m =
let
unzipIdMinimum =
foldr (\ ~(a, b) ~(as, bmin) -> (a:as, b `min` bmin)) ([], maxBound :: Int)
(fo', y) = unzipIdMinimum . map (flip copyRose m) $ fo
in (Node m fo', x `min` y)
repmin :: Tree Int -> Tree Int
repmin = (loop . uncurry) copyRose
Yet, I reckon the solutions to work very differently. Here is my understanding of the latter one:
Let us rewrite loop for (->) a bit:
loop f b = let cd = f (b, snd cd) in fst cd
I reckon it to be loop for (->)'s workalike as snd gives the same degree of laziness as pattern-matching within let.
So, when repmin traverses through the tree, it is:
Building up the minimum in the tree to be returned as the second element of the pair.
Leaves snd $ copyRose (tree, m) behind in every node.
Thus, when the traversal comes to an end, the programme knows the value of snd $ copyRose (tree, m) (that is, the minimum in the tree) and is able to show it whenever some node of the tree is being computed.
Do I understand repmin in Haskell correctly?
This is more an extended comment than an answer, but I don't really think of your implementation as single-pass. It looks like it traverses the tree once, producing a new, lazily-generated, tree and the global minimum, but it actually produces a lazily generated tree and an enormous tree of thunks that will eventually calculate the minimum. To avoid this, you can get closer to the Python code by generating the tree eagerly, keeping track of the minimum as you go.
You'll note that I've generalized the type from Int to an arbitrary Ord type. You'll also note that I've used to different type variables to refer to the type of elements in the given tree and the type of the minimum passed in to generate a new tree—this lets the type system tell me if I mix them up.
repmin :: Tree a -> Tree a
repmin = (loop . uncurry) copyRose
copyRose :: Ord a => Tree a -> b -> (Tree b, a)
copyRose (Node x ts) final_min
| (ts', m) <- copyForest x ts final_min
= (Node final_min ts', m)
copyForest :: Ord a => a -> [Tree a] -> b -> ([Tree b], a)
copyForest !m [] _final_min = ([], m)
copyForest !m (t : ts) final_min
| (t', m') <- copyTree m t final_min
, (ts', m'') <- copyForest m' ts final_min
= (t' : ts', m'')
copyTree :: Ord a => a -> Tree a -> b -> (Tree b, a)
copyTree !m (Node x ts) final_min
| (ts', m') <- copyForest (min m x) ts final_min
= (Node final_min ts', m')
Exercise: rewrite this in monadic style using ReaderT to pass the global minimum and State to keep track of the minimum so far.
I am currently doing an assigment for a class in which I have to implement a function which checks if an element is in a tree.
It is supposed to return Nothing when the element is not in the tree and Just (depth at which it was found) when it is.
An example:
sample1
##1
#3 2
###7 5 6 4
- contains 6 sample1 returns Just 2
- contains 1 sample1 returns Just 0
- contains 2 sample1 returns Just 1
- contains 8 sample1 returns Nothing
Here is what we are given:
Heap functional data structure:
module Fdata.Heap where
-- A signature for min-heaps
data Heap e t = Heap {
empty :: t e,
insert :: e -> t e -> t e,
findMin :: t e -> Maybe e,
deleteMin :: t e -> Maybe (t e),
merge :: t e -> t e -> t e,
contains :: e -> t e -> Maybe Int
}
An implementation of self-adjusting heaps:
import Fdata.Heap
import Fdata.Tree
-- An implementation of self-adjusting heaps
heap :: (Eq e, Ord e) => Heap e Tree
heap = Heap {
empty = Empty,
insert = \x t -> merge' (Node x Empty Empty) t,
findMin = \t -> case t of
Empty -> Nothing
(Node x _ _) -> Just x,
deleteMin = \t -> case t of
Empty -> Nothing
(Node _ l r) -> Just (merge' r l),
merge = \l r -> case (l, r) of
(Empty, t) -> t
(t, Empty) -> t
(t1#(Node x1 l1 r1), t2#(Node x2 l2 r2)) ->
if x1 <= x2
then Node x1 (merge' t2 r1) l1
else Node x2 (merge' t1 r2) l2,
contains = \x t -> case (x,t) of
(x,Empty)-> Nothing
(x,tx#(Node x1 l1 r1) ->
|x==x1 = Just 0
|x>x1 = (1+ (contains x l)
|x<x1 = (1+ (contains x r)
}
where
merge' = merge heap
The tree implementation
module Fdata.Tree where
import Fdata.Heap
data Tree x
= Empty
| Node x (Tree x) (Tree x)
deriving (Eq, Show)
leaf x = Node x Empty Empty
-- Convert a list to a heap
list2heap :: Heap x t -> [x] -> t x
list2heap i = foldl f z
where
f = flip $ insert i
z = empty i
-- Convert a heap to a list
heap2list :: Heap x t -> t x -> [x]
heap2list i t
= case (findMin i t, deleteMin i t) of
(Nothing, Nothing) -> []
(Just x, Just t') -> x : heap2list i t'
I am supposed to implement the contains function in the implementation for self-adjusting heaps.
I am not allowed to use any helper functions and I am supposed to use the maybe function.
My current implementation:
contains = \x t -> case (x,t) of
(x,Empty) -> Nothing
(x,tx#(Node x1 l1 r1))
|x==x1 -> Just 0
|x>x1 -> (1+ (contains x l1)
|x<x1 -> (1+ (contains x r1)
This does not work, since I get a parse error on input |.
I really dont know how to fix this since I did use 4 spaces instead of tabs and according to this: https://wiki.haskell.org/Case
the syntax is correct...
I once managed to fix this, but I got a type error about (1+ (contains x l), so this probably is not correct.
Any hint would be appreciated.
EDIT:
Thanks to everyone who answered!
Really appreciate that everyone took the time to explain their answers in great detail.
First of all:
there were some smaller mistakes, as pointed out by some of you in the comments:
I missed one closing parenthesis and accidentially named one argument l1 and another r1 and afterwards used r and l.
Fixed both mistakes.
Someone wrote that I do not need to use a lambda function. The problem is when I use something like:
contains _ Empty = Nothing
I get the error:
parse Error on input '_'.
However, lambda functions do not give me any errors about the input arguments.
Currently the only function that works without any errors is:
contains = \e t -> case (e,t) of
(_,Empty) -> Nothing
(e , Node x t1 t2) ->
if e == (head (heap2list heap (Node x t1 t2)))
then Just 0
else if (fmap (+1) (contains heap e t1))== Nothing
then (fmap (+1) (contains heap e t2))
else (fmap (+1) (contains heap e t1))
Found at:
Counting/Getting "Level" of a hierarchical data
Found by:Krom
One way of structuring contains :: Eq a => a -> Tree a -> Maybe Integer is to first label each element in your tree with its depth, using something like this, then fold the tree to find the element you're looking for, pulling its depth out with it. You can do this without very much code!
Jumping right in where this answer left off, here's contains.
contains :: Eq a => a -> Tree a -> Maybe Integer
contains x = fmap fst . find ((== x) . snd) . labelDepths
That's the whole function! This is classic functional programming style: rather than hand-crank a bespoke recursive tree traversal function I've structured the code as a pipeline of reusable operations. In Haskell pipelines are constructed using the composition operator (.) and are read from left to right. The result of labelDepths is passed to find ((== x) . snd), whose result is then passed to fmap fst.
labelDepths :: Tree a -> Tree (Integer, a), which I've explained in detail in the answer I linked above, attaches an Integer depth to each element of the input tree.
find :: Foldable t => (a -> Bool) -> t a -> Maybe a is a standard function which extracts the first element of a container (like a tree, or a list) that satisfies a predicate. In this instance, the Foldable structure in question is a Tree, so t ~ Tree and find :: (a -> Bool) -> Tree a -> Maybe a. The predicate I've given to find is ((== x) . snd), which returns True if the second element of its input tuple equals x: find ((== x) . snd) :: Tree (Integer, a) -> Maybe (Integer, a). find works by folding the input structure - testing its elements one at a time until it finds one that matches the predicate. The order in which elements are processed is defined by the container's Foldable instance, of which more below.
fmap :: Functor f => (a -> b) -> f a -> f b is another standard function. It applies a mapping function uniformly to each element of a container, transforming its elements from type a to type b. This time the container in question is the return value of find, which is a Maybe, so fmap :: (a -> b) -> Maybe a -> Maybe b. The mapping function I've supplied is fst, which extracts the first element of a tuple: fmap fst :: Maybe (Integer, a) -> Maybe Integer.
So putting it all together, you can see that this is a fairly direct implementation of my English description of the process above. First we label every element in the tree with its depth, then we find an element which matches the item we're looking for, then we extract the depth with which the element was previously labelled.
I mentioned above that Tree is a Foldable container. In fact, this isn't the case quite yet - there's no instance of Foldable for Tree. The easiest way to get a Foldable instance for Tree is to turn on the DeriveFoldable GHC extension and utter the magic words deriving Foldable.
{-# LANGUAGE DeriveFoldable #-}
data Tree x = Empty | Node x (Tree x) (Tree x) deriving Foldable
This automatically-implemented instance of Foldable will perform a preorder traversal, processing the tree in a top-down fashion. (x is considered to be "to the left of" l and r in the expression Node x l r.) You can adjust the derived traversal order by adjusting the layout of the Node constructor.
That said, I'm guessing that this is an assignment and you're not allowed to modify the definition of Tree or apply any language extensions. So you'll need to hand-write your own instance of Foldable, following the template at the bottom of this post. Here's an implementation of foldr which performs a preorder traversal.
instance Foldable Tree where
foldr f z Empty = z
foldr f z (Node x l r) = f x (foldr f (foldr f z r) l)
The Node case is the interesting one. We fold the tree from right to left (since this is a foldr) and from bottom to top. First we fold the right subtree, placing z at the rightmost leaf. Then we use the aggregated result of the right subtree as the seed for folding the left subtree. Finally we use the result of folding all of the Node's children as the aggregator to apply to f x.
Hopefully you didn't find this answer too advanced! (Happy to answer any questions you have.) While the other answers do a good job of showcasing how to write recursive tree traversal functions, I really wanted to give you a glimpse of the real power of functional programming. When you think at a higher level - breaking down a problem into its component parts, structuring operations as pipelines, and learning to spot common patterns like zipping, folding and mapping - you can be very productive and solve problems with very little code.
An instance of Foldable for a binary tree
To instantiate Foldable you need to provide a definition for at least foldMap or foldr.
data Tree a = Leaf
| Node (Tree a) a (Tree a)
instance Foldable Tree where
foldMap f Leaf = mempty
foldMap f (Node l x r) = foldMap f l `mappend` f x `mappend` foldMap f r
foldr f acc Leaf = acc
foldr f acc (Node l x r) = foldr f (f x (foldr f acc r)) l
This implementation performs an in-order traversal of the tree.
ghci> let myTree = Node (Node Leaf 'a' Leaf) 'b' (Node Leaf 'c' Leaf)
-- +--'b'--+
-- | |
-- +-'a'-+ +-'c'-+
-- | | | |
-- * * * *
ghci> toList myTree
"abc"
The DeriveFoldable extension allows GHC to generate Foldable instances based on the structure of the type. We can vary the order of the machine-written traversal by adjusting the layout of the Node constructor.
data Inorder a = ILeaf
| INode (Inorder a) a (Inorder a) -- as before
deriving Foldable
data Preorder a = PrLeaf
| PrNode a (Preorder a) (Preorder a)
deriving Foldable
data Postorder a = PoLeaf
| PoNode (Postorder a) (Postorder a) a
deriving Foldable
-- injections from the earlier Tree type
inorder :: Tree a -> Inorder a
inorder Leaf = ILeaf
inorder (Node l x r) = INode (inorder l) x (inorder r)
preorder :: Tree a -> Preorder a
preorder Leaf = PrLeaf
preorder (Node l x r) = PrNode x (preorder l) (preorder r)
postorder :: Tree a -> Postorder a
postorder Leaf = PoLeaf
postorder (Node l x r) = PoNode (postorder l) (postorder r) x
ghci> toList (inorder myTree)
"abc"
ghci> toList (preorder myTree)
"bac"
ghci> toList (postorder myTree)
"acb"
This function doesn't need to be a lambda:
contains x t =
Adding x to the case serves no purpose, since you only match it back to x. You can instead use pattern matching in the function head:
contains _ Empty = Nothing
The Node case has three sub-cases, where the value being searched for is less-than, greater-than, or equal to the value in the Node. If you order them that way, you get a symmetry from the less-than and greater-than tests, and can handle the equal case with an otherwise.
When recusring, you are going to get a Maybe Int, to which you want to add one. You can't do that directly because the Int is inside the Maybe. Normally, you would lift the addition, but I suspect that this is where the required call to maybe should go (however unnatural it may seem):
contains x (Node x' l r) | x < x' = maybe Nothing (Just . (+1)) $ contains x l
| x > x' = maybe Nothing (Just . (+1)) $ contains x r
| otherwise = Just 0
Instead of using maybe, the (+1) could have been lifted into the Maybe with fmap (or <$>):
... = fmap (+1) $ contains ...
Using maybe is unnatural because it has to explicitly pass the Nothing, and also re-wrap the Just.
This does not work, since I get a parse error on input |
Your previous line misses a closing parenthesis.
I got a Typ error about (1+ (contains x l)), so this probably is not correct.
The idea is totally correct, the issue is that contains x l returns a Maybe Int instead of an Int so you cannot directly add to that. You can only add to the result when it's a Just. There's a helper function that does exactly that, do something to Justs and keep Nothings: fmap (from Functor).
contains = \x t -> case (x,t) of
(x,Empty)-> Nothing
(x,tx#(Node x1 l1 r1))
|x==x1 -> Just 0
|x>x1 -> fmap (1+) (contains x l)
|x<x1 -> fmap (1+) (contains x r)
Btw, I'd write this as
contains x Empty = Nothing
contains x (Node v l r) = if x == v
then Just 0
else fmap (+1) $ contains x $ if x > v then l else r
When you want to pull an element out of a data structure, you have to give its index. But the meaning of index depends on the data structure itself.
class Indexed f where
type Ix f
(!) :: f a -> Ix f -> Maybe a -- indices can be out of bounds
For example...
Elements in a list have numeric positions.
data Nat = Z | S Nat
instance Indexed [] where
type Ix [] = Nat
[] ! _ = Nothing
(x:_) ! Z = Just x
(_:xs) ! (S n) = xs ! n
Elements in a binary tree are identified by a sequence of directions.
data Tree a = Leaf | Node (Tree a) a (Tree a)
data TreeIx = Stop | GoL TreeIx | GoR TreeIx -- equivalently [Bool]
instance Indexed Tree where
type Ix Tree = TreeIx
Leaf ! _ = Nothing
Node l x r ! Stop = Just x
Node l x r ! GoL i = l ! i
Node l x r ! GoR j = r ! j
Looking for something in a rose tree entails stepping down the levels one at a time by selecting a tree from the forest at each level.
data Rose a = Rose a [Rose a] -- I don't even like rosé
data RoseIx = Top | Down Nat RoseIx -- equivalently [Nat]
instance Indexed Rose where
type Ix Rose = RoseIx
Rose x ts ! Top = Just x
Rose x ts ! Down i j = ts ! i >>= (! j)
It seems that the index of a product type is a sum (telling you which arm of the product to look at), the index of an element is the unit type, and the index of a nested type is a product (telling you where to look in the nested type). Sums seem to be the only one which aren't somehow linked to the derivative. The index of a sum is also a sum - it tells you which part of the sum the user is hoping to find, and if that expectation is violated you're left with a handful of Nothing.
In fact I had some success implementing ! generically for functors defined as the fixed point of a polynomial bifunctor. I won't go into detail, but Fix f can be made an instance of Indexed when f is an instance of Indexed2...
class Indexed2 f where
type IxA f
type IxB f
ixA :: f a b -> IxA f -> Maybe a
ixB :: f a b -> IxB f -> Maybe b
... and it turns out you can define an instance of Indexed2 for each of the bifunctor building blocks.
But what's really going on? What is the underlying relationship between a functor and its index? How does it relate to the functor's derivative? Does one need to understand the theory of containers (which I don't, really) to answer this question?
It seems like the index into the type is an index into the set of constructors, following by an index into the product representing that constructor. This can be implemented quite naturally with e.g. generics-sop.
First you need a datatype to represent possible indices into a single element of the product. This could be an index pointing to an element of type a,
or an index pointing to something of type g b - which requires an index pointing into g and an index pointing to an element of type a in b. This is encoded with the following type:
import Generics.SOP
data ArgIx f x x' where
Here :: ArgIx f x x
There :: (Generic (g x')) => Ix g -> ArgIx f x x' -> ArgIx f x (g x')
newtype Ix f = ...
The index itself is just a sum (implemented by NS for n-ary sum) of sums over the generic representation of the type (choice of constructor, choice of constructor element):
newtype Ix f = MkIx (forall x . NS (NS (ArgIx f x)) (Code (f x)))
You can write smart constructors for various indices:
listIx :: Natural -> Ix []
listIx 0 = MkIx $ S $ Z $ Z Here
listIx k = MkIx $ S $ Z $ S $ Z $ There (listIx (k-1)) Here
treeIx :: [Bool] -> Ix Tree
treeIx [] = MkIx $ S $ Z $ S $ Z Here
treeIx (b:bs) =
case b of
True -> MkIx $ S $ Z $ Z $ There (treeIx bs) Here
False -> MkIx $ S $ Z $ S $ S $ Z $ There (treeIx bs) Here
roseIx :: [Natural] -> Ix Rose
roseIx [] = MkIx $ Z $ Z Here
roseIx (k:ks) = MkIx $ Z $ S $ Z $ There (listIx k) (There (roseIx ks) Here)
Note that e.g. in the list case, you cannot construct an (non-bottom) index pointing to the [] constructor - likewise for Tree and Empty, or constructors containing values whose type is not a or something containing some values of type a. The quantification in MkIx prevents the construction bad things like an index pointing to the first Int in data X x = X Int x where x is instantiated to Int.
The implementation of the index function is fairly straightforward, even if the types are scary:
(!) :: (Generic (f x)) => f x -> Ix f -> Maybe x
(!) arg (MkIx ix) = go (unSOP $ from arg) ix where
atIx :: a -> ArgIx f x a -> Maybe x
atIx a Here = Just a
atIx a (There ix0 ix1) = a ! ix0 >>= flip atIx ix1
go :: (All SListI xss) => NS (NP I) xss -> NS (NS (ArgIx f x)) xss -> Maybe x
go (Z a) (Z b) = hcollapse $ hzipWith (\(I x) -> K . atIx x) a b
go (S x) (S x') = go x x'
go Z{} S{} = Nothing
go S{} Z{} = Nothing
The go function compares the constructor pointed to by the index and the actual constructor used by the type. If the constructors don't match, the indexing returns Nothing. If they do, the actual indexing is done - which is trivial in the case that the index points exactly Here, and in the case of some substructure, both indexing operations must succeed one after the other, which is handled by >>=.
And a simple test:
>map (("hello" !) . listIx) [0..5]
[Just 'h',Just 'e',Just 'l',Just 'l',Just 'o',Nothing]
I've wrote the following code to increment the label of a given edge of a graph with FGL package, if the edge does not exist, it is created before being incremented :
import Data.Graph.Inductive
incrementEdge :: Edge -> Gr a Int -> Gr a Int
incrementEdge edge g = gmap (increment edge) g
increment :: Edge -> Context a Int -> Context a Int
increment (a,b) all#(p,n,x,v) = if a /= n then all else (p,n,x,v'')
where
v' = let (r,_) = elemNode b v in if r then v else ((0,b):v)
v'' = map (\(x,y) -> if y == b then (x+1,y) else (x,y)) v'
a :: Gr String Int
a = ([],1,"a",[]) & empty
b = ([],2,"b",[]) & a
while testing I got the following result :
*Main> incrementEdge (1,1) b
1:"a"->[(1,1)]
2:"b"->[]
*Main> incrementEdge (1,2) b
1:"a"->[(1,2)]
2:"b"->[]
*Main> incrementEdge (2,2) b
1:"a"->[]
2:"b"->[(1,2)]
But ...
*Main> incrementEdge (2,1) b
*** Exception: Edge Exception, Node: 1
what is the problem here ?
EDITION
elemNode ys [] = (False,0)
elemNode ys ((m,xs):xss) = if ys == xs then (True,m) else elemNode ys xss
I want to write a function which will add an edge to a graph from two nodes labels, the function checks that the two nodes exist, if not it create them :
- if nodes already exists the label of the edge between them is increment,
- if there is no edge between those node it is create before being incremented
Thanks for your reply
I don't think you're supposed to add edges with gmap: it folds over all the contexts in the graph in an arbitrary order and builds up the new graph by &ing the new contexts together. If a new context has a link to or from a node that hasn't been &ed yet, you get the Edge Exception.
Here's a simple example:
*Main> ([], 1, "a", [(0, 2)]) & empty :: Gr String Int
*** Exception: Edge Exception, Node: 2
I've only used FGL for a couple of little projects and am certainly no expert, but it probably makes more sense just to add new edges (with label 1) using insEdge and then do all the counting when needed:
import Data.Graph.Inductive
import qualified Data.IntMap as I
incrementEdge :: Edge -> Gr a Int -> Gr a Int
incrementEdge (a, b) = insEdge (a, b, 1)
count :: Gr a Int -> Gr a Int
count = gmap $ \(p, n, x, v) -> (countAdj p, n, x, countAdj v)
where
swap (a, b) = (b, a)
countAdj = map swap . I.toList . I.fromListWith (+) . map swap
This seems to work as desired:
*Main> count $ incrementEdge (2, 1) b
1:"a"->[]
2:"b"->[(1,1)]
*Main> count $ incrementEdge (2, 1) $ incrementEdge (2, 1) b
1:"a"->[]
2:"b"->[(2,1)]
1) A quick grep for Edge Exception in the fgl package:
cabal unpack fgl
cd fgl*
grep "Edge Exception" * -R
yields the file Data/Graph/Inductive/Tree.hs. Looking there we have the call updAdj that will throw this exception any time elemFM g v is false.
2) Could you provide runnable code? What you posted is missing elemNode (when using fgl 5.4.2.3)
3) Could you provide what version of fgl you're using? If it's old an upgrade might fix the issue.
Mapping over the graph doesn't seem like quite the right kind of traversal. The following works with the extracted context of the edge's source node.
edgeLookup :: Node -> [(a,Node)] -> Maybe ((a,Node), [(a,Node)])
edgeLookup n = aux . break ((== n) . snd)
where aux (h, []) = Nothing
aux (h, t:ts) = Just (t, h ++ ts)
incrementEdge :: Edge -> Gr a Int -> Maybe (Gr a Int)
incrementEdge (from,to) g = aux $ match from g
where aux (Nothing, _) = Nothing
aux (Just (i,n,l,o), g') = Just $ (i,n,l,checkEdge o) & g'
checkEdge outEdges =
maybe ((1,to):outEdges) incEdge $ edgeLookup to outEdges
incEdge ((cnt,n), rst) = (cnt+1,n):rst
I would probably also use a helper to go from (Maybe a, b) -> Maybe (a,b) then fmap aux over the helper composed with match. That would help to distill things down a bit better.
EDIT
To support node addition based on labels, one needs to track the bijection between labels and Node identifiers (Ints). This can be done by using a Map that is updated in parallel to the graph.
import Data.Graph.Inductive
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (fromJust)
-- A graph with uniquely labeled nodes.
type LGraph a b = (Map a Int, Gr a b)
-- Ensure that a node with the given label is present in the given
-- 'LGraph'. Return the Node identifier for the node, and a graph that
-- includes the node.
addNode :: Ord a => a -> LGraph a b -> (Int, LGraph a b)
addNode label (m,g) = aux $ M.lookup label m
where aux (Just nid) = (nid, (m,g))
aux Nothing = (nid', (m', g'))
[nid'] = newNodes 1 g
m' = M.insert label nid' m
g' = insNode (nid', label) g
-- Adding a context to a graph requires updating the label map.
(&^) :: Ord a => Context a b -> LGraph a b -> LGraph a b
c#(_, n, label, _) &^ (m,g) = (m', g')
where m' = M.insert label n m
g' = c & g
-- Look for a particular 'Node' in an edge list.
edgeLookup :: Node -> [(a,Node)] -> Maybe ((a,Node), [(a,Node)])
edgeLookup n = aux . break ((== n) . snd)
where aux (h, []) = Nothing
aux (h, t:ts) = Just (t, h ++ ts)
-- Increment the edge between two nodes; create a new edge if needed.
incrementEdge :: Edge -> Gr a Int -> Maybe (Gr a Int)
incrementEdge (from,to) g = fmap aux $ liftMaybe (match from g)
where aux ((i,n,l,o), g') = (i,n,l,checkEdge o) & g'
checkEdge outEdges =
maybe ((1,to):outEdges) incEdge $ edgeLookup to outEdges
incEdge ((cnt,n), rst) = (cnt+1,n):rst
liftMaybe :: (Maybe a, b) -> Maybe (a, b)
liftMaybe (Nothing, _) = Nothing
liftMaybe (Just x, y) = Just (x, y)
-- Increment an edge in an 'LGraph'. If the nodes are not part of the
-- graph, add them.
incrementLEdge :: Ord a => (a, a) -> LGraph a Int -> LGraph a Int
incrementLEdge (from,to) g = (m', fromJust $ incrementEdge' (from',to') g')
where (from', gTmp) = addNode from g
(to', (m',g')) = addNode to gTmp
-- Example
a' :: LGraph String Int
a' = ([],1,"a",[]) &^ (M.empty, empty)
b' = ([],2,"b",[]) &^ a'
test6 = incrementLEdge ("c","b") $ incrementLEdge ("b","a") b'
{-
*Main> test6
(fromList [("a",1),("b",2),("c",3)],
1:"a"->[]
2:"b"->[(1,1)]
3:"c"->[(1,2)])
-}