The question I posted makes no sense.
The type signatures were provided by ghci.
I misread it: not (MonadReader (Map k (Set a -> Set a)) m;
but rather: MonadReader (Map k (Set a -> Set a) m).
It was just an oversight. Sorry for wasting your time.
========================================
Is FlexibleContexts really needed in this context?
Which monad does "m" stand for?
I tried replacing "m" with [ ], but it didn't work.
{-# LANGUAGE FlexibleContexts #-}
module LeftCensorsList where
import Data.Set as S
import Data.Map as M
import Data.List as L
import Control.Monad.Reader
-- ============================== FUNCTIONS ==============================
censorsList :: Ord a => Map a (Set a -> Set a) -> [Set a] -> ([Set a], [Set a])
censorsList _ [] = ([],[])
censorsList cnsrmap (xs:xss) = runReader (go xs xss [xs]) cnsrmap
where
go _ [] invacc = pure (reverse invacc,[])
go cnsrs (ys:yss) invacc = do
ys' <- applyCensors cnsrs ys
if S.null ys'
then pure (reverse invacc,ys:yss)
else go ys' yss (ys': invacc)
applyCensors :: (MonadReader (Map k (Set a -> Set a)) m, Ord k) => Set k -> Set a -> m (Set a) -- <<<<<
applyCensors cnsrs xs = go (S.toList cnsrs) xs
where
go [] ys = pure ys
go (cnsr:rest) ys = do
ys' <- applyCensor cnsr ys
if S.null ys'
then pure S.empty
else go rest ys'
applyCensor :: (MonadReader (Map k (t -> t)) m, Ord k) => k -> t -> m t -- <<<<<
applyCensor cnsr xs = do
cnsrmap <- ask
case M.lookup cnsr cnsrmap of
Nothing -> pure xs
Just f -> pure $ f xs
-- ============================== TEST ==============================
t1,t2,t3, t4 :: ([Set Int],[Set Int])
t1 = censorsList M.empty $ L.map S.fromList [[1,3,13],[2,4,6]] -- ok
t2 = censorsList exCensorsMap $ L.map S.fromList [[1,3,13],[2,4,6]] -- ok
t3 = censorsList exCensorsMap [] -- ok
t4 = censorsList exCensorsMap $ L.map S.fromList [[1,4,13],[2,4,5]] -- ok
-- ============================== EXAMPLES ==============================
-- -------------------- MAPS --------------------
exCensorsMap :: Map Int (Set Int -> Set Int)
exCensorsMap = M.fromList $
[(1,censor1)
,(2,censor2)
,(3,censor3)
,(4,censor4)
]
-- -------------------- CENSORS --------------------
censor1, censor2, censor3, censor4 :: Set Int -> Set Int
censor1 = \xs -> xs S.\\ (S.fromList [2,4])
censor2 = \xs -> xs S.\\ (S.fromList [3])
censor3 = \xs -> xs S.\\ (S.fromList [1,2])
censor4 = \xs -> xs S.\\ (S.fromList [2,5])
The monad you are instantiating is the reader monad:
applyCensors :: (Ord k) => Set k -> Set a -> Reader (Map k (Set a -> Set a)) (Set a)
You can infer this yourself by noting the type of runReader and unifying from there.
The type signatures were provided by ghci.
I misread it: not (MonadReader (Map k (Set a -> Set a)) m;
but rather: MonadReader (Map k (Set a -> Set a) m).
It was just an oversight and therefore the question makes no sense.
Sorry for wasting your time.
Related
Starting with a concrete instance of my question, we all know (and love) the Monad type class:
class ... => Monad m where
return :: a -> m a
(>>=) :: m a -> (a -> m b) -> mb
...
Consider the following would-be instance, where we modify the standard list/"nondeterminism" instance using nub to retain only one copy of each "outcome":
type DistinctList a = DL { dL :: [a] }
instance Monad DistinctList where
return = DL . return
x >>= f = DL . nub $ (dL x) >>= (dL . f)
...Do you spot the error? The problem is that nub :: Eq a => [a] -> [a] and so x >>= f is only defined under the condition f :: Eq b => a -> DistinctList b, whereas the compiler demands f :: a -> DistinctList b. Is there some way I can proceed anyway?
Stepping back, suppose I have a would-be instance that is only defined under some condition on the parametric type's variable. I understand that this is generally not allowed because other code written with the type class cannot be guaranteed to supply parameter values that obey the condition. But are there circumstances where this still can be carried out? If so, how?
Here is an adaptation of the technique applied in set-monad to your case.
Note there is, as there must be, some "cheating". The structure includes extra value constructors to represent "return" and "bind". These act as suspended computations that need to be run. The Eq instance is there part of the run function, while the constructors that create the "suspension" are Eq free.
{-# LANGUAGE GADTs #-}
import qualified Data.List as L
import qualified Data.Functor as F
import qualified Control.Applicative as A
import Control.Monad
-- for reference, the bind operation to be implemented
-- bind operation requires Eq
dlbind :: Eq b => [a] -> (a -> [b]) -> [b]
dlbind xs f = L.nub $ xs >>= f
-- data structure comes with incorporated return and bind
-- `Prim xs` wraps a list into a DL
data DL a where
Prim :: [a] -> DL a
Return :: a -> DL a
Bind :: DL a -> (a -> DL b) -> DL b
-- converts a DL to a list
run :: Eq a => DL a -> [a]
run (Prim xs) = xs
run (Return x) = [x]
run (Bind (Prim xs) f) = L.nub $ concatMap (run . f) xs
run (Bind (Return x) f) = run (f x)
run (Bind (Bind ma f) g) = run (Bind ma (\a -> Bind (f a) g))
-- lifting of Eq and Show instance
-- Note: you probably should provide a different instance
-- one where eq doesn't depend on the position of the elements
-- otherwise you break functor laws (and everything else)
instance (Eq a) => Eq (DL a) where
dxs == dys = run dxs == run dys
-- this "cheats", i.e. it will convert to lists in order to show.
-- executing returns and binds in the process
instance (Show a, Eq a) => Show (DL a) where
show = show . run
-- uses the monad instance
instance F.Functor DL where
fmap = liftM
-- uses the monad instance
instance A.Applicative DL where
pure = return
(<*>) = ap
-- builds the DL using Return and Bind constructors
instance Monad DL where
return = Return
(>>=) = Bind
-- examples with bind for a "normal list" and a "distinct list"
list = [1,2,3,4] >>= (\x -> [x `mod` 2, x `mod` 3])
dlist = (Prim [1,2,3,4]) >>= (\x -> Prim [x `mod` 2, x `mod` 3])
And here is a dirty hack to make it more efficient, addressing the points raised below about evaluation of bind.
{-# LANGUAGE GADTs #-}
import qualified Data.List as L
import qualified Data.Set as S
import qualified Data.Functor as F
import qualified Control.Applicative as A
import Control.Monad
dlbind xs f = L.nub $ xs >>= f
data DL a where
Prim :: Eq a => [a] -> DL a
Return :: a -> DL a
Bind :: DL b -> (b -> DL a) -> DL a
-- Fail :: DL a -- could be add to clear failure chains
run :: Eq a => DL a -> [a]
run (Prim xs) = xs
run (Return x) = [x]
run b#(Bind _ _) =
case foldChain b of
(Bind (Prim xs) f) -> L.nub $ concatMap (run . f) xs
(Bind (Return a) f) -> run (f a)
(Bind (Bind ma f) g) -> run (Bind ma (\a -> Bind (f a) g))
-- fold a chain ((( ... >>= f) >>= g) >>= h
foldChain :: DL u -> DL u
foldChain (Bind b2 g) = stepChain $ Bind (foldChain b2) g
foldChain dxs = dxs
-- simplify (Prim _ >>= f) >>= g
-- if (f x = Prim _)
-- then reduce to (Prim _ >>= g)
-- else preserve (Prim _ >>= f) >>= g
stepChain :: DL u -> DL u
stepChain b#(Bind (Bind (Prim xs) f) g) =
let dys = map f xs
pms = [Prim ys | Prim ys <- dys]
ret = [Return ys | Return ys <- dys]
bnd = [Bind ys f | Bind ys f <- dys]
in case (pms, ret, bnd) of
-- ([],[],[]) -> Fail -- could clear failure
(dxs#(Prim ys:_),[],[]) -> let Prim xs = joinPrims dxs (Prim $ mkEmpty ys)
in Bind (Prim $ L.nub xs) g
_ -> b
stepChain dxs = dxs
-- empty list with type via proxy
mkEmpty :: proxy a -> [a]
mkEmpty proxy = []
-- concatenate Prims in on Prim
joinPrims [] dys = dys
joinPrims (Prim zs : dzs) dys = let Prim xs = joinPrims dzs dys in Prim (zs ++ xs)
instance (Ord a) => Eq (DL a) where
dxs == dys = run dxs == run dys
instance (Ord a) => Ord (DL a) where
compare dxs dys = compare (run dxs) (run dys)
instance (Show a, Eq a) => Show (DL a) where
show = show . run
instance F.Functor DL where
fmap = liftM
instance A.Applicative DL where
pure = return
(<*>) = ap
instance Monad DL where
return = Return
(>>=) = Bind
-- cheating here, Prim is needed for efficiency
return' x = Prim [x]
s = [1,2,3,4] >>= (\x -> [x `mod` 2, x `mod` 3])
t = (Prim [1,2,3,4]) >>= (\x -> Prim [x `mod` 2, x `mod` 3])
r' = ((Prim [1..1000]) >>= (\x -> return' 1)) >>= (\x -> Prim [1..1000])
If your type could be a Monad, then it would need to work in functions that are parameterized across all monads, or across all applicatives. But it can't, because people store all kinds of weird things in their monads. Most notably, functions are very often stored as the value in an applicative context. For example, consider:
pairs :: Applicative f => f a -> f b -> f (a, b)
pairs xs ys = (,) <$> xs <*> ys
Even though a and b are both Eq, in order to combine them into an (a, b) pair, we needed to first fmap a function into xs, briefly producing a value of type f (b -> (a, b)). If we let f be your DL monad, we see that this can't work, because this function type has no Eq instance.
Since pairs is guaranteed to work for all Applicatives, and it does not work for your type, we can be sure your type is not Applicative. And since all Monads are also Applicative, we can conclude that your type cannot possibly be made an instance of Monad: it would violate the laws.
I have been working on a question about reflexive closure:
The reflexive closure of a relation R is the smallest relation bigger than R which is reflexive. In other words, it is R with whatever pairs added to make R reflexive. Write a function (reflClosure) which takes a list of pairs (standing for R) and returns a list of pairs which is the reflexive closure of R. You do not need to worry about the order in which pairs appear in your return value.
I came up with this solution but it seems quite sloppy and lack neatness.
-- QUESTION 2: Functions and relations
reflClosure :: (Eq a) => [(a,a)] -> [(a,a)]
reflClosure (x:xs) = nub ( (x:xs) ++ [ (x,x) | x <- (heads (x:xs)) ++ (tails
(x:xs)) ])
nub :: Eq a => [a] -> [a]
nub = nubBy (==)
nubBy :: (a -> a -> Bool) -> [a] -> [a]
nubBy eq [] = []
nubBy eq (x:xs) = x : nubBy eq (filter (\y -> not (eq x y)) xs)
heads :: (Eq a) => [(a,a)] -> [a]
heads list = nub [x | (x, _) <- list]
tails :: (Eq a) => [(a,a)] -> [a]
tails list = nub [x | (_,x) <- list]
exists :: (Eq a) => (a,a) -> [(a,a)] -> Bool
exists x xs = length (filter (==x) xs) > 0
-- TEST SET FOR Q2
{-
Your functions should have the following behaviour:
reflClosure [(1,2),(3,2)] = [(1,2),(3,2),(1,1),(2,2),(3,3)]
reflClosure [(1,1),(3,5)] = [(1,1),(3,5),(3,3),(5,5)]
DO NOT WORRY ABOUT THE ORDER IN WHICH PAIRS APPEAR IN YOUR LIST
-}
Is there an easier way to do this? Explanation would be incredibly useful to learn from as well.
A nicer way to write heads and tails is the following:
heads :: (Eq a) => [(a,a)] -> [a]
heads = nub . map fst
tails :: (Eq a) => [(a,a)] -> [a]
tails = nub . map snd
It's point-free, plus it uses the more "functional" map rather than a list comprehension.
However, the fact that you need both means there's an even nicer way:
(heads (x:xs), tails (x:xs)) = (\(a,b) -> (nub a) (nub b)) $ unzip (x:xs)
Getting the fsts and the snds is equivalent to an unzip.
Also, you can simplify the signature of exists:
exists :: (Eq a) => a -> [a] -> Bool
exists x xs = length (filter (==x) xs) > 0
since nothing depends on the input being a list of pairs.
Data.List already defines nubBy, so I'm not sure why you've defined it there.
It's not clear why you've defined reflClosure to match on (x:xs), because all you care about (apparently) is that the list is non-empty. Perhaps something like this:
reflClosure :: (Eq a) => [(a,a)] -> [(a,a)]
reflClosure [] = []
reflClosure xs =
let (as,bs) = unzip xs
in nub $ xs ++ [ (x,x) | x <- (nub as) ++ (nub bs) ]
Relations are isomorphic to sets of pairs, not lists of pairs, so it makes sense to model them as such. Note that all the Ord constraints below are there because the implementation of Set needs it.
Use the standard library sets because they are fast.
import Data.Set (Set)
import qualified Data.Set as Set
A type synonym to make the code easier to read:
-- A relation with underlying set s
type Relation s = Set (s,s)
Now we can write a function that gets all the members of the underlying set:
underlyingMembers :: Ord a => Relation a -> Set a
underlyingMembers r = (Set.map fst r) `Set.union` (Set.map snd r)
Once we have that, finding the reflexive closure of a relation is easy:
reflexiveClosure :: Ord a => Relation a -> Relation a
reflexiveClosure r = r `Set.union` (Set.map (\x -> (x,x)) (underlyingMembers r)
If you really need to work with lists, (you really shouldn't, though) you can fromList/toList:
listVersion :: Ord a => [(a,a)] -> [(a,a)]
listVersion = Set.toList . reflexiveClosure . Set.fromList
If any of this is unclear, please leave a comment and I will explain more in detail.
I've been trying to reproduce an aside mentioned in All Sorts of Permutations (Functional Pearl) by Christiansen, Danilenko and Dylus, a paper for the upcoming ICFP 2016. Section 8 (“Final Remarks”) claims that by choosing a particular non-deterministic predicate, a monadic merge sort can produce all permutations of a sequence in lexicographical order.
We did only consider the non-deterministic predicate coinCmp, while there are other non-deterministic predicates that can be used to affect the order of enumeration. For example, the following function lifts a predicate cmp to a non-deterministic context.
liftCmp :: MonadPlus μ
⇒ (α → α → Bool) → Cmp α μ
liftCmp p x y = return (p x y) ⊕ return (not (p x y))
When we use this function to lift a comparison function and pass it to a monadic version of merge sort, we get a special kind of permutation function: it enumerates permutations in lexicographical order.
I'm pretty sure what I've written here is merge sort, but when run the ordering isn't as advertised.
import Control.Applicative (Alternative((<|>)))
import Control.Monad (MonadPlus, join)
import Data.Functor.Identity (Identity)
-- Comparison in a context
type Comparison a m = a -> a -> m Bool
-- Ordering lifted into the Boring Monad
boringCmp :: (a -> a -> Bool) -> Comparison a Identity
boringCmp p x y = return (p x y)
-- Arbitrary ordering in a non-deterministic context
cmp :: MonadPlus m => Comparison a m
cmp _ _ = return True <|> return False
-- Ordering lifted into a non-deterministic context
liftCmp :: MonadPlus m => (a -> a -> Bool) -> Comparison a m
liftCmp p x y = let b = p x y in return b <|> return (not b)
mergeM :: Monad m => Comparison a m -> [a] -> [a] -> m [a]
mergeM _ ls [] = return ls
mergeM _ [] rs = return rs
mergeM p lls#(l:ls) rrs#(r:rs) = do
b <- p l r
if b
then (l:) <$> mergeM p ls rrs
else (r:) <$> mergeM p lls rs
mergeSortM :: Monad m => Comparison a m -> [a] -> m [a]
mergeSortM _ [] = return []
mergeSortM _ [x] = return [x]
mergeSortM p xs = do
let (ls, rs) = deinterleave xs
join $ mergeM p <$> mergeSortM p ls <*> mergeSortM p rs
where
deinterleave :: [a] -> ([a], [a])
deinterleave [] = ([], [])
deinterleave [l] = ([l], [])
deinterleave (l:r:xs) = case deinterleave xs of (ls, rs) -> (l:ls, r:rs)
λ mergeSortM (boringCmp (<=)) [2,1,3] :: Identity [Int]
Identity [1,2,3]
λ mergeSortM cmp [2,1,3] :: [[Int]]
[[2,3,1],[2,1,3],[1,2,3],[3,2,1],[3,1,2],[1,3,2]]
λ mergeSortM (liftCmp (<=)) [2,1,3] :: [[Int]]
[[1,2,3],[2,1,3],[2,3,1],[1,3,2],[3,1,2],[3,2,1]]
And the actual lexicographic ordering for reference—
λ sort it
[[1,2,3],[1,3,2],[2,1,3],[2,3,1],[3,1,2],[3,2,1]]
Let's try a variant of deinterleave, which splits the first and last half of the list, instead of splitting even- and odd- indexed elements as in the posted code:
deinterleave :: [a] -> ([a], [a])
deinterleave ys = splitAt (length ys `div` 2) ys
Result:
> mergeSortM (liftCmp (<=)) [2,1,3] :: [[Int]]
[[1,2,3],[1,3,2],[2,1,3],[2,3,1],[3,1,2],[3,2,1]]
Unfortunately, this does not solve the issue as I first hoped, as Rowan Blush points out below. :-/
A brief introduction to the types and occurrences through examples.
Ex1. abbacb
a, b, c are the types.
a occurres 2 times; b occurres 3 times; c occurres 1 times.
This can be represented more concisely as [('a',2),('b',3),('c',1)] (Indeed, the order doesn't matter).
Ex2. abbacb
ab, bb, ba, ac, cb are sequences of types
Each sequence occurs only once.
This can be represented as [("ab",1),("bb",1),("ba",1),("ac",1),("cb",1)]
The following graphical structure has the same informative content of the previous two:
('a',2) -- 'a' occurs 2 times
('b',1) -- "ab" occurs 1 times
('c',1) -- "ac" occurs 1 times
('b',2) -- 'b' occurs 2 times
('a',1) -- "ba" occurs 1 times
('b',1) -- "bb" occurs 1 times
('c',1) -- 'c' occurs 1 times
('b',1) -- "cb" occurs 1 times
In Haskell: [(('a',2),[('b',1),('c',1)]),(('b',2),[('a',1),('b',1)]),(('c',1),[('b',1)])]
For occurrences of sequences of 3 elements:
('a',2) -- 'a' occurs 2 times
('b',1) -- "ab" occurs 1 times
('b',1) -- "abb" occurs 1 times
('c',1) -- "ac" occurs 1 times
('b',1) -- "acb" occurs 1 times
...
In Haskell:
[
(('a',2), [(('b',1),[('b',1)]),(('c',1),[('b',1)])]),
(('b',2), [(('a',1),[('c',1)]),(('b',1),[('a',1)])])
]
with type [((Char, Int), [((Char, Int), [(Char, Int)])])]
Even considering only the sequences of two and three elements, the comprehensibility of the graphical representation is much greater than that in Haskell.
In addition, lists are not very efficient, so I used the Data.Map library and consequently a slightly different representation.
The following examples are based on Pi's digits. Interesting results can be obtained using the words of a novel.
My questions are:
Functions dedicated to the sequences of the three types are very complicated. It is possible to drastically simplify them?
I cannot even imagine how it is possible to generalize the functions for sequences of arbitrary length. Someone has an idea of how it could be done?
Using the following data type recursion should be easier to implement:
data TuplesTypesOccurences a = L (M.Map a Int) | B (M.Map a (Int,TuplesTypesOccurences a))
In this way however does not lose access to all of the functions in Data.Map library?
import qualified Data.Map as M
import Data.List (sortBy)
piDigits = "31415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170679821480865132823066470938446095505822317253594081284811174502841027019385211055596446229489549303819644288109756659334461284756"
type TypesOccurrences a = M.Map a Int
toTypeOccurrences :: Ord k => [k] -> TypesOccurrences k -> TypesOccurrences k
toTypeOccurrences [] mp = mp
toTypeOccurrences (x:xs) mp = toTypeOccurrences xs $ M.insertWith (+) x 1 mp
-- ex. toTypeOccurrences piDigits M.empty
pprintTO :: Show a => TypesOccurrences a -> IO ()
pprintTO = mapM_ putStrLn . map (\(xs,n) -> show xs ++ " " ++ (show n)). sortBy (\x y -> compare (snd y) (snd x)) . M.toList
-- ex. pprintTO . M.filter (> 22) . toTypeOccurrences piDigits $ M.empty
type Seq2TypeOccurrences a = M.Map a (Int,TypesOccurrences a)
toSQ2TO :: Ord a => [a] -> Seq2TypeOccurrences a -> Seq2TypeOccurrences a
toSQ2TO [] mp = mp
toSQ2TO [x] mp = mp
toSQ2TO (x:y:xs) mp = toSQ2TO (y:xs) $
case M.lookup x mp of
Nothing -> M.insert x (1,M.singleton y 1) mp
Just (_,mp2) -> case M.lookup y mp2 of
Nothing -> M.update (\(n,mp2) -> Just (n+1,M.insert y 1 mp2)) x mp
Just _ -> M.update (\(n,mp2) -> Just (n+1,M.update (\m -> Just (m+1)) y mp2)) x mp
-- ex. toSQ2TO piDigits M.empty
pprintSQ2TO :: Show a => Seq2TypeOccurrences a -> IO ()
pprintSQ2TO = mapM_ putStrLn . map (\(x,(n,mp)) -> "(" ++ (show x) ++ "," ++ (show n) ++ ")\n\t" ++ (drop 2 . concatMap (("\n\t" ++) . show) . M.toList $ mp)) . M.toList
-- ex. pprintSQ2TO (toSQ2TO piDigits M.empty)
greaterThanSQ2TO :: Ord a => Int -> Seq2TypeOccurrences a -> Seq2TypeOccurrences a
greaterThanSQ2TO n = M.filter (\(_,mp2) -> not . M.null $ mp2) . M.map (\(o,mp2) -> (o,M.filter (> n) mp2)) . M.filter (\(m,mp) -> m > n)
-- ex. pprintSQ2TO . greaterThanSQ2TO 4 . toSQ2TO piDigits $ M.empty
descSortSQ2TO :: Ord a => Seq2TypeOccurrences a -> [([a], Int)]
descSortSQ2TO = sortBy (\xs ys -> compare (snd ys) (snd xs)) . concatMap (\(x,ys) -> zipWith (\x (y,n) -> ([x,y],n)) (repeat x) ys ) . map (\(x,(_,mp2)) -> (x,M.toList mp2)) . M.toList
-- mapM_ print . descSortSQ2TO . greaterThanSQ2TO 4 . toSQ2TO piDigits $ M.empty
unionSQ2TO :: Ord a => Seq2TypeOccurrences a -> Seq2TypeOccurrences a -> Seq2TypeOccurrences a
unionSQ2TO = M.unionWith (\(n1,mp1) (n2,mp2) -> (n1+n2, M.unionWith (+) mp1 mp2))
type Seq3TypeOccurrences a = M.Map a (Int,Seq2TypeOccurrences a)
toSQ3TO :: Ord k => [k] -> Seq3TypeOccurrences k -> Seq3TypeOccurrences k
toSQ3TO [] mp = mp
toSQ3TO [x] mp = mp
toSQ3TO [x,y] mp = mp
toSQ3TO (x:y:z:xs) mp = toSQ3TO (y:z:xs) $
case M.lookup x mp of
Nothing -> M.insert x (1,M.singleton y (1,M.singleton z 1)) mp
Just (_,mp2) -> case M.lookup y mp2 of
Nothing -> M.update (\(n,mp2) -> Just (n+1,M.insert y (1,M.singleton z 1) mp2)) x mp
Just (m,kns3) -> case M.lookup z kns3 of
Nothing -> M.update (\(n,_) -> Just (n+1,M.update (\(m,mp3) -> Just (m+1,M.insert z 1 mp3)) y mp2)) x mp
Just _ -> M.update (\(n,_) -> Just (n+1,M.update (\(m,mp3) -> Just (m+1,M.update (Just . (+1)) z mp3)) y mp2)) x mp
-- ex. toSQ3TO piDigits M.empty
pprint3 :: Show a => Seq3TypeOccurrences a -> IO ()
pprint3 = mapM_ putStrLn . map (\(x,(n,mp)) -> "(" ++ (show x) ++ "," ++ (show n) ++ ")" ++ (concatMap (\(x2,(n2,mp2)) -> "\n\t(" ++ (show x2) ++ "," ++ (show n2) ++ ")" ++ (f mp2)) . M.toList $ mp)) . M.toList
where
f = concatMap (\(x,n) -> "\n\t\t(" ++ (show x) ++ "," ++ (show n) ++ ")") . M.toList
-- pprint3 . toSQ3TO piDigits $ M.empty
pprint3B :: Show a => Seq3TypeOccurrences a -> IO ()
pprint3B = mapM_ putStrLn . map (\(xs,n) -> show xs ++ " " ++ (show n)) . concatMap (\(xs,mp) -> zipWith (\ys (z,n) -> (ys ++ [z],n)) (repeat xs) mp) . concatMap (\(x,mp) -> zipWith (\y (z,mp2) -> ([y,z],mp2)) (repeat x) mp) . map (\(x,(_,mp)) -> (x, map (\(y,(_,mp2)) -> (y, M.toList mp2)) $ M.toList mp)) . M.toList
-- pprint3B . toSQ3TO piDigits $ M.empty
greaterThan3Q2TO :: Ord a => Int -> Seq3TypeOccurrences a -> Seq3TypeOccurrences a
greaterThan3Q2TO n = M.filter (\(_,mp) -> not . M.null $ mp)
. M.map (\(m,mp) -> (m,M.filter (\(o,mp2) -> not . M.null $ mp2) mp))
. M.map (\(m,mp) -> (m,M.map (\(o,mp2) -> (o,M.filter (>n) mp2)) mp))
. M.filter (\(_,mp) -> not. M.null $ mp)
. M.map (\(m,mp) -> (m,M.filter ((n <) . fst) mp))
. M.filter (\(m,mp) -> m > n)
-- ex. pprint3B . greaterThan3Q2TO 2 . toSQ3TO piDigits $ M.empty
unionSQ3TO :: Ord a => Seq3TypeOccurrences a -> Seq3TypeOccurrences a -> Seq3TypeOccurrences a
unionSQ3TO = M.unionWith (\(n,mp2a) (m,mp2b) -> (n+m,unionSQ2TO mp2a mp2b))
You need to define a recursive data structure like this:
data Trie = Nil | Trie (Map Char (Int, Trie))
This allows the show and add functions to be defined recursively.
Here is an implementation. Run test3 to see an example of how it works.
import qualified Data.Map as M
import Text.PrettyPrint
import Data.List
data Trie = Nil | Trie (M.Map Char (Int, Trie))
showTrie :: String -> Trie -> Doc
showTrie _ Nil = empty
showTrie prefix (Trie m) =
vcat $
do (k,(count,t)) <- M.assocs m
let prefix' = prefix ++ [k]
return $
vcat [ lparen <> char '"' <> text prefix' <> char '"' <> comma <> int count <> rparen
, nest 4 (showTrie prefix' t)
]
-- add an element to a Trie
addTrie :: Trie -> String -> Trie
addTrie t [] = t
addTrie Nil xs = addTrie (Trie M.empty) xs
addTrie (Trie m) (x:xs) =
case M.lookup x m of
Nothing -> let t' = addTrie Nil xs
in Trie $ M.insert x (1,t') m
Just (c,t) -> let t' = addTrie t xs
in Trie $ M.insert x (c+1,t') m
test1 =
let t1 = addTrie Nil "abcd"
t2 = addTrie t1 "abce"
in putStrLn $ render $ showTrie "" t2
test2 n str =
putStrLn $ render $ showTrie "" $
foldr (flip addTrie) Nil (map (take n) (tails str))
test3 = test2 4 "31415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170679821480865132823066470938446095505822317253594081284811174502841027019385211055596446229489549303819644288109756659334461284756"
Many higher-order functions can be defined in term of the fold function. For example, here is the relation between filter and foldl in Haskell.
myFilter p [] = []
myFilter p l = foldl (\y x -> if (p x) then (x:y) else y) [] (reverse l)
Is there a similar relation between their monadic versions filterM and foldM ? How can I write filterM in term of foldM ?
I tried hard to find a monadic equivalent to \y x -> if (p x) then (x:y) else y to plug into foldM without success.
Like in D.M.'s answer, only without the reverse. Let the types guide you:
import Control.Monad
{-
foldM :: (Monad m) => (b -> a -> m b) -> b -> [a] -> m b
filterM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]
-}
filtM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]
filtM p xs = foldM f id xs >>= (return . ($ []))
where
f acc x = do t <- p x
if t then return (acc.(x:)) else return acc
Not sure that it has any sense (since it has that strange reverse), but at least it type checked well:
myFilterM :: Monad m => (a -> m Bool) -> [a] -> m [a]
myFilterM p l = foldM f [] (reverse l)
where
f y x = do
p1 <- p x
return $ if p1 then (x:y) else y