Pastable version of Raytracer in haskell

<pre class='prettyprint' language='haskell'>import System.IO
import Data.Word
import Foreign
import Data.Char

main :: IO ()
main = do
  handle &lt;- openBinaryFile &quot;test.bmp&quot; 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 = &quot;BM\54\249\54\0\0\0\0\0\54\0\0\0&quot;
             infoHeader = &quot;\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&quot;

putBin x y = (mapM new y) &gt;&gt;= mapM ((flip (hPutBuf x)) 1)

bitmap :: [Word8]
bitmap = concat $ parMap unTuple3 colors

unTuple3 :: Color -&gt; [Word8]
unTuple3 (a,b,c) = [a,b,c]

camera :: Vector
camera = (0.0, 0.0, -5.0)

createRay :: Double -&gt; Double -&gt; 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] -&gt; [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 -&gt; [Primitive] -&gt; [Primitive] -&gt; Scene
createScene x y z = (x, y, z)

colorFromRay r (distance, ((center, radius), color)) = color

findIntersection :: Scene -&gt; Ray -&gt; 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) -&gt; (Double, Primitive) -&gt; (Double, Primitive)
pickShortestDistance (x, y) (a, b) = if x &lt; a || (a &lt; 0 &amp;&amp; x &gt; 0) then (x, y) else (a, b)

intersectSpheres :: [Primitive] -&gt; Ray -&gt; [(Double, Primitive)]
intersectSpheres [] _ = []
intersectSpheres spheres r = (intersectSphere (head spheres) r) : (intersectSpheres (tail spheres) r)

intersectSphere :: Primitive -&gt; Ray -&gt; (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 &gt; 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 &gt; 0 then
                                                                      ((-b) - (sqrt d), ((center, radius),(255,255,255)))
                                                                  else
                                                                      (10000, ((center, radius),color))

intersectPlane :: ((Vector, Double), Color) -&gt; Ray -&gt; (Double, Primitive)
intersectPlane ((normal, distance), color) (origin, direction) = let d = normal `dotProduct` (direction `subtractVector` origin)
                                                                     n = normal `dotProduct` (normal `subtractVector` origin)
                                                                 in
                                                                   if d &gt; 0 then
                                                                      (n / d, ((normal, distance),color))
                                                                   else
                                                                      (10000, ((normal, distance),color))

normalizeVector :: Vector -&gt; Vector
normalizeVector v = scaleVector (1 / lengthVector v) v

scaleVector :: Double -&gt; Vector -&gt; Vector
scaleVector a (x,y,z) = (x*a, y*a, z*a)

lengthVector :: Vector -&gt; Double
lengthVector (x,y,z) = sqrt ( x^2 + y^2 + z^2)

addVector :: Vector -&gt; Vector -&gt; Vector
addVector (a,b,c) (x,y,z) = (a+x, b+y, z+c)

subtractVector :: Vector -&gt; Vector -&gt; Vector
subtractVector (a,b,c) (x,y,z) = (a-x, b-y, c-z)

dotProduct :: Vector -&gt; Vector -&gt; Double
dotProduct (a,b,c) (x,y,z) = a*x + b*y + c*z

crossProduct :: Vector -&gt; Vector -&gt; Vector
crossProduct (a,b,c) (x,y,z) = ((b * z - c*y), (c*x - a*z), (a*y - b*x))</pre>
<a href="http://www.refactormycode.com/codes/473-raytracer-in-haskell-lisp-seems-to-be-the-closest-answer-eh" style="color:#fff" title="As seen on RefactorMyCode.com"><img alt="Small_logo" src="http://www.refactormycode.com/images/small_logo.gif" style="border:0" /></a>

Refactor :my => 'code'

Recent

Popular

Pastable version of Raytracer in haskell