I am doing yet another Project Euler problem - Problem 38.
I have this function which returns a list of numbers but what I need is that list of numbers to be one number. It calculates the concatenated product of an integer.
f (a,b) = a*b
conProInt x n = map f (zip (replicate n x) ([1..n]))
prob38 = maximum [ (conProInt (x) (n)) | x <- [100..500], n <- [1..9], (sort $ nub $ (decToList $ (conProInt x n) )) == (sort $ (decToList $ (conProInt x n) )), (sort $ nub $ (decToList $ (conProInt x n))) == [1..9] ]
eg:
conProInt 192 3
returns:
[192,384,576]
what I need returned is:
192384576
I have searched around and can't find a function or think of a function I could construct that would deliver what I need. How would I go about this?
EDIT:
I have updated the script to incorporate faster concatenation, but it doesn't return the correct result:
f (a,b) = a*b
conProInt x n =( combine (map f (zip (replicate n x) ([1..n]))))
prob38 = maximum [ (conProInt (x) (n)) | x <- [1..50000], n <- [2..40], (sort $ nub $ (decToList $ (conProInt x n) )) == (sort $ (decToList $ (conProInt x n) )), (sort $ nub $ (decToList $ (conProInt x n))) == [1..9] ]
I'm pretty sure the pandigital test
(sort $ nub $ (decToList $ (conProInt x n) )) == (sort $ (decToList $ (conProInt x n) )), (sort $ nub $ (decToList $ (conProInt x n))) == [1..9]
won't fail. I tried to make the search as large as possible, but the maximum 9-pandigital I got was 986315724. Any suggestions? Is the range of values for n a very large one?
Going via Strings is probably easiest:
read $ concat $ map (show) [192,384,576]
Though you'll probably need to add a type signature:
Prelude> (read $ concat $ map (show) [192,384,576]) :: Int
192384576
You can use this function to concatenate a list of numbers:
concatNumbers :: [Int] -> String
concatNumbers = concat . map show
If you want the function to return the concatenation as a number, you can use read.
Here's an example of how to concatenate digits without converting to and from character strings.
-- foldl1' is a strict fold. "foldl1" would also work...
import Data.List (foldl1')
-- Combine two numbers such that their digits are concatenated.
-- op 1 23 = 123, op 0 12 = 12, op 12345 67 = 1234567
op :: Int -> Int -> Int
op a b = a * power 10 (numDigits b) + b
-- How many digits does a positive number have?
numDigits :: Int -> Int
numDigits x = length . takeWhile (>= 1) . iterate (`div` 10) $ x
-- Take a positive number and raise it to a positive power.
-- power 5 2 = 25, power 10 3 = 1000
power :: Int -> Int -> Int
power x y = foldl1' (*) . take y $ repeat x
-- Take a list of numbers, and concatenate all their digits.
combine :: [Int] -> Int
combine xs = foldl1' op xs
example run:
Prelude> :m +Data.List
Prelude Data.List> let power x y = foldl1' (*) . take y $ repeat x
Prelude Data.List> let numDigits = length . takeWhile (>=1) . iterate (`div` 10)
Prelude Data.List> let op a b = a * power 10 (numDigits b) + b
Prelude Data.List> let combine xs = foldl1' op xs
Prelude Data.List> combine [192, 384, 576]
192384576
Prelude Data.List>
Related
Input: List xs with arbitrary numeric elements, xs has at least two elements / Output: smallest distance between adjacent elements in the list.
-- Input: List xs with at least two numeric elements & its implementation an end recursive function.
-- Erg: Returns the smallest distance of adjacent elements from the output list.
minimumdistance :: [Int] -> Int
minimumdistance [] = error "Empty list".
minimumdistance [_] = error "Requirement is not met".
minimumdistance [a,b] = abs (a - b)
minimaldistance (x:y:xs) = helper (abs (x - y)) xs where
helper :: Int -> [Int] -> Int
helper acc [] = acc
helper acc (z:zs) = if (abs (y - z)) < acc then helper (abs (y - z)) zs else helper
acc zs
Is the function endrecursive because that we are supposed to solve the task endrecursive and I am sure because I do not have the definition yet correctly, but I also on other pages, the endrecursive representation not understood
Your code has several issues mentioned in comments.
I suggest you break this down into smaller problems. We can write a tail-recursive function to get pairs of adjacent numbers from the list.
pairs [] = error "Not long enough"
pairs [_] = error "Not long enough"
pairs lst = aux lst []
where
aux (a:b:c) acc = aux (b:c) ((a, b):acc)
aux _ acc = acc
Now, if we test this:
ghci> pairs [1, 3, 6, 7, 10]
[(7,10),(6,7),(3,6),(1,3)]
We can use map to get the differences.
ghci> map (\(a, b) -> abs (a - b)) $ pairs [1, 3, 6, 7, 10]
[3,1,3,2]
Now we just need to reduce that down to the minimum.
ghci> foldl1 min $ map (\(a, b) -> abs (a - b)) $ pairs [1, 3, 6, 7, 10]
1
In your code for the helper function, the y variable does not get updated at all. Hence it remains equal to the second element of the initial input list in all successive scopes. This is probably not what you want.
It is more reliable to just include the previous list element into your state/accumulator, together with the smallest distance seen so far. This gives the following code:
minimumDistance :: [Int] -> Int
minimumDistance [] = error "Empty list."
minimumDistance [_] = error "Requirement is not met."
minimumDistance (x:y:xs) = helper (abs (x-y), y) xs where
helper (mnd,u) [] = mnd
helper (mnd,u) (z:zs) = let d1 = abs (u-z)
in if (d1 < mnd) then helper (d1, z) zs
else helper (mnd, z) zs
Sanity check:
We can generate a small random list, and compare the result of our minimumDistance function with the one obtained by just combining a few suitable library functions. Like this:
$ ghci
GHCi, version 8.10.7: https://www.haskell.org/ghc/ :? for help
...
λ>
λ> :load q75011741.hs
[1 of 1] Compiling Main ( q75011741.hs, interpreted )
Ok, one module loaded.
λ>
λ> :type minimumDistance
minimumDistance :: [Int] -> Int
λ>
λ> import System.Random (randomRs, mkStdGen)
λ>
λ> g0 = mkStdGen 42
λ>
λ> xs = take 20 $ randomRs (0,500) g0
λ>
λ> xs
[48,151,95,271,208,466,401,23,139,95,500,306,187,389,398,297,248,94,348,91]
λ>
λ> minimumDistance xs
9
λ>
λ>
λ> zip xs (tail xs)
[(48,151),(151,95),(95,271),(271,208),(208,466),(466,401),(401,23),(23,139),(139,95),(95,500),(500,306),(306,187),(187,389),(389,398),(398,297),(297,248),(248,94),(94,348),(348,91)]
λ>
λ> map (\(a,b) -> abs(a-b)) $ zip xs (tail xs)
[103,56,176,63,258,65,378,116,44,405,194,119,202,9,101,49,154,254,257]
λ>
λ> minimum $ map (\(a,b) -> abs(a-b)) $ zip xs (tail xs)
9
λ>
So it looks OK.
Side note:
If for comparison purposes one also wants a solution based on a library-provided recursion scheme, the foldl' library function can be used. This gives the following code change:
minimumDistance (x:y:xs) = fst $ foldl' sfn acc0 xs where
acc0 = (abs(x-y), y)
sfn (mnd, pv) z = let d1 = abs (pv-z) in if (d1 < mnd) then (d1, z)
else (mnd, z)
I am working through some examples and trying to implement a function that counts how many subsets of a list add up to a given number.
In trying to rewrite some implementations in python to Haskell :
test1 :: [Int]
test1 = [2,4,6,10,1,4,5,6,7,8]
countSets1 total input = length [n | n <- subsets $ sort input, sum n == total]
where
subsets [] = [[]]
subsets (x:xs) = map (x:) (subsets xs) ++ subsets xs
countSets2 total input = go (reverse . sort $ input) total
where
go [] _ = 0
go (x:xs) t
| t == 0 = 1
| t < 0 = 0
| t < x = go xs t
| otherwise = go xs (t - x) + go xs t
countSets3 total input = go (sort input) total (length input - 1)
where
go xxs t i
| t == 0 = 1
| t < 0 = 0
| i < 0 = 0
| t < (xxs !! i) = go xxs t (i-1)
| otherwise = go xxs (t - (xxs !! i)) (i-1) + go xxs t (i-1)
I can't figure out why countSets2 does not return the same result as countSets3 (a copy of the python version)
λ: countSets1 16 test1
24
λ: countSets2 16 test1
13
λ: countSets3 16 test1
24
EDIT:
#freestyle pointed out that the order of my conditions was different in the two solutions:
countSets2 total input = go (sortBy (flip compare) input) total
where
go _ 0 = 1
go [] _ = 0
go (x:xs) t
| t < 0 = 0
| t < x = go xs t
| otherwise = go xs (t - x) + go xs t
fixes the problem.
I'm not sure about your logic, but in your second solution I think you need
go [] 0 = 1
otherwise, your code causes go [] 0 = 0 which feels wrong.
I don't treat your error so I don't expect you accept my answer. I only provide a solution:
import Math.Combinat.Sets (sublists)
getSublists :: [Int] -> Int -> [[Int]]
getSublists list total = filter (\x -> sum x == total) (sublists list)
countSublists :: [Int] -> Int -> Int
countSublists list total = length $ getSublists list total
The module Math.Combinat.Sets is from the combinat package.
>>> countSublists [2,4,6,10,1,4,5,6,7,8] 16
24
This problem looks similar to a pearl written by Richard Bird on how many sums and products can make 100. I'll use it as a template here. First, the specification:
subseqn :: (Num a, Eq a) => a -> [a] -> Int
subseqn n = length . filter ((== n) . sum) . subseqs
where
subseqs = foldr prefix [[]]
prefix x xss = map (x:) xss ++ xss
Observe that a lot of work may be wasted in subseqs. Intuitively, we can discard candidates as soon as they exceed n, i.e. use the weaker predicate (<= n) somewhere. Trivially, filtering on it before filtering on the stronger one does not change the outcome. Then you can derive
filter ((== n) . sum) . subseqs
= {- insert weaker predicate -}
filter ((== n) . sum) . filter ((<= n) . sum) . subseqs
= {- definition of subseqs -}
filter ((== n) . sum) . filter ((<= n) . sum) . foldr prefix [[]]
= {- fusion law of foldr -}
filter ((== n) . sum) . foldr prefix' [[]]
The fusion law states that f . foldr g a = foldr h b iff
f is strict
f a = b
f (g x y) = h x (f y)
Here, a = b = [[]], f is filter ((<= n) . sum) and g is prefix. You can derive h (i.e. prefix') by observing that the predicate can be applied before prefixing:
filter ((<= n) . sum) (prefix x xss) =
filter ((<= n) . sum) (prefix x (filter ((<= n) . sum) xss))
which is exactly the third condition; then h is filter ((<= n) . sum) . prefix.
Another observation is that sum is computed too many times. To get around that, we can modify our definition of subseqn so that each candidate carries its own sum. Let's use
(&&&) :: (a -> b) -> (a -> c) -> a -> (b, c)
(&&&) f g x = (f x, g x)
and derive
filter ((== n) . sum) . subseqs
= {- use &&& -}
filter ((== n) . snd) . map (id &&& sum) . subseqs
= {- definition of subseqs -}
filter ((== n) . snd) . map (id &&& sum) . foldr prefix' [[]]
= {- fusion law of foldr -}
filter ((== n) . snd) . foldr prefix'' [[]]
I won't go through the whole derivation of prefix'', it is quite long. The gist is that you can avoid using sum at all by working on pairs, so that the sum is computed iteratively. Initially the sum is 0 for the empty list and all we have to do is add the new candidate to it.
We update our base case from [[]] to [([], 0)] and get:
prefix'' x = filter ((<= n) . snd) . uncurry zip . (prefix x *** add x) . unzip
where
(***) :: (a -> a') -> (b -> b') -> (a, b) -> (a', b')
(***) f g (x, y) = (f x, g y)
add :: Num a => a -> [a] -> [a]
add x xs = map (x+) xs ++ xs
Here is the final version:
subseqn :: (Num a, Ord a) => a -> [a] -> Int
subseqn n = length . filter ((== n) . snd) . foldr expand [([], 0)]
where
expand x = filter ((<= n) . snd) . uncurry zip . (prefix x *** add x) . unzip
prefix x xss = map (x:) xss ++ xss
add x xs = map (x+) xs ++ xs
(*** and &&& are from Control.Arrow)
I tried solving this, and the following is trial stuff.
When I test this in ghci with hSetBuffering stdout NoBuffering, solveAct 1, 15 10, ghci showed few lines of results and blocked much time, and showed rest result at once.
How can I see the intermediate results in real time?
import Control.Monad
import Data.List
import Data.Maybe
import System.IO
readInts = fmap read . words <$> getLine :: IO [Int]
main = do
t <- readLn :: IO Int
hSetBuffering stdout NoBuffering
sequence_ $ solveAct <$> [1..t]
showTable x = intercalate "\n" $ intercalate " " . fmap show <$> x
solveAct i = do
[j, n] <- readInts
putStrLn $ "Case #" ++ show i ++ ":"
putStrLn $ showTable (take n $ solve (j-1))
digits n = [[x ^ y | y <- [1..n-1]] | x <- [2..10]]
primes = 2 : [x | x <- [3,5..], all (\y -> x `rem` y /= 0) $ takeWhile (<= intSqrt x) primes]
intSqrt = floor . sqrt . fromIntegral
getNDivisor n = listToMaybe [x | x <- takeWhile (<= intSqrt n) primes, n `rem` x == 0]
casesOfMat = subsequences . transpose . digits
casesOfJam n = fmap ([1 + x^n | x <- [2..10]]:) $ casesOfMat n
eachBaseReps n = fmap sum . transpose <$> casesOfJam n
solve :: Int -> [[Int]]
solve n = do
decimals <- eachBaseReps n
let divs = getNDivisor <$> decimals
guard $ all isJust divs
return $ last decimals : catMaybes divs
You are seeing the results in real time. It's just that the computation of all isJust . map getNDivisor takes a long time for the third element of eachBaseReps 14.
List functions allow us to implement arbitrarily-dimensional vector math quite elegantly. For example:
on = (.) . (.)
add = zipWith (+)
sub = zipWith (-)
mul = zipWith (*)
dist = len `on` sub
dot = sum `on` mul
len = sqrt . join dot
And so on.
main = print $ add [1,2,3] [1,1,1] -- [2,3,4]
main = print $ len [1,1,1] -- 1.7320508075688772
main = print $ dot [2,0,0] [2,0,0] -- 4
Of course, this is not the most efficient solution, but is insightful to look at, as one can say map, zipWith and such generalize those vector operations. There is one function I couldn't implement elegantly, though - that is cross products. Since a possible n-dimensional generalization of cross products is the nd matrix determinant, how can I implement matrix multiplication elegantly?
Edit: yes, I asked a completely unrelated question to the problem I set up. Fml.
It just so happens I have some code lying around for doing n-dimensional matrix operations which I thought was quite cute when I wrote it at least:
{-# LANGUAGE NoMonomorphismRestriction #-}
module MultiArray where
import Control.Arrow
import Control.Monad
import Data.Ix
import Data.Maybe
import Data.Array (Array)
import qualified Data.Array as A
-- {{{ from Dmwit.hs
deleteAt n xs = take n xs ++ drop (n + 1) xs
insertAt n x xs = take n xs ++ x : drop n xs
doublify f g xs ys = f (uncurry g) (zip xs ys)
any2 = doublify any
all2 = doublify all
-- }}}
-- makes the most sense when ls and hs have the same length
instance Ix a => Ix [a] where
range = sequence . map range . uncurry zip
inRange = all2 inRange . uncurry zip
rangeSize = product . uncurry (zipWith (curry rangeSize))
index (ls, hs) xs = fst . foldr step (0, 1) $ zip indices sizes where
indices = zipWith index (zip ls hs) xs
sizes = map rangeSize $ zip ls hs
step (i, b) (s, p) = (s + p * i, p * b)
fold :: (Enum i, Ix i) => ([a] -> b) -> Int -> Array [i] a -> Array [i] b
fold f n a = A.array newBound assocs where
(oldLowBound, oldHighBound) = A.bounds a
(newLowBoundBeg , dimLow : newLowBoundEnd ) = splitAt n oldLowBound
(newHighBoundBeg, dimHigh: newHighBoundEnd) = splitAt n oldHighBound
assocs = [(beg ++ end, f [a A.! (beg ++ i : end) | i <- [dimLow..dimHigh]])
| beg <- range (newLowBoundBeg, newHighBoundBeg)
, end <- range (newLowBoundEnd, newHighBoundEnd)
]
newBound = (newLowBoundBeg ++ newLowBoundEnd, newHighBoundBeg ++ newHighBoundEnd)
flatten a = check a >> return value where
check = guard . (1==) . length . fst . A.bounds
value = A.ixmap ((head *** head) . A.bounds $ a) return a
elementWise :: (MonadPlus m, Ix i) => (a -> b -> c) -> Array i a -> Array i b -> m (Array i c)
elementWise f a b = check >> return value where
check = guard $ A.bounds a == A.bounds b
value = A.listArray (A.bounds a) (zipWith f (A.elems a) (A.elems b))
unsafeFlatten a = fromJust $ flatten a
unsafeElementWise f a b = fromJust $ elementWise f a b
matrixMult a b = fold sum 1 $ unsafeElementWise (*) a' b' where
aBounds = (join (***) (!!0)) $ A.bounds a
bBounds = (join (***) (!!1)) $ A.bounds b
a' = copy 2 bBounds a
b' = copy 0 aBounds b
bijection f g a = A.ixmap ((f *** f) . A.bounds $ a) g a
unFlatten = bijection return head
matrixTranspose = bijection reverse reverse
copy n (low, high) a = A.ixmap (newBounds a) (deleteAt n) a where
newBounds = (insertAt n low *** insertAt n high) . A.bounds
The cute bit here is matrixMult, which is one of the only operations that is specialized to two-dimensional arrays. It expands its first argument along one dimension (by putting a copy of the two-dimensional object into each slice of the three-dimensional object); expands its second along another; does pointwise multiplication (now in a three-dimensional array); then collapses the fabricated third dimension by summing. Quite nice.
I need a function that does the same thing as itertools.combinations(iterable, r) in python
So far I came up with this:
{-| forward application -}
x -: f = f x
infixl 0 -:
{-| combinations 2 "ABCD" = ["AB","AC","AD","BC","BD","CD"] -}
combinations :: Ord a => Int -> [a] -> [[a]]
combinations k l = (sequence . replicate k) l -: map sort -: sort -: nub
-: filter (\l -> (length . nub) l == length l)
Is there a more elegant and efficient solution?
xs elements taken n by n is
mapM (const xs) [1..n]
all combinations (n = 1, 2, ...) is
allCombs xs = [1..] >>= \n -> mapM (const xs) [1..n]
if you need without repetition
filter ((n==).length.nub)
then
combinationsWRep xs n = filter ((n==).length.nub) $ mapM (const xs) [1..n]
(Based on #JoseJuan's answer)
You can also use a list comprehension to filter out those where the second character is not strictly smaller than the first:
[x| x <- mapM (const "ABCD") [1..2], head x < head (tail x) ]
(Based on #FrankSchmitt’s answer)
We have map (const x) [1..n] == replicate n x so we could change his answer to
[x| x <- sequence (replicate 2 "ABCD"), head x < head (tail x) ]
And while in original question, 2 was a parameter k, for this particular example would probably not want to replicate with 2 and write
[ [x1,x2] | x1 <- "ABCD", x2 <- "ABCD", x1 < x2 ]
instead.
With a parameter k things are a bit more tricky if you want to generate them without duplicates. I’d do it recursively:
f 0 _ = [[]]
f _ [] = []
f k as = [ x : xs | (x:as') <- tails as, xs <- f (k-1) as' ]
(This variant does not remove duplicates if there are already in the list as; if you worry about them, pass nub as to it)
This SO answer:
subsequences of length n from list performance
is the fastest solution to the problem that I've seen.
compositions :: Int -> [a] -> [[a]]
compositions k xs
| k > length xs = []
| k <= 0 = [[]]
| otherwise = csWithoutHead ++ csWithHead
where csWithoutHead = compositions k $ tail xs
csWithHead = [ head xs : ys | ys <- compositions (k - 1) $ tail xs ]