Related
I am trying to implement my code based almost directly on a paper (pages 34-35). I am using Haskell's Num class instead of the user-defined Number class suggested in the paper.
I want to focus on implementing addition over dynamic time-varying Float values, and subsequently addition over time-varying Points.
Listing 1 is my attempt. How do I get addition of points with time-varying coordinates to work properly? My research requires a review of the code in that particular paper. As far as it is practical, I need to stick to the structure of the original code in the paper. In other words, what
do I need to add to Listing 1 to overload (+) from Num to perform addition on time varying points?
module T where
type Time = Float
type Moving v = Time -> v
instance Num v => Num (Moving v) where
(+) a b = \t -> (a t) + (b t)
(-) a b = \t -> (a t) - (b t)
(*) a b = \t -> (a t) * (b t)
-- tests for time varying Float values, seems OK
a,b::(Moving Float)
a = (\t -> 4.0)
b = (\t -> 5.0)
testA = a 1.0
testAddMV1 = (a + b ) 1.0
testAddMV2 = (a + b ) 2.0
-- Point Class
class Num s => Points p s where
x, y :: p s -> s
xy :: s -> s -> p s
data Point f = Point f f deriving Show
instance Num v => Points Point v where
x (Point x1 y1) = x1
y (Point x1 y1) = y1
xy x1 y1 = Point x1 y1
instance Num v => Num (Point (Moving v)) where
(+) a b = xy (x a + x b) (y a + y b)
(-) a b = xy (x a - x b) (y a - y b)
(*) a b = xy (x a * x b) (y a * y b)
-- Cannot get this to work as suggested in paper.
np1, np2 :: Point (Moving Float)
np1 = xy (\t -> 4.0 + 0.5 * t) (\t -> 4.0 - 0.5 * t)
np2 = xy (\t -> 0.0 + 1.0 * t) (\t -> 0.0 - 1.0 * t)
-- Error
-- testAddMP1 = (np1 + np2 ) 1.0
-- * Couldn't match expected type `Double -> t'
-- with actual type `Point (Moving Float)'
The error isn't really about the addition operation. You also can't write np1 1.0 because this is a vector (I don't particularly like calling it that) whose components are functions. Whereas you try to use it as a function whose values are vectors.
What you're trying to express here is, "evaluate both the component-functions at this time-slice, and give me back the point corresponding to both coordinates". The standard solution (which I don't recommend, though) is to give Point a Functor instance. This is something the compiler can do for you:
{-# LANGUAGE DeriveFunctor #-}
data Point f = Point f f
deriving (Show, Functor)
And then you can write e.g.
fmap ($1) (np1 + np2)
Various libraries have special operators for this, e.g.
import Control.Lens ((??))
np1 + np2 ?? 1
Why is a functor instance a bad idea? For the same reason it's a bad idea to implement multiplication on points as component-wise multiplication†: it does not make sense physically. Namely, it depends on a particular choice of coordinate system, but the choice of coordinate frame is in principle arbitrary and should not affect the results. For addition it indeed does not affect the result (disregarding float inaccuracy), but for multiplication or arbitrary function-mapping it can massively affect the result.
A better solution is to just not use "function-valued points" in the first place, but instead point-valued functions.
np1, np2 :: Moving (Point Float)
np1 = \t -> xy (4.0 + 0.5 * t) (4.0 - 0.5 * t)
np2 t = xy (0.0 + 1.0 * t) (0.0 - 1.0 * t)
†Actually a functor instance is a less bad idea than a Num instance. The particular operation fmap ($1) is in fact equivariant under coordinate transformation. That's because point-evaluation of functions is a linear mapping. To properly express this, you could make Point an endofunctor in the category of linear maps.
I include a renaming approach in Listing 2 and a qualified import approach in Listing 3 .
Listing 2 contains code that I believe is reasonably close to the original code. It was necessary rename the operations in Number by appending (!). This avoids a clash with the operations in Prelude Num class. I believe that there were two errors in the original code. The most serious is in the instance Number (Moving Float) where the same operation symbols are used on the left and right of the equations (e.g. +). The compiler has no way to distinguish these operations. The other error is a syntax error instance Number v => (Point v) there is no class name after =>. In sort the original code will not run, which was the motivation behind the question.
Listing 2
module T where
type Time = Float
type Moving v = Time -> v
class Number a where
(+!), (-!), (*!) :: a -> a -> a
sqr1, sqrt1 :: a -> a
-- Define Number operations in terms of Num operations from Prelude
-- Original code does not distinguish between these operation and will not compile.
instance Number (Moving Float) where
(+!) a b = \t -> (a t) + (b t)
(-!) a b = \t -> (a t) - (b t)
(*!) a b = \t -> (a t) * (b t)
sqrt1 a = \t -> sqrt (a t)
sqr1 a = \t -> ((a t) * (a t))
data Point f = Point f f deriving Show
class Number s => Points p s where
x, y :: p s -> s
xy :: s -> s -> p s
dist :: p s -> p s -> s
dist a b = sqrt1 (sqr1 ((x a) -! (x b)) +! sqr1 ((y a) -! (y b)))
instance Number v => Points Point v where
x (Point x1 y1) = x1
y (Point x1 y1) = y1
xy x1 y1 = Point x1 y1
-- Syntax error in instance header in original code.
instance Number (Point (Moving Float)) where
(+!) a b = xy (x a +! x b) (y a +! y b)
(-!) a b = xy (x a -! x b) (y a -! y b)
(*!) a b = xy (x a *! x b) (y a *! y b)
sqrt1 a = xy (sqrt1 (x a)) (sqrt1 (y a))
sqr1 a = xy (sqr1 (x a)) (sqr1 (y a))
mp1, mp2 :: Point (Moving Float)
mp1 = (xy (\t -> 4.0 + 0.5 * t) (\t -> 4.0 - 0.5 * t))
mp2 = xy (\t -> 0.0 + 1.0 * t) (\t -> 0.0 - 1.0 * t)
movingDist_1_2 = dist mp1 mp2
dist_at_2 = movingDist_1_2 2.0 -- gives 5.83
Listing 3 uses a qualified import as suggested by ben. Note we need an additional instance to define the operations in the Number class using the Num class.
Listing 3
module T where
import qualified Prelude as P
type Time = P.Float
type Moving v = Time -> v
class Number a where
(+), (-), (*) :: a -> a -> a
sqr, sqrt:: a -> a
instance Number P.Float where
(+) a b = a P.+ b
(-) a b = a P.- b
(*) a b = a P.* b
sqrt a = P.sqrt a
sqr a = a P.* a
instance Number (Moving P.Float) where
(+) a b = \t -> (a t) + (b t)
(-) a b = \t -> (a t) - (b t)
(*) a b = \t -> (a t) * (b t)
sqrt a = \t -> sqrt (a t)
sqr a = \t -> ((a t) * (a t))
data Point f = Point f f deriving P.Show
class Number s => Points p s where
x, y :: p s -> s
xy :: s -> s -> p s
dist :: p s -> p s -> s
dist a b = sqrt (sqr ((x a) - (x b)) + sqr ((y a) - (y b)))
instance Number v => Points Point v where
x (Point x1 y1) = x1
y (Point x1 y1) = y1
xy x1 y1 = Point x1 y1
instance Number (Point (Moving P.Float)) where
(+) a b = xy (x a + x b) (y a + y b)
(-) a b = xy (x a - x b) (y a - y b)
(*) a b = xy (x a * x b) (y a * y b)
sqrt a = xy (sqrt (x a)) (sqrt (y a))
sqr a = xy (sqr (x a)) (sqr (y a))
mp1, mp2 :: Point (Moving P.Float)
mp1 = xy (\t -> 4.0 + (0.5 * t)) (\t -> 4.0 - (0.5 * t))
mp2 = xy (\t -> 0.0 + (1.0 * t)) (\t -> 0.0 - (1.0 * t))
movingDist_1_2 = dist mp1 mp2
dist_at_2 = movingDist_1_2 2.0
I'm trying to make sharpness filter in Haskell using JuicyPixels. And I've made same Gaussian blur function and it works fine, but that one doesn't. These (Int, Int, Int) tuples are my workaround for storing negative pixel values. T means tuples there in names.
pxMultNumT :: (Int, Int, Int) -> Double -> (Int, Int, Int)
pxMultNumT (r, g, b) q = (m r, m g, m b)
where m p = floor $ fromIntegral p * q
pxPlusT :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int)
pxPlusT (r1, g1, b1) (r2, g2, b2) = (r1 + r2, g1 + g2, b1 + b2)
fromPixelT :: PixelRGBA8 -> (Int, Int, Int)
fromPixelT (PixelRGBA8 r g b a) = (convert r, convert g, convert b)
toPixelT :: (Int, Int, Int) -> PixelRGBA8
toPixelT (r,g,b) = PixelRGBA8 (fromInteger $ toInteger r) (fromInteger $ toInteger g) (fromInteger $ toInteger b) 255
sharpen :: Image PixelRGBA8 -> Image PixelRGBA8
sharpen img#Image {..} = generateImage blurrer imageWidth imageHeight
where blurrer x y | x >= (imageWidth - offset) || x < offset
|| y >= (imageHeight - offset) || y < offset = whitePx
| otherwise = do
let applyKernel i j p | j >= matrixLength = applyKernel (i + 1) 0 p
| i >= matrixLength = toPixelT p
| otherwise = do
let outPixelT = pxMultNumT
(fromPixelT (pixelAt img (x + j - offset) (y + i - offset)))
(kernel !! i !! j)
applyKernel i (j+1) (outPixelT `pxPlusT` p)
applyKernel 0 0 (0,0,0)
kernel = [[ 0, -0.5, 0],
[-0.5, 3, -0.5],
[ 0, -0.5, 0]]
matrixLength = length kernel
offset = matrixLength `div` 2
And here are input image: and output image:
So, what did I wrong here?
Edit: I rewrote functions like this
sharpen :: Image PixelRGBA8 -> Image PixelRGBA8
sharpen img#Image {..} = promoteImage $ generateImage blurrer imageWidth imageHeight
where blurrer x y | x >= (imageWidth - offset) || x < offset
|| y >= (imageHeight - offset) || y < offset = PixelRGB8 0 0 0
| otherwise = do
let applyKernel i j p | j >= matrixLength = applyKernel (i + 1) 0 p
| i >= matrixLength = normalizePixel p
| otherwise = do
let outPixel = pxMultNum
(promotePixel $ dropTransparency $ pixelAt img (x + j - offset) (y + i - offset))
(kernel !! i !! j)
applyKernel i (j+1) (pxPlus outPixel p)
applyKernel 0 0 (PixelRGBF 0 0 0)
kernel = [[ -1, -1, -1],
[-1, 9, -1],
[ -1, -1, -1]]
matrixLength = length kernel
offset = matrixLength `div` 2
pxPlus :: PixelRGBF -> PixelRGBF -> PixelRGBF
pxPlus (PixelRGBF r1 g1 b1) (PixelRGBF r2 g2 b2) = PixelRGBF (r1 + r2) (g1 + g2) (b1 + b2)
pxMultNum :: PixelRGBF -> Float -> PixelRGBF
pxMultNum (PixelRGBF r g b) q = PixelRGBF (r * q) (g * q) (b * q)
normalizePixel :: PixelRGBF -> PixelRGB8
normalizePixel (PixelRGBF r g b) = PixelRGB8 (n r) (n g) (n b)
where n f = floor $ 255 * f
and now it works!
The short answer to your question is to use Double or Float instead of working with integral precision per channel. You are not gaining anything but this sort of overflow problems. Scaling [0, 255] range to [0.0, 1.0] should be the first step before you start doing image processing.
See my answer to your other question for more details on what you should do to improve your implementation. Here is also a proper solution to this problem as well:
import Data.Massiv.Array as A
import Data.Massiv.Array.Unsafe (makeStencil)
import Data.Massiv.Array.IO as A
sharpenImageF :: (ColorModel cs Float) => Image S cs Float -> Image S cs Float
sharpenImageF = compute . applyStencil padding sharpStencil
where
padding = noPadding -- decides what happens at the border
{-# INLINE sharpenImageF #-}
sharpStencil :: (Floating e, ColorModel cs e) => Stencil Ix2 (Pixel cs e) (Pixel cs e)
sharpStencil = makeStencil (Sz2 3 3) (1 :. 1) stencil
where
stencil f = (-0.5) * f (-1 :. 0)
- 0.5 * f ( 0 :. -1) + 3 * f ( 0 :. 0) - 0.5 * f ( 0 :. 1)
- 0.5 * f ( 1 :. 0)
{-# INLINE stencil #-}
{-# INLINE sharpStencil #-}
λ> img <- readImageAuto "4ZYKa.jpg" :: IO (Image S (SRGB 'Linear) Float)
λ> let imgSharpened = sharpenImageF img
λ> imgCropped <- extractM (1 :. 1) (size imgSharpened) img
λ> imgBoth <- appendM 1 imgCropped imgSharpened
λ> let out = convertPixel <$> imgBoth :: Image DL (Y'CbCr SRGB) Word8
λ> writeImage "out.jpg" $ computeAs S out
I need help with this function. It has to return 2 lists. All the points, that are in the radius in the first and all others in the second. This is what I wrote, but it gave me so much errors.
type Point = (Double, Double)
splitPoints :: Point -> Double -> [Point] -> ([Point], [Point])
splitPoints (x, y) r (z:zs)
|(_, _) _ [] = ([][])
|x * x + y * y <= r * r = (x,y) : (splitPoints (x, y) r zs) []
|otherwise = [] (x,y) : (splitPoints (x, y) r zs)
First, you have to move the pattern match for the empty list out of the guard and as a seperate function clause.
Second, I suggest putting the recursive call in a where clause to seperate the points in the circle and outside of the circle. Then you can check in your guard, in which list you have to insert the point.
type Point = (Double, Double)
splitPoints :: Point -> Double -> [Point] -> ([Point], [Point])
splitPoints _ _ [] = ([], [])
splitPoints center#(centerx, centery) r ((x,y):zs)
| (x-centerx)**2 + (y-centery)**2 <= r**2 = ((x,y) : inside, outside)
| otherwise = (inside, (x,y) : outside)
where (inside, outside) = splitPoints center r zs
The reason this does not work is because you make some syntactical errors:
pattern matching in the guards;
([][]) is not a 2-tuple with two empty lists;
[] (x, y) will try to perform function application with [] the function.
You furthermore calculate the distance of the center point to the origin, not the distance between two points. So either all Points will be in the left sublist, or in the right sublist.
We can fix this with:
type Point = (Double, Double)
splitPoints :: Point -> Double -> [Point] -> ([Point], [Point])
splitPoints _ _ [] = ([], [])
splitPoints (x0, y0) r ((x, y):zs)
| dx*dx + dy*dy <= r*r = ((x, y):ra, rb)
|otherwise = (ra, (x, y):rb)
where dx = x - x0
dy = y - y0
(ra,rb) = splitPoints (x0, y0) r zs
But this still does not look very elegant. I think it is probably better to separte your concerns. You can for example use partition :: (a -> Bool) -> [a] -> ([a], [a]) to divide items in two lists: one that satisfies a predicate, and one where the items do not satisfy this predicate.
So now it is a matter of designing a predicate. We can do that with:
import Data.List(partition)
type Point = (Double, Double)
splitPoints :: Point -> Double -> [Point] -> ([Point], [Point])
splitPoints (x0, y0) r = partition p
where p (x, y) = dx*dx + dy*dy <= r * r
where dx = x - x0
dy = y - y0
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. :-)