import System.IO
import Data.Word
import Foreign
import Data.Char
main :: IO ()
main = do
handle <- openBinaryFile "test.bmp" WriteMode
putBin handle header
print $ head rays
putBin handle bitmap
hClose handle
type Vector = (Double, Double, Double)
type Color = (Word8, Word8, Word8)
type Ray = (Vector, Vector)
type Sphere = (Vector, Double)
type Light = Sphere
type Plane = Sphere
type Primitive = (Sphere, Color)
type Scene = (Primitive, [Primitive], [Primitive])
parMap = map
-- arg can't deal with this in anything other than characters. trying to write bytes hurts my head
header :: [Word8]
header = parMap (fromIntegral . ord) $ fileHeader ++ infoHeader
where
fileHeader = "BM\54\249\54\0\0\0\0\0\54\0\0\0"
infoHeader = "\40\0\0\0\32\3\0\0\88\2\0\0\1\0\24\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"
putBin x y = (mapM new y) >>= mapM ((flip (hPutBuf x)) 1)
bitmap :: [Word8]
bitmap = concat $ parMap unTuple3 colors
unTuple3 :: Color -> [Word8]
unTuple3 (a,b,c) = [a,b,c]
camera :: Vector
camera = (0.0, 0.0, -5.0)
createRay :: Double -> Double -> Ray
createRay y x = (camera, (normalizeVector ((x,y,0) `subtractVector` camera)))
rayx :: [Double]
rayx = [8.0,7.98..(-7.98)]
rayy :: [Double]
rayy = [6.0,5.98..(-5.98)]
createRays :: [Double] -> [Ray]
createRays [] = []
createRays xs = (parMap (createRay (head xs)) rayx) ++ (createRays (tail xs))
rays :: [Ray]
rays = createRays rayy
-- reverse because BMP is a fucked up format
colors = parMap (findIntersection scene) $ reverse rays
scene :: Scene
scene = createScene plane spheres lights
plane :: Primitive
plane = (((0, (-0.39), 0), 4.4), (128,128,128))
spheres :: [Primitive]
spheres = bigSphere : littleSphere : []
bigSphere :: Primitive
bigSphere = (((1.0, (-0.8), 3.0), 0.5), (255,128,128))
littleSphere :: Primitive
littleSphere = ((((-5.5), (-0.5), 7.0), 0.4), (128,255,128))
lights = light1 : light2 : []
light1 = (((0.0, 5.0, 5.0), 0.02), (128, 128, 255))
light2 = (((2.0, 5.0, 1.0), 0.02), (255, 128, 255))
createScene :: Primitive -> [Primitive] -> [Primitive] -> Scene
createScene x y z = (x, y, z)
colorFromRay r (distance, ((center, radius), color)) = color
findIntersection :: Scene -> Ray -> Color
findIntersection (plane, spheres, lights) r = colorFromRay r $ foldl (pickShortestDistance) (1000, ((camera, 0.1), (255,255,255))) $ [intersectPlane plane r] ++ (intersectSpheres (spheres ++ lights) r )
pickShortestDistance :: (Double, Primitive) -> (Double, Primitive) -> (Double, Primitive)
pickShortestDistance (x, y) (a, b) = if x < a || (a < 0 && x > 0) then (x, y) else (a, b)
intersectSpheres :: [Primitive] -> Ray -> [(Double, Primitive)]
intersectSpheres [] _ = []
intersectSpheres spheres r = (intersectSphere (head spheres) r) : (intersectSpheres (tail spheres) r)
intersectSphere :: Primitive -> Ray -> (Double, Primitive)
intersectSphere ((center, radius), color) (origin, direction) = let destination = normalizeVector $ center `subtractVector` origin
b = - ( destination `dotProduct` (normalizeVector direction))
c = (destination `dotProduct` destination) - (radius * radius)
d = b * b - c
in
if d > 0 then
((-b) - (sqrt d), ((center, radius),color))
else
(10000, ((center, radius),color))
intersectLight ((center, radius), color) (origin, direction) = let destination = normalizeVector $ center `subtractVector` origin
b = - ( destination `dotProduct` (normalizeVector direction))
c = (destination `dotProduct` destination) - (radius * radius)
d = b * b - c
in
if d > 0 then
((-b) - (sqrt d), ((center, radius),(255,255,255)))
else
(10000, ((center, radius),color))
intersectPlane :: ((Vector, Double), Color) -> Ray -> (Double, Primitive)
intersectPlane ((normal, distance), color) (origin, direction) = let d = normal `dotProduct` (direction `subtractVector` origin)
n = normal `dotProduct` (normal `subtractVector` origin)
in
if d > 0 then
(n / d, ((normal, distance),color))
else
(10000, ((normal, distance),color))
normalizeVector :: Vector -> Vector
normalizeVector v = scaleVector (1 / lengthVector v) v
scaleVector :: Double -> Vector -> Vector
scaleVector a (x,y,z) = (x*a, y*a, z*a)
lengthVector :: Vector -> Double
lengthVector (x,y,z) = sqrt ( x^2 + y^2 + z^2)
addVector :: Vector -> Vector -> Vector
addVector (a,b,c) (x,y,z) = (a+x, b+y, z+c)
subtractVector :: Vector -> Vector -> Vector
subtractVector (a,b,c) (x,y,z) = (a-x, b-y, c-z)
dotProduct :: Vector -> Vector -> Double
dotProduct (a,b,c) (x,y,z) = a*x + b*y + c*z
crossProduct :: Vector -> Vector -> Vector
crossProduct (a,b,c) (x,y,z) = ((b * z - c*y), (c*x - a*z), (a*y - b*x))
Refactorings
No refactoring yet !
Tj Holowaychuk
April 10, 2009, April 10, 2009 23:12, permalink
No rating.
Login to rate!
Give me a few weeks to learn Haskell and I will help :) haha (just picked up a book)
This is my first serious haskell project. It's kinda-working, but currently only flat shading. I'd like to get it down in size so I can work on more interesting parts of it.
Using GHC 6.8.2 on ubuntu, output is a 800x600 BMP file (for right now)