Related
I have this type
data List a = EmptyL | ConsL a (List (a,a))
and I wrote this function
lenL :: List a -> Int
lenL EmptyL = 0
lenL (ConsL x xs) = 1 + lenL xs
Can I write a function like this?
sumL :: List Int -> Int
How?
Sure:
data List a = EmptyL | ConsL a (List (a,a))
pair f (x, y) = (f x, f y)
nest :: (a -> b) -> List a -> List b
nest f EmptyL = EmptyL
nest f (ConsL x xs) = ConsL (f x) (nest (pair f) xs)
sumL :: List Int -> Int
sumL EmptyL = 0
sumL (ConsL x xs) = x + sumL (nest (uncurry (+)) xs)
We have:
*Main> sumL EmptyL
0
*Main> sumL (ConsL 1 EmptyL)
1
*Main> sumL (ConsL 1 (ConsL (2, 3) EmptyL))
6
The "magic" is explained in: http://www.cs.ox.ac.uk/jeremy.gibbons/publications/efolds.pdf
For completeness, here's a full definition in terms of the generalized fold as described in the paper:
import Prelude hiding (sum, fold)
data List a = EmptyL | ConsL (a, List (a, a))
nest :: (a -> b) -> List a -> List b
nest f EmptyL = EmptyL
nest f (ConsL (x, xs)) = ConsL (f x, nest (pair f) xs)
pair :: (a -> b) -> (a, a) -> (b, b)
pair f (x, y) = (f x, f y)
fold :: a -> ((b, a) -> a) -> ((b, b) -> b) -> List b -> a
fold e f g EmptyL = e
fold e f g (ConsL (x, xs)) = f (x, fold e f g (nest g xs))
sum :: List Int -> Int
sum = fold 0 (uncurry (+)) (uncurry (+))
The data type you have is not really for lists, more like complete binary trees. You can convert the trees you have to ordinary lists like this:
toList :: List a -> [a]
toList EmptyL = []
toList (ConsL x xs) = x:uncurry (++) (unzip (toList xs))
Not the most efficient code and the ordering is a bit arbitrary, but it should work. If you want the sum or anything else you can just use sum . toList.
Note that your lenL function does not compute the length of the resulting list, but rather the depth of the original tree. If you want the number of elements in the tree you can use length . toList.
Since sum is a method of Foldable, let's see how we'd implement foldMap:
data List a = EmptyL | ConsL a (List (a,a))
instance Foldable List where
foldMap _ EmptyL = mempty
foldMap f (ConsL a as) = f a <> foldMap (\(x,y) -> f x <> f y) as
We can write sumL = getSum . foldMap Sum.
My problem is how to efficiently memoize an expensive function f :: [Integer] -> a that is defined for all finite lists of integers and has the property f . sort = f?
My typical use case is that given a list as of integers I need to obtain the values f (a:as) for various Integer a, so I'd like to build up simultaneously a directed labelled graph whose vertices are pairs of an Integer list and its function value. An edge labelled by a from (as, f as) to (bs, f bs) exists if and only if a:as = bs.
Stealing from a brilliant answer by Edward Kmett I simply copied
{-# LANGUAGE BangPatterns #-}
data Tree a = Tree (Tree a) a (Tree a)
instance Functor Tree where
fmap f (Tree l m r) = Tree (fmap f l) (f m) (fmap f r)
index :: Tree a -> Integer -> a
index (Tree _ m _) 0 = m
index (Tree l _ r) n = case (n - 1) `divMod` 2 of
(q,0) -> index l q
(q,1) -> index r q
nats :: Tree Integer
nats = go 0 1
where go !n !s = Tree (go l s') n (go r s')
where l = n + s
r = l + s
s' = s * 2
and adapted his idea to my problem as
-- directed graph labelled by Integers
data Graph a = Graph a (Tree (Graph a))
instance Functor Graph where
fmap f (Graph a t) = Graph (f a) (fmap (fmap f) t)
-- walk the graph following the given labels
walk :: Graph a -> [Integer] -> a
walk (Graph a _) [] = a
walk (Graph _ t) (x:xs) = walk (index t x) xs
-- graph of all finite integer sequences
intSeq :: Graph [Integer]
intSeq = Graph [] (fmap (\n -> fmap (n:) intSeq) nats)
-- could be replaced by Data.Strict.Pair
data StrictPair a b = StrictPair !a !b
deriving Show
-- f = sum modified according to Edward's idea (the real function is more complicated)
g :: ([Integer] -> StrictPair Integer [Integer]) -> [Integer] -> StrictPair Integer [Integer]
g mf [] = StrictPair 0 []
g mf (a:as) = StrictPair (a+x) (a:as)
where StrictPair x y = mf as
g_graph :: Graph (StrictPair Integer [Integer])
g_graph = fmap (g g_m) intSeq
g_m :: [Integer] -> StrictPair Integer [Integer]
g_m = walk g_graph
This works OK, but as the function f is independent of the order of the occurring integers (but not of their counts) there should be only one vertex in the graph for all integer lists equal up to ordering.
How do I achieve this?
How about just defining g_m' = g_m . sort, i.e. you simply sort the input list first before calling your memoized function?
I have a feeling this is the best you can do since if you want your memoized graph to consist of only sorted paths someone is going to have to look at all of the elements of the list before constructing the path.
Depending on what your input lists look like it might be helpful to transform them in a way which makes the trees branch less. For instance, you might try sorting and taking differences:
original input list: [8,3,14,8,5]
sorted: [3,3,8,8,14]
diffed: [3,0,5,0,6] -- use this as the key
The transformation is a bijection, and the trees branch less because there are smaller numbers involved.
You can use a bit different approach.
There is a trick in proof that a finite product of countable sets is countable:
We can map the sequence [a1, ..., an] to Nat by product . zipWith (^) primes: 2 ^ a1 * 3 ^ a2 * 5 ^ a3 * ... * primen ^ an.
To avoid problems with sequences with zero at the end, we can increase the last index.
As the sequence is ordered, we can exploit the property as user5402 mentioned.
The benefit of using the tree, is that you can increase branching to speed-up traversal. OTOH prime trick could make indexes quite big, but hopefully some tree paths will just be unexplored (remain as thunks).
{-# LANGUAGE BangPatterns #-}
-- Modified from Kmett's answer:
data Tree a = Tree a (Tree a) (Tree a) (Tree a) (Tree a)
instance Functor Tree where
fmap f (Tree x a b c d) = Tree (f x) (fmap f a) (fmap f b) (fmap f c) (fmap f d)
index :: Tree a -> Integer -> a
index (Tree x _ _ _ _) 0 = x
index (Tree _ a b c d) n = case (n - 1) `divMod` 4 of
(q,0) -> index a q
(q,1) -> index b q
(q,2) -> index c q
(q,3) -> index d q
nats :: Tree Integer
nats = go 0 1
where
go !n !s = Tree n (go a s') (go b s') (go c s') (go d s')
where
a = n + s
b = a + s
c = b + s
d = c + s
s' = s * 4
toList :: Tree a -> [a]
toList as = map (index as) [0..]
-- Primes -- https://www.haskell.org/haskellwiki/Prime_numbers
-- Generation and factorisation could be done much better
minus (x:xs) (y:ys) = case (compare x y) of
LT -> x : minus xs (y:ys)
EQ -> minus xs ys
GT -> minus (x:xs) ys
minus xs _ = xs
primes = 2 : sieve [3..] primes
where
sieve xs (p:ps) | q <- p*p , (h,t) <- span (< q) xs =
h ++ sieve (t `minus` [q, q+p..]) ps
addToLast :: [Integer] -> [Integer]
addToLast [] = []
addToLast [x] = [x + 1]
addToLast (x:xs) = x : addToLast xs
subFromLast :: [Integer] -> [Integer]
subFromLast [] = []
subFromLast [x] = [x - 1]
subFromLast (x:xs) = x : subFromLast xs
addSubProp :: [NonNegative Integer] -> Property
addSubProp xs = xs' === subFromLast (addToLast xs')
where xs' = map getNonNegative xs
-- Trick from user5402 answer
toDiffList :: [Integer] -> [Integer]
toDiffList = toDiffList' 0
where toDiffList' _ [] = []
toDiffList' p (x:xs) = x - p : toDiffList' x xs
fromDiffList :: [Integer] -> [Integer]
fromDiffList = fromDiffList' 0
where fromDiffList' _ [] = []
fromDiffList' p (x:xs) = p + x : fromDiffList' (x + p) xs
diffProp :: [Integer] -> Property
diffProp xs = xs === fromDiffList (toDiffList xs)
listToInteger :: [Integer] -> Integer
listToInteger = product . zipWith (^) primes . addToLast
integerToList :: Integer -> [Integer]
integerToList = subFromLast . impl primes 0
where impl _ _ 0 = []
impl _ 0 1 = []
impl _ k 1 = [k]
impl (p:ps) k n = case n `divMod` p of
(n', 0) -> impl (p:ps) (k + 1) n'
(_, _) -> k : impl ps 0 n
listProp :: [NonNegative Integer] -> Property
listProp xs = xs' === integerToList (listToInteger xs')
where xs' = map getNonNegative xs
toIndex :: [Integer] -> Integer
toIndex = listToInteger . toDiffList
fromIndex :: Integer -> [Integer]
fromIndex = fromDiffList . integerToList
-- [1,0] /= [0]
-- Decreasing sequence!
doesntHold :: [NonNegative Integer] -> Property
doesntHold xs = xs' === fromIndex (toIndex xs')
where xs' = map getNonNegative xs
holds :: [NonNegative Integer] -> Property
holds xs = xs' === fromIndex (toIndex xs')
where xs' = sort $ map getNonNegative xs
g :: ([Integer] -> Integer) -> [Integer] -> Integer
g mg = g' . sort
where g' [] = 0
g' (x:xs) = x + sum (map mg $ tails xs)
g_tree :: Tree Integer
g_tree = fmap (g faster_g' . fromIndex) nats
faster_g' :: [Integer] -> Integer
faster_g' = index g_tree . toIndex
faster_g = faster_g' . sort
On my machine fix g [1..22] feels slow, when faster_g [1..40] is still blazing fast.
Addition: if we have bounded set (with indexes 0..n-1) , we can encode it as: a0 * n^0 + a1 * n^1 ....
We can encode any Integer as binary list, e.g. 11 is [1, 1, 0, 1] (least bit first).
Then if we separate integers in the list with 2, we get sequence of bounded values.
As bonus we can take the sequence of 0, 1, 2 digits and compress it to binary using e.g. Huffman encoding, as 2 is much rarer than 0 or 1. But this might be overkill.
With this trick, indexes stay much smaller and the space probably is better packed.
{-# LANGUAGE BangPatterns #-}
-- From Kment's answer:
import Data.Function (fix)
import Data.List (sort, tails)
import Data.List.Split (splitOn)
import Test.QuickCheck
{-- Tree definition as before --}
-- 0, 1, 2
newtype N3 = N3 { unN3 :: Integer }
deriving (Eq, Show)
instance Arbitrary N3 where
arbitrary = elements $ map N3 [ 0, 1, 2 ]
-- Integer <-> N3
coeffs3 :: [Integer]
coeffs3 = coeffs' 1
where coeffs' n = n : coeffs' (n * 3)
listToInteger :: [N3] -> Integer
listToInteger = sum . zipWith f coeffs3
where f n (N3 m) = n * m
listFromInteger :: Integer -> [N3]
listFromInteger 0 = []
listFromInteger n = case n `divMod` 3 of
(q, m) -> N3 m : listFromInteger q
listProp :: [N3] -> Property
listProp xs = (null xs || last xs /= N3 0) ==> xs === listFromInteger (listToInteger xs)
-- Integer <-> N2
-- 0, 1
newtype N2 = N2 { unN2 :: Integer }
deriving (Eq, Show)
coeffs2 :: [Integer]
coeffs2 = coeffs' 1
where coeffs' n = n : coeffs' (n * 2)
integerToBin :: Integer -> [N2]
integerToBin 0 = []
integerToBin n = case n `divMod` 2 of
(q, m) -> N2 m : integerToBin q
integerFromBin :: [N2] -> Integer
integerFromBin = sum . zipWith f coeffs2
where f n (N2 m) = n * m
binProp :: NonNegative Integer -> Property
binProp (NonNegative n) = n === integerFromBin (integerToBin n)
-- unsafe!
n3ton2 :: N3 -> N2
n3ton2 = N2 . unN3
n2ton3 :: N2 -> N3
n2ton3 = N3 . unN2
-- [Integer] <-> [N3]
integerListToN3List :: [Integer] -> [N3]
integerListToN3List = concatMap (++ [N3 2]) . map (map n2ton3 . integerToBin)
integerListFromN3List :: [N3] -> [Integer]
integerListFromN3List = init . map (integerFromBin . map n3ton2) . splitOn [N3 2]
n3ListProp :: [NonNegative Integer] -> Property
n3ListProp xs = xs' === integerListFromN3List (integerListToN3List xs')
where xs' = map getNonNegative xs
-- Trick from user5402 answer
-- Integer <-> Sorted Integer
toDiffList :: [Integer] -> [Integer]
toDiffList = toDiffList' 0
where toDiffList' _ [] = []
toDiffList' p (x:xs) = x - p : toDiffList' x xs
fromDiffList :: [Integer] -> [Integer]
fromDiffList = fromDiffList' 0
where fromDiffList' _ [] = []
fromDiffList' p (x:xs) = p + x : fromDiffList' (x + p) xs
diffProp :: [Integer] -> Property
diffProp xs = xs === fromDiffList (toDiffList xs)
---
toIndex :: [Integer] -> Integer
toIndex = listToInteger . integerListToN3List . toDiffList
fromIndex :: Integer -> [Integer]
fromIndex = fromDiffList . integerListFromN3List . listFromInteger
-- [1,0] /= [0]
-- Decreasing sequence! doesn't terminate in this case
doesntHold :: [NonNegative Integer] -> Property
doesntHold xs = xs' === fromIndex (toIndex xs')
where xs' = map getNonNegative xs
holds :: [NonNegative Integer] -> Property
holds xs = xs' === fromIndex (toIndex xs')
where xs' = sort $ map getNonNegative xs
g :: ([Integer] -> Integer) -> [Integer] -> Integer
g mg = g' . sort
where g' [] = 0
g' (x:xs) = x + sum (map mg $ tails xs)
g_tree :: Tree Integer
g_tree = fmap (g faster_g' . fromIndex) nats
faster_g' :: [Integer] -> Integer
faster_g' = index g_tree . toIndex
faster_g = faster_g' . sort
Second addition:
I quickly benchmarked graph and binary sequence approach for my g with:
main :: IO ()
main = do
n <- read . head <$> getArgs
print $ faster_g [100, 110..n]
And the results are:
% time ./IntegerMemo 1000
1225560638892526472150132981770
./IntegerMemo 1000 0.19s user 0.01s system 98% cpu 0.200 total
% time ./IntegerMemo 2000
3122858113354873680008305238045814042010921833620857170165770
./IntegerMemo 2000 1.83s user 0.05s system 99% cpu 1.888 total
% time ./IntegerMemo 2500
4399449191298176980662410776849867104410434903220291205722799441218623242250
./IntegerMemo 2500 3.74s user 0.09s system 99% cpu 3.852 total
% time ./IntegerMemo 3000
5947985907461048240178371687835977247601455563536278700587949163642187584269899171375349770
./IntegerMemo 3000 6.66s user 0.13s system 99% cpu 6.830 total
% time ./IntegerMemoGrap 1000
1225560638892526472150132981770
./IntegerMemoGrap 1000 0.10s user 0.01s system 97% cpu 0.113 total
% time ./IntegerMemoGrap 2000
3122858113354873680008305238045814042010921833620857170165770
./IntegerMemoGrap 2000 0.97s user 0.04s system 98% cpu 1.028 total
% time ./IntegerMemoGrap 2500
4399449191298176980662410776849867104410434903220291205722799441218623242250
./IntegerMemoGrap 2500 2.11s user 0.08s system 99% cpu 2.202 total
% time ./IntegerMemoGrap 3000
5947985907461048240178371687835977247601455563536278700587949163642187584269899171375349770
./IntegerMemoGrap 3000 3.33s user 0.09s system 99% cpu 3.452 total
Looks like that graph version is faster by constant factor of 2. But they seem to have same time complexity :)
Looks like my problem is solved by simply replacing intSeq in the definition of g_graph by a monotone version:
-- replace vertexes for non-monotone integer lists by the according monotone one
monoIntSeq :: Graph [Integer]
monoIntSeq = f intSeq
where f (Graph as t) | as == sort as = Graph as $ fmap f t
| otherwise = fetch monIntSeq $ sort as
-- extract the subgraph after following the given labels
fetch :: Graph a -> [Integer] -> Graph a
fetch g [] = g
fetch (Graph _ t) (x:xs) = fetch (index t x) xs
g_graph :: Graph (StrictPair Integer [Integer])
g_graph = fmap (g g_m) monoIntSeq
Many thanks to all (especially user5402 and Oleg) for the help!
Edit: I still have the problem that the memory consumption is to high for my typical use case which can be described by following a path like this:
p :: [Integer]
p = map f [1..]
where f n | n `mod` 6 == 0 = n `div` 6
| n `mod` 3 == 0 = n `div` 3
| n `mod` 2 == 0 = n `div` 2
| otherwise = n
A slight improvement is to define the monotone integer sequences directly like this:
-- extract the subgraph after following the given labels (right to left)
fetch :: Graph a -> [Integer] -> Graph a
fetch = foldl' step
where step (Graph _ t) n = index t n
-- walk the graph following the given labels (right to left)
walk :: Graph a -> [Integer] -> a
walk g ns = a
where Graph a _ = fetch g ns
-- all monotone falling integer sequences
monoIntSeqs :: Graph [Integer]
monoIntSeqs = Graph [] $ fmap (flip f monoIntSeqs) nats
where f n (Graph ns t) | null ns = Graph (n:ns) $ fmap (f n) t
| n >= head ns = Graph (n:ns) $ fmap (f n) t
| otherwise = fetch monoIntSeqs (insert' n ns)
insert' = insertBy (comparing Down)
But at the end I might just use the original integer sequences without identification, identify nodes now and then explicitly and avoid keeping a reference to g_graph etc to let the garbage collection clean up as the program proceeds.
Reading the functional pearl Trouble Shared is Trouble Halved by Richard Bird and Ralf Hinze, I understood how to implement, what I was looking for two years ago (again based on Edward Kmett's trick):
{-# LANGUAGE BangPatterns #-}
import Data.Function (fix)
data Tree a = Tree (Tree a) a (Tree a)
deriving Show
instance Functor Tree where
fmap f (Tree l m r) = Tree (fmap f l) (f m) (fmap f r)
index :: Tree a -> Integer -> a
index (Tree _ m _) 0 = m
index (Tree l _ r) n = case (n - 1) `divMod` 2 of
(q,0) -> index l q
(q,1) -> index r q
nats :: Tree Integer
nats = go 0 1
where go !n !s = Tree (go l s') n (go r s')
where l = n + s
r = l + s
s' = s * 2
data IntSeqTree a = IntSeqTree a (Tree (IntSeqTree a))
val :: IntSeqTree a -> a
val (IntSeqTree a _) = a
step :: Integer -> IntSeqTree t -> IntSeqTree t
step n (IntSeqTree _ ts) = index ts n
intSeqTree :: IntSeqTree [Integer]
intSeqTree = fix $ create []
where create p x = IntSeqTree p $ fmap (extend x) nats
extend x n = case span (>n) (val x) of
([], p) -> fix $ create (n:p)
(m, p) -> foldr step intSeqTree (m ++ n:p)
instance Functor IntSeqTree where
fmap f (IntSeqTree a t) = IntSeqTree (f a) (fmap (fmap f) t)
In my use case I have hundreds or thousands of similar integer sequences (of length few hundred entries) that are generated incrementally. So for me this way is cheaper than sorting the sequences before looking up the function value (which I will access by using fmap on intSeqTree).
I want to take a list (or a string) and split it into sub-lists of N elements. How do I do it in Haskell?
Example:
mysteryFunction 2 "abcdefgh"
["ab", "cd", "ef", "gh"]
cabal update
cabal install split
And then use chunksOf from Data.List.Split
Here's one option:
partition :: Int -> [a] -> [[a]]
partition _ [] = []
partition n xs = (take n xs) : (partition n (drop n xs))
And here's a tail recursive version of that function:
partition :: Int -> [a] -> [[a]]
partition n xs = partition' n xs []
where
partition' _ [] acc = reverse acc
partition' n xs acc = partition' n (drop n xs) ((take n xs) : acc)
You could use:
mysteryFunction :: Int -> [a] -> [[a]]
mysteryFunction n list = unfoldr takeList list
where takeList [] = Nothing
takeList l = Just $ splitAt n l
or alternatively:
mysteryFunction :: Int -> [a] -> [[a]]
mysteryFunction n list = unfoldr (\l -> if null l then Nothing else Just $ splitAt n l) list
Note this puts any remaining elements in the last list, for example
mysteryFunction 2 "abcdefg" = ["ab", "cd", "ef", "g"]
import Data.List
import Data.Function
mysteryFunction n = map (map snd) . groupBy ((==) `on` fst) . zip ([0..] >>= replicate n)
... just kidding...
mysteryFunction x "" = []
mysteryFunction x s = take x s : mysteryFunction x (drop x s)
Probably not the elegant solution you had in mind.
There's already
Prelude Data.List> :t either
either :: (a -> c) -> (b -> c) -> Either a b -> c
and
Prelude Data.List> :t maybe
maybe :: b -> (a -> b) -> Maybe a -> b
so there really should be
list :: t -> ([a] -> t) -> [a] -> t
list n _ [] = n
list _ c xs = c xs
as well. With it,
import Data.List (unfoldr)
g n = unfoldr $ list Nothing (Just . splitAt n)
without it,
g n = takeWhile (not.null) . unfoldr (Just . splitAt n)
A fancy answer.
In the answers above you have to use splitAt, which is recursive, too. Let's see how we can build a recursive solution from scratch.
Functor L(X)=1+A*X can map X into a 1 or split it into a pair of A and X, and has List(A) as its minimal fixed point: List(A) can be mapped into 1+A*List(A) and back using a isomorphism; in other words, we have one way to decompose a non-empty list, and only one way to represent a empty list.
Functor F(X)=List(A)+A*X is similar, but the tail of the list is no longer a empty list - "1" - so the functor is able to extract a value A or turn X into a list of As. Then List(A) is its fixed point (but no longer the minimal fixed point), the functor can represent any given list as a List, or as a pair of a element and a list. In effect, any coalgebra can "stop" decomposing the list "at will".
{-# LANGUAGE DeriveFunctor #-}
import Data.Functor.Foldable
data N a x = Z [a] | S a x deriving (Functor)
(which is the same as adding the following trivial instance):
instance Functor (N a) where
fmap f (Z xs) = Z xs
fmap f (S x y) = S x $ f y
Consider the definition of hylomorphism:
hylo :: (f b -> b) -> (c -> f c) -> c -> b
hylo psi phi = psi . fmap (hylo psi phi) . phi
Given a seed value, it uses phi to produce f c, to which fmap applies hylo psi phi recursively, and psi then extracts b from the fmapped structure f b.
A hylomorphism for the pair of (co)algebras for this functor is a splitAt:
splitAt :: Int -> [a] -> ([a],[a])
splitAt n xs = hylo psi phi (n, xs) where
phi (n, []) = Z []
phi (0, xs) = Z xs
phi (n, (x:xs)) = S x (n-1, xs)
This coalgebra extracts a head, as long as there is a head to extract and the counter of extracted elements is not zero. This is because of how the functor was defined: as long as phi produces S x y, hylo will feed y into phi as the next seed; once Z xs is produced, functor no longer applies hylo psi phi to it, and the recursion stops.
At the same time hylo will re-map the structure into a pair of lists:
psi (Z ys) = ([], ys)
psi (S h (t, b)) = (h:t, b)
So now we know how splitAt works. We can extend that to splitList using apomorphism:
splitList :: Int -> [a] -> [[a]]
splitList n xs = apo (hylo psi phi) (n, xs) where
phi (n, []) = Z []
phi (0, xs) = Z xs
phi (n, (x:xs)) = S x (n-1, xs)
psi (Z []) = Cons [] $ Left []
psi (Z ys) = Cons [] $ Right (n, ys)
psi (S h (Cons t b)) = Cons (h:t) b
This time the re-mapping is fitted for use with apomorphism: as long as it is Right, apomorphism will keep using hylo psi phi to produce the next element of the list; if it is Left, it produces the rest of the list in one step (in this case, just finishes off the list with []).
I've been trying to learn a bit of functional programming (with Haskell & Erlang) lately and I'm always amazed at the succinct solutions people can come up with when they can think recursively and know the tools.
I want a function to convert a list of sorted, unique, non-contiguous integers into a list of contiguous lists, i.e:
[1,2,3,6,7,8,10,11]
to:
[[1,2,3], [6,7,8], [10,11]
This was the best I could come up with in Haskell (two functions)::
make_ranges :: [[Int]] -> [Int] -> [[Int]]
make_ranges ranges [] = ranges
make_ranges [] (x:xs)
| null xs = [[x]]
| otherwise = make_ranges [[x]] xs
make_ranges ranges (x:xs)
| (last (last ranges)) + 1 == x =
make_ranges ((init ranges) ++ [(last ranges ++ [x])]) xs
| otherwise = make_ranges (ranges ++ [[x]]) xs
rangify :: [Int] -> [[Int]]
rangify lst = make_ranges [] lst
It might be a bit subjective but I'd be interested to see a better, more elegant, solution to this in either Erlang or Haskell (other functional languages too but I might not understand it.) Otherwise, points for just fixing my crappy beginner's Haskell style!
Most straightforward way in my mind is a foldr:
ranges = foldr step []
where step x [] = [[x]]
step x acc#((y:ys):zs) | y == x + 1 = (x:y:ys):zs
| otherwise = [x]:acc
Or, more concisely:
ranges = foldr step []
where step x ((y:ys):zs) | y == x + 1 = (x:y:ys):zs
step x acc = [x]:acc
But wait, there's more!
abstractRanges f = foldr step []
where step x ((y:ys):zs) | f x y = (x:y:ys):zs
step x acc = [x]:acc
ranges = abstractRanges (\x y -> y == x + 1)
powerRanges = abstractRanges (\x y -> y == x*x) -- mighty morphin
By turning the guard function into a parameter, you can group more interesting things than just +1 sequences.
*Main> powerRanges [1,1,1,2,4,16,3,9,81,5,25]
[[1,1,1],[2,4,16],[3,9,81],[5,25]]
The utility of this particular function is questionable...but fun!
I can't believe I got the shortest solution. I know this is no code golf, but I think it is still quite readable:
import GHC.Exts
range xs = map (map fst) $ groupWith snd $ zipWith (\a b -> (a, a-b)) xs [0..]
or pointfree
range = map (map snd) . groupWith fst . zipWith (\a b -> (b-a, b)) [0..]
BTW, groupWith snd can be replaced with groupBy (\a b -> snd a == snd b) if you prefer Data.List over GHC.Exts
[Edit]
BTW: Is there a nicer way to get rid of the lambda (\a b -> (b-a, b)) than (curry $ (,) <$> ((-) <$> snd <*> fst) <*> snd) ?
[Edit 2]
Yeah, I forgot (,) is a functor. So here is the obfuscated version:
range = map (map fst) . groupWith snd . (flip $ zipWith $ curry $ fmap <$> (-).fst <*> id) [0..]
Suggestions are welcome...
import Data.List (groupBy)
ranges xs = (map.map) snd
. groupBy (const fst)
. zip (True : zipWith ((==) . succ) xs (tail xs))
$ xs
As to how to come up with such a thing: I started with the zipWith f xs (tail xs), which is a common idiom when you want to do something on consecutive elements of a list. Likewise is zipping up a list with information about the list, and then acting (groupBy) upon it. The rest is plumbing.
Then, of course, you can feed it through #pl and get:
import Data.List (groupBy)
import Control.Monad (ap)
import Control.Monad.Instances()
ranges = (((map.map) snd)
. groupBy (const fst))
.) =<< zip
. (True:)
. ((zipWith ((==) . succ)) `ap` tail)
, which, by my authoritative definition, is evil due to Mondad ((->) a). Twice, even. The data flow is meandering too much to lay it out in any sensible way. zipaptail is an Aztec god, and Aztec gods aren't to be messed with.
Another version in Erlang:
part(List) -> part(List,[]).
part([H1,H2|T],Acc) when H1 =:= H2 - 1 ->
part([H2|T],[H1|Acc]);
part([H1|T],Acc) ->
[lists:reverse([H1|Acc]) | part(T,[])];
part([],Acc) -> Acc.
k z = map (fst <$>) . groupBy (const snd) .
zip z . (False:) . (zipWith ((==) . succ) <*> tail) $ z
Try reusing standard functions.
import Data.List (groupBy)
rangeify :: (Num a) => [a] -> [[a]]
rangeify l = map (map fst) $ groupBy (const snd) $ zip l contigPoints
where contigPoints = False : zipWith (==) (map (+1) l) (drop 1 l)
Or, following (mixed) advice to use unfoldr, stop abusing groupBy, and be happy using partial functions when it doesn't matter:
import Control.Arrow ((***))
import Data.List (unfoldr)
spanContig :: (Num a) => [a] -> [[a]]
spanContig l =
map fst *** map fst $ span (\(a, b) -> a == b + 1) $ zip l (head l - 1 : l)
rangeify :: (Num a) => [a] -> [[a]]
rangeify = unfoldr $ \l -> if null l then Nothing else Just $ spanContig l
Erlang using foldr:
ranges(List) ->
lists:foldr(fun (X, [[Y | Ys], Acc]) when Y == X + 1 ->
[[X, Y | Ys], Acc];
(X, Acc) ->
[[X] | Acc]
end, [], List).
This is my v0.1 and I can probably make it better:
makeCont :: [Int] -> [[Int]]
makeCont [] = []
makeCont [a] = [[a]]
makeCont (a:b:xs) = if b - a == 1
then (a : head next) : tail next
else [a] : next
where
next :: [[Int]]
next = makeCont (b:xs)
And I will try and make it better. Edits coming I think.
As a comparison, here's an implementation in Erlang:
partition(L) -> [lists:reverse(T) || T <- lists:reverse(partition(L, {[], []}))].
partition([E|L], {R, [EL|_] = T}) when E == EL + 1 -> partition(L, {R, [E|T]});
partition([E|L], {R, []}) -> partition(L, {R, [E]});
partition([E|L], {R, T}) -> partition(L, {[T|R], [E]});
partition([], {R, []}) -> R;
partition([], {R, T}) -> [T|R].
The standard paramorphism recursion scheme isn't in Haskell's Data.List module, though I think it should be. Here's a solution using a paramorphism, because you are building a list-of-lists from a list, the cons-ing is a little tricksy:
contig :: (Eq a, Num a) => [a] -> [[a]]
contig = para phi [] where
phi x ((y:_),(a:acc)) | x + 1 == y = (x:a):acc
phi x (_, acc) = [x]:acc
Paramorphism is general recursion or a fold with lookahead:
para :: (a -> ([a], b) -> b) -> b -> [a] -> b
para phi b [] = b
para phi b (x:xs) = phi x (xs, para phi b xs)
It can be pretty clear and simple in the Erlang:
partition([]) -> [];
partition([A|T]) -> partition(T, [A]).
partition([A|T], [B|_]=R) when A =:= B+1 -> partition(T, [A|R]);
partition(L, P) -> [lists:reverse(P)|partition(L)].
Edit: Just for curiosity I have compared mine and Lukas's version and mine seems about 10% faster either in native either in bytecode version on testing set what I generated by lists:usort([random:uniform(1000000)||_<-lists:seq(1,1000000)]) on R14B01 64b version at mine notebook. (Testing set is 669462 long and has been partitioned to 232451 sublists.)
Edit2: Another test data lists:usort([random:uniform(1000000)||_<-lists:seq(1,10000000)]), length 999963 and 38 partitions makes bigger diference in native code. Mine version finish in less than half of time. Bytecode version is only about 20% faster.
Edit3: Some microoptimizations which provides additional performance but leads to more ugly and less maintainable code:
part4([]) -> [];
part4([A|T]) -> part4(T, A, []).
part4([A|T], B, R) when A =:= B+1 -> part4(T, A, [B|R]);
part4([A|T], B, []) -> [[B]|part4(T, A, [])];
part4([A|T], B, R) -> [lists:reverse(R, [B])|part4(T, A, [])];
part4([], B, R) -> [lists:reverse(R,[B])].
Here's an attempt from a haskell noob
ranges ls = let (a, r) = foldl (\(r, a#(h:t)) e -> if h + 1 == e then (r, e:a) else (a:r, [e])) ([], [head ls]) (tail ls)
in reverse . map reverse $ r : a
A couple of times I've found myself wanting a zip in Haskell that adds padding to the shorter list instead of truncating the longer one. This is easy enough to write. (Monoid works for me here, but you could also just pass in the elements that you want to use for padding.)
zipPad :: (Monoid a, Monoid b) => [a] -> [b] -> [(a, b)]
zipPad xs [] = zip xs (repeat mempty)
zipPad [] ys = zip (repeat mempty) ys
zipPad (x:xs) (y:ys) = (x, y) : zipPad xs ys
This approach gets ugly when trying to define zipPad3. I typed up the following and then realized that of course it doesn't work:
zipPad3 :: (Monoid a, Monoid b, Monoid c) => [a] -> [b] -> [c] -> [(a, b, c)]
zipPad3 xs [] [] = zip3 xs (repeat mempty) (repeat mempty)
zipPad3 [] ys [] = zip3 (repeat mempty) ys (repeat mempty)
zipPad3 [] [] zs = zip3 (repeat mempty) (repeat mempty) zs
zipPad3 xs ys [] = zip3 xs ys (repeat mempty)
zipPad3 xs [] zs = zip3 xs (repeat mempty) zs
zipPad3 [] ys zs = zip3 (repeat mempty) ys zs
zipPad3 (x:xs) (y:ys) (z:zs) = (x, y, z) : zipPad3 xs ys zs
At this point I cheated and just used length to pick the longest list and pad the others.
Am I overlooking a more elegant way to do this, or is something like zipPad3 already defined somewhere?
How about custom head and tail functions (named next and rest in my example below)?
import Data.Monoid
zipPad :: (Monoid a, Monoid b) => [a] -> [b] -> [(a,b)]
zipPad [] [] = []
zipPad xs ys = (next xs, next ys) : zipPad (rest xs) (rest ys)
zipPad3 :: (Monoid a, Monoid b, Monoid c) => [a] -> [b] -> [c] -> [(a,b,c)]
zipPad3 [] [] [] = []
zipPad3 xs ys zs = (next xs, next ys, next zs) : zipPad3 (rest xs) (rest ys) (rest zs)
next :: (Monoid a) => [a] -> a
next [] = mempty
next xs = head xs
rest :: (Monoid a) => [a] -> [a]
rest [] = []
rest xs = tail xs
Test snippet:
instance Monoid Int where
mempty = 0
mappend = (+)
main = do
print $ zipPad [1,2,3,4 :: Int] [1,2 :: Int]
print $ zipPad3 [1,2,3,4 :: Int] [9 :: Int] [1,2 :: Int]
Its output:
[(1,1),(2,2),(3,0),(4,0)]
[(1,9,1),(2,0,2),(3,0,0),(4,0,0)]
This pattern comes up quite a lot. A solution I learned from Paul Chiusano is as follows:
data These a b = This a | That b | These a b
class Align f where
align :: (These a b -> c) -> f a -> f b -> f c
instance Align [] where
align f [] [] = []
align f (x:xs) [] = f (This x) : align f xs []
align f [] (y:ys) = f (That y) : align f [] ys
align f (x:xs) (y:ys) = f (These x y) : align f xs ys
liftAlign2 f a b = align t
where t (This l) = f l b
t (That r) = f a r
t (These l r) = f l r
zipPad a b = liftAlign2 (,) a b
liftAlign3 f a b c xs ys = align t (zipPad a b xs ys)
where t (This (x,y)) = f x y c
t (That r) = f a b r
t (These (x,y) r) = f x y r
zipPad3 a b c = liftAlign3 (,,) a b c
A little test in ghci:
*Main> zipPad3 ["foo", "bar", "baz"] [2, 4, 6, 8] [True, False] "" 0 False
[("foo",2,True),("bar",4,False),("baz",6,False),("",8,False)]
A simpler way to do this is with Maybe. I will illustrate with Edward's
more general formulation:
import Data.Maybe
import Control.Applicative
zipWithTails l r f as bs = catMaybes . takeWhile isJust $
zipWith fMaybe (extend as) (extend bs)
where
extend xs = map Just xs ++ repeat Nothing
fMaybe a b = liftA2 f a b <|> fmap l a <|> fmap r b
There are times when you want to be able to apply a different function to either tail rather than just supply mempty or manual zeroes as well:
zipWithTail :: (a -> a -> a) -> [a] -> [a] -> [a]
zipWithTail f (a:as) (b:bs) = f a b : zipWithTails f as bs
zipWithTail f [] bs = bs
zipWithTail f as _ = as
zipWithTails :: (a -> c) -> (b -> c) -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithTails l r f (a:as) (b:bs) = f a b : zipWithTails l r f as bs
zipWithTails _ r _ [] bs = fmap r bs
zipWithTails l _ _ as _ = fmap l as
I use the former when I'm doing something like zipWithTail (+)
and the former when I need to do something like zipWithTail (*b) (a*) (\da db -> a*db+b*da) since the former can be much more efficient than feeding a default into a function, and the latter a little bit so.
However, if you just wanted to make a more succinct version of what you have, you could probably turn to mapAccumL ,but its not any clearer, and the ++ can be expensive.
zipPad as bs = done $ mapAccumL go as bs
where go (a:as) b = (as,(a,b))
go [] b = ([],(mempty,b))
done (cs, both) = both ++ fmap (\x -> (x, mempty)) cs