Related
I'm interested in writing an efficient Haskell function triangularize :: [a] -> [[a]] that takes a (perhaps infinite) list and "triangularizes" it into a list of lists. For example, triangularize [1..19] should return
[[1, 3, 6, 10, 15]
,[2, 5, 9, 14]
,[4, 8, 13, 19]
,[7, 12, 18]
,[11, 17]
,[16]]
By efficient, I mean that I want it to run in O(n) time where n is the length of the list.
Note that this is quite easy to do in a language like Python, because appending to the end of a list (array) is a constant time operation. A very imperative Python function which accomplishes this is:
def triangularize(elements):
row_index = 0
column_index = 0
diagonal_array = []
for a in elements:
if row_index == len(diagonal_array):
diagonal_array.append([a])
else:
diagonal_array[row_index].append(a)
if row_index == 0:
(row_index, column_index) = (column_index + 1, 0)
else:
row_index -= 1
column_index += 1
return diagonal_array
This came up because I have been using Haskell to write some "tabl" sequences in the On-Line Encyclopedia of Integer Sequences (OEIS), and I want to be able to transform an ordinary (1-dimensional) sequence into a (2-dimensional) sequence of sequences in exactly this way.
Perhaps there's some clever (or not-so-clever) way to foldr over the input list, but I haven't been able to sort it out.
Make increasing size chunks:
chunks :: [a] -> [[a]]
chunks = go 0 where
go n [] = []
go n as = b : go (n+1) e where (b,e) = splitAt n as
Then just transpose twice:
diagonalize :: [a] -> [[a]]
diagonalize = transpose . transpose . chunks
Try it in ghci:
> diagonalize [1..19]
[[1,3,6,10,15],[2,5,9,14],[4,8,13,19],[7,12,18],[11,17],[16]]
This appears to be directly related to the set theory argument proving that the set of integer pairs are in one-to-one correspondence with the set of integers (denumerable). The argument involves a so-called Cantor pairing function.
So, out of curiosity, let's see if we can get a diagonalize function that way.
Define the infinite list of Cantor pairs recursively in Haskell:
auxCantorPairList :: (Integer, Integer) -> [(Integer, Integer)]
auxCantorPairList (x,y) =
let nextPair = if (x > 0) then (x-1,y+1) else (x+y+1, 0)
in (x,y) : auxCantorPairList nextPair
cantorPairList :: [(Integer, Integer)]
cantorPairList = auxCantorPairList (0,0)
And try that inside ghci:
λ> take 15 cantorPairList
[(0,0),(1,0),(0,1),(2,0),(1,1),(0,2),(3,0),(2,1),(1,2),(0,3),(4,0),(3,1),(2,2),(1,3),(0,4)]
λ>
We can number the pairs, and for example extract the numbers for those pairs which have a zero x coordinate:
λ>
λ> xs = [1..]
λ> take 5 $ map fst $ filter (\(n,(x,y)) -> (x==0)) $ zip xs cantorPairList
[1,3,6,10,15]
λ>
We recognize this is the top row from the OP's result in the text of the question.
Similarly for the next two rows:
λ>
λ> makeRow xs row = map fst $ filter (\(n,(x,y)) -> (x==row)) $ zip xs cantorPairList
λ> take 5 $ makeRow xs 1
[2,5,9,14,20]
λ>
λ> take 5 $ makeRow xs 2
[4,8,13,19,26]
λ>
From there, we can write our first draft of a diagonalize function:
λ>
λ> printAsLines xs = mapM_ (putStrLn . show) xs
λ> diagonalize xs = takeWhile (not . null) $ map (makeRow xs) [0..]
λ>
λ> printAsLines $ diagonalize [1..19]
[1,3,6,10,15]
[2,5,9,14]
[4,8,13,19]
[7,12,18]
[11,17]
[16]
λ>
EDIT: performance update
For a list of 1 million items, the runtime is 18 sec, and 145 seconds for 4 millions items. As mentioned by Redu, this seems like O(n√n) complexity.
Distributing the pairs among the various target sublists is inefficient, as most filter operations fail.
To improve performance, we can use a Data.Map structure for the target sublists.
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE ScopedTypeVariables #-}
import qualified Data.List as L
import qualified Data.Map as M
type MIL a = M.Map Integer [a]
buildCantorMap :: forall a. [a] -> MIL a
buildCantorMap xs =
let ts = zip xs cantorPairList -- triplets (a,(x,y))
m0 = (M.fromList [])::MIL a
redOp m (n,(x,y)) = let afn as = case as of
Nothing -> Just [n]
Just jas -> Just (n:jas)
in M.alter afn x m
m1r = L.foldl' redOp m0 ts
in
fmap reverse m1r
diagonalize :: [a] -> [[a]]
diagonalize xs = let cm = buildCantorMap xs
in map snd $ M.toAscList cm
With that second version, performance appears to be much better: 568 msec for the 1 million items list, 2669 msec for the 4 millions item list. So it is close to the O(n*Log(n)) complexity we could have hoped for.
It might be a good idea to craete a comb filter.
So what does comb filter do..? It's like splitAt but instead of splitting at a single index it sort of zips the given infinite list with the given comb to separate the items coressponding to True and False in the comb. Such that;
comb :: [Bool] -- yields [True,False,True,False,False,True,False,False,False,True...]
comb = iterate (False:) [True] >>= id
combWith :: [Bool] -> [a] -> ([a],[a])
combWith _ [] = ([],[])
combWith (c:cs) (x:xs) = let (f,s) = combWith cs xs
in if c then (x:f,s) else (f,x:s)
λ> combWith comb [1..19]
([1,3,6,10,15],[2,4,5,7,8,9,11,12,13,14,16,17,18,19])
Now all we need to do is to comb our infinite list and take the fst as the first row and carry on combing the snd with the same comb.
Lets do it;
diags :: [a] -> [[a]]
diags [] = []
diags xs = let (h,t) = combWith comb xs
in h : diags t
λ> diags [1..19]
[ [1,3,6,10,15]
, [2,5,9,14]
, [4,8,13,19]
, [7,12,18]
, [11,17]
, [16]
]
also seems to be lazy too :)
λ> take 5 . map (take 5) $ diags [1..]
[ [1,3,6,10,15]
, [2,5,9,14,20]
, [4,8,13,19,26]
, [7,12,18,25,33]
, [11,17,24,32,41]
]
I think the complexity could be like O(n√n) but i can not make sure. Any ideas..?
the type is defined as follows:
gap :: (Eq a) => a -> a -> [a] -> Maybe Int
I have been stuck on this problem for more than an hour and have no idea how to approach the problem. I am aware that it requires the use of fold and am familiar with that topic.
Please take into consideration that either foldl or foldr must be used.
The output when called ought to look like this
gap 3 8 [1..10]
=Just 5
gap 8 3 [1..10]
=Nothing
gap 'h' 'l' "hello"
=Just 2
gap 'h' 'z' "hello"
=Nothing
You might dropWhile the list until you find the starting element and then fold from the right, starting with Nothing, replacing that with Just 1 once you hit the end element, and fmaping +1 to the accumulator. In code:
gap :: Eq a => a -> a -> [a] -> Maybe Int
gap from to xs = case dropWhile (/= from) xs of
[] -> Nothing
(_:rest) -> gap' to rest
gap' :: Eq a => a -> [a] -> Maybe Int
gap' to = foldr f Nothing
where f x acc | x == to = Just 1
| otherwise = (+1) <$> acc
The nice thing is that it works correctly if you have several occurences of the elements in your sequence:
*Main> gap 3 8 $ [1..10] ++ [1..10]
Just 5
*Main> gap 3 8 [1, 2, 3, 3, 3, 8]
Just 3
Maybe my solution isn't nice, but it works
import Control.Monad
import Data.Function
import Data.Foldable
(...) = (.) . (.)
gap x y = liftA2 ((guard . (> 0) =<<) ... liftA2 (subtract `on` fst))
(find ((==x) . snd)) (find((==y) . snd)) . zip [0..]
I have list of lists of Int and I need to add an Int value to the last list from the list of lists. How can I do this? My attempt is below
f :: [[Int]] -> [Int] -> Int -> Int -> Int -> [[Int]]
f xs [] cur done total = [[]]
f xs xs2 cur done total = do
if total >= length xs2 then
xs
else
if done == fib cur then
f (xs ++ [[]]) xs2 (cur + 1) 0 total
else
f ((last xs) ++ [[xs2!!total]]) xs2 cur (done + 1) (total + 1)
The problem is:
We have a list A of Int
And we need to slpit it on N lists B_1 ,..., B_n , length of B_i is i-th Fibonacci number.
If we have list [1 , 2 , 3 , 4 , 5 , 6 , 7] (xs2 in my code)
The result should be [[1] , [2] , [3 , 4] , [5 , 6 , 7]]
The easy way to deal with problems like this is to separate the problem into sub-problems. In this case, you want to change the last item in a list. The way you want to change it is by adding an item to it.
First let's tackle changing the last item of a list. We'll do this by applying a function to the last item, but not to any other items.
onLast :: [a] -> (a -> a) -> [a]
onLast xs f = go xs
where
go [] = []
go [x] = [f x]
go (x:xs) = x:go xs
You want to change the last item in the list by adding an additional value, which you can do with (++ [value]).
Combining the two with the value you want to add (xs2!!total) we get
(onLast xs (++ [xs2!!total]))
f :: [[Int]] -> Int -> [[Int]]
f [] _ = []
f xs i = (take n xs) ++ [[x + i | x <- last xs]]
where n = (length xs) - 1
last = head . (drop n)
For example,
*Main> f [[1, 2, 3], [], [4, 5, 6]] 5
[[1,2,3],[],[9,10,11]]
*Main> f [[1, 2, 3]] 5
[[6,7,8]]
*Main> f [] 3
You approach uses a do block, this is kind of weird since do blocks are usually used for monads. Furthermore it is rather unclear what cur, done and total are doing. Furthermore you use (!!) :: [a] -> Int -> a and length :: [a] -> Int. The problem with these functions is that these run in O(n), so it makes the code inefficient as well.
Based on changed specifications, you want to split the list in buckets with length the Fibonacci numbers. In that case the signature should be:
f :: [a] -> [[a]]
because as input you give a list of numbers, and as output, you return a list of numbers. We can then implement that as:
f :: [a] -> [[a]]
f = g 0 1
where g _ _ [] = []
g a b xs = xa : g b (a+b) xb
where (xa,xb) = splitAt b xs
This generates:
*Main> f [1,2,3,4,5,6]
[[1],[2],[3,4],[5,6]]
*Main> f [1,2,3,4,5,6,7]
[[1],[2],[3,4],[5,6,7]]
*Main> f [1,2,3,4,5,6,7,8]
[[1],[2],[3,4],[5,6,7],[8]]
*Main> f [1,2,3,4,5,6,7,8,9]
[[1],[2],[3,4],[5,6,7],[8,9]]
The code works as follows: we state that f = g 0 1 so we pass the arguments of f to g, but g also gets an 0 and a 1 (the first Fibonacci numbers).
Each iteration g checks whether we reached the end of the list. If so, we return an empty list as well. Otherwise we determine the last Fibonacci number that far (b), and use a splitAt to obtain the first b elements of the list we process, as well as the remainder. We then emit the first part as head of the list, and for the tail we calculate the next Fibonacci number and pass that to g with the tail of splitAt.
I've been working with problems (such as pentagonal numbers) that involve generating a list based on the previous elements in the list. I can't seem to find a built-in function of the form I want. Essentially, I'm looking for a function of the form:
([a] -> a) -> [a] -> [a]
Where ([a] -> a) takes the list so far and yields the next element that should be in the list and a or [a] is the initial list. I tried using iterate to achieve this, but that yields a list of lists, which each successive list having one more element (so to get the 3000th element I have to do (list !! 3000) !! 3000) instead of list !! 3000.
If the recurrence depends on a constant number of previous terms, then you can define the series using standard corecursion, like with the fibonacci sequence:
-- fibs(0) = 1
-- fibs(1) = 1
-- fibs(n+2) = fibs(n) + fibs(n+1)
fibs = 1 : 1 : zipWith (+) fibs (tail fibs)
-- foos(0) = -1
-- foos(1) = 0
-- foos(2) = 1
-- foos(n+3) = foos(n) - 2*foos(n+1) + foos(n+2)
foos = -1 : 0 : 1 : zipWith (+) foos
(zipWith (+)
(map (negate 2 *) (tail foos))
(tail $ tail foos))
Although you can introduce some custom functions to make the syntax a little nicer
(#) = flip drop
infixl 7 #
zipMinus = zipWith (-)
zipPlus = zipWith (+)
-- foos(1) = 0
-- foos(2) = 1
-- foos(n+3) = foos(n) - 2*foos(n+1) + foos(n+2)
foos = -1 : 0 : 1 : ( ( foos # 0 `zipMinus` ((2*) <$> foos # 1) )
`zipPlus` foos # 2 )
However, if the number of terms varies, then you'll need a different approach.
For example, consider p(n), the number of ways in which a given positive integer can be expressed as a sum of positive integers.
p(n) = p(n-1) + p(n-2) - p(n-5) - p(n-7) + p(n-12) + p(n-15) - ...
We can define this more simply as
p(n) = ∑ k ∈ [1,n) q(k) p(n-k)
Where
-- q( i ) | i == (3k^2+5k)/2 = (-1) ^ k
-- | i == (3k^2+7k+2)/2 = (-1) ^ k
-- | otherwise = 0
q = go id 1
where go zs c = zs . zs . (c:) . zs . (c:) $ go ((0:) . zs) (negate c)
ghci> take 15 $ zip [1..] q
[(1,1),(2,1),(3,0),(4,0),(5,-1),(6,0),(7,-1),(8,0),(9,0),(10,0),(11,0),(12,1),
(13,0),(14,0),(15,1)]
Then we could use iterate to define p:
p = map head $ iterate next [1]
where next xs = sum (zipWith (*) q xs) : xs
Note how iterate next creates a series of reversed prefixes of p to make it easy to use q to calculate the next element of p. We then take the head element of each of these reversed prefixes to find p.
ghci> next [1]
[1,1]
ghci> next it
[2,1,1]
ghci> next it
[3,2,1,1]
ghci> next it
[5,3,2,1,1]
ghci> next it
[7,5,3,2,1,1]
ghci> next it
[11,7,5,3,2,1,1]
ghci> next it
[15,11,7,5,3,2,1,1]
ghci> next it
[22,15,11,7,5,3,2,1,1]
Abstracting this out to a pattern, we can get the function you were looking for:
construct :: ([a] -> a) -> [a] -> [a]
construct f = map head . iterate (\as -> f as : as)
p = construct (sum . zipWith (*) q) [1]
Alternately, we could do this in the standard corecursive style if we define a helper function to generate the reversed prefixes of a list:
rInits :: [a] -> [[a]]
rInits = scanl (flip (:)) []
p = 1 : map (sum . zipWith (*) q) (tail $ rInits p)
What's the most direct/efficient way to create all possibilities of dividing one (even) list into two in Haskell? I toyed with splitting all permutations of the list but that would add many extras - all the instances where each half contains the same elements, just in a different order. For example,
[1,2,3,4] should produce something like:
[ [1,2], [3,4] ]
[ [1,3], [2,4] ]
[ [1,4], [2,3] ]
Edit: thank you for your comments -- the order of elements and the type of the result is less important to me than the concept - an expression of all two-groups from one group, where element order is unimportant.
Here's an implementation, closely following the definition.
The first element always goes into the left group. After that, we add the next head element into one, or the other group. If one of the groups becomes too big, there is no choice anymore and we must add all the rest into the the shorter group.
divide :: [a] -> [([a], [a])]
divide [] = [([],[])]
divide (x:xs) = go ([x],[], xs, 1,length xs) []
where
go (a,b, [], i,j) zs = (a,b) : zs -- i == lengh a - length b
go (a,b, s#(x:xs), i,j) zs -- j == length s
| i >= j = (a,b++s) : zs
| (-i) >= j = (a++s,b) : zs
| otherwise = go (x:a, b, xs, i+1, j-1) $ go (a, x:b, xs, i-1, j-1) zs
This produces
*Main> divide [1,2,3,4]
[([2,1],[3,4]),([3,1],[2,4]),([1,4],[3,2])]
The limitation of having an even length list is unnecessary:
*Main> divide [1,2,3]
[([2,1],[3]),([3,1],[2]),([1],[3,2])]
(the code was re-written in the "difference-list" style for efficiency: go2 A zs == go1 A ++ zs).
edit: How does this work? Imagine yourself sitting at a pile of stones, dividing it into two. You put the first stone to a side, which one it doesn't matter (so, left, say). Then there's a choice where to put each next stone — unless one of the two piles becomes too small by comparison, and we thus must put all the remaining stones there at once.
To find all partitions of a non-empty list (of even length n) into two equal-sized parts, we can, to avoid repetitions, posit that the first element shall be in the first part. Then it remains to find all ways to split the tail of the list into one part of length n/2 - 1 and one of length n/2.
-- not to be exported
splitLen :: Int -> Int -> [a] -> [([a],[a])]
splitLen 0 _ xs = [([],xs)]
splitLen _ _ [] = error "Oops"
splitLen k l ys#(x:xs)
| k == l = [(ys,[])]
| otherwise = [(x:us,vs) | (us,vs) <- splitLen (k-1) (l-1) xs]
++ [(us,x:vs) | (us,vs) <- splitLen k (l-1) xs]
does that splitting if called appropriately. Then
partitions :: [a] -> [([a],[a])]
partitions [] = [([],[])]
partitions (x:xs)
| even len = error "Original list with odd length"
| otherwise = [(x:us,vs) | (us,vs) <- splitLen half len xs]
where
len = length xs
half = len `quot` 2
generates all the partitions without redundantly computing duplicates.
luqui raises a good point. I haven't taken into account the possibility that you'd want to split lists with repeated elements. With those, it gets a little more complicated, but not much. First, we group the list into equal elements (done here for an Ord constraint, for only Eq, that could still be done in O(length²)). The idea is then similar, to avoid repetitions, we posit that the first half contains more elements of the first group than the second (or, if there is an even number in the first group, equally many, and similar restrictions hold for the next group etc.).
repartitions :: Ord a => [a] -> [([a],[a])]
repartitions = map flatten2 . halves . prepare
where
flatten2 (u,v) = (flatten u, flatten v)
prepare :: Ord a => [a] -> [(a,Int)]
prepare = map (\xs -> (head xs, length xs)) . group . sort
halves :: [(a,Int)] -> [([(a,Int)],[(a,Int)])]
halves [] = [([],[])]
halves ((a,k):more)
| odd total = error "Odd number of elements"
| even k = [((a,low):us,(a,low):vs) | (us,vs) <- halves more] ++ [normalise ((a,c):us,(a,k-c):vs) | c <- [low + 1 .. min half k], (us,vs) <- choose (half-c) remaining more]
| otherwise = [normalise ((a,c):us,(a,k-c):vs) | c <- [low + 1 .. min half k], (us,vs) <- choose (half-c) remaining more]
where
remaining = sum $ map snd more
total = k + remaining
half = total `quot` 2
low = k `quot` 2
normalise (u,v) = (nz u, nz v)
nz = filter ((/= 0) . snd)
choose :: Int -> Int -> [(a,Int)] -> [([(a,Int)],[(a,Int)])]
choose 0 _ xs = [([],xs)]
choose _ _ [] = error "Oops"
choose need have ((a,k):more) = [((a,c):us,(a,k-c):vs) | c <- [least .. most], (us,vs) <- choose (need-c) (have-k) more]
where
least = max 0 (need + k - have)
most = min need k
flatten :: [(a,Int)] -> [a]
flatten xs = xs >>= uncurry (flip replicate)
Daniel Fischer's answer is a good way to solve the problem. I offer a worse (more inefficient) way, but one which more obviously (to me) corresponds to the problem description. I will generate all partitions of the list into two equal length sublists, then filter out equivalent ones according to your definition of equivalence. The way I usually solve problems is by starting like this -- create a solution that is as obvious as possible, then gradually transform it into a more efficient one (if necessary).
import Data.List (sort, nubBy, permutations)
type Partition a = ([a],[a])
-- Your notion of equivalence (sort to ignore the order)
equiv :: (Ord a) => Partition a -> Partition a -> Bool
equiv p q = canon p == canon q
where
canon (xs,ys) = sort [sort xs, sort ys]
-- All ordered partitions
partitions :: [a] -> [Partition a]
partitions xs = map (splitAt l) (permutations xs)
where
l = length xs `div` 2
-- All partitions filtered out by the equivalence
equivPartitions :: (Ord a) => [a] -> [Partition a]
equivPartitions = nubBy equiv . partitions
Testing
>>> equivPartitions [1,2,3,4]
[([1,2],[3,4]),([3,2],[1,4]),([3,1],[2,4])]
Note
After using QuickCheck to test the equivalence of this implementation with Daniel's, I found an important difference. Clearly, mine requires an (Ord a) constraint and his does not, and this hints at what the difference would be. In particular, if you give his [0,0,0,0], you will get a list with three copies of ([0,0],[0,0]), whereas mine will give only one copy. Which of these is correct was not specified; Daniel's is natural when considering the two output lists to be ordered sequences (which is what that type is usually considered to be), mine is natural when considering them as sets or bags (which is how this question seemed to be treating them).
Splitting The Difference
It is possible to get from an implementation that requires Ord to one that doesn't, by operating on the positions rather than the values in a list. I came up with this transformation -- an idea which I believe originates with Benjamin Pierce in his work on bidirectional programming.
import Data.Traversable
import Control.Monad.Trans.State
data Labelled a = Labelled { label :: Integer, value :: a }
instance Eq (Labelled a) where
a == b = compare a b == EQ
instance Ord (Labelled a) where
compare a b = compare (label a) (label b)
labels :: (Traversable t) => t a -> t (Labelled a)
labels t = evalState (traverse trav t) 0
where
trav x = state (\i -> i `seq` (Labelled i x, i + 1))
onIndices :: (Traversable t, Functor u)
=> (forall a. Ord a => t a -> u a)
-> forall b. t b -> u b
onIndices f = fmap value . f . labels
Using onIndices on equivPartitions wouldn't speed it up at all, but it would allow it to have the same semantics as Daniel's (up to equiv of the results) without the constraint, and with my more naive and obvious way of expressing it -- and I just thought it was an interesting way to get rid of the constraint.
My own generalized version, added much later, inspired by Will's answer:
import Data.Map (adjust, fromList, toList)
import Data.List (groupBy, sort)
divide xs n evenly = divide' xs (zip [0..] (replicate n [])) where
evenPSize = div (length xs) n
divide' [] result = [result]
divide' (x:xs) result = do
index <- indexes
divide' xs (toList $ adjust (x :) index (fromList result)) where
notEmptyBins = filter (not . null . snd) $ result
partlyFullBins | evenly == "evenly" = map fst . filter ((<evenPSize) . length . snd) $ notEmptyBins
| otherwise = map fst notEmptyBins
indexes = partlyFullBins
++ if any (null . snd) result
then map fst . take 1 . filter (null . snd) $ result
else if null partlyFullBins
then map fst. head . groupBy (\a b -> length (snd a) == length (snd b)) . sort $ result
else []