Related
I am trying to write a linear interpolation in Haskell:
linear_interpolation:: [(Double, Double)] -> Double -> Maybe Double
linear_interpolation list x
| x1 /= Nothing && x2 /= Nothing && y1 /= Nothing && y2 /= Nothing
= Just (y1+ (y2-y1)*(x - x1)/(x2 - x1))
| otherwise = Nothing
where
x2 = find (> x) (x_list list)
x1 = max_elem $ filter (< x) (x_list list)
y1 = lookup x1 list
y2 = lookup x2 list
But I get this error:
• Couldn't match type ‘Double’ with ‘Maybe Double’
Expected: [(Maybe Double, Double)]
Actual: [(Double, Double)]
• In the second argument of ‘lookup’, namely ‘list’
In the expression: lookup x2 list
In an equation for ‘y2’: y2 = lookup x2 list
|
29 | y2 = lookup x2 list
| ^^^^
I don't really understand what's going on, because lookup type is like that:
lookup :: Eq a => a -> [(a, b)] -> Maybe b
P.S
The same problem for y1, x1, x2
Testing x1 /= Nothing doesn't change the type of x1, which is still Maybe Double, so we can't perform arithmetic operations on x1.
For this reason, testing x1 /= Nothing, isNothing x1, or isJust x1 is most likely to be the wrong thing to do. Most often what we really need to use is pattern matching:
linear_interpolation
:: [(Double, Double)] -> Double -> Maybe Double
linear_interpolation list x = let
x2 = find (> x) (x_list list)
x1 = max_elem $ filter (< x) (x_list list)
in case (x1, x2) of
(Just x1', Just x2') -> let
y1 = lookup x1' list
y2 = lookup x2' list
in case (y1, y2) of
(Just y1', Just y2') ->
Just (y1' + (y2' - y1')*(x - x1')/(x2' - x1'))
-> Nothing
_ -> Nothing
Here, x1',x2',y1',y2' will have the wanted type Double.
The nested let and case is not so readable. In this case, it's simpler if we exploit the Maybe monad and use do notation.
linear_interpolation
:: [(Double, Double)] -> Double -> Maybe Double
linear_interpolation list x = do
x2 <- find (> x) (x_list list)
x1 <- max_elem $ filter (< x) (x_list list)
y1 <- lookup x1 list
y2 <- lookup x2 list
Just (y1 + (y2 - y1)*(x - x1)/(x2 - x1))
Here, using <-, we make x1,x2,y1,y2 :: Double removing the Maybe from the type. The Nothing case is automatically dealt with, which makes it rather convenient.
I'm doing some dynamic programming in Haskell with mutual recursion implementation.
I decided to speed things up using memoization.
Monad.Memo offers MemoT transformer for that exact case. But it uses Map as internal representation for stored values. And while this gave me order of magnitude speed boost it is still not enough.
While lib supports Array-based and Vector-based implementation as internal storage it only works for simple recursion and I did not found any transformers like MemoT to use it for mutual recursion.
What is the best way to do mutual recursion memoization with efficient vector based internal representation (if any)?
My next question is about memoization effect. So I expected my function to take more time during first run and much less during consecutive runs. But what I found running it in ghci the time it takes each time is the same. So no difference between first and second run. I measured time as follows:
timeit $ print $ dynamic (5,5)
With dynamic being my function.
The full implementation is as follows:
import Control.Monad.Memo
import Control.Monad.Identity
type Pos = (Int, Int)
type MemoQ = MemoT (Int, Int, Int) [Int]
type MemoV = MemoT (Int, Int, Int) Int
type MemoQV = MemoQ (MemoV Identity)
-- we are moving to (0,0) as we can always shift the world by substituting variables
-- due to symmetry of cost function it is enougth to solve for only positive x and y
dynamic :: Pos -> [Int]
dynamic (x, y) = lastUnique $ map (evalQ x y) [1 ..]
where lastUnique (x0:x1:xs) | x0 == x1 = x0
| otherwise = lastUnique (x1:xs)
evalQ :: Int -> Int -> Int -> [Int]
evalQ x y n = startEvalMemo . startEvalMemoT $ fqmon x y n
fqmon :: Int -> Int -> Int -> MemoQV [Int]
fqmon _ _ 0 = return [0,0,0,0]
fqmon x y n = do
let pts = neighbours (x, y)
let v = for3 memol1 fvmon n
let c = cost (x, y)
let q = fmap (c +) . uncurry v
traverse q pts
fvmon :: Int -> Int -> Int -> MemoQV Int
fvmon _ 0 0 = return 0
fvmon 0 x y = return $ cost (x, y)
fvmon n x y | limit = return 1000000
| otherwise = liftM minimum $ for3 memol0 fqmon x' y' (n - 1)
where x' = abs x
y' = abs y
limit = x' > 25 || y' > 25
cost :: Pos -> Int
cost (x, y) = abs x + abs y
neighbours :: Pos -> [Pos]
neighbours (x, y) = [(x-1, y), (x+1, y), (x, y-1), (x, y+1)]
Added:
According to #liqui comment I tried memcombinators.
So first is the non memoized initial implementation:
type Pos = (Int, Int)
dynamic :: Int -> Int -> [Int]
dynamic x y = lastUnique $ map (fq x y) [1 ..]
where lastUnique (x0:x1:xs) | x0 == x1 = x0
| otherwise = lastUnique (x1:xs)
fq :: Int -> Int -> Int -> [Int]
fq _ _ 0 = [0, 0, 0, 0] -- Q at 0 step is 0 in all directions
fq x y n = (cost (x, y) +) . (uncurry $ fv n) <$> neighbours (x, y)
fv :: Int -> Int -> Int -> Int
fv _ 0 0 = 0 -- V at (0, 0) is 0 at any atep
fv 0 x y = cost (x, y) -- V at 0 step is a cost
fv n x y = minimum $ fq x y (n - 1)
cost :: Pos -> Int
cost (x, y) = abs x + abs y
neighbours :: Pos -> [Pos]
neighbours (x, y) = [(x-1, y), (x+1, y), (x, y-1), (x, y+1)]
Then my attempt to memization (only changed part):
dynamic :: Int -> Int -> [Int]
dynamic x y = lastUnique $ map (fqmem x y) [1 ..]
where lastUnique (x0:x1:xs) | x0 == x1 = x0
| otherwise = lastUnique (x1:xs)
-- memoizing version of fq
fqmem :: Int -> Int -> Int -> [Int]
fqmem x y n = fqmem' x y n
where fqmem' = memo3 integral integral integral fq
-- memoizing version of fv
fvmem :: Int -> Int -> Int -> Int
fvmem n x y = fvmem' n x y
where fvmem' = memo3 integral integral integral fv
fq :: Int -> Int -> Int -> [Int]
fq _ _ 0 = [0, 0, 0, 0] -- Q at 0 step is 0 in all directions
fq x y n = (cost (x, y) +) . (uncurry $ fvmem n) <$> neighbours (x, y)
fv :: Int -> Int -> Int -> Int
fv _ 0 0 = 0 -- V at (0, 0) is 0 at any atep
fv 0 x y = cost (x, y) -- V at 0 step is a cost
fv n x y = minimum $ fqmem x y (n - 1)
The result a bit of paradox. It is 3 time slower than non memoized recursive implementation. Memoizing only one function (namely fq) and not touching fv gives results 2 times slower. The more I memoize with memcombinators the slower the computation. And again no difference between first and second invocation.
Also the last question. What is the rationale for choosing between Monad.Memo or memcombinators or MemotTrie? There is a point on using last 2 in comments. What are the situations when Monad.Memo is a better choice?
Finally MemoTrie did the job.
At first invocation it works as fast (possibly much faster) than Monad.Memo and at consecutive invocations it take virtually no time!
And tha change in code is trivial compared to monadic approach:
import Data.MemoTrie
type Pos = (Int, Int)
-- we are moving to (0,0) as we can always shift the world by substituting variables
-- due to symmetry it is enougth to solve for only positive x and y
dynamic :: Int -> Int -> [Int]
dynamic x y = lastUnique $ map (fqmem x y) [1 ..]
where lastUnique (x0:x1:xs) | x0 == x1 = x0
| otherwise = lastUnique (x1:xs)
fqmem = memo3 fq
fvmem = memo3 fv
fq :: Int -> Int -> Int -> [Int]
fq _ _ 0 = [0, 0, 0, 0] -- Q at 0 step is 0 in all directions
fq x y n = (cost (x, y) +) . (uncurry $ fvmem n) <$> neighbours (x, y)
fv :: Int -> Int -> Int -> Int
fv _ 0 0 = 0 -- V at (0, 0) is 0 at any atep
fv 0 x y = cost (x, y) -- V at 0 step is a cost
fv n x y = minimum $ fqmem x y (n - 1)
cost :: Pos -> Int
cost (x, y) = abs x + abs y
neighbours :: Pos -> [Pos]
neighbours (x, y) = [(x-1, y), (x+1, y), (x, y-1), (x, y+1)]
Still I would like to know what is the benefits of using Monad.Memo and what are use cases for that? Or it becomes obsolete with MemoTrie?
Why Memocombinators did not worked for me?
What is the rule of thumb on choosing between Monad.Memo, Memocombinators or MemoTrie?
I'm testing this code:
puntosEnCircunferencia :: Float -> (Float , Float) -> [(Float , Float)] -> [(Float , Float)]
puntosEnCircunferencia a y z = filter auxPuntos z
where auxPuntos (w,s) (k,r) = ((k - w)^2 + (r - s)^2) < (a ^ 2)
but it throw me this error:
• Couldn't match type ‘(Float, Float) -> Bool’ with ‘Bool’
Expected type: (Float, Float) -> Bool
Actual type: (Float, Float) -> (Float, Float) -> Bool
• Probable cause: ‘auxPuntos’ is applied to too few arguments
In the first argument of ‘filter’, namely ‘auxPuntos’
In the expression: filter auxPuntos z
In an equation for ‘puntosEnCircunferencia’:
puntosEnCircunferencia a y z
= filter auxPuntos z
where
auxPuntos (w, s) (k, r) = ((k - w) ^ 2 + (r - s) ^ 2) < (a ^ 2)
What im doing wrong. Im starting with Haskell so I don't have much experience to fix this.
Thanks.
puntosCircunferencia takes three arguments: a radius a, a center y, and a list of points z. auxPuntos should test if a single given point is with a distance a of point y, and as such should only take a single argument.
Below, I replace y with a pattern to match the components, as we need those in the definition of auxPuntos.
puntosEnCircunferencia a (x0, y0) zs = filter auxPuntos zs
where auxPuntos (x1, y1) = ((x1-x0)^2 + (y1-y0)^2) < (a^2)
Another (possibly) clearer way to write this is to define a distance function as well.
puntosEnCircunferencia a y zs = filter auxPuntos zs
where auxPuntos p = squareDistance p y < a^2
squareDistance (x0, y0) (x1, y1) = (x1 - x0)^2 + (y1 - y0)^2
(In either case, you can drop zs as an explicit argument:
puntosEnCircunferencia a y = filter auxPuntos
where ...
)
The problem of your code is in the where pattern matching, the ghci tell us:
Expected type: (Float, Float) -> Bool
Actual type: (Float, Float) -> (Float, Float) -> Bool
Now lets get back into your code, you have:
where auxPuntos (w,s) (k,r) = ((k - w)^2 + (r - s)^2) < (a ^ 2)
Above you're calling auxPuntos with 2 parameters (two arrays), but you only have one list of arrays z not two.
filter auxPuntos z
But remember the type of filter is:
filter :: (a -> Bool) -> [a] -> [a]
So we only apply a filter to [a], to solve this we need to add the k and r values into the where:
puntosEnCircunferencia a b z= filter p z
where
k = b !! 0
r = b !! 1
p (w,s)= ((k - w)^2 + (r - s)^2) < a^2
ghci> largestDivisible 1 [2,1] [(1,2),(3,4)]
I'm trying to write a simulator for charged and massed objects based on just calculating the net force on each object then finding the change in position across the period of time specified by the user.
However, I'm finding that when I change the dt, the change in position is drastic, when it shouldn't change significantly, decreasing the dt should just let the position converge on the correct answer.
For instance, with objects at the Cartesian coordinates (1, 0, 0) and (-1, 0, 0), with masses of 9e-31 (mass of electron) and a charge of 1 Coulomb (not the charge of an electron, I know), run for 0.1 seconds and a dt of 0.01 seconds, there is a total change of position of 2048 meters for each object. However, run for 0.1 seconds and a dt of 0.001 seconds, there is a change in position of about 1.3e30 meters. This seems rather outrageous to me, but I can't find any issues in the parts that use dt.
The code I'm using (c/p'd to avoid any possible changes)
import Data.List
main = print $ mainprog
where
mainprog = runUniverse makeUniverse 1 0.1
type Length = Double
type Mass = Double
type Charge = Double
type Time = Double
type Vector = (Double, Double, Double)
type Position = Vector
type Velocity = Vector
type Acceleration = Vector
type Force = Vector
data Widget = Widget {pos :: Position, mass :: Double, charge :: Double, velocity :: Velocity} deriving (Eq, Show, Read)
--utils
toScalar :: Vector -> Double
toScalar (x, y, z) = sqrt (x ^^ 2 + y ^^ 2 + z ^^ 2)
toUnit :: Vector -> Vector
toUnit (x, y, z) = (x / scalar, y / scalar, z / scalar)
where
scalar = toScalar (x, y, z)
add :: Vector -> Vector -> Vector
add (x1, y1, z1) (x2, y2, z2) = (x1 + x2, y1 + y2, z1 + z2)
mult :: Vector -> Double -> Vector
mult (x, y, z) k = (k * x, k * y, k * z)
diff :: Vector -> Vector -> Vector
diff (x1, y1, z1) (x2, y2, z2) = (x1 - x2, y1 - y2, z1 - z2)
--calcs
gForce :: Widget -> Widget -> Force
gForce (Widget pos1 mass1 _ _) (Widget pos2 mass2 _ _) = mult unitForce scalarForce
where
unitForce = toUnit posdiff
scalarForce = (g * mass1 * mass2) / (radius ^^ 2)
g = 6.674e-11
radius = toScalar posdiff
posdiff = diff pos1 pos2
eForce :: Widget -> Widget -> Force
eForce (Widget pos1 _ charge1 _) (Widget pos2 _ charge2 _) = mult unitForce scalarForce
where
unitForce = (toUnit posdiff)
--necessary to determine attraction vs repulsion, whereas gravitational is always attractive
scalarForce = ((abs (k_C * charge1 * charge2)) / (radius ^^ 2)) * (signum charge1) * (signum charge2)
k_C = 8.988e9
radius = toScalar posdiff
posdiff = diff pos1 pos2
netForce :: [Force] -> Force
netForce = foldl add (0, 0, 0)
toAccel :: Force -> Widget -> Acceleration
toAccel f (Widget _ mass _ _) = mult f (1/mass)
newVeloc :: Velocity -> Acceleration -> Time -> Velocity
newVeloc v a dt = add v (mult a dt)
newPos :: Vector -> Velocity -> Time -> Vector
newPos s v dt = add s (mult v dt)
newWidget :: Widget -> Position -> Velocity -> Widget
newWidget (Widget pos1 mass charge vel1) pos2 vel2 = Widget pos2 mass charge vel2
tUniverse :: [Widget] -> Time -> [Widget]
tUniverse widgets dt = zipWith3 newWidget widgets poses vels
where
netMassForces = map (\w -> gForcePrime w (widgets \\ [w])) widgets
gForcePrime w ws = netForce $ map (gForce w) ws
netElectricForces = map (\w -> eForcePrime w (widgets \\ [w])) widgets
eForcePrime w ws = netForce $ map (eForce w) ws
volds = map velocity widgets
polds = map pos widgets
accels = zipWith toAccel (map netForce (zipWith (\a b -> a : [b]) netMassForces netElectricForces)) widgets
vels = zipWith (\v a -> newVeloc v a dt) volds accels
poses = zipWith (\s v -> newPos s v dt) polds vels
makeUniverse :: [Widget]
makeUniverse = [(Widget (-1, 0, 0) 1 1 (0, 0, 0)), (Widget (1, 0, 0) 1 1 (0, 0, 0))]
runUniverse :: [Widget] -> Time -> Time -> [Widget]
runUniverse ws t dt
| t <= 0 = ws
| otherwise = runUniverse (tUniverse (inelasticCollide ws) dt) (t-dt) dt
inelasticCollide :: [Widget] -> [Widget]
inelasticCollide [] = []
inelasticCollide (w:[]) = [w]
inelasticCollide (w:ws) = (combine w (sameposes w ws)) : (inelasticCollide $ ws \\ (sameposes w ws))
where
sameposes w ws = filter (\w' -> pos w == pos w') ws
combine :: Widget -> [Widget] -> Widget
combine = foldl (\(Widget pos mass1 charge1 veloc1) (Widget _ mass2 charge2 veloc2) -> Widget pos (charge1 + charge2) (mass1 + mass2) (newveloc mass1 mass2 veloc1 veloc2))
--inelastic collision, m1v1 + m2v2 = m3v3 therefore v3 = (m1v1 + m2v2)/(m1 + m2)
newveloc m1 m2 v1 v2 = ((v1 `mult` m1) `add` (v2 `mult` m2)) `mult` (1 / (m1 + m2))
The issue I know is in the tUniverse function, probably in some calculation of either acceleration, velocity, or position (accels, vels, or poses). I've tried changing toAccel, newVeloc, and newPos by multiplying each by the inverse of dt, but it didn't significantly change the outputs.
Feel free to ignore inelasticCollide, I could probably replace it with the id function, but I just left it in because it will be relevant at some point.
EDIT: I've updated the code to fix the incorrect calculation of acceleration, the switching of mass and charge in inelasticallyCollide, and the double counting with dpos/dvel, but I'm still finding that I'm getting an error of by a magnitude of 10. For instance, with a charge of 1 C for each, I got ~10^8 for dt = 0.01 and ~10^7 for dt = 0.1 and with a charge of 0.01 C for each, ~250 for dt = 0.01 and ~65 for dt = 0.1.
It seems the "obvious" issue is that newWidget assumes dpos and dvel are deltas, but when it's called in tUniverse poses and vels have actually already done the addition.
To debug I had rewritten things to use newtypes thinking that perhaps there was a mismatch somewhere. There did turn out to be an issue of masses and charges being transposed in inelasticCollide but that didn't matter for my test case. The way I found this issue was by adding the traces and seeing that the object's position component doubled each tick when the velocity component was 1.
I have no idea whether any calculations are accurate otherwise.
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
import Data.List
import Debug.Trace (trace)
main = print $ runUniverse makeUniverse 0.1 0.01
newtype Length = Length {unLength::Double}
newtype Mass = Mass {unMass::Double} deriving (Num,Eq,Show)
newtype Charge = Charge {unCharge::Double} deriving (Num,Eq,Show)
newtype Time = Time {unTime::Double} deriving (Num,Eq,Ord,Fractional)
type Vector = (Double,Double,Double)
newtype Position = Position {unPosition::Vector} deriving (Eq,Show)
newtype Velocity = Velocity {unVelocity::Vector} deriving (Eq,Show)
newtype Acceleration = Acceleration {unAcceleration::Vector}
newtype Force = Force {unForce::Vector} deriving (Eq,Show)
data Widget = Widget {pos :: Position, mass :: Mass, charge :: Charge, velocity :: Velocity} deriving (Eq, Show)
--utils
toScalar :: Vector -> Double
toScalar (x, y, z) = sqrt (x ^^ 2 + y ^^ 2 + z ^^ 2)
toUnit :: Vector -> Vector
toUnit (x, y, z) = (x / scalar, y / scalar, z / scalar)
where
scalar = toScalar (x, y, z)
add :: Vector -> Vector -> Vector
add (x1, y1, z1) (x2, y2, z2) = (x1 + x2, y1 + y2, z1 + z2)
mult :: Vector -> Double -> Vector
mult (x, y, z) k = (k * x, k * y, k * z)
diff :: Vector -> Vector -> Vector
diff (x1, y1, z1) (x2, y2, z2) = (x1 - x2, y1 - y2, z1 - z2)
--calcs
gForce :: Widget -> Widget -> Force
gForce (Widget (Position pos1) (Mass mass1) _ _) (Widget (Position pos2) (Mass mass2) _ _) = Force (mult unitForce scalarForce)
where
unitForce = toUnit posdiff
scalarForce = (g * mass1 * mass2) / (radius ^^ 2)
g = 6.674e-11
radius = toScalar posdiff
posdiff = diff pos1 pos2
eForce :: Widget -> Widget -> Force
eForce (Widget (Position pos1) _ (Charge charge1) _) (Widget (Position pos2) _ (Charge charge2) _) = Force (mult unitForce scalarForce)
where
unitForce = (toUnit posdiff)
--necessary to determine attraction vs repulsion, whereas gravitational is always attractive
scalarForce = ((abs (k_C * charge1 * charge2)) / (radius ^^ 2)) * (signum charge1) * (signum charge2)
k_C = 8.988e9
radius = toScalar posdiff
posdiff = diff pos1 pos2
netForce :: [Force] -> Force
netForce = Force . foldl add (0,0,0) . map unForce
toAccel :: Force -> Widget -> Acceleration
toAccel f (Widget _ mass _ _) = Acceleration (mult (unForce f) (unMass mass))
newVeloc :: Velocity -> Acceleration -> Time -> Velocity
newVeloc v a dt = Velocity (add (unVelocity v) (mult (unAcceleration a) (unTime dt)))
newPos :: Position -> Velocity -> Time -> Position
newPos s v dt = Position (add (unPosition s) (mult (unVelocity v) (unTime dt)))
newWidget :: Widget -> Position -> Velocity -> Widget
newWidget w#(Widget pos1 _ _ vel1) dpos dvel = w { pos=Position ((unPosition dpos)),velocity=Velocity ((unVelocity dvel)) }
tUniverse :: [Widget] -> Time -> [Widget]
tUniverse widgets dt = zipWith3 newWidget widgets (trace (show poses) poses) (trace (show vels) vels)
where
netMassForces = map (\w -> gForcePrime w (widgets \\ [w])) widgets
gForcePrime w ws = netForce $ map (gForce w) ws
netElectricForces = map (\w -> eForcePrime w (widgets \\ [w])) widgets
eForcePrime w ws = netForce $ map (eForce w) ws
volds = map velocity widgets
polds = map pos widgets
accels = zipWith toAccel (map netForce (zipWith (\a b -> a : [b]) netMassForces netElectricForces)) widgets
vels = zipWith (\v a -> newVeloc v a dt) volds accels
poses = zipWith (\s v -> newPos s v dt) polds vels
makeUniverse :: [Widget]
makeUniverse = [Widget (Position (1,0,0)) (Mass 0) (Charge 0) (Velocity (1,0,0))] -- , (Widget (1, 0, 0) 9e-31 1 (0, 0, 0))]
runUniverse :: [Widget] -> Time -> Time -> [Widget]
runUniverse ws t dt
| t < 0 = ws
| otherwise = runUniverse (tUniverse (inelasticCollide ws) dt) (t-dt) dt
inelasticCollide :: [Widget] -> [Widget]
inelasticCollide [] = []
inelasticCollide (w:[]) = [w]
inelasticCollide (w:ws) = (combine w (sameposes w ws)) : (inelasticCollide $ ws \\ (sameposes w ws))
where
sameposes w ws = filter (\w' -> pos w == pos w') ws
combine :: Widget -> [Widget] -> Widget
combine = foldl (\(Widget pos mass1 charge1 veloc1) (Widget _ mass2 charge2 veloc2) -> Widget pos (mass1 + mass2) (charge1 + charge2) (Velocity (newveloc (unMass mass1) (unMass mass2) (unVelocity veloc1) (unVelocity veloc2))))
--inelastic collision, m1v1 + m2v2 = m3v3 therefore v3 = (m1v1 + m2v2)/(m1 + m2)
newveloc m1 m2 v1 v2 = ((v1 `mult` m1) `add` (v2 `mult` m2)) `mult` (1 / (m1 + m2))
I am currently making a ray tracing program with Haskell. As I am a very beginner of Haskell, I don't understand the evaluation strategy of IO monad clearly.
The problem is the memory usage of a long list of "IO a", which is "IO Vec" in my code.
Each element of the list is computed by a recursive function that compute IO Vec which represents the color for a pixel. Therefore, the length of the list is equals to width x height.
In addition, I take multiple samples for a pixels. As a whole, the function radiance to compute pixel value is called width x height x samples times.
First I was implemented this program simply by using list comprehension. The code is like,
main = do
...
let ray = (compute ray for every pair of [0..w-1], [0..h-1]
pixels <- sequence [ (sumOfRadiance scene ray samples) | ray <- rays]
In my understanding, as pixels is not used before it is written to a file, Haskell stores some data for function call inside pixels which is an array of IO Vec. Finally, memory consumption increases by calling recursive function radiance to compute pixel values.
If I change the program to evaluate the pixel value one by one using unsafePerformIO can prevent this strange use of memory space.
main = do
...
let ray = (compute ray for every pair of [0..w-1], [0..h-1]
let pixels = [ (unsafePerformIO (sumOfRadiance scene ray samples)) | ray <- rays]
I know unsafePerformIO is a bad solution, so I'd like to know if Haskell provides another way to evaluate inside of IO monad immediately. The following is the whole of my code (Sorry, it's a bit long...)
Thank you for your help.
-- Small path tracing with Haskell
import System.Environment
import System.Random.Mersenne
import System.IO.Unsafe
import Control.Monad
import Codec.Picture
import Data.Time
import qualified Data.Word as W
import qualified Data.Vector.Storable as V
-- Parameters
eps :: Double
eps = 1.0e-4
inf :: Double
inf = 1.0e20
nc :: Double
nc = 1.0
nt :: Double
nt = 1.5
-- Vec
data Vec = Vec (Double, Double, Double) deriving (Show)
instance (Num Vec) where
(Vec (x, y, z)) + (Vec (a, b, c)) = Vec (x + a, y + b, z + c)
(Vec (x, y, z)) - (Vec (a, b, c)) = Vec (x - a, y - b, z - c)
(Vec (x, y, z)) * (Vec (a, b, c)) = Vec (x * a, y * b, z * c)
abs = undefined
signum = undefined
fromInteger x = Vec (dx, dx, dx) where dx = fromIntegral x
x :: Vec -> Double
x (Vec (x, _, _)) = x
y :: Vec -> Double
y (Vec (_, y, _)) = y
z :: Vec -> Double
z (Vec (_, _, z)) = z
mul :: Vec -> Double -> Vec
mul (Vec (x, y, z)) s = Vec (x * s, y * s, z * s)
dot :: Vec -> Vec -> Double
dot (Vec (x, y, z)) (Vec (a, b, c)) = x * a + y * b + z * c
norm :: Vec -> Vec
norm (Vec (x, y, z)) = Vec (x * invnrm, y * invnrm, z * invnrm)
where invnrm = 1 / sqrt (x * x + y * y + z * z)
cross :: Vec -> Vec -> Vec
cross (Vec (x, y, z)) (Vec (a, b, c)) = Vec (y * c - b * z, z * a - c * x, x * b - a * y)
-- Ray
data Ray = Ray (Vec, Vec) deriving (Show)
org :: Ray -> Vec
org (Ray (org, _)) = org
dir :: Ray -> Vec
dir (Ray (_, dir)) = dir
-- Material
data Refl = Diff
| Spec
| Refr
deriving Show
-- Sphere
data Sphere = Sphere (Double, Vec, Vec, Vec, Refl) deriving (Show)
rad :: Sphere -> Double
rad (Sphere (rad, _, _, _, _ )) = rad
pos :: Sphere -> Vec
pos (Sphere (_ , p, _, _, _ )) = p
emit :: Sphere -> Vec
emit (Sphere (_ , _, e, _, _ )) = e
col :: Sphere -> Vec
col (Sphere (_ , _, _, c, _ )) = c
refl :: Sphere -> Refl
refl (Sphere (_ , _, _, _, refl)) = refl
intersect :: Sphere -> Ray -> Double
intersect sp ray =
let op = (pos sp) - (org ray)
b = op `dot` (dir ray)
det = b * b - (op `dot` op) + ((rad sp) ** 2)
in
if det < 0.0
then inf
else
let sqdet = sqrt det
t1 = b - sqdet
t2 = b + sqdet
in ansCheck t1 t2
where ansCheck t1 t2
| t1 > eps = t1
| t2 > eps = t2
| otherwise = inf
-- Scene
type Scene = [Sphere]
sph :: Scene
sph = [ Sphere (1e5, Vec ( 1e5+1, 40.8, 81.6), Vec (0.0, 0.0, 0.0), Vec (0.75, 0.25, 0.25), Diff) -- Left
, Sphere (1e5, Vec (-1e5+99, 40.8, 81.6), Vec (0.0, 0.0, 0.0), Vec (0.25, 0.25, 0.75), Diff) -- Right
, Sphere (1e5, Vec (50.0, 40.8, 1e5), Vec (0.0, 0.0, 0.0), Vec (0.75, 0.75, 0.75), Diff) -- Back
, Sphere (1e5, Vec (50.0, 40.8, -1e5+170), Vec (0.0, 0.0, 0.0), Vec (0.0, 0.0, 0.0), Diff) -- Front
, Sphere (1e5, Vec (50, 1e5, 81.6), Vec (0.0, 0.0, 0.0), Vec (0.75, 0.75, 0.75), Diff) -- Bottom
, Sphere (1e5, Vec (50,-1e5+81.6,81.6), Vec (0.0, 0.0, 0.0), Vec (0.75, 0.75, 0.75), Diff) -- Top
, Sphere (16.5, Vec (27, 16.5, 47), Vec (0.0, 0.0, 0.0), Vec (1,1,1) `mul` 0.999, Spec) -- Mirror
, Sphere (16.5, Vec (73, 16.5, 78), Vec (0.0, 0.0, 0.0), Vec (1,1,1) `mul` 0.999, Refr) -- Glass
, Sphere (600, Vec (50, 681.6 - 0.27, 81.6), Vec (12, 12, 12), Vec (0, 0, 0), Diff) ] -- Light
-- Utility functions
clamp :: Double -> Double
clamp = (max 0.0) . (min 1.0)
isectWithScene :: Scene -> Ray -> (Double, Int)
isectWithScene scene ray = foldr1 (min) $ zip [ intersect sph ray | sph <- scene ] [0..]
nextDouble :: IO Double
nextDouble = randomIO
lambert :: Vec -> Double -> Double -> (Vec, Double)
lambert n r1 r2 =
let th = 2.0 * pi * r1
r2s = sqrt r2
w = n
u = norm $ (if (abs (x w)) > eps then Vec (0, 1, 0) else Vec (1, 0, 0)) `cross` w
v = w `cross` u
uu = u `mul` ((cos th) * r2s)
vv = v `mul` ((sin th) * r2s)
ww = w `mul` (sqrt (1.0 - r2))
rdir = norm (uu + vv + ww)
in (rdir, 1)
reflect :: Vec -> Vec -> (Vec, Double)
reflect v n =
let rdir = v - (n `mul` (2.0 * n `dot` v))
in (rdir, 1)
refract :: Vec -> Vec -> Vec -> Double -> (Vec, Double)
refract v n orn rr =
let (rdir, _) = reflect v orn
into = (n `dot` orn) > 0
nnt = if into then (nc / nt) else (nt / nc)
ddn = v `dot` orn
cos2t = 1.0 - nnt * nnt * (1.0 - ddn * ddn)
in
if cos2t < 0.0
then (rdir, 1.0)
else
let tdir = norm $ ((v `mul` nnt) -) $ n `mul` ((if into then 1 else -1) * (ddn * nnt + (sqrt cos2t)))
a = nt - nc
b = nt + nc
r0 = (a * a) / (b * b)
c = 1.0 - (if into then -ddn else (tdir `dot` n))
re = r0 + (1 - r0) * (c ** 5)
tr = 1.0 - re
pp = 0.25 + 0.5 * re
in
if rr < pp
then (rdir, (pp / re))
else (tdir, ((1.0 - pp) / tr))
radiance :: Scene -> Ray -> Int -> IO Vec
radiance scene ray depth = do
let (t, i) = (isectWithScene scene ray)
if inf <= t
then return (Vec (0, 0, 0))
else do
r0 <- nextDouble
r1 <- nextDouble
r2 <- nextDouble
let obj = (scene !! i)
let c = col obj
let prob = (max (x c) (max (y c) (z c)))
if depth >= 5 && r0 >= prob
then return (emit obj)
else do
let rlt = if depth < 5 then 1 else prob
let f = (col obj)
let d = (dir ray)
let x = (org ray) + (d `mul` t)
let n = norm $ x - (pos obj)
let orn = if (d `dot` n) < 0.0 then n else (-n)
let (ndir, pdf) = case (refl obj) of
Diff -> (lambert orn r1 r2)
Spec -> (reflect d orn)
Refr -> (refract d n orn r1)
nextRad <- (radiance scene (Ray (x, ndir)) (succ depth))
return $ ((emit obj) + ((f * nextRad) `mul` (1.0 / (rlt * pdf))))
toByte :: Double -> W.Word8
toByte x = truncate (((clamp x) ** (1.0 / 2.2)) * 255.0) :: W.Word8
accumulateRadiance :: Scene -> Ray -> Int -> Int -> IO Vec
accumulateRadiance scene ray d m = do
let rays = take m $ repeat ray
pixels <- sequence [radiance scene r 0 | r <- rays]
return $ (foldr1 (+) pixels) `mul` (1 / fromIntegral m)
main :: IO ()
main = do
args <- getArgs
let argc = length args
let w = if argc >= 1 then (read (args !! 0)) else 400 :: Int
let h = if argc >= 2 then (read (args !! 1)) else 300 :: Int
let spp = if argc >= 3 then (read (args !! 2)) else 4 :: Int
startTime <- getCurrentTime
putStrLn "-- Smallpt.hs --"
putStrLn $ " width = " ++ (show w)
putStrLn $ " height = " ++ (show h)
putStrLn $ " spp = " ++ (show spp)
let dw = fromIntegral w :: Double
let dh = fromIntegral h :: Double
let cam = Ray (Vec (50, 52, 295.6), (norm $ Vec (0, -0.042612, -1)));
let cx = Vec (dw * 0.5135 / dh, 0.0, 0.0)
let cy = (norm $ cx `cross` (dir cam)) `mul` 0.5135
let dirs = [ norm $ (dir cam) + (cy `mul` (y / dh - 0.5)) + (cx `mul` (x / dw - 0.5)) | y <- [dh-1,dh-2..0], x <- [0..dw-1] ]
let rays = [ Ray ((org cam) + (d `mul` 140.0), (norm d)) | d <- dirs ]
let pixels = [ (unsafePerformIO (accumulateRadiance sph r 0 spp)) | r <- rays ]
let pixelData = map toByte $! pixels `seq` (foldr (\col lst -> [(x col), (y col), (z col)] ++ lst) [] pixels)
let pixelBytes = V.fromList pixelData :: V.Vector W.Word8
let img = Image { imageHeight = h, imageWidth = w, imageData = pixelBytes } :: Image PixelRGB8
writePng "image.png" img
endTime <- getCurrentTime
print $ diffUTCTime endTime startTime
First, I think there is an error. When you talk about going from
pixels <- sequence [ (sumOfRadiance scene ray samples) | ray <- rays]
to
pixels <- sequence [ (unsafePerformIO (sumOfRadiance scene ray samples)) | ray <- rays]
that doesn't make sense. The types shouldn't match up -- sequence only makes sense if you are combining a bunch of things of type m a. It would be correct to do
let pixels = [ unsafePerformIO (sumOfRadiance scene ray samples) | ray <- rays ]
I will somewhat cavalierly assume that that is what you did and you simply made a mistake when entering your question.
If this is the case, then what you are actually looking for is a way to execute IO actions more lazily, not more immediately. The sequence call forces all the actions to be run right then, whereas the unsafePerformIO version simply creates a list of un-run actions (and indeed the list itself is generated lazily so it doesn't exist all at once), and the actions are run individually as their results are needed.
It appears that the reason you need IO is to generate random numbers. Randomness can be kind of a pain -- usually MonadRandom does the job, but it still creates a sequential dependence between actions and may still not be lazy enough (I'd give it a try -- if you use it you get reproducibility -- the same seed gives the same results, even after refactorings that respect the monad laws).
If MonadRandom doesn't work and you need to generate random numbers in a more on-demand way, the way would be to make your own randomness monad which does the same thing as your unsafePerformIO solution, but in a way that is properly encapsulated. I'm going to show you the way I consider to be the Haskell Way To Cheat. First, a lovely pure implementation sketch:
-- A seed tells you how to generate random numbers
data Seed = ...
splitSeed :: Seed -> (Seed, Seed)
random :: Seed -> Double
-- A Cloud is a probability distribution of a's, or an a which
-- depends on a random seed. This monad is just as lazy as a
-- pure computation.
newtype Cloud a = Cloud { runCloud :: Seed -> a }
deriving (Functor)
instance Monad Cloud where
return = Cloud . const
m >>= f = Cloud $ \seed ->
let (seed1, seed2) = splitSeed seed in
runCloud (f (runCloud m seed1)) seed2
(I think I got that right. The point is that at every bind you split the seed in two and pass one to the left and the other to the right.)
Now this is a perfectly pure implementation of randomness... with a couple catches. (1) there is no non-trivial splitSeed which will strictly respect the monad laws, and (2) even if we allow the laws to be broken, random number generators based on splitting can be pretty slow. But if we give up determinism, if all we care about is that we get a good sampling from the distribution rather than the exact same result, then we don't need to strictly respect the monad laws. And at that point we cheat and pretend there is a suitable Seed type:
data Seed = Seed
splitSeed Seed = (Seed, Seed)
-- Always NOINLINE functions with unsafePerformIO to keep the
-- optimizer from messing with you.
{-# NOINLINE random #-}
random Seed = unsafePerformIO randomIO
We should hide this inside a module to keep the abstraction barrier clear. Cloud and runCloud should not be exposed since they allow us to violate purity; expose only
runCloudIO :: Cloud a -> IO a
runCloudIO = return . runCloud
which doesn't technically need IO, but communicates that this will not be deterministic. Then you can build up whatever you need as a value in the Cloud monad, and run it once in your main program.
You might ask why we have a Seed type at all if it doesn't have any information. Well, I think splitSeed is just a nod to purity and isn't actually doing anything -- you could remove it -- but we need Cloud to be a function type so that the implicit caching of laziness doesn't break our semantics. Otherwise
let foo = random in liftM2 (,) foo foo
would always return a pair with two identical components, since the random value was really associated with foo. I am not sure about these things since at this point we are at war with the optimizer, it takes some experimentation.
Happy cheating. :-)