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. :-/
Related
I've created a function m such that
m "abc" "def" == "bcd"
and I would like to create another function that uses m to generate the output ["bcd","efg","hia"] when given the input ["abc","def","ghi"]
The definition of m is
m :: [a] -> [a] -> [a]
m str1 str2 = (drop 1 str1) ++ (take 1 str2)
You can make use of zipWith :: (a -> b -> c) -> [a] -> [b] -> [c] here where you take the entire list as first parameter, and tail (cycle l) as second parameter (with l the list):
combine :: [a] -> [a]
combine l = zipWith m l (tail (cycle l))
zipWith will enumerate concurrently on both lists and each time call m with an element of the first and the second list. For example:
Prelude> combine ["abc","def","ghi"]
["bcd","efg","hia"]
You can append the first element to the end to simulate a wrap-around, then zip the list with its tail to get tuples of each element, then map it:
f :: [[a]] -> [[a]]
f [] = []
f l#(x:xs) = map (\(a, b) -> m a b) $ zip wrapped (tail wrapped)
where wrapped = l ++ [x]
Alternatively, you can use uncurry:
f :: [[a]] -> [[a]]
f [] = []
f l#(x:xs) = map (uncurry m) $ zip wrapped (tail wrapped)
where wrapped = l ++ [x]
import Data.List.HT (rotate)
m2 :: [[a]] -> [[a]]
m2 list = zipWith m list (rotate 1 list)
where m is yours.
You can make it point free in a couple of ways.
Here's using the Applicative style,
m2 :: [[a]] -> [[a]]
m2 = zipWith m <$> id <*> (rotate 1)
which can read as m2 is the function that passes its argument to id and rotate 1 respectively, and then those results to zipWith m.
Here's using the Monadic style,
import Control.Monad (ap)
m2 :: [[a]] -> [[a]]
m2 = zipWith m `ap` rotate 1
which is imho a bit less clear, in this case; you can read it as m2 passes its argument to both zipWith m and rotate 1 and then feeds the result of the latter to the the result of the former.
Honestly, I like the other answer a bit more, as it avoids importing rotate and gets the same effect with tail . cycle.
I would like to define a greaters function, which selects from a list items that are larger than the one before it.
For instance:
greaters [1,3,2,4,3,4,5] == [3,4,4,5]
greaters [5,10,6,11,7,12] == [10,11,12]
The definition I came up with is this :
greaters :: Ord a => [a] -> [a]
Things I tried so far:
greaters (x:xs) = group [ d | d <- xs, x < xs ]
Any tips?
We can derive a foldr-based solution by a series of re-writes starting from the hand-rolled recursive solution in the accepted answer:
greaters :: Ord a => [a] -> [a]
greaters [] = []
greaters (x:xs) = go x xs -- let's re-write this clause
where
go _ [] = []
go last (act:xs)
| last < act = act : go act xs
| otherwise = go act xs
greaters (x:xs) = go xs x -- swap the arguments
where
go [] _ = []
go (act:xs) last
| last < act = act : go xs act
| otherwise = go xs act
greaters (x:xs) = foldr g z xs x -- go ==> foldr g z
where
foldr g z [] _ = []
foldr g z (act:xs) last
| last < act = act : foldr g z xs act
| otherwise = foldr g z xs act
greaters (x:xs) = foldr g z xs x
where -- simplify according to
z _ = [] -- foldr's definition
g act (foldr g z xs) last
| last < act = act : foldr g z xs act
| otherwise = foldr g z xs act
Thus, with one last re-write of foldr g z xs ==> r,
greaters (x:xs) = foldr g z xs x
where
z = const []
g act r last
| last < act = act : r act
| otherwise = r act
The extra parameter serves as a state being passed forward as we go along the input list, the state being the previous element; thus avoiding the construction by zip of the shifted-pairs list serving the same purpose.
I would start from here:
greaters :: Ord a => [a] -> [a]
greaters [] = []
greaters (x:xs) = greatersImpl x xs
where
greatersImpl last [] = <fill this out>
greatersImpl last (x:xs) = <fill this out>
The following functions are everything you’d need for one possible solution :)
zip :: [a] -> [b] -> [(a, b)]
drop 1 :: [a] -> [a]
filter :: (a -> Bool) -> [a] -> [a]
(<) :: Ord a => a -> a -> Bool
uncurry :: (a -> b -> c) -> (a, b) -> c
map :: (a -> b) -> [a] -> [b]
snd :: (a, b) -> b
Note: drop 1 can be used when you’d prefer a “safe” version of tail.
If you like over-generalization like me, you can use the witherable package.
{-# language ScopedTypeVariables #-}
import Control.Monad.State.Lazy
import Data.Witherable
{-
class (Traversable t, Filterable t) => Witherable t where
-- `wither` is an effectful version of mapMaybe.
wither :: Applicative f => (a -> f (Maybe b)) -> t a -> f (t b)
-}
greaters
:: forall t a. (Ord a, Witherable t)
=> t a -> t a
greaters xs = evalState (wither go xs) Nothing
where
go :: a -> State (Maybe a) (Maybe a)
go curr = do
st <- get
put (Just curr)
pure $ case st of
Nothing -> Nothing
Just prev ->
if curr > prev
then Just curr
else Nothing
The state is the previous element, if there is one. Everything is about as lazy as it can be. In particular:
If the container is a Haskell list, then it can be an infinite one and everything will still work. The beginning of the list can be produced without withering the rest.
If the container extends infinitely to the left (e.g., an infinite snoc list), then everything will still work. How can that be? We only need to know what was in the previous element to work out the state for the current element.
"Roll your own recursive function" is certainly an option here, but it can also be accomplished with a fold. filter can't do it because we need some sort of state being passed, but fold can nicely accumulate the result while keeping that state at the same time.
Of course the key idea is that we keep track of last element add the next one to the result set if it's greater than the last one.
greaters :: [Int] -> [Int]
greaters [] = []
greaters (h:t) = reverse . snd $ foldl (\(a, r) x -> (x, if x > a then x:r else r)) (h, []) t
I'd really love to eta-reduce it but since we're dropping the first element and seeding the accumulator with it it kinda becomes awkward with the empty list; still, this is effectively an one-liner.
So i have come up with a foldr solution. It should be similar to what #Will Ness has demonstrated but not quite i suppose as we don't need a separate empty list check in this one.
The thing is, while folding we need to encapsulate the previous element and also the state (the result) in a function type. So in the go helper function f is the state (the result) c is the current element of interest and p is the previous one (next since we are folding right). While folding from right to left we are nesting up these functions only to run it by applyying the head of the input list to it.
go :: Ord a => a -> (a -> [a]) -> (a -> [a])
go c f = \p -> let r = f c
in if c > p then c:r else r
greaters :: Ord a => [a] -> [a]
greaters = foldr go (const []) <*> head
*Main> greaters [1,3,2,4,3,4,5]
[3,4,4,5]
*Main> greaters [5,10,6,11,7,12]
[10,11,12]
*Main> greaters [651,151,1651,21,651,1231,4,1,16,135,87]
[1651,651,1231,16,135]
*Main> greaters [1]
[]
*Main> greaters []
[]
As per rightful comments of #Will Ness here is a modified slightly more general code which hopefully doesn't break suddenly when the comparison changes. Note that const [] :: b -> [a] is the initial function and [] is the terminator applied to the result of foldr. We don't need Maybe since [] can easily do the job of Nothing here.
gs :: Ord a => [a] -> [a]
gs xs = foldr go (const []) xs $ []
where
go :: Ord a => a -> ([a] -> [a]) -> ([a] -> [a])
go c f = \ps -> let r = f [c]
in case ps of
[] -> r
[p] -> if c > p then c:r else r
According to following rules, I tried to solve the following problem:
No definition of recursion
No List of Comprehension
Only Prelude-Module is allowed.
Now I have to implement higher-order for concat and filter.
Im at this point:
concat' :: [[a]] -> [a]
concat' a = (concat a)
filter' :: (a -> Bool) -> [a] -> [a]
filter' p [] = []
filter' p (x:xs)
| p x = x : filter p xs
| otherwise = filter p xs
The concat function is working (nothing special so far) -> Is that a defined recursion? I mean I use the predefined concat from standard-prelude but myself I don't define it - or am I wrong?
For the filter, the function I've looked up the definition of standard prelude but that's either not working and it contains a definition of recursion.
I'm supposing the concat and filter functions should be avoided. Why would we need to implement concat and filter if they're already available? So try implementing them from scratch.
We can use folding instead of recursion and list comprehensions. The below solutions use the function foldr.
foldr :: Foldable t => (a -> b -> b) -> b -> t a -> b
concat' :: [[a]] -> [a]
concat' = foldr (++) []
filter' :: (a -> Bool) -> [a] -> [a]
filter' p = foldr (\x acc -> if p x then x:acc else acc) []
Examples:
main = do
print $ concat' ["A", "B", "CAB"] -- "ABCAB"
print $ filter' (\x -> x `mod` 2 == 0) [1..9] -- [2, 4, 6, 8]
You may do as follows;
concat' :: Monad m => m (m b) -> m b
concat' = (id =<<)
filter' p = ((\x-> if p x then [x] else []) =<<)
=<< is just flipped version of the monadic bind operator >>=.
filter' (< 10) [1,2,3,10,11,12]
[1,2,3]
I am trying to implement sorting using Monoid and Foldable. This is what I have so far. It is really slow. However, when I write the same functions without Monoid or Foldable, it is reasonably fast. Any pointers as to what I am doing wrong here would be greatly appreciated.
newtype MergeL a = MergeL { getMergeL :: [a] } deriving (Eq, Show)
instance Ord a => Monoid (MergeL a) where
mempty = MergeL []
mappend l r = MergeL $ merge (getMergeL l) (getMergeL r)
comp :: a -> MergeL a
comp a = MergeL [a]
instance Foldable MergeL where
foldMap f xs =
case divide xs of
(MergeL [], MergeL []) -> mempty
(MergeL l , MergeL []) -> foldMap f l
(MergeL [], MergeL r) -> foldMap f r
(MergeL l , MergeL r) -> foldMap f l <> foldMap f r
divide :: MergeL a -> (MergeL a, MergeL a)
-- now uses leftHalf and rightHalf
divide xs = (MergeL $ leftHalf ls, MergeL $ rightHalf ls)
where
ls = getMergeL xs
foldSort :: (Ord a, Foldable t) => t a -> [a]
foldSort = getMergeL . foldMap comp
mon :: Integer -> IO ()
mon n = (print . last . getMergeL . foldMap comp) $ MergeL [n,n - 1 ..0]
Shared helper functions:
leftHalf :: [a] -> [a]
leftHalf xs = take (length xs `div` 2) xs
rightHalf :: [a] -> [a]
rightHalf xs = drop (length xs `div` 2) xs
merge :: Ord a => [a] -> [a] -> [a]
merge xs [] = xs
merge [] ys = ys
merge (x:xs) (y:ys)
| (x <= y) = x:(merge xs (y:ys))
| otherwise = y:(merge (x:xs) ys)
Here is the implementation of the the sort function without Monoid. It uses the same leftHalf and rightHalf for spliting the list and the same merge for merging the lists:
mergesort :: Ord a => [a] -> [a]
mergesort [] = []
mergesort [x] = [x]
mergesort xs = merge (mergesort (leftHalf xs)) (mergesort (rightHalf xs))
plain :: Integer -> IO ()
plain n = (print . last . mergesort) [n,n - 1 ..0]
The difference in performance is:
λ> mon 4000
4000
(2.20 secs, 1,328,105,368 bytes)
λ> plain 4000
4000
(0.03 secs, 11,130,816 bytes)
The main problem here is quite easy to miss (in fact, I overlooked it until I threw in a trace in divide). One of your foldMap cases is:
(MergeL l , MergeL r) -> foldMap f l <> foldMap f r
There, foldMap is being called on l and r, which are plain lists, as opposed to MergeL-wrapped lists. That being so, l and r are not divided; rather, they are merged element by element. As a consequence, the sorting becomes quadratic.
In addition to using the MergeL foldMap recursively, fixing the instance also requires adding extra cases for single element lists, as dividing them is as problematic as dividing empty lists:
instance Foldable MergeL where
foldMap f xs =
case divide xs of
(MergeL [], MergeL []) -> mempty
(ml, MergeL [y]) -> foldMap f ml <> f y
(MergeL [x], mr) -> f x <> foldMap f mr
(ml, MergeL []) -> foldMap f ml
(MergeL [], mr) -> foldMap f mr
(ml, mr) -> foldMap f ml <> foldMap f mr
This gives acceptable performance -- same complexity and order of magnitude of timings than the plain implementation without optimisations, and about the same performance with optimisations.
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