insert :: Eq(a) => a -> a -> [a] -> [a]
insert m n [] = []
insert m n (x:xs) | m==x = n : x : insert m n xs
| otherwise = x : insert m n xs
The insert function above is a working function that inserts a value n into a list before all instances of a value m.
I need help writing an interspace function that inserts a value n between all values m and q in a list. This is what I have so far:
interspace :: Eq(a) => a -> a -> a->[a] -> [a]
interspace m n q[] = []
interspace m n q (x:xs)| m==x && q==(head xs) = n: x : insert m n (headxs)++interspace m n q (xs)
| otherwise = x : interspace m n q xs
Since you will only be adding values to the front of the list, your insert function is unnecessary. (:) will suffice instead. Much like in insert, we pass recursively over the list. Since we want to check if two values match at a time and will also call the function recursively on different lists based on whether or not we find a match, it's a good idea to pattern match (x1:x2:xs) rather than just (x:xs).
If m matches x1 and q matches x2, we place the onto the head of the list and call interspace recursively on the rest of the list. If they do not mach, we call interspace on (x2:xs).
interspace :: Eq a => a -> a -> a-> [a] -> [a]
interspace m n q [] = []
interspace m n q [x] = [x]
interspace m n q (x1:x2:xs) | m == x1 && q == x2 = m : n : q : interspace m n q xs
| otherwise = x1 : interspace m n q (x2:xs)
Example usage:
ghci>> interspace 1 2 1 [1,1,2,1,1]
[1,2,1,2,1,2,1]
ghci>> interspace 1 2 1 [1,1,3]
[1,2,1,3]
ghci>> interspace 1 2 1 [1,2,4,2]
[1,2,4,2]
ghci>> interspace 1 2 1 [1]
[1]
ghci>> interspace 1 2 1 []
[]
Related
here a piece of code :
$> ls
` = _ ; ? ( ] # \ % 1 4 7 a B d E g H J l M o P r S u V x Y
^ > - : ' ) { $ & + 2 5 8 A c D f G i k L n O q R t U w X z
< | , ! " [ } * # 0 3 6 9 b C e F h I K m N p Q s T v W y Z
I'm printing all ASCII character, each element is a folder, and I'm trying to understand the default sorting order of the ls command.
I understand that's there is a case insensitive comparison to sort alphabetic character, with digit coming first.
I've some trouble to understand how special character are sorted, and I'm not able to find something clear. I was thinking it could be related to the ASCII table, but when we see how things are ordered it really make no sens with it... Where is this order coming from ?
Thanks
I'm solving the following problem, which in essence is "find the diameter of a connected undirected weighted graph", in Haskell. Now, the solution below produces correct answers, but exceeds the time limit on 9/27 of the tests. I'm far from a Haskell prodigy, can you guys give me a clue whether and how I can improve the performance of my solution without using the builtin Data.Graph module? I tried using accumulator parameters, strict pairs and strict evaluation in some places, but either I used them incorrectly or the performance issue is elsewhere. Thanks in advance!
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.List (maximumBy)
import Data.Ord (comparing)
buildGraph :: [Int] -> Map.Map Int [(Int, Int)] -> Map.Map Int [(Int, Int)]
buildGraph [] acc = acc
buildGraph (from:to:dist:rest) acc = let withTo = Map.insertWith (++) from [(to, dist)] acc
withFromTo = Map.insertWith (++) to [(from, dist)] withTo
in buildGraph rest $ withFromTo
data Queue a = Queue {
ingoing :: [a]
, outgoing :: [a]
} deriving Show
toQueue xs = Queue [] xs
enqMany xs (Queue is os) = (Queue (reverse xs ++ is) os)
deq (Queue is []) = deq (Queue [] $ reverse is)
deq (Queue is (o:os)) = (o, Queue is os)
extract :: (Ord a) => a -> Map.Map a [b] -> [b]
extract k m = case Map.lookup k m of
Just value -> value
Nothing -> error "sdfsd" -- should never happen
bfs node graph = bfs' Set.empty (toQueue [(node, 0)]) []
where
bfs' :: Set.Set Int -> Queue (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
bfs' visited (Queue [] []) acc = acc
bfs' visited que acc = let ((n, dist), rest) = deq que
in if Set.member n visited
then bfs' visited rest acc
else let children = map (\(i, d) -> (i, d + dist)) $ extract n graph
newNodes = enqMany children rest
in bfs' (Set.insert n visited) newNodes ((n, dist):acc)
findMostDistant xs = maximumBy (comparing snd) xs
solve input = answer
where
-- the first number is the number of edges and is not necessary
(_:triples) = map read $ words input
graph = buildGraph triples Map.empty
-- pick arbitary node, find the farther node from it using bfs
(mostDistant, _) = findMostDistant $ bfs (head triples) graph
-- find the farthest node from the previously farthest node, counting the distance on the way
(_, answer) = findMostDistant $ bfs mostDistant graph
tests = [
"11 2 7 2 1 7 6 5 1 8 2 8 6 8 6 9 10 5 5 9 1 9 0 10 15 3 1 21 6 4 3" -- 54
, "5 3 4 3 0 3 4 0 2 6 1 4 9" -- 22
, "16 2 3 92 5 2 10 14 3 42 2 4 26 14 12 50 4 6 93 9 6 24 15 14 9 0 2 95 8 0 90 0 13 60 9 10 59 1 0 66 11 12 7 7 10 35" -- 428
]
runZeroTests = mapM_ print $ map solve tests
main = do
answer <- solve <$> getContents
print answer
deq (Queue [] []) causes an infinite loop, I think.
When I’ve solved contest problems in Haskell, typically the biggest performance hog has been the slow I/O library, which operates on lazy linear linked lists of wide characters. The first thing I always do for a programming contest is replace that with fast I/O,
Here’s a version that makes minimal changes to the program logic and just replaces the I/O with Data.ByteString.Lazy.Char8, implemented with a lazily-evaluated list of strict byte arrays, and Data.ByteString.Builder, which builds a function to fill an output buffer. It should be useful to calculate the speed-up from fast I/O alone.
{-# LANGUAGE OverloadedStrings #-} -- Added
import Data.ByteString.Builder
(Builder, char7, intDec, toLazyByteString) -- Added
import qualified Data.ByteString.Lazy.Char8 as B8 -- Added
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.List (maximumBy)
import Data.Maybe (fromJust) -- Added
import Data.Monoid ((<>)) -- Added
import Data.Ord (comparing)
buildGraph :: [Int] -> Map.Map Int [(Int, Int)] -> Map.Map Int [(Int, Int)]
buildGraph [] acc = acc
buildGraph (from:to:dist:rest) acc = let withTo = Map.insertWith (++) from [(to, dist)] acc
withFromTo = Map.insertWith (++) to [(from, dist)] withTo
in buildGraph rest $ withFromTo
data Queue a = Queue {
ingoing :: [a]
, outgoing :: [a]
} deriving Show
toQueue xs = Queue [] xs
enqMany xs (Queue is os) = (Queue (reverse xs ++ is) os)
deq (Queue is []) = deq (Queue [] $ reverse is)
deq (Queue is (o:os)) = (o, Queue is os)
extract :: (Ord a) => a -> Map.Map a [b] -> [b]
extract k m = case Map.lookup k m of
Just value -> value
Nothing -> error "sdfsd" -- should never happen
bfs node graph = bfs' Set.empty (toQueue [(node, 0)]) []
where
bfs' :: Set.Set Int -> Queue (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
bfs' visited (Queue [] []) acc = acc
bfs' visited que acc = let ((n, dist), rest) = deq que
in if Set.member n visited
then bfs' visited rest acc
else let children = map (\(i, d) -> (i, d + dist)) $ extract n graph
newNodes = enqMany children rest
in bfs' (Set.insert n visited) newNodes ((n, dist):acc)
findMostDistant xs = maximumBy (comparing snd) xs
solve triples = answer -- Changed (by deleting one line)
where
graph = buildGraph triples Map.empty
-- pick arbitary node, find the farther node from it using bfs
(mostDistant, _) = findMostDistant $ bfs (head triples) graph
-- find the farthest node from the previously farthest node, counting the distance on the way
(_, answer) = findMostDistant $ bfs mostDistant graph
tests = [ -- Unchanged, but now interpreted as OverloadedStrings
"11 2 7 2 1 7 6 5 1 8 2 8 6 8 6 9 10 5 5 9 1 9 0 10 15 3 1 21 6 4 3" -- 54
, "5 3 4 3 0 3 4 0 2 6 1 4 9" -- 22
, "16 2 3 92 5 2 10 14 3 42 2 4 26 14 12 50 4 6 93 9 6 24 15 14 9 0 2 95 8 0 90 0 13 60 9 10 59 1 0 66 11 12 7 7 10 35" -- 428
]
runZeroTests = B8.putStr -- Changed
. toLazyByteString
. foldMap format
. map (solve . parse)
$ tests
main :: IO () -- Changed
main = B8.interact ( toLazyByteString . format . solve . parse )
parse :: B8.ByteString -> [Int] -- Added
-- the first number is the number of edges and is not necessary
parse = map (fst . fromJust . B8.readInt) . tail . B8.words
format :: Int -> Builder -- Added
format n = intDec n <> eol where
eol = char7 '\n'
With help from #Davislor with doing IO using ByteString and a few other things I managed to get 100 points on the problem. In the end, what I did to optimize it was:
Using ByteString IO as #Davislor suggested
Since I knew integers in the input were valid, I wrote my own parseInt function that does not perform unnecessary checks.
Instead of lazy Map, I used Array to create an adjacency list. I do not know what the asymptotic complexity of constructing an Array using accumArray is (I believe it should be O(n)), but lookup in the array should be O(1), instead of the O(log n) for the Map.
Here is the final solution:
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
import Data.ByteString.Builder
(Builder, char7, intDec, toLazyByteString)
import qualified Data.ByteString.Lazy.Char8 as B8
import qualified Data.Set as Set
import Data.Monoid ((<>))
import Data.Char (ord)
import Data.ByteString (getLine)
import Data.Array (Array, array, accumArray, (!), (//))
buildAdjList :: Int -> [Int] -> Array Int [(Int, Int)]
buildAdjList n xs = accumArray (flip (:)) [] (0, n) $ triples xs []
where
triples [] res = res
triples (x:y:dist:rest) res = let edgeXY = (x, (y, dist))
edgeYX = (y, (x, dist))
in triples rest (edgeXY:edgeYX:res)
data Queue a = Queue {
ingoing :: [a]
, outgoing :: [a]
} deriving Show
enqMany xs (Queue is os) = Queue (reverse xs ++ is) os
deq (Queue [] []) = error "gosho"
deq (Queue is []) = deq (Queue [] $ reverse is)
deq (Queue is (o:os)) = (o, Queue is os)
bfs !node adjList = let start = (node, 0) in bfs' Set.empty (Queue [] [start]) start
where
bfs' :: Set.Set Int -> Queue (Int, Int) -> (Int, Int) -> (Int, Int)
bfs' visited (Queue [] []) !ans = ans
bfs' visited que !ans = let (curr#(n, dist), rest) = deq que
in if Set.member n visited
then bfs' visited rest ans
else let children = map (\(i, d) -> (i, d + dist)) $ adjList ! n
newNodes = enqMany children rest
in bfs' (Set.insert n visited) newNodes (longerEdge curr ans)
longerEdge :: (Int, Int) -> (Int, Int) -> (Int, Int)
longerEdge a b = if (snd a) < (snd b) then b else a
parseInt :: B8.ByteString -> Int
parseInt str = parseInt' str 0 where
parseInt' str !acc
| B8.null str = acc
| otherwise = parseInt' (B8.tail str) $ ((ord $ B8.head str) - 48 + acc * 10)
parseIntList :: B8.ByteString -> [Int]
parseIntList = map parseInt . B8.words
solve :: [Int] -> Int
solve (n:triples) = answer
where
graph = buildAdjList n triples
-- pick arbitary node, find the farther node from it using bfs
(mostDistant, _) = bfs (head triples) graph
-- find the farthest node from the previously farthest node, counting the distance on the way
(_, answer) = bfs mostDistant graph
main :: IO ()
main = B8.interact ( toLazyByteString . intDec . solve . parseIntList )
-- debug code below
tests = [
"11 2 7 2 1 7 6 5 1 8 2 8 6 8 6 9 10 5 5 9 1 9 0 10 15 3 1 21 6 4 3" -- 54
, "5 3 4 3 0 3 4 0 2 6 1 4 9" -- 22
, "16 2 3 92 5 2 10 14 3 42 2 4 26 14 12 50 4 6 93 9 6 24 15 14 9 0 2 95 8 0 90 0 13 60 9 10 59 1 0 66 11 12 7 7 10 35" -- 428
]
runZeroTests = B8.putStr
. toLazyByteString
. foldMap format
. map (solve . parseIntList)
$ tests
format :: Int -> Builder
format n = intDec n <> eol
where eol = char7 '\n'
There could still be room for improvement, the Set for visited nodes could be changed to a bit array, Int32 can be used instead of Int, BangPatterns could be applied, although I feel like I can't really make sense of the execution order of Haskell programs.
I have this code:
project= [
[(a,b),(c,d),(e,f)]
|
a<-[1..5],
b<-[1..3],
c<-[1..5],
d<-[1..3],
e<-[1..5],
f<-[1..3]
, a*b + c*d + e*f <6
, a + c + e == 5
, b == 3 || d==3 || f==3
]
x=take 1 project
main = print $ x
it is return a list of 3 pairs [(x,y),(x,y),(x,y)] .
There are 3 conditions:
If you sum all the x you must get 5.
If you sum all the x*y you will get less than 6.
There is at least one y that equal to 3.
Now, I want exactly the same algorithm to work for any longer list for example 10 pairs. How should I do that?
Here:
project n =
[ x
| x <- replicateM n $ liftA2 (,) [1..5] [1..3]
, sum (map (uncurry (*)) x) < 6
, sum (map fst x) == 5
, any ((==3) . snd) x
]
main = print $ take 1 $ project 3
Or like so:
project n
= filter (any ((==3) . snd))
$ filter ((==5) . sum . map fst)
$ filter ((<6) . sum . map (uncurry (*)))
$ replicateM n
$ liftA2 (,) [1..5] [1..3]
I'm looking for an efficient polynomial-time solution to the following problem:
Implement a recursive function node x y for calculating the (x,y)-th number in a number triangle defined as
g(x,y) = 0 if |x| > y
= 1 if (x,y) = (0,0)
= sum of all incoming paths otherwise
The sum of all incoming paths to a node is defined as the sum of the values of all possible paths from the root node (x, y) = (0, 0) to the node under consideration, where at each node (x,y) a path can either continue diagonally down and left (x−1,y+1), straight down (x,y+1), or diagonally down and right (x+1,y+1). The value of a path to a node is defined as the sum of all the nodes along that path up to, but not including, the node under consideration.
The first few entries in the number triangle are given in the table:
\ x -3 -2 -1 0 1 2 3
\
y \ _________________________
|
0 | 0 0 0 1 0 0 0
|
1 | 0 0 1 1 1 0 0
|
2 | 0 2 4 6 4 2 0
|
3 | 4 16 40 48 40 16 4
I am trying to work out a naive solution first, here is what I have:
node x y | y < 0 = error "number cannot be negative"
| (abs x) > y = 0
| (x == 0) && (y == 0) = 1
| otherwise = node (x+1) (y-1) + node x (y-1) + node (x-1) (y-1)
Whenever I run this I get:
"* Exception: stack overflow"?
I believe your problem is a bit more complicated than your example code suggests. First, let's be clear about some definitions here:
Let pathCount x y be the number of paths that end at (x, y). We have
pathCount :: Int -> Int -> Integer
pathCount x y
| y == 0 = if x == 0 then 1 else 0
| otherwise = sum [ pathCount (x + d) (y - 1) | d <- [-1..1]]
Now let's pathSum x y be the sum of all paths that end in (x, y). We have:
pathSum :: Int -> Int -> Integer
pathSum x y
| y == 0 = if x == 0 then 1 else 0
| otherwise = sum [ pathSum (x + d) (y - 1) + node x y * pathCount (x + d) (y - 1)
| d <- [-1..1] ]
With this helper, we can finally define node x y properly:
node :: Int -> Int -> Integer
node x y
| y == 0 = if x == 0 then 1 else 0
| otherwise = sum [ pathSum (x + d) (y - 1) | d <- [-1..1]]
This algorithm as such is exponential time in its current form. We can however add memoization to make the number of additions quadratic. The memoize package on Hackage makes this easy as pie. Full example:
import Control.Monad
import Data.List (intercalate)
import Data.Function.Memoize (memoize2)
node' :: Int -> Int -> Integer
node' x y
| y == 0 = if x == 0 then 1 else 0
| otherwise = sum [ pathSum (x + d) (y - 1) | d <- [-1..1]]
node = memoize2 node'
pathCount' :: Int -> Int -> Integer
pathCount' x y
| y == 0 = if x == 0 then 1 else 0
| otherwise = sum [ pathCount (x + d) (y - 1) | d <- [-1..1]]
pathCount = memoize2 pathCount'
pathSum' :: Int -> Int -> Integer
pathSum' x y
| y == 0 = if x == 0 then 1 else 0
| otherwise = sum [ pathSum (x + d) (y - 1) + node x y * pathCount (x + d) (y - 1)
| d <- [-1..1] ]
pathSum = memoize2 pathSum'
main =
forM_ [0..n] $ \y ->
putStrLn $ intercalate " " $ map (show . flip node y) [-n..n]
where n = 5
Output:
0 0 0 0 0 1 0 0 0 0 0
0 0 0 0 1 1 1 0 0 0 0
0 0 0 2 4 6 4 2 0 0 0
0 0 4 16 40 48 40 16 4 0 0
0 8 72 352 728 944 728 352 72 8 0
16 376 4248 16608 35128 43632 35128 16608 4248 376 16
As you can see the algorithm the size of the numbers will get out of hands rather quickly. So the runtime is not O(n^2), while the number of arithmetic operations is.
You're thinking in terms of outgoing paths, when you should be thinking in terms of incoming paths. Your recursive step is currently looking for nodes from below, instead of above.
First of all, sorry if this is long. I wanted to explain the step by step thought process.
To start off with, you need one crucial fact: You can represent the "answer" at each "index" by a list of paths. For all the zeros, this is [[]], for your base case it is [[1]], and for example, for 0,2 it is [[6,1,1],[6,1,1],[6,1,1]]. This may seem like some redundancy, but it simplifies things down the road. Then, extracting the answer is head . head if the list is non empty, or const 0 if it is.
This is very useful because you can store the answer as a list of rows (the first row would be '[[1]], [], [] ...) and the results of any given row depend only on the previous row.
Secondly, this problem is symmetrical. This is pretty obvious.
The first thing we will do will mirror the definition of fib very closely:
type Path = [[Integer]]
triangle' :: [[Path]]
triangle' = ([[1]] : repeat []) : map f triangle'
We know this must be close to correct, since the 2nd row will depend on the first row only, the third on the 2nd only, etc. So the result will be
([[1]] : repeat []) : f ([[1]] : repeat []) : f ....
Now we just need to know what f is. Firstly, its type: [Path] -> [Path]. Quite simply, given the previous row, return the next row.
Now you may see another problem arising. Each invocation of f needs to know how many columns in the current row. We could actually count the length of non-null elements in the previous row, but it is simpler to pass the parameter directly, so we change map f triangle' to zipWith f [1..] triangle', giving f the type Int -> [Path] -> [Path].
f needs to handle one special case and one general case. The special case is x=0, in this case we simply treat the x+1,y-1 and x-1,y-1 recursions the same, and otherwise is identical to gn. Lets make two functions, g0 and gn which handle these two cases.
The actually computation of gn is easy. We know for some x we need the elements x-1, x, x+1 of the previous row. So if we drop x-1 elements before giving the previous row to the xth invocation of gn, gn can just take the first 3 elements and it will have what it needs. We write this as follows:
f :: Int -> [Path] -> [Path]
f n ps = g0 ps : map (gn . flip drop ps) [0..n-1] ++ repeat []
The repeat [] at the end should be obvious: for indices outside the triangle, the result is 0.
Now writing g0 and gs is really quite simple:
g0 :: [Path] -> Path
g0 (a:b:_) = map (s:) q
where
s = sum . concat $ q
q = b ++ a ++ b
gn :: [Path] -> Path
gn (a:b:c:_) = map (s:) q
where
s = sum . concat $ q
q = a ++ b ++ c
On my machine this version is about 3-4 times faster than the fastest version I could write with normal recursion and memoization.
The rest is just printing or pulling out the number you want.
triangle :: Int -> Int -> Integer
triangle x y = case (triangle' !! y) !! (abs x) of
[] -> 0
xs -> head $ head xs
triList :: Int -> Int -> Path
triList x y = (triangle' !! y) !! (abs x)
printTri :: Int -> Int -> IO ()
printTri width height =
putStrLn $ unlines $ map unwords
[[ p $ triangle x y | x <- [-x0..x0]] | y <- [0..height]]
where maxLen = length $ show $ triangle 0 height
x0 = width `div` 2
p = printf $ "%" ++ show maxLen ++ "d "
I'm looking for an efficient algorithm for computing the multiplicative partitions for any given integer. For example, the number of such partitions for 12 is 4, which are
12 = 12 x 1 = 4 x 3 = 2 x 2 x 3 = 2 x 6
I've read the wikipedia article for this, but that doesn't really give me an algorithm for generating the partitions (it only talks about the number of such partitions, and to be honest, even that is not very clear to me!).
The problem I'm looking at requires me to compute multiplicative partitions for very large numbers (> 1 billion), so I was trying to come up with a dynamic programming approach for it (so that finding all possible partitions for a smaller number can be re-used when that smaller number is itself a factor of a bigger number), but so far, I don't know where to begin!
Any ideas/hints would be appreciated - this is not a homework problem, merely something I'm trying to solve because it seems so interesting!
The first thing I would do is get the prime factorization of the number.
From there, I can make a permutation of each subset of the factors, multiplied by the remaining factors at that iteration.
So if you take a number like 24, you get
2 * 2 * 2 * 3 // prime factorization
a b c d
// round 1
2 * (2 * 2 * 3) a * bcd
2 * (2 * 2 * 3) b * acd (removed for being dup)
2 * (2 * 2 * 3) c * abd (removed for being dup)
3 * (2 * 2 * 2) d * abc
Repeat for all "rounds" (round being the number of factors in the first number of the multiplication), removing duplicates as they come up.
So you end up with something like
// assume we have the prime factorization
// and a partition set to add to
for(int i = 1; i < factors.size; i++) {
for(List<int> subset : factors.permutate(2)) {
List<int> otherSubset = factors.copy().remove(subset);
int subsetTotal = 1;
for(int p : subset) subsetTotal *= p;
int otherSubsetTotal = 1;
for(int p : otherSubset) otherSubsetTotal *= p;
// assume your partition excludes if it's a duplicate
partition.add(new FactorSet(subsetTotal,otherSubsetTotal));
}
}
Of course, the first thing to do is find the prime factorisation of the number, like glowcoder said. Say
n = p^a * q^b * r^c * ...
Then
find the multiplicative partitions of m = n / p^a
for 0 <= k <= a, find the multiplicative partitions of p^k, which is equivalent to finding the additive partitions of k
for each multiplicative partition of m, find all distinct ways to distribute a-k factors p among the factors
combine results of 2. and 3.
It is convenient to treat the multiplicative partitions as lists (or sets) of (divisor, multiplicity) pairs to avoid producing duplicates.
I've written the code in Haskell because it's the most convenient and concise of the languages I know for this sort of thing:
module MultiPart (multiplicativePartitions) where
import Data.List (sort)
import Math.NumberTheory.Primes (factorise)
import Control.Arrow (first)
multiplicativePartitions :: Integer -> [[Integer]]
multiplicativePartitions n
| n < 1 = []
| n == 1 = [[]]
| otherwise = map ((>>= uncurry (flip replicate)) . sort) . pfPartitions $ factorise n
additivePartitions :: Int -> [[(Int,Int)]]
additivePartitions 0 = [[]]
additivePartitions n
| n < 0 = []
| otherwise = aParts n n
where
aParts :: Int -> Int -> [[(Int,Int)]]
aParts 0 _ = [[]]
aParts 1 m = [[(1,m)]]
aParts k m = withK ++ aParts (k-1) m
where
withK = do
let q = m `quot` k
j <- [q,q-1 .. 1]
[(k,j):prt | let r = m - j*k, prt <- aParts (min (k-1) r) r]
countedPartitions :: Int -> Int -> [[(Int,Int)]]
countedPartitions 0 count = [[(0,count)]]
countedPartitions quant count = cbParts quant quant count
where
prep _ 0 = id
prep m j = ((m,j):)
cbParts :: Int -> Int -> Int -> [[(Int,Int)]]
cbParts q 0 c
| q == 0 = if c == 0 then [[]] else [[(0,c)]]
| otherwise = error "Oops"
cbParts q 1 c
| c < q = [] -- should never happen
| c == q = [[(1,c)]]
| otherwise = [[(1,q),(0,c-q)]]
cbParts q m c = do
let lo = max 0 $ q - c*(m-1)
hi = q `quot` m
j <- [lo .. hi]
let r = q - j*m
m' = min (m-1) r
map (prep m j) $ cbParts r m' (c-j)
primePowerPartitions :: Integer -> Int -> [[(Integer,Int)]]
primePowerPartitions p e = map (map (first (p^))) $ additivePartitions e
distOne :: Integer -> Int -> Integer -> Int -> [[(Integer,Int)]]
distOne _ 0 d k = [[(d,k)]]
distOne p e d k = do
cap <- countedPartitions e k
return $ [(p^i*d,m) | (i,m) <- cap]
distribute :: Integer -> Int -> [(Integer,Int)] -> [[(Integer,Int)]]
distribute _ 0 xs = [xs]
distribute p e [(d,k)] = distOne p e d k
distribute p e ((d,k):dks) = do
j <- [0 .. e]
dps <- distOne p j d k
ys <- distribute p (e-j) dks
return $ dps ++ ys
distribute _ _ [] = []
pfPartitions :: [(Integer,Int)] -> [[(Integer,Int)]]
pfPartitions [] = [[]]
pfPartitions [(p,e)] = primePowerPartitions p e
pfPartitions ((p,e):pps) = do
cop <- pfPartitions pps
k <- [0 .. e]
ppp <- primePowerPartitions p k
mix <- distribute p (e-k) cop
return (ppp ++ mix)
It's not particularly optimised, but it does the job.
Some times and results:
Prelude MultiPart> length $ multiplicativePartitions $ 10^10
59521
(0.03 secs, 53535264 bytes)
Prelude MultiPart> length $ multiplicativePartitions $ 10^11
151958
(0.11 secs, 125850200 bytes)
Prelude MultiPart> length $ multiplicativePartitions $ 10^12
379693
(0.26 secs, 296844616 bytes)
Prelude MultiPart> length $ multiplicativePartitions $ product [2 .. 10]
70520
(0.07 secs, 72786128 bytes)
Prelude MultiPart> length $ multiplicativePartitions $ product [2 .. 11]
425240
(0.36 secs, 460094808 bytes)
Prelude MultiPart> length $ multiplicativePartitions $ product [2 .. 12]
2787810
(2.06 secs, 2572962320 bytes)
The 10^k are of course particularly easy because there are only two primes involved (but squarefree numbers are still easier), the factorials get slow earlier. I think by careful organisation of the order and choice of better data structures than lists, there's quite a bit to be gained (probably one should sort the prime factors by exponent, but I don't know whether one should start with the highest exponents or the lowest).
Why dont you find all the numbers that can divide the number and then you find permutations of the numbers that multiplications will add up to the number?
Finding all numbers that can divide your number takes O(n).
Then you can permute this set to find all possible sets that multiplication of this set will give you the number.
Once you find set of all possible numbers that divide the original number, then you can do dynamic programming on them to find the set of numbers that multiplying them will give you the original number.