Raytracer

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155

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))