This is a followup to a recent question that wasn't asked clearly. The poster Aditi Jain's clarifications invalidate the answer somewhat that's already posted there, hence this new post.
The objective is to check whether there's no diagonally adjacent pair of elements in the nested lists which are negative of one another. The poster is new to Haskell programming.
The function signature is:
checkNegation :: [[Int]] -> Bool
Examples:
checkNegation [[1,2], [-2,3]] will return False:
[ [ 1 , 2], -- 2, -2 are diagonally adjacent
[-2 , 3] ]
checkNegation [[1,2], [3,-1]] will return False:
[ [ 1 , 2], -- 1, -1 are diagonally adjacent
[ 3 , -1] ]
checkNegation [[1,2], [-1,3]] will return True:
[ [ 1 , 2], -- no diagonally adjacent negatives
[-1 , 3] ]
checkNegation [[0,2,1], [3,1,-2], [3,-1,3]] will return False:
[ [ 0 , 2, 1], -- 2, -2 are diagonally adjacent
[ 3 , 1, -2],
[ 3 , -1, 3] ]
No coding attempts were provided in the original post.
(I'm not marking this as CW so as not to prevent the answerers getting reputation points for their efforts)
It's a little easier to do things if we take the matrix row-by-row. For the following, for instance:
[a,b,c],
[d,e,f],
We only want to compare the pairs:
[(a,e),(b,f),(b,d),(c,e)]
So the first step is to write a function which constructs that list from two adjacent rows.
diags xs ys = zip xs (drop 1 ys) ++ zip (drop 1 xs) ys
We're using drop 1 rather than tail because it doesn't error on the empty list, and the way I'm going to use this function later will use empty lists.
If we use this in a fold, then, it looks like the following:
anyDiags :: (a -> a -> Bool) -> [[a]] -> Bool
anyDiags p = fst . foldr f (False, [])
where
f xs (a, ys) = (a || or (zipWith p xs (drop 1 ys)) || or (zipWith p (drop 1 xs) ys), xs)
We've also made it generic over any relation.
Next we will want to figure out how to check if two numbers are negations of each other.
negEachOther x y = negate x == y
And then our check negation function is as follows:
checkNegation = anyDiags negEachOther
There are some fun things we can do with the anyDiags function here. There's actually a use of the writer monad hidden in it. With that, we can rewrite the fold to use that fact:
anyDiags :: (a -> a -> Bool) -> [[a]] -> Bool
anyDiags p = getAny . fst . foldrM f []
where
f xs ys = (Any (or (zipWith p xs (drop 1 ys)) || or (zipWith p (drop 1 xs) ys)), xs)
Though I'm not sure if it's any clearer.
Alternatively, we could do the whole thing using the zip xs (tail xs) trick:
anyDiags :: (a -> a -> Bool) -> [[a]] -> Bool
anyDiags p xs = or (zipWith f xs (tail xs))
where
f xs ys = or (zipWith p xs (drop 1 ys)) || or (zipWith p (drop 1 xs) ys)
We can use the diagonals utility from Data.Universe.Helpers package. Such that
λ> diagonals [[0,2,1], [3,1,-2], [3,-1,3]]
[[0],[3,2],[3,1,1],[-1,-2],[3]]
which is only half of what we need. So lets flip our 2D list and apply diagonals once more. Flipping a list would take reverse . transpose operation such that
λ> (reverse . transpose) [[0,2,1], [3,1,-2], [3,-1,3]]
[[1,-2,3],[2,1,-1],[0,3,3]]
now we can use diagonals on this flipped list to obtain the remaining diagonals.
λ> (diagonals . reverse . transpose) [[0,2,1], [3,1,-2], [3,-1,3]]
[[1],[2,-2],[0,1,3],[3,-1],[3]]
For all diagonals we need to concatenate them. So altogether we may do like;
allDiags = (++) <$> diagonals . reverse . transpose <*> diagonals
The rest is applying necessary boolean test.
import Data.List (transpose)
import Data.Universe.Helpers (diagonals)
checkNegation :: Num a => Eq a => [[a]] -> Bool
checkNegation = and . map (and . (zipWith (\x y -> 0 /= (x + y)) <*> tail)) . allDiags
where
allDiags = (++) <$> diagonals . reverse . transpose <*> diagonals
λ> checkNegation [[0,2,1], [3,1,-2], [3,-1,3]]
False
λ> checkNegation [[1,2], [-1,3]]
True
If you have a matrix like this and want to compare adjacent diagonal elements:
m = [[ 1, 2, 3, 4]
,[ 5, 6, 7, 8]
,[ 9,10,11,12]]
then you want to make two comparisons. First, you want to compare, element by element, the sub-matrix you get by dropping the first row and first column (left) with the sub-matrix you get by dropping the last row and last column (right):
[[ 6, 7, 8] [[ 1, 2, 3]
,[10,11,12] ,[ 5, 6, 7]]
Second, you want to compare, element by element, the sub-matrix you get by dropping the first row and last column (left) with the sub-matrix you get by dropping the last row and first column (right):
[[ 5, 6, 7] [[ 2, 3, 4]
,[ 9,10,11]] ,[ 6, 7, 8]]
We can construct these submatrices using init, tail, and maps of these:
m1 = tail (map tail m) -- drop first row and first column
m2 = init (map init m) -- drop last row and last column
m3 = tail (map init m) -- drop first row and last column
m4 = init (map tail m) -- drop last row and first column
giving:
λ> m1
[[6,7,8],[10,11,12]]
λ> m2
[[1,2,3],[5,6,7]]
λ> m3
[[5,6,7],[9,10,11]]
λ> m4
[[2,3,4],[6,7,8]]
How do we compare two sub-matrices? Well, we can write a two-dimensional version of zipWith to apply a binary function (a comparison, say) element by element to two matrices, the same way zipWith applies a binary function element by element to two lists:
zipZipWith :: (a -> b -> c) -> [[a]] -> [[b]] -> [[c]]
zipZipWith f m1 m2 = zipWith zipRow m1 m2
where zipRow r1 r2 = zipWith f r1 r2
This works by zipping the matrices together, row by row, using the zipRow helper function. For each pair of rows, zipRow zips the rows together, element by element, with the function f. This definition can be simplified to the slightly less clear:
zipZipWith f m1 m2 = zipWith (zipWith f) m1 m2
Anyway, to check if corresponding pairs of elements in two matrices are negatives of each other, we can use zipZipWith isNeg where:
isNeg :: (Num a, Eq a) => a -> a -> Bool
isNeg x y = x == -y
Then, to check if any of these pairs are negatives, we can use concat to change the matrix of booleans into a long list and or to check for any True values:
anyNegPairs :: (Num a, Eq a) => [[a]] -> [[a]] -> Bool
anyNegPairs ma mb = or . concat $ zipZipWith isNeg ma mb
Finally, then, a complete function to perform the comparison would be:
noDiagNeg :: (Num a, Eq a) => [[a]] -> Bool
noDiagNeg m = not (anyNegPairs m1 m2 || anyNegPairs m3 m4)
Since zipZipWith, like zipWith, ignores "extra" elements when comparing arguments of different sizes, it's not actually necessary to trim off the last column/row, so the sub-matrix definitions can be simplified by removing all the inits:
m1 = tail (map tail m)
m2 = m
m3 = tail m
m4 = map tail m
We could actually write m1 in terms of m4 to save double-calculating map tail m:
m1 = tail m4
but the compiler is smart enough to figure this out on its own.
So, a reasonable final solution would be:
noDiagNeg :: (Num a, Eq a) => [[a]] -> Bool
noDiagNeg m = not (anyNegPairs m1 m2 || anyNegPairs m3 m4)
where
m1 = tail (map tail m)
m2 = m
m3 = tail m
m4 = map tail m
anyNegPairs ma mb = or . concat $ zipZipWith isNeg ma mb
isNeg x y = x == -y
zipZipWith :: (a -> b -> c) -> [[a]] -> [[b]] -> [[c]]
zipZipWith f m1 m2 = zipWith (zipWith f) m1 m2
and it seems to work as desired on the test cases:
λ> noDiagNeg [[1,2],[-2,3]]
False
λ> noDiagNeg [[1,2],[3,-1]]
False
λ> noDiagNeg [[1,2],[-1,3]]
True
λ> noDiagNeg [[0,2,1],[3,1,-2],[3,-1,3]]
False
This is quite similar to #oisdk's solution, though this version might be easier to understand if you aren't too familiar with folds yet.
It fails on (certain) matrices with no elements:
λ> noDiagNeg []
*** Exception: Prelude.tail: empty list
λ> noDiagNeg [[],[]]
*** Exception: Prelude.tail: empty list
so you could use #oisdk's technique of replacing tail with drop 1, if this is a problem. (Actually, I might define tail' = drop 1 as a helper and replace all tail calls with tail' calls, since that would look a little nicer.)
First we pair up the rows: first with second, then second with third, then third with fourth, and so on.
Then, for each pair of rows, we consider all wedge-shaped triples of cells, like this:
--*---
-*-*--
So that the bottom-row cells are diagonally adjacent to the top-row ones.
Then we just check if any of the bottom ones are a negative of the top.
Except this has (literally) an edge case: beginnings and ends of the rows. If we do this wedge-shaped triple thing, we're going to miss the first and the last elements of the top row. To get around this, we first wrap the whole matrix in Just and then extend each row with Nothings on left and right:
[a,b,c] ==> [Nothing, Just a, Just b, Just c, Nothing]
[d,e,f] ==> [Nothing, Just d, Just e, Just f, Nothing]
Now we can safely iterate in triples and not miss anything.
checkNegation :: [[Int]] -> Bool
checkNegation matrix = any rowPairHasNegation rowPairs
where
extendedMatrix = map extendRow matrix
extendRow row = [Nothing] ++ map Just row ++ [Nothing]
rowPairs = extendedMatrix `zip` drop 1 extendedMatrix
rowPairHasNegation (row, nextRow) =
any cellTripleHasNegation $
drop 1 row `zip` nextRow `zip` drop 2 nextRow
cellTripleHasNegation ((x1y0, x0y1), x2y1) =
isNegation x1y0 x0y1 || isNegation x1y0 x2y1
isNegation (Just a) (Just b) = a == -b
isNegation _ _ = False
As far as I understand, this will result in iterating over the whole matrix exactly thrice - once as top row and twice as bottom row, meaning O(n*m)
Related
I have a 2d list l, and
[l!!y!!x| x<-[0..length l-1], y<-[0..length l-1]]
will produce a 1d list where rows and columns are swapped.
How can I implement this without list comprehension(i.e. using map)?
Break down the problem into parts. To transpose a single row, you want to return a column where each row contains a single element. A 1 x n matrix becomes an n x 1 matrix:
{- 1 2 ... n 1
2
...
n
-}
transpose [row] = map (\ x -> [x]) row
E.g.: transpose [[1, 2, 3]] = [[1], [2], [3]].
\ x -> [x] can also be written as an operator section (: []) or pure from Applicative.
When you pattern-match on the outer list (input rows), you split the top row of the matrix from the remaining rows. The transpose of a matrix is the transposition of the first row prepended to the transposition of the remaining rows. You can join two matrices vertically (i.e. placing one atop the other) with (++) (which could be written as (<>) from Semigroup) or horizontally with zipWith (++) (resp. zipWith (<>)) (i.e. placing one beside the other). Transposed matrices are joined horizontally:
{- 1 2 ... n 1 a ... p
a b ... c 2 b ... q
....... .........
p q ... r n c ... r
-}
transpose (top : down)
= zipWith (++) (transpose [top]) (transpose down)
E.g.: transpose [[1, 2], [3, 4], [5, 6]] = [[1] ++ [3, 5], [2] ++ [4, 6]].
This can also be expressed as zipWith (:) top (transpose down) since we know we have single elements to prepend; this skips some of the redundant effort of wrapping and then immediately unwrapping the elements of the input row / output column.
Finally, the transposition of an empty matrix with no rows is also the empty matrix.
transpose [] = []
Putting these together:
transpose :: [[a]] -> [[a]]
transpose [r] = map (: []) r
transpose (r : rs) = zipWith (:) r (transpose rs)
transpose [] = []
Follow-up: consider how this code responds to the edge cases where the input is non-rectangular or has an infinite number of rows or columns.
As Will Ness’s answer makes clear, this recursive function is nearly equivalent to a right fold, where the combining function is the prepending of columns by zipWith (:), and the base accumulator is the empty column of indefinite height, repeat [], i.e. transpose m = foldr (zipWith (:)) (repeat []) m, or eta-reduced, transpose = foldr (zipWith (:)) (repeat []).
However, they differ in an edge case: the fold produces an infinite list when given an empty input. That version is also equivalent to getZipList . traverse ZipList, based on the observation that traverse id :: (Traversable t, Applicative f) => t (f b) -> f (t b) is a kind of generalised transposition.
Since you wanted it without explicit recursion,
zipWith is also a binary map of sorts (and in some other languages map actually can take any number of argument lists). Hence,
transposed = foldr (zipWith (:)) (repeat [])
Trying it:
> transposed [[1,2,3],[11,12,13],[21,22,23,24]]
[[1,11,21],[2,12,22],[3,13,23]]
This can be simply composed with concat :: [[a]] -> [a] to concatenate the transposed lists.
We can work with recursion for this: each time we yield the heads of the lists, and then recurse on the tails, so:
catTranspose :: [[a]] -> [a]
catTranspose ([]:_) = []
catTranspose xs = map head xs ++ …
where I leave filling in … as an exercise. It should make a recursive call where we map each item in xs to its tail.
If the list is rectangular, this will work, for non-rectangular 2d lists, you will need to work with functions that are more safe, and thus will not error like head does on an empty list.
One can also drop the explicit recursion and work for example with unfoldr :: (b -> Maybe (a, b)) -> b -> [a] and concat :: Foldable f => f [a] -> [a] that will then perform the recursion.
This is for a class
We're supposed to write 3 functions :
1 : Prints list of fibbonaci numbers
2 : Prints list of prime numbers
3 : Prints list of fibonacci numbers whose indexes are prime
EG : Let this be fibbonaci series
Then In partC - certain elements are only shown
1: 1
*2: 1 (shown as index 2 is prime )
*3: 2 (shown as index 3 is prime )
4: 3
*5: 5 (shown )
6: 8
*7: 13 (shown as index 7 prime and so on)
I'm done with part 1 & 2 but I'm struggling with part 3. I created a function listNum that creates a sort of mapping [Integer, Integer] from the Fibbonaci series - where 1st Int is the index and 2nd int is the actual fibbonaci numbers.
Now my function partC is trying to stitch snd elements of the fibonaci series by filtering the indexes but I'm doing something wrong in the filter step.
Any help would be appreciated as I'm a beginner to Haskell.
Thanks!
fib :: [Integer]
fib = 0 : 1 : zipWith (+) fib (tail fib)
listNum :: [(Integer, Integer)]
listNum = zip [1 .. ] fib
primes :: [Integer]
primes = sieve (2 : [3,5 ..])
where
sieve (p:xs) = p : sieve [x | x <- xs , x `mod` p > 0]
partC :: [Integer] -- Problem in filter part of this function
partC = map snd listNum $ filter (\x -> x `elem` primes) [1,2 ..]
main = do
print (take 10 fib) -- Works fine
print (take 10 primes) --works fine
print (take 10 listNum) --works fine
print ( take 10 partC) -- Causes error
Error :
prog0.hs:14:9: error:
• Couldn't match expected type ‘[Integer] -> [Integer]’
with actual type ‘[Integer]’
• The first argument of ($) takes one argument,
but its type ‘[Integer]’ has none
In the expression:
map snd listNum $ filter (\ x -> x `elem` primes) [1, 2 .. ]
In an equation for ‘partC’:
partC
= map snd listNum $ filter (\ x -> x `elem` primes) [1, 2 .. ]
|
14 | partC = map snd listNum $ filter (\x -> x `elem` primes) [1,2 ..]
Here's what I think you intended as the original logic of partC. You got the syntax mostly right, but the logic has a flaw.
partC = snd <$> filter ((`elem` primes) . fst) (zip [1..] fib)
-- note that (<$>) = fmap = map, just infix
-- list comprehension
partC = [fn | (idx, fn) <- zip [1..] fib, idx `elem` primes]
But this cannot work. As #DanRobertson notes, you'll try to check 4 `elem` primes and run into an infinite loop, because primes is infinite and elem tries to be really sure that 4 isn't an element before giving up. We humans know that 4 isn't an element of primes, but elem doesn't.
There are two ways out. We can write a custom version of elem that gives up once it finds an element larger than the one we're looking for:
sortedElem :: Ord a => a -> [a] -> Bool
sortedElem x (h:tl) = case x `compare` h of
LT -> False
EQ -> True
GT -> sortedElem x tl
sortedElem _ [] = False
-- or
sortedElem x = foldr (\h tl -> case x `compare` h of
LT -> False
EQ -> True
GT -> tl
) False
Since primes is a sorted list, sortedElem will always give the correct answer now:
partC = snd <$> filter ((`sortedElem` primes) . fst) (zip [1..] fib)
However, there is a performance issue, because every call to sortedElem has to start at the very beginning of primes and walk all the way down until it figures out whether or not the index is right. This leads into the second way:
partC = go primeDiffs fib
where primeDiffs = zipWith (-) primes (1:primes)
-- primeDiffs = [1, 1, 2, 2, 4, 2, 4, 2, 4, 6, ...]
-- The distance from one prime (incl. 1) to the next
go (step:steps) xs = x:go steps xs'
where xs'#(x:_) = drop step xs
go [] _ = [] -- unused here
-- in real code you might pull this out into an atOrderedIndices :: [Int] -> [a] -> [a]
We transform the list of indices (primes) into a list of offsets, each one building on the next, and we call it primeDiffs. We then define go to take such a list of offsets and extract elements from another list. It first drops the elements being skipped, and then puts the top element into the result before building the rest of the list. Under -O2, on my machine, this version is twice as fast as the other one when finding partC !! 5000.
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.
Need increment every second item starting from the right in Haskell list but keeping origin order (e.g. reverse is not a case). For example:
f [1, 2, 3] -- [1, 3, 3]
f [1, 2, 3, 4] -- [2, 2, 4, 4]
I've tried something like a following:
fc ([]) = []
fc (x:[]) = [x]
fc (x:[y]) = [x+1,y]
fc( x:xs ) = fc [x] : ( fc xs ) -- this line is wrong
p.s. Obviously I could reverse (but prefer to understand original task) the list twice and apply something like:
helper (x:y:tail) = [x, y+1] ++ tail
fc x = reverse (helper (reverse x) )
The typical way to process a Haskell list from right to left would be to reverse it. Since you want to have the original order for the result, you would simply reverse again:
f1 = reverse . zipWith (+) (cycle [0,1]) . reverse
But if you really want to, you can have each recursive call return both the updated tail and a flag that indicates whether that position is even when counted from the end so you know whether to increase the element at that position or not:
f2 = snd . g
where
g [] = (False, [])
g (x:xs) = let (addOne, xs') = g xs
x' = if addOne then x + 1 else x
in (not addOne, x':xs')
We're basically mapping a function over the list, but this function requires an extra parameter that gets computed starting from the right end of the list. There's a standard function we can use:
import Data.List (mapAccumR)
f2' = snd . mapAccumR g False
where
g addOne x = (not addOne, if addOne then x + 1 else x)
I think a cleaner specification for what you want is that you increment even indicies if the length is even and odd indicies if the length is odd. For example, when indexing from zero, the list of length 3 resulted in index 1 being incremented. One way to do this is with the obvious two pass solution:
f xs = zipWith (+) (cycle sol) xs
where sol = map fromEnum [even len, odd len]
len = length xs
This can be done in one pass (without relying on the compiler fusion rules) by "tying the knot". For example (using manual recursive style as means of communication).
f2 xs = let (isEven, result) = go isEven xs in result
where
go _ [] = (True, [])
go e (x:xs) = let (ne,rest) = go (not e) xs
in (not ne, x+fromEnum e : rest)
This can be done efficiently using a left fold:
inc :: Num a => [a] -> [a]
inc xs = foldl go (\_ _ acc -> acc) xs id (+ 1) []
where go run x f g acc = run g f (f x: acc)
Note that even thought this is a left fold, the list is built using cons (:) operator; and it will perform linearly and not quadratic (similar construct as in difference lists).
\> inc [1, 2, 3]
[1,3,3]
\> inc [1, 2, 3, 4]
[2,2,4,4]
It can also be generalized to alternating functions other than id and (+ 1).
I like Thomas's solution. However, I think a simple foldr is enough here.
process = snd . foldr (\x (b,xs) -> (not b, x + fromEnum b:xs)) (False,[])
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 []