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.
module Graph where
import Control.Monad.State
import Data.Maybe
import Data.Set as Set
-- | 'Edge' represents an edge entre two nodes.
data Edge v = Edge {source :: v, target :: v}
deriving (Show,Eq,Ord)
data Graph v = Graph {nodes :: Set v, edges :: Set (Edge v)}
deriving Show
-- | 'Eq' for graphs.
instance Ord v => Eq (Graph v) where
g == g' = nodes g == nodes g' && edges g == edges g'
isValid :: Ord v => Graph v -> Bool
isValid g = (Set.map source (edges g) `Set.union` Set.map target (edges g)) `isSubsetOf` nodes g
-- | 'isDAG' tests if a graph is acyclic
isDAG :: Ord v => Graph v -> Bool
isDAG g = isValid g && all nocycle (nodes g)
where nocycle v = all (\a -> v `notMember` reachable g a) $ Set.map target (adj g v)
I'm trying to use QuickCheck to test 'isDAG', could you give me an property that 'isDAG' abides?
prop_isDAG :: Graph Int -> Property
prop_isDAG g =
I believe that's the accurate function declaration, if not, feel free to change it!
Here is another example that I've made for another function, to guide possible helpers on what i'm looking for:
-- | The function 'isSubgraphOf' tests if the first graph is subgraph of the second.
isSubgraphOf :: Ord v => Graph v -> Graph v -> Bool
isSubgraphOf g g' = isSubsetOf (nodes g) (nodes g') && isSubsetOf (edges g) (edges g')
And this is the QuickCheck property that it abides:
-- QuickCheck proprety to test 'isSubgraphOf'
prop_isSubgraphOf :: Graph Int -> Property
prop_isSubgraphOf g = forAll (elements $ elems $ nodes g) $ \v -> adj g v `isSubsetOf` edges g
prop_dag :: Property
prop_dag = forAll (dag :: Gen (DAG Int)) $ \g -> collect (length (edges g)) $ isDAG g
This was what I was looking for.
I am completely new to Haskell and trying to learn. I decided to write a short (unbalanced) binary search tree code just to get going. It breaks a text into words, adds the words to the binary tree (discarding repetitions), and then traverses the tree in order to print out the sorted list of words in the text.
data BinTree t = ExternalNode
| InternalNode (BinTree t) t (BinTree t)
treeInsert :: Ord t => BinTree t -> t -> BinTree t
treeInsert ExternalNode w = InternalNode ExternalNode w ExternalNode
treeInsert tree#(InternalNode left v right) w
| w == v = tree
| w < v = InternalNode (treeInsert left w) v right
| otherwise = InternalNode left v (treeInsert right w)
treeFromList :: Ord t => [t] -> BinTree t
treeFromList l = go ExternalNode l
where
go acc [] = acc
go acc (x : xs) = acc `seq` go (treeInsert acc x) xs
inOrderList :: BinTree t -> [t]
inOrderList ExternalNode = []
inOrderList (InternalNode left v right) = (inOrderList left) ++ [ v ] ++ (inOrderList right)
main :: IO ()
main = do
tmp <- readFile "words.txt"
printList . inOrderList . treeFromList $ words tmp
where
printList [] = return ()
printList (x : xs) = do
putStrLn x
printList xs
The program works fine on small texts. Then I fed the King James Bible to it. It crashes complaining that the stack size is too small. I have to increase the stack size to 200M to make it work!
Where is my mistake? I imagine it could have something to do with lazy evaluation messing up stuff. In any case, the problem is not with the depth of the binary search tree, which is only 163 for the Bible example.
The problem is that you are building up too deeply nested thunks.
This version adds seq calls in treeInsert to force evaluation at each level of the tree
and can run in very little stack:
import System.Environment
import Control.Monad
data BinTree t = ExternalNode
| InternalNode (BinTree t) !t (BinTree t)
treeInsert :: Ord t => BinTree t -> t -> BinTree t
treeInsert ExternalNode w = InternalNode ExternalNode w ExternalNode
treeInsert tree#(InternalNode left v right) w
| w == v = tree
| w < v = let t = treeInsert left w in t `seq` InternalNode t v right
| otherwise = let t = treeInsert right w in t `seq` InternalNode left v t
treeFromList :: Ord t => [t] -> BinTree t
treeFromList l = go ExternalNode l
where
go acc [] = acc
go acc (x : xs) = let t = treeInsert acc x in t `seq` go t xs
inOrderList :: BinTree t -> [t]
inOrderList ExternalNode = []
inOrderList (InternalNode left v right) = (inOrderList left) ++ [ v ] ++ (inOrderList right)
main1 = do
(arg0:_) <- getArgs
tmp <- readFile arg0
let t = treeFromList $ words tmp
forM_ (inOrderList t) putStrLn
main = main1
You can also use strictness annotations in the definition of BinTree:
data BinTree t = ExternalNode | InternalNode !(BinTree t) !t !(BinTree t)
in lieu of the seq calls in treeInsert - this is what Data.Set does.
It appears that the seq call in treeFromList doesn't have much effect.
In my application, I'm trying to implement an animation system. In this system, animations are represented as a cyclic list of frames:
data CyclicList a = CL a [a]
We can (inefficiently) advance the animation as follows:
advance :: CyclicList a -> CyclicList a
advance (CL x []) = CL x []
advance (CL x (z:zs)) = CL z (zs ++ [x])
Now, I'm pretty sure that this data type is a comonad:
instance Functor CyclicList where
fmap f (CL x xs) = CL (f x) (map f xs)
cyclicFromList :: [a] -> CyclicList a
cyclicFromList [] = error "Cyclic list must have one element!"
cyclicFromList (x:xs) = CL x xs
cyclicLength :: CyclicList a -> Int
cyclicLength (CL _ xs) = length xs + 1
listCycles :: CyclicList a -> [CyclicList a]
listCycles cl = let
helper 0 _ = []
helper n cl' = cl' : (helper (n-1) $ advance cl')
in helper (cyclicLength cl) cl
instance Comonad CyclicList where
extract (CL x _) = x
duplicate = cyclicFromList . listCycles
The question I have is: what kind of benefits do I get (if any) from using the comonad instance?
The advantage of providing a type class or implementing an interface is that code, written to use that typeclass or interface, can use your code without any modifications.
What programs can be written in terms of Comonad? A Comonad provides a way to both inspect the value at the current location (without observing its neighbors) using extract and a way to observe the neighborhood of every location with duplicate or extend. Without any additional functions, this isn't terribly useful. However, if we also require other functions along with the Comonad instance, we can write programs that depend on both local data and data from elsewhere. For example, if we require functions that allow us to change location, such as your advance, we can write programs that depend only on the local structure of the data, not on the data structure itself.
For a concrete example, consider a cellular automata program written in terms of Comonad and the following Bidirectional class:
class Bidirectional c where
forward :: c a -> Maybe (c a)
backward :: c a -> Maybe (c a)
The program could use this, together with Comonad, to extract data stored in a cell and explore the cells forward and backward of the current cell. It can use duplicate to capture the neighborhood of each cell and fmap to inspect that neighborhood. This combination of fmap f . duplicate is extract f.
Here is such a program. rule' is only interesting to the example; it implements cellular automata rules on neighborhood with just the left and right values. rule extracts data from the neighborhood, given the class, and runs the rule on each neighborhood. slice pulls out even larger neighborhoods so that we can display them easily. simulate runs the simulation, displaying these larger neighborhoods for each generation.
rule' :: Word8 -> Bool -> Bool -> Bool -> Bool
rule' x l m r = testBit x ((if l then 4 else 0) .|. (if m then 2 else 0) .|. (if r then 1 else 0))
rule :: (Comonad w, Bidirectional w) => Word8 -> w Bool -> w Bool
rule x = extend go
where
go w = rule' x (maybe False extract . backward $ w) (extract w) (maybe False extract . forward $ w)
slice :: (Comonad w, Bidirectional w) => Int -> Int -> a -> w a -> [a]
slice l r a w = sliceL l w (extract w : sliceR r w)
where
sliceR r w | r > 0 = case (forward w) of
Nothing -> take r (repeat a)
Just w' -> extract w' : sliceR (r-1) w'
sliceR _ _ = []
sliceL l w r | l > 0 = case (backward w) of
Nothing -> take l (repeat a) ++ r
Just w' -> sliceL (l-1) w' (extract w':r)
sliceL _ _ r = r
simulate :: (Comonad w, Bidirectional w) => (w Bool -> w Bool) -> Int -> Int -> Int -> w Bool -> IO ()
simulate f l r x w = mapM_ putStrLn . map (map (\x -> if x then '1' else '0') . slice l r False) . take x . iterate f $ w
This program might have been intended to work with the following Bidirectional Comonad, a Zipper on a list.
data Zipper a = Zipper {
heads :: [a],
here :: a,
tail :: [a]
} deriving Functor
instance Bidirectional Zipper where
forward (Zipper _ _ [] ) = Nothing
forward (Zipper l h (r:rs)) = Just $ Zipper (h:l) r rs
backward (Zipper [] _ _) = Nothing
backward (Zipper (l:ls) h r) = Just $ Zipper ls l (h:r)
instance Comonad Zipper where
extract = here
duplicate (Zipper l h r) = Zipper (goL (h:r) l) (Zipper l h r) (goR (h:l) r)
where
goL r [] = []
goL r (h:l) = Zipper l h r : goL (h:r) l
goR l [] = []
goR l (h:r) = Zipper l h r : goR (h:l) r
But will also work with a CyclicList Bidirectional Comonad.
data CyclicList a = CL a (Seq a)
deriving (Show, Eq, Functor)
instance Bidirectional CyclicList where
forward (CL x xs) = Just $ case viewl xs of
EmptyL -> CL x xs
x' :< xs' -> CL x' (xs' |> x)
backward (CL x xs) = Just $ case viewr xs of
EmptyR -> CL x xs
xs' :> x' -> CL x' (x <| xs')
instance Comonad CyclicList where
extract (CL x _) = x
duplicate (CL x xs) = CL (CL x xs) (go (singleton x) xs)
where
go old new = case viewl new of
EmptyL -> empty
x' :< xs' -> CL x' (xs' >< old) <| go (old |> x') xs'
We can reuse simulate with either data structure. The CyclicList has a more interesting output, because, instead of bumping into a wall, it wraps back around to interact with itself.
{-# LANGUAGE DeriveFunctor #-}
import Control.Comonad
import Data.Sequence hiding (take)
import Data.Bits
import Data.Word
main = do
putStrLn "10 + 1 + 10 Zipper"
simulate (rule 110) 10 10 30 $ Zipper (take 10 . repeat $ False) True (take 10 . repeat $ False)
putStrLn "10 + 1 + 10 Cyclic"
simulate (rule 110) 10 10 30 $ CL True (fromList (take 20 . repeat $ False))
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)])
-}