I'm trying to make what I think is called an Ulam spiral using Haskell.
It needs to go outwards in a clockwise rotation:
6 - 7 - 8 - 9
| |
5 0 - 1 10
| | |
4 - 3 - 2 11
|
..15- 14- 13- 12
For each step I'm trying to create coordinates, the function would be given a number and return spiral coordinates to the length of input number eg:
mkSpiral 9
> [(0,0),(1,0),(1,-1),(0,-1),(-1,-1),(-1,0),(-1,1),(0,1),(1,1)]
(-1, 1) - (0, 1) - (1, 1)
|
(-1, 0) (0, 0) - (1, 0)
| |
(-1,-1) - (0,-1) - (1,-1)
I've seen Looping in a spiral solution, but this goes counter-clockwise and it's inputs need to the size of the matrix.
I also found this code which does what I need but it seems to go counterclock-wise, stepping up rather than stepping right then clockwise :(
type Spiral = Int
type Coordinate = (Int, Int)
-- number of squares on each side of the spiral
sideSquares :: Spiral -> Int
sideSquares sp = (sp * 2) - 1
-- the coordinates for all squares in the given spiral
coordinatesForSpiral :: Spiral -> [Coordinate]
coordinatesForSpiral 1 = [(0, 0)]
coordinatesForSpiral sp = [(0, 0)] ++ right ++ top ++ left ++ bottom
where fixed = sp - 1
sides = sideSquares sp - 1
right = [(x, y) | x <- [fixed], y <- take sides [-1*(fixed-1)..]]
top = [(x, y) | x <- reverse (take sides [-1*fixed..]), y <- [fixed]]
left = [(x, y) | x <- [-1*fixed], y <- reverse(take sides [-1*fixed..])]
bottom = [(x, y) | x <- take sides [-1*fixed+1..], y <- [-1*fixed]]
-- an endless list of coordinates (the complete spiral)
mkSpiral :: Int -> [Coordinate]
mkSpiral x = take x endlessSpiral
endlessSpiral :: [Coordinate]
endlessSpiral = endlessSpiral' 1
endlessSpiral' start = coordinatesForSpiral start ++ endlessSpiral' (start + 1)
After much experimentation I can't seem to change the rotation or starting step direction, could someone point me in the right way or a solution that doesn't use list comprehension as I find them tricky to decode?
Let us first take a look at how the directions of a spiral are looking:
R D L L U U R R R D D D L L L L U U U U ....
We can split this in sequences like:
n times n+1 times
_^_ __^__
/ \ / \
R … R D … D L L … L U U … U
\_ _/ \__ __/
v v
n times n+1 times
We can repeat that, each time incrementing n by two, like:
data Dir = R | D | L | U
spiralSeq :: Int -> [Dir]
spiralSeq n = rn R ++ rn D ++ rn1 L ++ rn1 U
where rn = replicate n
rn1 = replicate (n + 1)
spiral :: [Dir]
spiral = concatMap spiralSeq [1, 3..]
Now we can use Dir here to calculate the next coordinate, like:
move :: (Int, Int) -> Dir -> (Int, Int)
move (x, y) = go
where go R = (x+1, y)
go D = (x, y-1)
go L = (x-1, y)
go U = (x, y+1)
We can use scanl :: (a -> b -> a) -> a -> [b] -> [a] to generate the points, like:
spiralPos :: [(Int, Int)]
spiralPos = scanl move (0,0) spiral
This will yield an infinite list of coordinates for the clockwise spiral. We can use take :: Int -> [a] -> [a] to take the first k items:
Prelude> take 9 spiralPos
[(0,0),(1,0),(1,-1),(0,-1),(-1,-1),(-1,0),(-1,1),(0,1),(1,1)]
The idea with the following solution is that instead of trying to generate the coordinates directly, we’ll look at the directions from one point to the next. If you do that, you’ll notice that starting from the first point, we go 1× right, 1× down, 2× left, 2× up, 3× right, 3× down, 4× left… These can then be seperated into the direction and the number of times repeated:
direction: > v < ^ > v < …
# reps: 1 1 2 2 3 3 4 …
And this actually gives us two really straightforward patterns! The directions just rotate > to v to < to ^ to >, while the # of reps goes up by 1 every 2 times. Once we’ve made two infinite lists with these patterns, they can be combined together to get an overall list of directions >v<<^^>>>vvv<<<<…, which can then be iterated over to get the coordinate values.
Now, I’ve always thought that just giving someone a bunch of code as the solution is not the best way to learn, so I would highly encourage you to try implementing the above idea yourself before looking at my solution below.
Welcome back (if you did try to implement it yourself). Now: onto my own solution. First I define a Stream data type for an infinite stream:
data Stream a = Stream a (Stream a) deriving (Show)
Strictly speaking, I don’t need streams for this; Haskell’s predefined lists are perfectly adequate for this task. But I happen to like streams, and they make some of the pattern matching a bit easier (because I don’t have to deal with the empty list).
Next, I define a type for directions, as well as a function specifying how they interact with points:
-- Note: I can’t use plain Left and Right
-- since they conflict with constructors
-- of the ‘Either’ data type
data Dir = LeftDir | RightDir | Up | Down deriving (Show)
type Point = (Int, Int)
move :: Dir -> Point -> Point
move LeftDir (x,y) = (x-1,y)
move RightDir (x,y) = (x+1, y)
move Up (x,y) = (x,y+1)
move Down (x,y) = (x,y-1)
Now I go on to the problem itself. I’ll define two streams — one for the directions, and one for the number of repetitions of each direction:
dirStream :: Stream Dir
dirStream = Stream RightDir $ Stream Down $ Stream LeftDir $ Stream Up dirVals
numRepsStream :: Stream Int
numRepsStream = go 1
where
go n = Stream n $ Stream n $ go (n+1)
At this point we’ll need a function for replicating each element of a stream a specific number of times:
replicateS :: Stream Int -> Stream a -> Stream a
replicateS (Stream n ns) (Stream a as) = conss (replicate n a) $ replicateS ns as
where
-- add more than one element to the beginning of a stream
conss :: [a] -> Stream a -> Stream a
conss [] s = s
conss (x:xs) s = Stream x $ appends xs s
This gives replicateS dirStream numRepsStream for the stream of directions. Now we just need a function to convert those directions to coordinates, and we’ve solved the problem:
integrate :: Stream Dir -> Stream Point
integrate = go (0,0)
where
go p (Stream d ds) = Stream p (go (move d p) ds)
spiral :: Stream Point
spiral = integrate $ replicateS numRepsStream dirStream
Unfortunately, it’s somewhat inconvenient to print an infinite stream, so the following function is useful for debugging and printing purposes:
takeS :: Int -> Stream a -> [a]
takeS 0 _ = []; takeS n (Stream x xs) = x : (takeS (n-1) xs)
Related
I am trying to solve the problems from Project Euler using Haskell, but I got sucked at #24
I'm trying to use factorials to solve problem but just can't work for the last three digits, here is my code:
import Data.List
fact n = product [n, n-1 .. 1]
recur :: Int -> Int -> [Int] -> [Int]
recur x y arr
| y > 1 = arr !! d : recur r (y-1) (delete (arr !! d) arr)
| otherwise = arr
where d = x `div` fact y
r = x `mod` fact y
main::IO()
main = print(recur 1000000 9 [0..9])
(I know it is now not really "functional")
I managed to get result [2,7,8,3,9,1,4,5,0,6], while the right answer I accidently figured out by hand is 2783915460.
I just want to know why this algorithm doesn't work for the last three digits. Thanks.
Unadulterated divMod is wrong for this algorithm. You need
dvm x facty | r == 0 = (d-1, facty)
| otherwise = (d, r)
where
(d, r) = divMod x facty
instead:
recur x y arr
.......
.......
where (d, r) = x `dvm` fact y
We cannot have zero combinations to do left. Zero means none.
Also the pattern guard condition should be changed to y > 0. Only when the length of the remaining choices list is 1 (at which point y is 0) there's no more choices to be made and we just use the last available digit left.
I'm trying to print out my 2d array in game of life, but i'm not quite sure how to go on with it. So I need some help with my printArray function I'm not quite sure how to proceed. Her is the code below, everything is working.. Except printing it out in the right manner.
module GameOfLife where
import Data.List
import System.IO
import Text.Show
import Data.Array
import System.Random
width :: Int
width = 5
height :: Int
height = 5
data State = Alive | Dead deriving (Eq, Show)
type Pos = (Int,Int)
type Board = Array Pos State
startBoard :: Pos -> Board
startBoard (width,height) =
let bounds = ((0,0),(width - 1,height - 1))
in array bounds $ zip (range bounds) (repeat Dead)
set :: Board -> [(Pos,State)] -> Board
set = (//)
get :: Board -> [Pos] -> [State]
get board pos = map (board!) pos
neighbours :: Board -> Pos -> [Pos]
neighbours board c#(x,y) =
filter (/= c) $ filter (inRange (bounds board)) [(x',y') | x' <- [x -
1..x + 1], y' <- [y - 1..y + 1]]
nextGen :: Board -> Board
nextGen board =(irrelevant code for the question..)
printArray :: Board -> String
printArray arr =
unlines [unwords [show (arr ! (x, y)) | x <- [1..5]] | y <- [1..5]]
My output:
[((0,0),Dead),((0,1),Dead),((0,2),Dead),((0,3),Dead),((1,0),Dead),
((1,1),Dead),((1,2),Dead),((1,3),Dead),((2,0),Dead),((2,1),Dead),
((2,2),Dead)2,3),Dead)]
My preferable output:
1 2 3 4 5
1 . . . . .
2 n n n . .
3 n X n . .
4 n n n . .
5 . . . . .
To start to answer your question, I suggest breaking the problem into several pieces:
Print out the numbers across the top.
Number each row as you print them.
Decide what symbol to print in each cell.
Tackle each of these pieces one at a time. If it helps, rather than think in terms of "printing" just build up a String object. Once you have a String, printing is pretty trivial.
Apologies for my poor wording of the question. I've tried searching for an answer but not knowing what to search is making it very difficult to find one.
Here is a simple function which calculates the area of a triangle.
triangleArea :: Float -> Float -> Float -> Float
triangleArea a b c
| (a + b) <= c = error "Not a triangle!"
| (a + c) <= b = error "Not a triangle!"
| (b + c) <= a = error "Not a triangle!"
| otherwise = sqrt (s * (s - a) * (s - b) * (s - c))
where s = (a + b + c) / 2
Three lines of the function have been taken up for the purposes of error checking. I was wondering if these three lines could be condensed into one generic line.
I was wondering if something similar to the following would be possible
(arg1 + arg2) == arg3
where Haskell knows to check each possible combination of the three arguments.
I think #behzad.nouri's comment is the best. Sometimes doing a little math is the best way to program. Here's a somewhat overdone expansion on #melpomene's solution, which I thought would be fun to share. Let's write a function similar to permutations but that computes combinations:
import Control.Arrow (first, second)
-- choose n xs returns a list of tuples, the first component of each having
-- n elements and the second component having the rest, in all combinations
-- (ignoring order within the lists). N.B. this would be faster if implemented
-- using a DList.
choose :: Int -> [a] -> [([a],[a])]
choose 0 xs = [([], xs)]
choose _ [] = []
choose n (x:xs) =
map (first (x:)) (choose (n-1) xs) ++
map (second (x:)) (choose n xs)
So..
ghci> choose 2 [1,2,3]
[([1,2],[3]),([1,3],[2]),([2,3],[1])]
Now you can write
triangleArea a b c
| or [ x + y <= z | ([x,y], [z]) <- choose 2 [a,b,c] ] = error ...
This doesn't address the question of how to shorten your error checking code, but you may be able to limit how often you repeat it by defining some new types with invariants. This function needs error checking because you can't trust the user to supply Float triples that make a reasonable triangle, and if you continue to define functions this way then every triangle-related function you write would need similar error checks.
However, if you define a Triangle type, you can check your invariants only once, when a triangle is created, and then all other functions will be guaranteed to receive valid triangles:
module Triangle (Triangle(), mkTriangle, area) where
data Triangle a = Triangle a a a deriving Show
mkTriangle :: (Num a, Ord a) => a -> a -> a -> Either String (Triangle a)
mkTriangle a b c
| a + b <= c = wrong
| a + c <= b = wrong
| b + c <= a = wrong
| otherwise = Right $ Triangle a b c
where wrong = Left "Not a triangle!"
area :: Floating a => Triangle a -> a
area (Triangle a b c) = sqrt (s * (s - a) * (s - b) * (s - c))
where s = (a + b + c) / 2
Here we export the Triangle type, but not its constructor, so that the client must use mkTriangle instead, which can do the required error checking. Then area, and any other triangle functions you write, can omit the checks that they are receiving a valid triangle. This general pattern is called "smart constructors".
Here are two ideas.
Using existing tools, you can generate all the permutations of the arguments and check that they all satisfy a condition. Thus:
import Data.List
triangleArea a b c
| any (\[x, y, z] -> x + y <= z) (permutations [a,b,c])
= error "Not a triangle!"
| otherwise = {- ... -}
This doesn't require writing very much additional code; however, it will search some permutations you don't care about.
Use the usual trick for choosing an element from a list and the left-overs. The zippers function is one I use frequently:
zippers :: [a] -> [([a], a, [a])]
zippers = go [] where
go b [] = []
go b (v:e) = (b, v, e) : go (v:b) e
We can use it to build a function which chooses only appropriate triples of elements:
triples :: [a] -> [(a, a, a)]
triples xs = do
(b1, v1, e1) <- zippers xs
(b2, v2, e2) <- zippers e1
v3 <- b1 ++ b2 ++ e2
return (v1, v2, v3)
Now we can write our guard like in part (1), but it will only consider unique pairings for the addition.
triangleArea a b c
| any (\(x, y, z) -> x + y <= z) (triples [a,b,c])
= error "Not a triangle!"
| otherwise = {- ... -}
I'm solving the Brigde and torch problem
in Haskell.
I wrote a function that given a state of the puzzle, as in which people have yet to cross and those who have crossed, gives back a list of all possible moves from one side to the other (moving two people forwards and one person backwards).
module DarkBridgeDT where
data Crossing = Trip [Float] [Float] Float deriving (Show)
data RoundTrip = BigTrip Crossing Crossing deriving (Show)
trip :: [Float] -> [Float] -> Float -> Crossing
trip x y z = Trip x y z
roundtrip :: Crossing -> Crossing -> RoundTrip
roundtrip x y = BigTrip x y
next :: Crossing -> [RoundTrip]
next (Trip [] _ _) = []
next (Trip (a:b:[]) s _ )
|a>b = [BigTrip (Trip [] (a:b:s) a) (Trip [] [] 0)]
|otherwise = [BigTrip (Trip [] (b:a:s) b) (Trip [] [] 0)]
next (Trip d s _) = [BigTrip (Trip [x,z] (i:j:s) j) b | i <- d, j <- d, i < j, x <- d, z <- d, x < z, z /= i, z /= j, x /= z, x /= i, x /= j, b <- (back [x,z] (i:j:s))]
where
back [] s = []
back d s = [Trip (i:d) (filter (/= i) s) i | i <- s]
Now I need a function that given a state as the one above and a maximum amount of time gives back all possible solutions to the puzzle in less than that given time.
All I have for that is this:
cross :: Crossing -> Float -> [[RoundTrip]]
cross (Trip [] _ _) _ = []
cross (Trip _ _ acu) max
| acu > max = []
cross (Trip a b acu) max = map (cross (map (crec) (next (Trip a b acu)) acu)) max
where
crec (BigTrip (Trip _ _ t1) (Trip a b t2)) acu = (Trip a b (t1+t2+acu))
Of course that doesn't compile, the 5th line is the one that's driving me insane. Any input?
Edit:
The cross function is meant to apply the next function to every result of the last nextfunction called.
If the first result of next was something like: [A,B,C,D] then it would call next on A B C and D to see if any or all of those get to a solution in less than max (A B C and D would be Crossings inside which contain the floats that are the time that ads up and is compared to max).
My data structure is
Crossing: Contains the first side of the bridge (the people in it represented by the time they take to cross the bridge) the other side of the bridge (the same as the other) and a time that represents the greatest time that last crossed the bridge (either the greatest of the two in the first crossing or the only one in the second) or the amount of time acumulated crossing the bridge (in the cross function).
RoundTrip: Represents two crossings, the first and the second, the one getting to safety and the one coming back to danger.
cross (Trip [1,2,5,10] [] 0) 16 should give an empty list for there is no solution that takes less than 17 minutes (or whatever time unit).
cross (Trip [1,2,5,10] [] 0) 17 should give the normal solution to the puzzle as a list of roundtrips.
I hope that makes it clearer.
Edit2:
I finally got it. I read Carsten's solution before I completed mine and we laid it out practically the same. He used fancier syntax and more complex structures but it's really similar:
module DarkBridgeST where
data Torch = Danger | Safety deriving (Eq,Show)
data State = State
[Float] -- people in danger
[Float] -- people safe
Torch -- torch position
Float -- remaining time
deriving (Show)
type Crossing = [Float]
classic :: State
classic = State [1,2,5,10] [] Danger 17
next :: State -> [Crossing] -- List all possible moves
next (State [] _ _ _) = [] -- Finished
next (State _ [] Safety _) = [] -- No one can come back
next (State danger _ Danger rem) = [[a,b] | a <- danger, b <- danger, a /= b, a < b, max a b <= rem]
next (State _ safe Safety rem) = [[a] | a <- safe, a <= rem]
cross :: State -> Crossing -> State -- Crosses the bridge depending on where the torch is
cross (State danger safe Danger rem) cross = State (taking cross danger) (safe ++ cross) Safety (rem - (maximum cross))
cross (State danger safe Safety rem) cross = State (danger ++ cross) (taking cross safe) Danger (rem - (maximum cross))
taking :: [Float] -> [Float] -> [Float]
taking [] d = d
taking (x:xs) d = taking xs (filter (/=x) d)
solve :: State -> [[Crossing]]
solve (State [] _ _ _) = [[]]
solve sf = do
c <- next sf
let sn = cross sf c
r <- solve sn
return (c:r)
All in all thanks everyone. I'm new to Haskell programming and this helped me understand a lot of things. I hope this post can also help someone starting haskell like me one day :)
I'm not going to leave much of your code intact here.
The first problems are with the data structures. Crossing doesn't actually represent anything to do with crossing the bridge, but the state before or after a bridge crossing. And you can't use RoundTrip because the number of bridge crossings is always odd.
I'm renaming the data structure I'm actually keeping, but I'm not keeping it unmodified.
data Bank = Danger | Safety deriving (Eq,Show)
data PuzzleState = PuzzleState
[Float] -- people still in danger
[Float] -- people on the safe bank
Bank -- current location of the torch
Float -- remaining time
type Crossing = ([Float],Bank)
Modifying/writing these functions is left as an exercise for the reader
next :: PuzzleState -> [Crossing] -- Create a list of possible crossings
applyCrossing :: PuzzleState -> Crossing -> PuzzleState -- Create the next state
Then something like this function can put it all together (assuming next returns an empty list if the remaining time is too low):
cross (PuzzleState [] _ _ _) = [[]]
cross s1 = do
c <- next s1
let s2 = applyCrossing s1 c
r <- cross s2
return $ c : r
Just for the fun, an approach using a lazy tree:
import Data.List
import Data.Tree
type Pawn = (Char, Int)
data Direction = F | B
data Turn = Turn {
_start :: [Pawn],
_end :: [Pawn],
_dir :: Direction,
_total :: Int
}
type Solution = ([String], Int)
-- generate a tree
mkTree :: [Pawn] -> Tree Turn
mkTree p = Node{ rootLabel = s, subForest = branches s }
where s = Turn p [] F 0
-- generates a node for a Turn
mkNode :: Turn -> Tree Turn
mkNode t = Node{ rootLabel = t, subForest = branches t }
-- next possible moves
branches :: Turn -> [Tree Turn]
-- complete
branches (Turn [] e d t) = []
-- moving forward
branches (Turn s e F t) = map (mkNode.turn) (next s)
where
turn n = Turn (s\\n) (e++n) B (t+time n)
time = maximum . map snd
next xs = [x| x <- mapM (const xs) [1..2], head x < head (tail x)]
-- moving backward
branches (Turn s e B t) = map (mkNode.turn) e
where
turn n = Turn (n:s) (delete n e) F (t+time n)
time (_,b) = b
solve :: Int -> Tree Turn -> [Solution]
solve limit tree = solve' [] [] limit tree
where
solve' :: [Solution] -> [String] -> Int -> Tree Turn -> [Solution]
solve' sols cur limit (Node (Turn s e d t) f)
| and [t <= limit, s == []] = sols ++ [(cur++[step],t)]
| t <= limit = concat $ map (solve' sols (cur++[step]) limit) f
| otherwise = []
where step = "[" ++ (v s) ++ "|" ++ (v e) ++ "]"
v = map fst
Then you you can get a list of solutions:
solve 16 $ mkTree [('a',2), ('b',4), ('c',8)]
=> [(["[abc|]","[c|ab]","[ac|b]","[|bac]"],14),(["[abc|]","[c|ab]","[bc|a]","[|abc]"],16),(["[abc|]","[b|ac]","[ab|c]","[|cab]"],14),(["[abc|]","[a|bc]","[ba|c]","[|cab]"],16)]
Or also generate a tree of solutions:
draw :: Int -> Tree Turn -> Tree String
draw limit (Node (Turn s e d t) f)
| t > limit = Node "Time Out" []
| s == [] = Node ("Complete: " ++ step) []
| otherwise = Node step (map (draw limit) f)
where step = "[" ++ (v s) ++ "|" ++ (v e) ++ "]" ++ " - " ++ (show t)
v = map fst
Then:
putStrLn $ drawTree $ draw 16 $ mkTree [('a',2), ('b',4), ('c',8)]
Will result in:
[abc|] - 0
|
+- [c|ab] - 4
| |
| +- [ac|b] - 6
| | |
| | `- Complete: [|bac] - 14
| |
| `- [bc|a] - 8
| |
| `- Complete: [|abc] - 16
|
+- [b|ac] - 8
| |
| +- [ab|c] - 10
| | |
| | `- Complete: [|cab] - 14
| |
| `- [cb|a] - 16
| |
| `- Time Out
|
`- [a|bc] - 8
|
+- [ba|c] - 12
| |
| `- Complete: [|cab] - 16
|
`- [ca|b] - 16
|
`- Time Out
Consider the modified Euler problem #4 -- "Find the maximum palindromic number which is a product of two numbers between 100 and 9999."
rev :: Int -> Int
rev x = rev' x 0
rev' :: Int -> Int -> Int
rev' n r
| n == 0 = r
| otherwise = rev' (n `div` 10) (r * 10 + n `mod` 10)
pali :: Int -> Bool
pali x = x == rev x
main :: IO ()
main = print . maximum $ [ x*y | x <- nums, y <- nums, pali (x*y)]
where
nums = [9999,9998..100]
This Haskell solution using -O2 and ghc 7.4.1 takes about 18
seconds.
The similar C solution takes 0.1 second.
So Haskell is 180 times
slower. What's wrong with my solution? I assume that this type of
problems Haskell solves pretty well.
Appendix - analogue C solution:
#define A 100
#define B 9999
int ispali(int n)
{
int n0=n, k=0;
while (n>0) {
k = 10*k + n%10;
n /= 10;
}
return n0 == k;
}
int main(void)
{
int max = 0;
for (int i=B; i>=A; i--)
for (int j=B; j>=A; j--) {
if (i*j > max && ispali(i*j))
max = i*j; }
printf("%d\n", max);
}
The similar C solution
That is a common misconception.
Lists are not loops!
And using lists to emulate loops has performance implications unless the compiler is able to eliminate the list from the code.
If you want to compare apples to apples, write the Haskell structure more or less equivalent to a loop, a tail recursive worker (with strict accumulator, though often the compiler is smart enough to figure out the strictness by itself).
Now let's take a more detailed look. For comparison, the C, compiled with gcc -O3, takes ~0.08 seconds here, the original Haskell, compiled with ghc -O2 takes ~20.3 seconds, with ghc -O2 -fllvm ~19.9 seconds. Pretty terrible.
One mistake in the original code is to use div and mod. The C code uses the equivalent of quot and rem, which map to the machine division instructions and are faster than div and mod. For positive arguments, the semantics are the same, so whenever you know that the arguments are always non-negative, never use div and mod.
Changing that, the running time becomes ~15.4 seconds when compiling with the native code generator, and ~2.9 seconds when compiling with the LLVM backend.
The difference is due to the fact that even the machine division operations are quite slow, and LLVM replaces the division/remainder with a multiply-and-shift operation. Doing the same by hand for the native backend (actually, a slightly better replacement taking advantage of the fact that I know the arguments will always be non-negative) brings its time down to ~2.2 seconds.
We're getting closer, but are still a far cry from the C.
That is due to the lists. The code still builds a list of palindromes (and traverses a list of Ints for the two factors).
Since lists cannot contain unboxed elements, that means there is a lot of boxing and unboxing going on in the code, that takes time.
So let us eliminate the lists, and take a look at the result of translating the C to Haskell:
module Main (main) where
a :: Int
a = 100
b :: Int
b = 9999
ispali :: Int -> Bool
ispali n = go n 0
where
go 0 acc = acc == n
go m acc = go (m `quot` 10) (acc * 10 + (m `rem` 10))
maxpal :: Int
maxpal = go 0 b
where
go mx i
| i < a = mx
| otherwise = go (inner mx b) (i-1)
where
inner m j
| j < a = m
| p > m && ispali p = inner p (j-1)
| otherwise = inner m (j-1)
where
p = i*j
main :: IO ()
main = print maxpal
The nested loop is translated to two nested worker functions, we use an accumulator to store the largest palindrome found so far. Compiled with ghc -O2, that runs in ~0.18 seconds, with ghc -O2 -fllvm it runs in ~0.14 seconds (yes, LLVM is better at optimising loops than the native code generator).
Still not quite there, but a factor of about 2 isn't too bad.
Maybe some find the following where the loop is abstracted out more readable, the generated core is for all intents and purposes identical (modulo a switch of argument order), and the performance of course the same:
module Main (main) where
a :: Int
a = 100
b :: Int
b = 9999
ispali :: Int -> Bool
ispali n = go n 0
where
go 0 acc = acc == n
go m acc = go (m `quot` 10) (acc * 10 + (m `rem` 10))
downto :: Int -> Int -> a -> (a -> Int -> a) -> a
downto high low acc fun = go high acc
where
go i acc
| i < low = acc
| otherwise = go (i-1) (fun acc i)
maxpal :: Int
maxpal = downto b a 0 $ \m i ->
downto b a m $ \mx j ->
let p = i*j
in if mx < p && ispali p then p else mx
main :: IO ()
main = print maxpal
#axblount is at least partly right; the following modification makes the program run almost three times as fast as the original:
maxPalindrome = foldl f 0
where f a x | x > a && pali x = x
| otherwise = a
main :: IO ()
main = print . maxPalindrome $ [x * y | x <- nums, y <- nums]
where nums = [9999,9998..100]
That still leaves a factor 60 slowdown, though.
This is more true to what the C code is doing:
maxpali :: [Int] -> Int
maxpali xs = go xs 0
where
go [] m = m
go (x:xs) m = if x > m && pali(x) then go xs x else go xs m
main :: IO()
main = print . maxpali $ [ x*y | x <- nums, y <- nums ]
where nums = [9999,9998..100]
On my box this takes 2 seconds vs .5 for the C version.
Haskell may be storing that entire list [ x*y | x <- nums, y <- nums, pali (x*y)] where as the C solution calculates the maximum on the fly. I'm not sure about this.
Also the C solution will only calculate ispali if the product beats the previous maximum. I would bet Haskell calculates are palindrome products regardless of whether x*y is a possible max.
It seems to me that you are having a branch prediction problem. In the C code, you have two nested loops and as soon as a palindrome is seen in the inner loop, the rest of the inner loop will be skipped very fast.
The way you feed this list of products instead of the nested loops I am not sure that ghc is doing any of this prediction.
Another way to write this is to use two folds, instead of one fold over the flattened list:
-- foldl g0 0 [x*y | x<-[b-1,b-2..a], y<-[b-1,b-2..a], pali(x*y)] (A)
-- foldl g1 0 [x*y | x<-[b-1,b-2..a], y<-[b-1,b-2..a]] (B)
-- foldl g2 0 [ [x*y | y<-[b-1,b-2..a]] | x<-[b-1,b-2..a]] (C)
maxpal b a = foldl f1 0 [b-1,b-2..a] -- (D)
where
f1 m x = foldl f2 m [b-1,b-2..a]
where
f2 m y | p>m && pali p = p
| otherwise = m
where p = x*y
main = print $ maxpal 10000 100
Seems to run much faster than (B) (as in larsmans's answer), too (only 3x - 4x slower then the following loops-based code). Fusing foldl and enumFromThenTo definitions gets us the "functional loops" code (as in DanielFischer's answer),
maxpal_loops b a = f (b-1) 0 -- (E)
where
f x m | x < a = m
| otherwise = g (b-1) m
where
g y m | y < a = f (x-1) m
| p>m && pali p = g (y-1) p
| otherwise = g (y-1) m
where p = x*y
The (C) variant is very suggestive of further algorithmic improvements (that's outside the scope of the original Q of course) that exploit the hidden order in the lists, destroyed by the flattening:
{- foldl g2 0 [ [x*y | y<-[b-1,b-2..a]] | x<-[b-1,b-2..a]] (C)
foldl g2 0 [ [x*y | y<-[x, x-1..a]] | x<-[b-1,b-2..a]] (C1)
foldl g0 0 [ safehead 0 . filter pali $
[x*y | y<-[x, x-1..a]] | x<-[b-1,b-2..a]] (C2)
fst $ until ... (\(m,s)-> (max m .
safehead 0 . filter pali . takeWhile (> m) $
head s, tail s))
(0,[ [x*y | y<-[x, x-1..a]] | x<-[b-1,b-2..a]]) (C3)
safehead 0 $ filter pali $ mergeAllDescending
[ [x*y | y<-[x, x-1..a]] | x<-[b-1,b-2..a]] (C4)
-}
(C3) can stop as soon as the head x*y in a sub-list is smaller than the currently found maximum. It is what short-cutting functional loops code could achieve, but not (C4), which is guaranteed to find the maximal palindromic number first. Plus, for list-based code its algorithmic nature is more visually apparent, IMO.