Skip to content

Instantly share code, notes, and snippets.

@Rufflewind

Rufflewind/sphtrace.hs

Forked from wolfiestyle/sphtrace.hs
Last active October 15, 2015 05:29
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save Rufflewind/f5e2675c51d2f3a82019 to your computer and use it in GitHub Desktop.
Save Rufflewind/f5e2675c51d2f3a82019 to your computer and use it in GitHub Desktop.
Download ZIP
raytracer in haskell
Raw
sphtrace.hs
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
data Vec a = Vec { vecx, vecy, vecz :: !a }
instance Functor Vec where
fmap f (Vec x y z) = Vec (f x) (f y) (f z)
instance Applicative Vec where
pure x = Vec x x x
(Vec f g h) <*> (Vec x y z) = Vec (f x) (g y) (h z)
instance Foldable Vec where
foldr f a (Vec x y z) = f x $ f y $ f z a
foldl1 f (Vec x y z) = f z $ f y x
instance Num a => Num (Vec a) where
u + v = (+) <$> u <*> v
u * v = (*) <$> u <*> v
u - v = (-) <$> u <*> v
abs v = abs <$> v
signum v = signum <$> v
fromInteger i = pure $ fromInteger i
dot :: Num a => Vec a -> Vec a -> a
dot u v = foldl1 (+) $ u * v
cross :: Num a => Vec a -> Vec a -> Vec a
cross (Vec ux uy uz) (Vec vx vy vz) = Vec (uy * vz - uz * vy) (uz * vx - ux * vz) (ux * vy - uy * vx)
normsq :: Num a => Vec a -> a
normsq v = v `dot` v
norm :: Floating a => Vec a -> a
norm v = sqrt $ normsq v
normalize :: Floating a => Vec a -> Vec a
normalize v = fmap (/ len) v
where len = norm v
transpose :: Vec a -> Vec a -> Vec a -> (Vec a, Vec a, Vec a)
transpose u v w = (x, y, z)
where x = Vec (vecx u) (vecx v) (vecx w)
y = Vec (vecy u) (vecy v) (vecy w)
z = Vec (vecz u) (vecz v) (vecz w)
data Camera a = Cam {
cam_size :: (Int, Int),
cam_pos :: Vec a,
cam_scale :: (a, a),
cam_aspect, cam_cz :: a,
cam_dir :: (Vec a, Vec a, Vec a)
}
calc_camera :: Floating a => Int -> Int -> a -> Vec a -> Vec a -> Vec a -> Camera a
calc_camera w h fov pos center up = Cam (w, h) pos (scale_x, scale_y) aspect cz (transpose di dj dk)
where (w', h') = (fromIntegral w, fromIntegral h)
(scale_x, scale_y) = (2 / (w' - 1), 2 / (h' - 1))
aspect = h' / w'
cz = 1 / tan(fov * pi / 360)
dk = normalize $ center - pos
di = normalize $ dk `cross` up
dj = di `cross` dk
trace_ray :: RealFloat a => (Vec a -> a) -> Int -> Int -> a -> Camera a -> Maybe (Vec a)
trace_ray dist_fn sx sy max_t cam = ray_loop 0
where pos = cam_pos cam
(scale_x, scale_y) = cam_scale cam
(dir_x, dir_y, dir_z) = cam_dir cam
cx = fromIntegral sx * scale_x - 1
cy = (1 - fromIntegral sy * scale_y) * (cam_aspect cam)
c = Vec cx cy (cam_cz cam)
m = normalize $ Vec (dir_x `dot` c) (dir_y `dot` c) (dir_z `dot` c)
ray_loop t
| t >= max_t = Nothing
| d < eps = Just r
| otherwise = ray_loop (t + d)
where r = fmap (*t) m + pos
d = dist_fn r
eps = 0.001
data Light a = Light { light_pos :: Vec a, light_val :: a }
calc_diffuse :: RealFloat a => Light a -> Vec a -> Vec a -> a
calc_diffuse light pos snorm = col * il * int / dsq
where col = light_val light
d = light_pos light - pos
dsq = normsq d
int = max 0 $ snorm `dot` d
il = 1 / sqrt dsq
gradient :: Floating a => (Vec a -> a) -> Vec a -> Vec a
gradient f p = normalize $ Vec dx dy dz
where dx = f (p + epsx) - f (p - epsx)
dy = f (p + epsy) - f (p - epsy)
dz = f (p + epsz) - f (p - epsz)
(epsx, epsy, epsz) = (Vec eps 0 0, Vec 0 eps 0, Vec 0 0 eps)
eps = 1e-6
data Image a = Image Int Int [a]
render :: RealFloat a => (Vec a -> a) -> Camera a -> Light a -> a -> a -> Image a
render scene cam light ambient max_t = Image w h [pixel x y | y <- [0 .. h-1], x <- [0 .. w-1]]
where (w, h) = cam_size cam
pixel sx sy = clamp 0 1 $ maybe ambient color $ trace_ray scene sx sy max_t cam
where clamp mn mx = max mn . min mx
color hit_pos = ambient + diffuse
where diffuse = calc_diffuse light hit_pos $ gradient scene hit_pos
to_ppm :: RealFloat a => Image a -> B.ByteString
to_ppm (Image w h pixels) = B.append header img_bin
where header = C.pack $ "P5\n" ++ show w ++ " " ++ show h ++ "\n255\n"
img_bin = B.pack $ map color_val pixels
color_val x = truncate $ x * 255
-- CSG operations
union :: RealFloat a => [Vec a -> a] -> Vec a -> a
union fs p = foldl1 min $ map ($p) fs
intersect :: RealFloat a => [Vec a -> a] -> Vec a -> a
intersect fs p = foldl1 max $ map ($p) fs
difference :: RealFloat a => (Vec a -> a) -> (Vec a -> a) -> Vec a -> a
difference fa fb p = max (fa p) (-fb p)
translate :: RealFloat a => a -> a -> a -> (Vec a -> a) -> Vec a -> a
translate dx dy dz f p = f (p - Vec dx dy dz)
-- Scene definition
scene :: RealFloat a => Vec a -> a
scene p = minimum [translate 2 (-0.5) 0 (sphere 0.6) p,
translate 2 0 1.5 (cone (pi/6)) p,
translate (-1) 0 0 (torus 1.5 0.3) p,
difference (box (Vec 1 1 1)) (sphere 1.3),
maximum [translate 0 (-1) 0 (cylinder_xy 0.6) p,
translate 0 (-1) 2.5 (cylinder_yz 0.6) p],
plane (Vec 1 0 0) 2.1 p, plane (Vec 0 1 0) 1 p, plane (Vec 0 0 1) 1.5 p]
where sphere r p = norm p - r
torus r1 r2 (Vec x y z) = let q = sqrt (x*x + z*z) - r1 in sqrt (q*q + y*y) - r2
plane n b p = p `dot` n + b
cone t (Vec x y z) = let q = sqrt (x*x + z*z) in q * cos(t) + y * sin(t)
box b p = let d = abs(p) - b in min 0 (foldl1 max d) + normsq ((max 0) <$> d)
cylinder_xy r (Vec x y _) = sqrt (x*x + y*y) - r
cylinder_yz r (Vec _ y z) = sqrt (y*y + z*z) - r
main = B.writeFile "out.ppm" $ to_ppm $ render scene cam light 0.03 42
where cam = calc_camera 640 480 60 (Vec 3 3 5) (Vec 0 (-1) 0) (Vec 0 1 0)
light = Light (Vec 3 2 2) 7
Raw
sphtrace.prof
Generated using: ghc -fllvm -O -prof -fprof-auto -rtsopts sphtrace.hs && ./sphtrace +RTS -p
Thu Oct 1 02:33 2015 Time and Allocation Profiling Report (Final)
sphtrace +RTS -p -RTS
total time = 4.66 secs (4662 ticks @ 1000 us, 1 processor)
total alloc = 3,184,029,472 bytes (excludes profiling overheads)
COST CENTRE MODULE %time %alloc
scene Main 45.0 56.3
box Main 9.2 5.0
plane Main 7.5 5.0
sphere Main 7.5 5.0
cone Main 4.6 0.0
box.d Main 3.9 8.4
trace_ray.ray_loop Main 3.5 0.1
trace_ray Main 2.8 0.1
torus Main 2.3 1.7
trace_ray.ray_loop.r Main 1.8 0.0
render.pixel.color.diffuse Main 1.5 2.0
+ Main 1.5 6.7
cylinder_yz Main 1.3 0.0
cylinder_xy Main 1.2 0.0
trace_ray.ray_loop.d Main 0.9 6.7
individual inherited
COST CENTRE MODULE no. entries %time %alloc %time %alloc
MAIN MAIN 42 0 0.0 0.0 100.0 100.0
main Main 85 0 0.0 0.0 0.0 0.0
CAF Main 83 0 0.0 0.0 100.0 100.0
main Main 84 1 0.9 0.0 100.0 100.0
main.light Main 174 1 0.0 0.0 0.0 0.0
scene Main 152 0 0.6 0.0 4.3 0.0
cone Main 153 0 3.7 0.0 3.7 0.0
main.cam Main 92 1 0.0 0.0 0.0 0.0
calc_camera Main 93 1 0.0 0.0 0.0 0.0
vecz Main 140 3 0.0 0.0 0.0 0.0
vecy Main 138 3 0.0 0.0 0.0 0.0
calc_camera.dj Main 136 1 0.0 0.0 0.0 0.0
calc_camera.dk Main 130 1 0.0 0.0 0.0 0.0
fmap Main 134 1 0.0 0.0 0.0 0.0
- Main 133 1 0.0 0.0 0.0 0.0
* Main 132 1 0.0 0.0 0.0 0.0
foldl1 Main 131 1 0.0 0.0 0.0 0.0
calc_camera.di Main 127 1 0.0 0.0 0.0 0.0
fmap Main 135 1 0.0 0.0 0.0 0.0
* Main 129 1 0.0 0.0 0.0 0.0
foldl1 Main 128 1 0.0 0.0 0.0 0.0
vecx Main 126 3 0.0 0.0 0.0 0.0
calc_camera.cz Main 119 1 0.0 0.0 0.0 0.0
calc_camera.aspect Main 117 1 0.0 0.0 0.0 0.0
calc_camera.h' Main 115 1 0.0 0.0 0.0 0.0
calc_camera.scale_y Main 114 1 0.0 0.0 0.0 0.0
calc_camera.(...) Main 110 1 0.0 0.0 0.0 0.0
calc_camera.w' Main 109 1 0.0 0.0 0.0 0.0
calc_camera.(...) Main 108 1 0.0 0.0 0.0 0.0
calc_camera.scale_x Main 107 1 0.0 0.0 0.0 0.0
render Main 87 1 0.2 0.9 93.8 98.7
render.pixel Main 97 113687 0.7 0.2 93.7 97.8
render.pixel.color Main 168 113686 0.2 0.0 18.7 18.8
render.pixel.color.diffuse Main 169 113686 1.5 2.0 18.5 18.8
fmap Main 204 113686 0.0 0.0 0.0 0.0
foldl1 Main 203 113686 0.0 0.0 0.0 0.0
* Main 202 113686 0.0 0.0 0.0 0.0
- Main 201 341058 0.0 0.0 0.0 0.0
scene Main 182 682116 8.6 11.5 16.3 16.6
plane Main 198 2046348 1.5 1.0 1.5 1.0
foldl1 Main 200 2046348 0.0 0.0 0.0 0.0
* Main 199 2046348 0.0 0.0 0.0 0.0
cylinder_yz Main 197 682116 0.2 0.0 0.2 0.0
cylinder_xy Main 196 682116 0.3 0.0 0.3 0.0
box Main 189 682116 2.2 1.0 3.2 2.7
fmap Main 195 682116 0.0 0.0 0.0 0.0
* Main 194 682116 0.0 0.0 0.0 0.0
box.d Main 191 682116 0.8 1.7 0.9 1.7
- Main 193 682116 0.0 0.0 0.0 0.0
abs Main 192 682116 0.0 0.0 0.0 0.0
foldl1 Main 190 1364232 0.0 0.0 0.0 0.0
torus Main 188 682116 0.5 0.3 0.5 0.3
cone Main 187 682116 0.2 0.0 0.2 0.0
sphere Main 184 1364232 1.7 1.0 1.7 1.0
* Main 186 1364232 0.0 0.0 0.0 0.0
foldl1 Main 185 1364232 0.0 0.0 0.0 0.0
- Main 183 3410580 0.0 0.0 0.0 0.0
+ Main 181 341058 0.0 0.0 0.0 0.0
calc_diffuse Main 170 113686 0.4 0.1 0.7 0.2
calc_diffuse.int Main 205 113686 0.0 0.1 0.0 0.1
* Main 207 113686 0.0 0.0 0.0 0.0
foldl1 Main 206 113686 0.0 0.0 0.0 0.0
calc_diffuse.il Main 180 113686 0.1 0.0 0.1 0.0
calc_diffuse.col Main 178 113686 0.0 0.0 0.0 0.0
light_val Main 179 1 0.0 0.0 0.0 0.0
calc_diffuse.dsq Main 175 113686 0.0 0.1 0.0 0.1
foldl1 Main 177 113686 0.0 0.0 0.0 0.0
* Main 176 113686 0.0 0.0 0.0 0.0
calc_diffuse.d Main 171 113686 0.2 0.0 0.2 0.0
light_pos Main 173 1 0.0 0.0 0.0 0.0
- Main 172 113686 0.0 0.0 0.0 0.0
trace_ray Main 99 113687 2.8 0.1 74.2 78.8
trace_ray.pos Main 143 1 0.0 0.0 0.0 0.0
cam_pos Main 144 1 0.0 0.0 0.0 0.0
trace_ray.dir_z Main 139 1 0.0 0.0 0.0 0.0
trace_ray.dir_y Main 137 1 0.0 0.0 0.0 0.0
trace_ray.(...) Main 124 1 0.0 0.0 0.0 0.0
cam_dir Main 125 1 0.0 0.0 0.0 0.0
trace_ray.dir_x Main 123 1 0.0 0.0 0.0 0.0
trace_ray.m Main 120 113687 0.5 0.0 0.5 0.3
fmap Main 141 113687 0.1 0.3 0.1 0.3
* Main 122 454748 0.0 0.0 0.0 0.0
foldl1 Main 121 454748 0.0 0.0 0.0 0.0
trace_ray.scale_y Main 113 1 0.0 0.0 0.0 0.0
trace_ray.cy Main 112 178 0.0 0.0 0.0 0.0
cam_aspect Main 116 1 0.0 0.0 0.0 0.0
trace_ray.c Main 111 113687 0.2 0.1 0.2 0.1
cam_cz Main 118 1 0.0 0.0 0.0 0.0
trace_ray.(...) Main 105 1 0.0 0.0 0.0 0.0
cam_scale Main 106 1 0.0 0.0 0.0 0.0
trace_ray.scale_x Main 104 1 0.0 0.0 0.0 0.0
trace_ray.cx Main 103 113687 0.0 0.1 0.0 0.1
trace_ray.ray_loop Main 100 2655582 3.5 0.1 70.8 78.2
trace_ray.ray_loop.eps Main 167 2655581 0.0 0.0 0.0 0.0
trace_ray.ray_loop.d Main 145 2655582 0.9 6.7 64.0 71.5
scene Main 146 2655582 35.8 44.8 63.2 64.8
plane Main 164 7966745 6.0 4.0 6.2 4.0
foldl1 Main 166 7966745 0.1 0.0 0.1 0.0
* Main 165 7966745 0.1 0.0 0.1 0.0
cylinder_yz Main 163 2655582 1.1 0.0 1.1 0.0
cylinder_xy Main 162 2655582 0.9 0.0 0.9 0.0
box Main 155 2655582 7.0 4.0 10.4 10.7
fmap Main 161 2655582 0.1 0.0 0.1 0.0
* Main 160 2655582 0.0 0.0 0.0 0.0
box.d Main 157 2655582 3.1 6.7 3.2 6.7
- Main 159 2655582 0.1 0.0 0.1 0.0
abs Main 158 2655582 0.1 0.0 0.1 0.0
foldl1 Main 156 5311164 0.0 0.0 0.0 0.0
torus Main 154 2655582 1.8 1.3 1.8 1.3
cone Main 151 2655582 0.8 0.0 0.8 0.0
sphere Main 148 5311164 5.8 4.0 5.9 4.0
* Main 150 5311164 0.1 0.0 0.1 0.0
foldl1 Main 149 5311164 0.0 0.0 0.0 0.0
- Main 147 13277910 0.2 0.0 0.2 0.0
trace_ray.ray_loop.r Main 101 2655582 1.8 0.0 3.3 6.7
+ Main 142 2655582 1.5 6.7 1.5 6.7
fmap Main 102 2655582 0.0 0.0 0.0 0.0
render.pixel.clamp Main 98 1 0.1 0.0 0.1 0.0
render.h Main 94 1 0.0 0.0 0.0 0.0
render.(...) Main 90 1 0.0 0.0 0.0 0.0
cam_size Main 91 1 0.0 0.0 0.0 0.0
render.w Main 89 1 0.0 0.0 0.0 0.0
to_ppm Main 86 1 0.1 0.0 1.0 1.3
to_ppm.img_bin Main 95 1 0.3 0.9 0.8 1.3
to_ppm.color_val Main 96 113687 0.5 0.5 0.5 0.5
to_ppm.header Main 88 1 0.0 0.0 0.0 0.0
CAF GHC.IO.Handle.FD 77 0 0.0 0.0 0.0 0.0
CAF GHC.TopHandler 74 0 0.0 0.0 0.0 0.0
CAF GHC.Conc.Signal 73 0 0.0 0.0 0.0 0.0
CAF GHC.IO.Encoding 72 0 0.0 0.0 0.0 0.0
CAF GHC.IO.FD 71 0 0.0 0.0 0.0 0.0
CAF GHC.IO.Encoding.Iconv 57 0 0.0 0.0 0.0 0.0
@Rufflewind
Copy link
Author

https://gist.github.com/darkstalker/0195bf6ed135a25f26e5

@Rufflewind
Copy link
Author

https://gist.github.com/darkstalker/68889032dacf932dc1c9

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment