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 want to write base implementation for Vertex.
data Point a = Point a a
class XY c where
x :: c a -> a
y :: c a -> a
class XY c => Vertex c where
translate :: c a -> c a -> c a
scale :: a -> c a -> c a
rotate :: a -> c a -> c a
instance XY Point where
x (Point first second) = first
y (Point first second) = second
instance Vertex Point where
translate xy1 xy2 = Point (x xy1 + x xy2) (y xy1 + y xy2)
scale a xy = Point ((*a) $ x xy) ((*a) $ y xy)
rotate a xy = Point (x * cosA - y * sinA) (x * sinA + y * cosA) where
cosA = cos a
sinA = sin a
I have to create instance of typeclass Vertex with implementation of Floating typeclass in Point type parameter.
If i implement it like instance (Floating a) => Vertex Point a where i get:
Expected kind ‘* -> Constraint’,
but ‘Vertex Point’ has kind ‘Constraint’
What is the correct way to write it in Haskell?
Aww. This well-known problem is a pet peeve of mine. The correct™ solution is to make the XY and Point classes not for parametric types. The scalar argument becomes an associated type synonym, and everything works easily:
{-# LANGUAGE TypeFamilies #-}
class XY p where
type Component p :: *
x :: p -> Component p
y :: p -> Component p
class XY p => Vertex p where
translate :: p -> p -> p
scale :: Component p -> p -> p
rotate :: Component p -> p -> p
N.B. In fact you could even consider simplifying this to always use the same component type, since you'll likely never need anything else:class XY p where
x :: p -> Double
y :: p -> Double
class XY p => Vertex p where
translate :: p -> p -> p
scale :: Double -> p -> p
rotate :: Double -> p -> p
With the non-parametric form, you can now easily add a number-type constraint exactly where it's needed, namely in the instance Vertex Point instance:
instance XY (Point a) where
type Component (Point a) = a
x (Point xc _) = xc
y (Point _ yc) = yc
instance Floating a => Vertex (Point a) where
translate xy1 xy2 = Point (x xy1 + x xy2) (y xy1 + y xy2)
scale a xy = Point ((*a) $ x xy) ((*a) $ y xy)
rotate a xy = Point (x * cosA - y * sinA) (x * sinA + y * cosA)
where cosA = cos a
sinA = sin a
For some reason†, most people however prefer to make classes for geometric entities parametric over the scalar type, which is not only completely unnecessary but also un-geometric, because proper geometry is emphatically not depended of an actual basis decomposition.
†Actually I'm fairly certain what the reason is: Edward Kmett's decision to use parameterised types in the linear library. He should have known better, especially since Conal Elliott's vector-space library, which does it the right way, has been around for longer already.
The following version is corrected so that it compiles:
data Point a = Point a a
class XY c where
x :: c a -> a
y :: c a -> a
class XY c => Vertex c where
translate :: (Num a) => c a -> c a -> c a
scale :: (Num a) => a -> c a -> c a
rotate :: (Floating a) => a -> c a -> c a
instance XY Point where
x (Point first second) = first
y (Point first second) = second
instance Vertex Point where
translate xy1 xy2 = Point (x xy1 + x xy2) (y xy1 + y xy2)
scale a xy = Point ((*a) $ x xy) ((*a) $ y xy)
rotate a xy = Point ((x xy) * cosA - (y xy) * sinA) ((x xy) * sinA + (y xy) * cosA) where
cosA = cos a
sinA = sin a
There were only 2 changes needed, in fact:
I have added type constraints on a for the methods of the XY class. Otherwise, you can't use functions such as + which you have in the implementation of the instance for Point. (GHC actually makes this exact suggestion in one of the error messages it throws when trying to compile your version.) Note that these have to go on the class, not the instance, because the instance declaration makes no mention of the type a (even though the implementation does). If you don't put the constraints in the class then the methods are expected to work for all possible types a.
x and y are in fact functions, so you can't multiply them with numbers like sinA. I suspect you just got confused here and could have figured out what to do - you needed to apply them to the xy (the "point" itself) to get the "x" and "y" "co-ordinates".
So actually you were pretty close, and just needed to pay attention to what the compiler was telling you. GHC's error messages can seem a bit obscure when you're new to Haskell, but with a bit of practice you soon see that they're (often, although not always) quite helpful.
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. :-)
It's my first exercise to understand the classes in Haskell. My problem is how to define the functions that I have declared in the class and how to test them by terminal ghci.
I explain step by step what I did:
type Point2d = (Int, Int) -- point
type Vector2d = (Int, Int) -- vector
data Shape =
Line Point2d Point2d
| Triangle Point2d Point2d Point2d
deriving (Eq, Show)
class ClassShape s where
name :: s -> String
perim :: s -> Int -- given a CShape calculates the perimeter
move :: s -> Vector2d -> s
Now, I declare s as ClassShape instance, by implementing the corresponding functions.
nameShape :: Shape s -> String
nameShape Line = "Line"
nameShape Triangle = "Triangle"
perimShape :: Shape s -> Int
perimShape Line a b = 999 -- ...
perimShape Triangle a b c = 999 -- ...
Here's my problem: how should I declare the functions? I just need to see an "example" to understand the concept.
The error that Haskell returns is:
`Shape' is applied to too many type arguments
In the type signature for `nameShape':
nameShape :: Shape s -> String
`Shape' is applied to too many type arguments
In the type signature for `perimShape':
perimShape :: Shape s -> Int
Then, how do I test the program on Haskell?
Thanks to all.
Note that nameShape function will not work, because there is no Shape s type defined. Remember that s is a type variable. Only if you have defined Shape s type constructor you can use them. You have defined Shape type in your definition but not Shape s. For defining instance of typeclass, you have to do something like this:
instance ClassShape Shape where
name (Line _ _) = "Line"
name (Triangle _ _ _) = "Triangle"
perim (Line x y) = undefined -- Calculate perimiter using x and y
perim (Triangle x y z) = undefined
move (Line x y) = undefined
move (Triangle x y z) = undefined
You have to fill the undefined with working parts.
You're making a common confusion of early Haskell programmers: using two different things which work in related ways (sum types and classes) to do the same thing in two different ways. Thus there are two problems: the "little" problem (what does this error mean?) and the "big" problem (why is your code shaped like this?).
The Little Problem
You wrote Shape s when you meant to just write Shape. The way you have defined Shape, it has kind * (that is, it is a concrete type) rather than kind * -> *, which is the kind of adjectives -- things like "a list of" or "a pair of" which are abstract until you give them a concrete type to modify ("a list of strings" is concrete, "a list of" is abstract). When you write Shape s you are applying Shape as an adjective to a type variable s but it's not an adjective; it's a noun.
That is why you get the error:
`Shape' is applied to too many type arguments
Side note: you may be used to languages where the error message usually is not very well-related to the actual problem. In Haskell usually the compiler tells you exactly what is wrong, as it did in this case.
The Big Problem
Type classes are collections of unrelated types which can do the same things. The type class syntax passes an implicit context as a "constraint", this context can be implicit because it belongs to the type.
You may need to read that last paragraph a few times in a quiet corner. Basically I mean to say that you can do the same thing as a type class with a data constructor for the context:
data EqOrd s = EqOrdLib {getEq :: s -> s -> Bool, getCmp :: s -> s -> Ordering}
-- this is just provided to us as a primitive by Haskell
intEOL :: EqOrd Int
intEOL = EqOrdLib (==) compare
-- but we can then define things like this:
listEOL :: EqOrd x -> EqOrd [x]
listEOL (EqOrdLib base_eq base_cmp) = EqOrdLib list_eq list_cmp where
list_cmp [] [] = EQ
list_cmp (_:_) [] = GT
list_cmp [] (_:_) = LT
list_cmp (x:xs) (y:ys) = case base_cmp x y of
LT -> LT
GT -> GT
EQ -> list_cmp xs ys
list_eq xs ys = list_cmp xs ys == EQ
Now to use that sort of context, you would have to write explicitly:
quicksort :: EqOrd x -> [x] -> [x]
quicksort _ [] = []
quicksort lib (p:els) = quicksort lib lesser ++ [p] ++ quicksort lib greater
where cmp = getCmp lib
p_less_than x = cmp x p == LT
p_gte x = not . p_less_than
greater = filter p_less_than els
lesser = filter p_gte els
See, we explicitly pass in this library of functions lib and explicitly pull out the comparison function cmp = getCmp lib.
Type classes allow us to implicitly pass the library of functions, by stating up-front that the type itself only has one such library. We pass the library as a "constraint", so instead of EqOrd x -> [x] -> [x] you write Ord x => [x] -> [x] with the "fat arrow" of constraints. But secretly it means "when you ask me to use the < function on two values of type x, I know implicitly what library to get that function from and will get that function for you."
Now: you have one type, Shape, so you don't need typeclasses. (Go back to the first paragraph above: Type classes are collections of unrelated types which can do the same things.
If you want to do type classes then instead of the sum-type for Shape, let's define n-dimensional vectors of different types:
class Vector v where
(*.) :: (Num r) => r -> v r -> v r
(.+.) :: (Num r) => v r -> v r -> v r
norm :: (Num r, Floating r) => v r -> r
-- another advantage of type classes is *default declarations* like:
(.-.) :: (Num r) => v r -> v r -> v r
v1 .-. v2 = v1 .+. (-1 *. v2)
data V2D r = V2D r r deriving (Eq, Show)
instance Vector V2D where
s *. V2D x y = V2D (s * x) (s * y)
V2D x1 y1 .+. V2D x2 y2 = V2D (x1 + x2) (y1 + y2)
norm (V2D x y) = sqrt (x^2 + y^2)
data V3D r = V3D r r r deriving (Eq, Show)
instance Vector V3D where
s *. V3D x y z = V3D (s * x) (s * y) (s * z)
V3D x1 y1 z1 .+. V3D x2 y2 z2 = V3D (x1 + x2) (y1 + y2) (z1 + z2)
norm (V3D x y z) = sqrt (x^2 + y^2 + z^2)
Then we can write things like:
newtype GeneralPolygon v r = Poly [v r]
perimeter :: (Num r, Floating r, Vector v) -> GeneralPolygon v r -> r
perimeter (Poly []) = 0
perimeter (Poly (x : xs)) = foldr (+) 0 (map norm (zipWith (.-.) (x : xs) (xs ++ [x])))
translate :: (Vector v, Num r) => GeneralPolygon v r -> v r -> GeneralPolygon v r
translate (Poly xs) v = Poly (map (v .+.) xs)
Making Typeclasses Work For You
Now if you really want to, you can also unwrap your sum-type data declaration into a bunch of data declarations:
data Line = Line Point2d Point2d deriving (Eq, Show)
data Square = Square Point2d Point2d deriving (Eq, Show)
data Triangle = Triangle Point2d Point2d Point2d deriving (Eq, Show)
Now you can do something simple like:
class Shape s where
perim :: s -> Int
move :: s -> Vector2d -> s
Although I should say, you'll run into a problem when you want to do square roots for perimeters (sqrt is in the Floating typeclass, which Int does not have functions for, you'll want to change Int to Double or something).
https://wiki.haskell.org/The_Monad.Reader/Issue5/Practical_Graph_Handling#foldG
i follow 1.5.2
after load trees.hs has error, just hope to run some examples in above link and export some graph jpeg or png file
Prelude> :l trees.hs
[1 of 1] Compiling Main ( trees.hs, interpreted )
trees.hs:39:22: parse error on input `='
Failed, modules loaded: none.
import Data.List
import Data.Array
--import Data.Graph
import Control.Monad
import Math.Combinat
import Math.Core.Utils
import Math.Core.Field
import Math.Algebras.VectorSpace
import Math.Algebras.Structures
--import Math.CommutativeAlgebra.GroebnerBasis
--import Math.CommutativeAlgebra.Polynomial
--import Math.Algebras.Matrix
import System.IO
import qualified Data.Map as M
type Vertex = Int
type Table a = Array Vertex a
type Graph e = Table [(e, Vertex)]
type Bounds = (Vertex, Vertex)
type Edge e = (Vertex, e, Vertex)
type Labeling a = Vertex -> a
data LabGraph n e = LabGraph (Graph e) (Labeling n)
foldGAll :: (Eq r) => r -> (Vertex -> [(e, r)] -> r) -> Graph e -> Table r
foldGAll bot f gr = finalTbl
where finalTbl = fixedPoint updateTbl initialTbl
initialTbl = listArray bnds (replicate (rangeSize bnds) bot)
fixedPoint f x = fp x
where fp z = if z == z' then z else fp z'
where z' = f z
updateTbl tbl = listArray bnds $ map recompute $ indices gr
where recompute v = f v [(b, tbl!k) | (b, k) <- gr!v]
bnds = bounds gr
foldG :: (Eq r) => r -> (Vertex -> [(e, r)] -> r) -> Graph e -> Vertex -> r
foldG i f g v = foldGAll i f g ! v
-- | Build a graph from a list of edges.
buildG :: Bounds -> [Edge e] -> Graph e
buildG bounds0 edges0 = accumArray (flip () [] bounds0 [(v, (l,w)) | (v,l,w) <- edges0]
-- | The graph obtained by reversing all edges.
transposeG :: Graph e -> Graph e
transposeG g = buildG (bounds g) (reverseE g)
edges :: Graph e -> [Edge e]
edges g = [ (v, l, w) | v <- indices g, (l, w) <- g!v ]
reverseE :: Graph e -> [Edge e]
reverseE g = [ (w, l, v) | (v, l, w) <- edges g ]
showGraphViz (LabGraph gr lab) =
"digraph name {\n" ++
"rankdir=LR;\n" ++
(concatMap showNode $ indices gr) ++
(concatMap showEdge $ edges gr) ++
"}\n"
where showEdge (from, t, to) = show from ++ " -> " ++ show to ++
" [label = \"" ++ show t ++ "\"];\n"
showNode v = show v ++ " [label = " ++ (show $ lab v) ++ "];\n"
-- | Compute the distance to v for every vertex of gr.
distsTo :: Vertex -> Graph Float -> Table Float
distsTo v gr = foldGAll infinite distance gr
where infinite = 10000000 -- well, you get the idea
distance v' neighbours
| v == v' = 0
| otherwise = minimum [distV+arcWeight | (distV, arcWeight) <- neighbours]
You seem to have several problems with indentation in that source file. Your question is also not clear, so it's hard to help you, without more information on what you are trying to achieve.
In any case, the error message is quite clear: there is a problem where ghci is unable to parse an '=' sign in line 39, character 22. Keep in mind that indentation is part of the language and that many of these parsing errors are a consequence of improper indentation.
I hope this helps.