This question derived from previous question and answer. You can found the link here: Haskell :: Recursion in Recursion for Loop in Loop (Part 1)
The question were answered, I can say super amazing with nice explanation for future reference. Credit to #user2407038 for his amazing skills. However, something interesting to ponder with recursion with more than two partition. To make it clear I've changed the data a little bit for simplicity. Here how it looks:
Previously, the 2 red dots were generated by finding (min x, min y) and (max x, max y). To generate 4 red dots (min x, min y) (max x, min y) (min x, max y) (max x, max y) partition4 should take into consideration. Visually it looks like this:
Considering the max members for each group is 3, group 1 and group 4 exceed the number. A new group should be created based on these group. However, the trickier part is that this group will not compute the distance with previous red dots:
The edited code for previous question:
data Point = Point { ptX :: Double, ptY :: Double }
data Cluster = Cluster { clusterPts :: [Point] }
minMaxPoints :: [Point] -> (Point, Point)
minMaxPoints ps =
(Point minX minY
,Point maxX maxY)
where minX = minimum $ map ptX ps
maxX = maximum $ map ptX ps
minY = minimum $ map ptY ps
maxY = maximum $ map ptY ps
main = do
let pointDistance :: Point -> Point -> Double
pointDistance (Point x1 y1) (Point x2 y2) = sqrt $ (x1-x2)^2 + (y1-y2)^2
cluster1 :: [Point] -> [Cluster]
cluster1 ps =
let (mn, mx) = minMaxPoints ps
(psmn, psmx) = partition (\p -> pointDistance mn p < pointDistance mx p) ps
in [ Cluster psmn, Cluster psmx ]
cluster :: [Point] -> [Cluster]
cluster ps =
cluster1 ps >>= \cl#(Cluster c) ->
if length c > 5
then cluster c
else [cl]
testPts :: [Point]
testPts = map (uncurry Point)
[ (1,0), (2,1), (0,2)
, (5,2), (4,3), (4,4)
, (8,2), (9,3), (10,2)
, (11,4), (12,3), (13,3) ]
main = mapM (map (\p -> (ptX p, ptY p)) . clusterPts) $ cluster testPts
print main
I've found it when the length c changed the answer as not as expected it should be. Perhaps I've edited it wrongly (Sigh).
Still figuring how to fit in PartitionN code for partitioning into N groups as suggested.
Related
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)
Hi I am generating a sparse DAG of 1000 X 1000 nodes each having ~4 edges (direction). Here is the relevant code : Full Code with imports
The problem i am solving has values between [0-1500]. I have hardcoded 1501 as upper value for now. I am trying to calculate longest path of edges in the DAG. However, these details are not direct part of my question :
My question is related to how to judge the usage of force or similar constructs while writing algos in haskell :
type OutGoingEdges = Map.Map NodeId [ NodeId ]
type NodesData = Map.Map NodeId Node
type NodeId = Int
data DAG = AdjList
{ outGoingEdges :: OutGoingEdges
, nodesData :: NodesData
} deriving (Eq, Show)
makeDAG :: DAGDataPath -> IO (DAG, SourceNodes)
makeDAG filepath = do
listOfListOfInts <- makeInteger <$> readLines filepath
let [width, height] = head listOfListOfInts
numNodes = width * height
rows = (replicate width 1501) : (drop 1 listOfListOfInts) ++ [(replicate width 1501)]
heightsWithNodeIdsRows = force . fmap (\ (row, rowId) -> fmap (\ (height, colId) -> (height, rowId * width + colId)) $ zip row [1..]) $ zip rows [1..]
emptyGraph = AdjList Map.empty $ Map.fromList (fmap (\(h, nid) -> (nid, Node h)) . concat . tail . init $ heightsWithNodeIdsRows)
emptyNodesWithEdges = Set.empty
threeRowsInOneGo = zip3 heightsWithNodeIdsRows (drop 1 heightsWithNodeIdsRows) (drop 2 heightsWithNodeIdsRows)
(graph, nodesWithInEdges) = DL.foldl' makeGraph (emptyGraph, emptyNodesWithEdges) threeRowsInOneGo
sourceNodes = Set.difference (Set.fromList . Map.keys . nodesData $ graph) nodesWithInEdges
-- traceShow [take 10 . Map.keys . nodesData $ graph] (return (Set.toList sourceNodes))
-- traceShow graph (return (Set.toList sourceNodes))
-- traceShow sourceNodes (return (Set.toList sourceNodes))
return (graph, force $ Set.toList sourceNodes)
where
makeGraph (graphTillNow, nodesWithInEdges) (prevRow, row, nextRow) =
let updownEdges = zip3 prevRow row nextRow
(graph', nodesInEdges') = addEdges (graphTillNow, nodesWithInEdges) updownEdges
leftRightEdges = zip3 ((1501, 0) : row) (drop 1 row) (drop 2 row)
(graph'', nodesInEdges'') = addEdges (graph', nodesInEdges') leftRightEdges
Next line is interesting... graph'' is DAG and nodesInEdges'' is a Set NodeId
in (graph'', nodesInEdges'')
addEdges (g, n) edges =
DL.foldl' (\ (!g', !n') ((p, pId), (c, cId), (n, nId)) ->
let (g'', n'') = if c > p
then (makeEdge cId pId g', Set.insert pId n')
else (g', n')
(g''', n''') = if c > n
then (makeEdge cId nId g'', Set.insert nId n'')
else (g'', n'')
in (g''', n'''))
(g, n)
edges
While profiling i found that, if i use (force graph'', force nodesInEdges'') instead of (graph'', nodesInEdges''), my memory usage reduces from 3 GB to 600 MB. But running time of program increases from 37 secs to 69 secs. These numbers are from time command and looking at activity monitor. I also checked with profiling and it was similar results.
I am compiling profile builds with :
stack build --executable-profiling --library-profiling --ghc-options="-fprof-auto -auto-all -caf-all -fforce-recomp -rtsopts" --file-watch
I have ghc-7.10.3 and stack 1.1.2.
I think that force goes over the data structure again and again.
Can force be told to not go over the graph if it already fully evaluated ?
Can i use some other strategy ?
Sample Input:
2 2 -- width height
1 2
3 4
Output:
3
Output is length of longest path in the graph. [4 -> 2 -> 1] i.e. [(1,1),(0,1), (0,0)]. Just to remind, correctness of program is not the question;
space/time efficiency is. Thanks
Yesterday I finally decided to start learning Haskell. I started scanning through tutorials, but quickly decided practical exercises would be more beneficial. Therefore I proceeded to port a python script of mine which supposedly simulates gravity into Haskell. To my surprise it actually worked and the generated values match those of python.
I realize the implementation is probably absolutely terrible. The horrible lack of performance does not bother me so much, but what bothers me is that I keep running out of memory when attempting to run the simulation for a longer period of time. Is this because the implementation is inherently flawed or can it be made to work?
I have tried to construct the main loop with three different approaches: "iterate", a recursive function (I read about tail recursion, but didn't manage to make it work) and with a more experimental recursive do function. The functions in question are named simulation, test and test2. I compiled the program with option "-O2".
Why does the program run out of memory, and what can I do to prevent that?
Not so relevant parts of the code:
import System.Environment
import Data.List (tails)
import System.CPUTime
import Text.Printf
import Control.Exception
gConst = 6.674e-11
data Vector = Vector2D Double Double | Vector3D Double Double Double deriving (Show)
deltaVector :: Vector -> Vector -> Vector
deltaVector (Vector2D x1 y1) (Vector2D x2 y2) = Vector2D (x2 - x1) (y2 - y1)
deltaVector (Vector3D x1 y1 z1) (Vector3D x2 y2 z2) = Vector3D (x2 - x1) (y2 - y1) (z2 - z1)
data Position = Position Vector deriving (Show)
data Velocity = Velocity Vector deriving (Show)
distance2DSquared (Vector2D deltaX deltaY) = deltaX ** 2 + deltaY ** 2
distance3DSquared (Vector3D deltaX deltaY deltaZ) = (distance2DSquared $ Vector2D deltaX deltaY) + deltaZ ** 2
distance vector = sqrt (distance3DSquared $ vector)
force vector mass1 mass2 = gConst * (mass1 * mass2) / (distance3DSquared vector)
acceleration force mass = force / mass
vectorComponentDivide (Vector2D x y) c = Vector2D (x/c) (y/c)
vectorComponentDivide (Vector3D x y z) c = Vector3D (x/c) (y/c) (z/c)
vectorComponentMultiply (Vector2D x y) c = Vector2D (x*c) (y*c)
vectorComponentMultiply (Vector3D x y z) c = Vector3D (x*c) (y*c) (z*c)
vectorComponentAdd (Vector2D x1 y1) (Vector2D x2 y2) = Vector2D (x1+x2) (y1+y2)
vectorComponentAdd (Vector3D x1 y1 z1) (Vector3D x2 y2 z2) = Vector3D (x1+x2) (y1+y2) (z1+z2)
invertedVector (Vector2D x1 y1) = Vector2D (-x1) (-y1)
invertedVector (Vector3D x1 y1 z1) = Vector3D (-x1) (-y1) (-z1)
normalizedVector :: Vector -> Vector
normalizedVector vector = vectorComponentDivide vector $ distance vector
velocity vel0 mass1 mass2 vector deltaT =
vectorComponentMultiply (vectorComponentAdd vel0 (vectorComponentMultiply (normalizedVector vector) (acceleration (force vector mass1 mass2) mass1))) deltaT
data Actor = Actor String Vector Vector Double deriving (Show)
earth = Actor "Object1" (Vector3D 0 0 0) (Vector3D 0 0 0) 10
moon = Actor "Object2" (Vector3D 10 0 0) (Vector3D 0 0 0) 10
actors = [earth, moon]
combinations :: Int -> [a] -> [[a]]
combinations 0 _ = [ [] ]
combinations n xs = [ y:ys | y:xs' <- tails xs
, ys <- combinations (n-1) xs']
updateVelocity [(Actor name1 position1 velocity1 mass1),(Actor name2 position2 velocity2 mass2)] =
[(Actor name1 position1 a mass1),(Actor name2 position2 b mass2)]
where a = velocity velocity1 mass1 mass2 vector deltaT
b = velocity velocity2 mass2 mass1 (invertedVector vector) deltaT
vector = deltaVector position1 position2
deltaT = 1
updatePosition [(Actor name1 position1 velocity1 mass1),(Actor name2 position2 velocity2 mass2)] =
[Actor name1 (vectorComponentAdd position1 velocity1) velocity1 mass1, Actor name2 (vectorComponentAdd position2 velocity2) velocity2 mass2]
Relevant parts:
update list = map updatePosition (map updateVelocity list)
simulation state n = do
if n == 0
then do
print state
return ()
else do
let newState = update state
simulation newState $! (n-1)
test list n = iterate update list !! n
test2 list 0 = list
test2 list n = (test2 (update list) (n-1))
time :: IO t -> IO t
time a = do
start <- getCPUTime
v <- a
end <- getCPUTime
let diff = (fromIntegral (end - start)) / (10^12)
printf "Computation time: %0.3f sec\n" (diff :: Double)
return v
main :: IO ()
main = do
let combo = combinations 2 actors
putStrLn "Hello World!"
let n = 1000000
print n
--time $ print (test combo n)
time $ simulation combo n
_ <- getLine
putStrLn "BAI"
I believe laziness harms your code: your code builds large thunks (unevaluated expressions) which lead to OOM.
For instance, iterate is (in)famous for leading to large thunks, when you access the resulting list in the middle without forcing the previous list elements. More precisely
iterate f x !! n
is bad, since it will build the expression f (f (f ...(f x))) before really performing any work. We want to evaluate every list element before accessing the next one. This could be dome by a custom !! function:
(!!!) :: [a] -> Int -> a
[] !!! _ = error "!!!: out of range"
(x:_ ) !!! 0 = x
(x:xs) !!! n = seq x (xs !!! pred n)
Now we can use iterate f a !!! n without large thunks building up.
This has the same problem:
simulation state n = do
if n == 0
then do
print state
return ()
else do
let newState = update state
simulation newState $! (n-1)
It will build large update (update (update ...)) thunks without evaluating them. A possible fix could be
...
(simulation $! newState) $! (n-1)
However, keep in mind that in your case newState is a list (of lists!). In such case, seq or $! will only demand the list to be evaluated as far as its first cell constructor -- just enough to check whether the list is empty or not. This "forcing" might be enough or not for your purposes.
There is a library function named deepSeq which will force the full list, if really needed (use Hoogle to find the docs).
Summing up: lazy evaluation has its benefits and its downsides. It usually allows for more efficiency, e.g. sometimes providing constant space list processing without the need of writing carefully crafted functions. It also allows infinite lists tricks which are handy. However, it can also cause unwanted thunks to stick around for too long, wasting memory. So, in those cases, programmers have some burden put on them. Especially when one is used to strict semantics, these issues can be scary at first (we've been there!).
I have a function ascArr :: String -> BigData for parsing some big strict data from a string and another one, altitude :: BigData -> Pt -> Maybe Double, for getting something useful from the parsed data. I want to parse the big data once and then use the altitude function with the first argument fixed and the second one varying. Here's the code (TupleSections are enabled):
exampleParseAsc :: IO ()
exampleParseAsc = do
asc <- readFile "foo.asc"
let arr = ascArr asc
print $ map (altitude arr . (, 45)) [15, 15.01 .. 16]
This is all ok. Then I want to connect the two functions together and to use partial application for caching the big data. I use three versions of the same function:
parseAsc3 :: String -> Pt -> Maybe Double
parseAsc3 str = altitude d
where d = ascArr str
parseAsc4 :: String -> Pt -> Maybe Double
parseAsc4 str pt = altitude d pt
where d = ascArr str
parseAsc5 :: String -> Pt -> Maybe Double
parseAsc5 = curry (uncurry altitude . first ascArr)
And I call them like this:
exampleParseAsc2 :: IO ()
exampleParseAsc2 = do
asc <- readFile "foo.asc"
let alt = parseAsc5 asc
print $ map (alt . (, 45)) [15, 15.01 .. 16]
Only the parseAsc3 works like in the exampleParseAsc: Memory usage rises at the beginning (when allocating memory for the UArray in the BigData), then it is constant while parsing, then altitude quickly evaluates the result and then everything is done and the memory is freed. The other two versions are different: The memory usage rises multiple times until all the memory is consumed, I think that the parsed big data is not cached inside the alt closure. Could someone explain the behaviour? Why are the versions 3 and 4 not equivalent? In fact I started with something like parseAsc2 function and just after hours of trial I found out the parseAsc3 solution. And I am not satisfied without knowing the reason...
Here you can see all my effort (only the parseAsc3 does not consume whole the memory; parseAsc is a bit different from the others - it uses parsec and it was really greedy for memory, I'd be glad if some one explained me why, but I think that the reason is different than the main point of this question, you may just skip it):
type Pt = (Double, Double)
type BigData = (UArray (Int, Int) Double, Double, Double, Double)
parseAsc :: String -> Pt -> Maybe Double
parseAsc str (x, y) =
case parse ascParse "" str of
Left err -> error "no parse"
Right (x1, y1, coef, m) ->
let bnds = bounds m
i = (round $ (x - x1) / coef, round $ (y - y1) / coef)
in if inRange bnds i then Just $ m ! i else Nothing
where
ascParse :: Parsec String () (Double, Double, Double, UArray (Int, Int) Double)
ascParse = do
[w, h] <- mapM ((read <$>) . keyValParse digit) ["ncols", "nrows"]
[x1, y1, coef] <- mapM ((read <$>) . keyValParse (digit <|> char '.'))
["xllcorner", "yllcorner", "cellsize"]
keyValParse anyChar "NODATA_value"
replicateM 6 $ manyTill anyChar newline
rows <- replicateM h . replicateM w
$ read <$> (spaces *> many1 digit)
return (x1, y1, coef, listArray ((0, 0), (w - 1, h - 1)) (concat rows))
keyValParse :: Parsec String () Char -> String -> Parsec String () String
keyValParse format key = string key *> spaces *> manyTill format newline
parseAsc2 :: String -> Pt -> Maybe Double
parseAsc2 str (x, y) = if all (inRange bnds) (is :: [(Int, Int)])
then Just $ (ff * (1 - px) + cf * px) * (1 - py)
+ (fc * (1 - px) + cc * px) * py
else Nothing
where (header, elevs) = splitAt 6 $ lines str
header' = map ((!! 1) . words) header
[w, h] = map read $ take 2 header'
[x1, y1, coef, _] = map read $ drop 2 header'
bnds = ((0, 0), (w - 1, h - 1))
arr :: UArray (Int, Int) Double
arr = listArray bnds (concatMap (map read . words) elevs)
i = [(x - x1) / coef, (y - y1) / coef]
[ixf, iyf, ixc, iyc] = [floor, ceiling] >>= (<$> i)
is = [(ix, iy) | ix <- [ixf, ixc], iy <- [iyf, iyc]]
[px, py] = map (snd . properFraction) i
[ff, cf, fc, cc] = map (arr !) is
ascArr :: String -> BigData
ascArr str = (listArray bnds (concatMap (map read . words) elevs), x1, y1, coef)
where (header, elevs) = splitAt 6 $ lines str
header' = map ((!! 1) . words) header
[w, h] = map read $ take 2 header'
[x1, y1, coef, _] = map read $ drop 2 header'
bnds = ((0, 0), (w - 1, h - 1))
altitude :: BigData -> Pt -> Maybe Double
altitude d (x, y) = if all (inRange bnds) (is :: [(Int, Int)])
then Just $ (ff * (1 - px) + cf * px) * (1 - py)
+ (fc * (1 - px) + cc * px) * py
else Nothing
where (arr, x1, y1, coef) = d
bnds = bounds arr
i = [(x - x1) / coef, (y - y1) / coef]
[ixf, iyf, ixc, iyc] = [floor, ceiling] >>= (<$> i)
is = [(ix, iy) | ix <- [ixf, ixc], iy <- [iyf, iyc]]
[px, py] = map (snd . properFraction) i
[ff, cf, fc, cc] = map (arr !) is
parseAsc3 :: String -> Pt -> Maybe Double
parseAsc3 str = altitude d
where d = ascArr str
parseAsc4 :: String -> Pt -> Maybe Double
parseAsc4 str pt = altitude d pt
where d = ascArr str
parseAsc5 :: String -> Pt -> Maybe Double
parseAsc5 = curry (uncurry altitude . first ascArr)
Compiled with GHC 7.10.3, with -O optimization.
Thank you.
You can figure out what's happening by looking at the generated core from GHC. The evaluation semantics of optimized core are very predictable (unlike Haskell itself) so it is often a useful tool for performance analysis.
I compiled your code with ghc -fforce-recomp -O2 -ddump-simpl file.hs with GHC 7.10.3. You can look at the full output yoursefl but I've extracted the relevant bits:
$wparseAsc2
$wparseAsc2 =
\ w_s8e1 ww_s8e5 ww1_s8e6 ->
let { ...
parseAsc2 =
\ w_s8e1 w1_s8e2 ->
case w1_s8e2 of _ { (ww1_s8e5, ww2_s8e6) ->
$wparseAsc2 w_s8e1 ww1_s8e5 ww2_s8e6
}
The code above looks a little funny but is essentially Haskell. Note that the first thing parseAsc2 does is force its second argument to be evaluated (the case statement evaluates the tuple, which corresponds to the pattern match) - but not the string. The string won't be touched until deep inside $wParseAsc2 (definition omitted). But the part of the function that computes the "parse" is inside the lambda - it will be recomputed for every invocation of the function. You don't even have to look at what it is - the rules for evaluating core expressions are very prescriptive.
$wparseAsc
$wparseAsc =
\ w_s8g9 ww_s8gg ww1_s8gi -> ...
parseAsc
parseAsc =
\ w_s8g9 w1_s8ga ->
case w1_s8ga of _ { (ww1_s8gd, ww2_s8gi) ->
case ww1_s8gd of _ { D# ww4_s8gg ->
$wparseAsc w_s8g9 ww4_s8gg ww2_s8gi
}
}
The situation with parseAsc has little to do with Parsec*. This is much like version two - now both arguments are evaluated, however. This has little effect, however, on the performance, because the same problem is there - $wparseAsc is just a lambda, meaning all the work it does is done at every invocation of the function. There can be no sharing.
parseAsc3 =
\ str_a228 ->
let {
w_s8c1
w_s8c1 =
case $wascArr str_a228
of _ { (# ww1_s8gm, ww2_s8gn, ww3_s8go, ww4_s8gp #) ->
(ww1_s8gm, ww2_s8gn, ww3_s8go, ww4_s8gp)
} } in
\ w1_s8c2 ->
case w1_s8c2 of _ { (ww1_s8c5, ww2_s8c6) ->
$waltitude w_s8c1 ww1_s8c5 ww2_s8c6
}
Here is the "good" version. It takes a string, applies $wascArr to it, and then the string is never used again. This is crucial - if this function is partially applied to a string, you are left with let w_s = .. in \w1 -> ... - none of this mentions the string, so it can be garbage collected. The long lived reference is to w_s which is your "big data". And note: even if a reference to the string was maintained, and it could not be garbage collected, this version would still be substantially better - simply because it does not recompute the "parse" at each invocation of the function. This is the critical flaw - the fact that the string can be garbage collected immediately is extra.
parseAsc4 =
\ str_a22a pt_a22b ->
case pt_a22b of _ { (ww1_s8c5, ww2_s8c6) ->
$waltitude (ascArr str_a22a) ww1_s8c5 ww2_s8c6
}
Same issue as version two. Unlike version three, if you partially apply this, you get \w1 -> altitude (ascArr ...) ..., so ascArr is recomputed for every invocation of the function. It doesn't matter how you use this function - it simply won't work the way you want.
parseAsc5 = parseAsc4
Amazingly (to me), GHC figures out that parseAsc5 is precisely the same as parseAsc4! Well this one should be obvious then.
As for why GHC generates this particular core for this code, it really isn't easy to tell. In many cases the only way to guarantee sharing is to have explicit sharing in your original code. GHC does not do common subexpression elimination - parseAsc3 implements manual sharing.
*Maybe the parser itself has some performance issues too, but that isn't the focus here. If you have question about your Parsec parser (performance wise, or otherwise) I encourage you to ask a separate question.
I've written some code that's meant to integrate a function numerically using the trapezoidal rule. It works, but the answer it produces has a wrong sign. Why might that be?
The code is:
integration :: (Double -> Double) -> Double -> Double -> Double
integration f a b = h * (f a + f b + partial_sum)
where
h = (b - a) / 1000
most_parts = map f (points (1000-1) h)
partial_sum = sum most_parts
points :: Double -> Double -> [Double]
points x1 x2
| x1 <= 0 = []
| otherwise = (x1*x2) : points (x1-1) x2
Trapezoidal rule
The code is probably inelegant, but I'm only a student of Haskell and would like to deal with the current problem first and coding style matters after that.
Note: This answer is written in literate Haskell. Save it with .lhs as extension and load it in GHCi to test the solution.
Finding the culprit
First of all, let's take a look at integration. In its current form, it contains only summation of function values f x. Even though the factors aren't correct at the moment, the overall approach is fine: you evaluate f at the grid points. However, we can use the following function to verify that there's something wrong:
ghci> integration (\x -> if x >= 10 then 1 else (-1)) 10 15
-4.985
Wait a second. x isn't even negative in [10,15]. This suggests that you use the wrong grid points.
Grid points revisited
Even though you've linked the article, let's have a look at an exemplary use of the trapezoidal rule (public domain, original file by Oleg Alexandrov):
Although this doesn't use a uniform grid, let's suppose that the 6 grid points are equidistant with grid distance h = (b - a) / 5. What are the x coordinates of those points?
x_0 = a + 0 * h (== a)
x_1 = a + 1 * h
x_2 = a + 2 * h
x_3 = a + 3 * h
x_4 = a + 4 * h
x_5 = a + 5 * h (== b)
If we use set a = 10 and b = 15 (and therefore h = 1), we should end up with [10, 11, 12, 13, 14, 15]. Let's check your points. In this case, you would use points 5 1 and end up with [5,4,3,2,1].
And there's the error. points doesn't respect the boundary. We can easily fix this by using pointsWithOffset:
> points :: Double -> Double -> [Double]
> points x1 x2
> | x1 <= 0 = []
> | otherwise = (x1*x2) : points (x1-1) x2
>
> pointsWithOffset :: Double -> Double -> Double -> [Double]
> pointsWithOffset x1 x2 offset = map (+offset) (points x1 x2)
That way, we can still use your current points definition to generate grid points from x1 to 0 (almost). If we use integration with pointsWithOffset, we end up with
integration :: (Double -> Double) -> Double -> Double -> Double
integration f a b = h * (f a + f b + partial_sum)
where
h = (b - a) / 1000
most_parts = map f (pointsWithOffset (1000-1) h a)
partial_sum = sum most_parts
Tying up loose ends
However, this doesn't take into account that you use all inner points twice in the trapezoid rule. If we add the factors, we end up with
> integration :: (Double -> Double) -> Double -> Double -> Double
> integration f a b =
> h / 2 * (f a + f b + 2 * partial_sum)
> -- ^^^ ^^^
> where
> h = (b - a) / 1000
> most_parts = map f (pointsWithOffset (1000-1) h a)
> partial_sum = sum most_parts
Which yields the correct value for our test function above.
Exercise
Your current version only supports 1000 grid points. Add an Int argument so that one can change the number of grid points:
integration :: Int -> (Double -> Double) -> Double -> Double -> Double
integration n f a b = -- ...
Furthermore, try to write points in different ways, for example go from a to b, use takeWhile and iterate, or even a list comprehension.
Yes it indeed was the points plus you had some factors wrong (the inner points are multiplied by 2) - this is the fixed version of your code:
integration :: (Double -> Double) -> Double -> Double -> Double
integration f a b = h * (f a + f b + innerSum) / 2
where
h = (b - a) / 1000
innerPts = map ((2*) . f . (a+)) (points (1000-1) h)
innerSum = sum innerPts
points :: Double -> Double -> [Double]
points i x
| i <= 0 = []
| otherwise = (i*x) : points (i-1) x
which gives sensible approximations (to 1000 points):
λ> integration (const 2) 1 2
2.0
λ> integration id 1 2
1.5
λ> integration (\x -> x*x) 1 2
2.3333334999999975
λ> 7/3
2.3333333333333335