├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── Smallpt ├── Mutable.hs ├── Storable.hs └── Unboxed.hs ├── bench.hs ├── cbits └── smallpt.cpp ├── profile.hs ├── smallpt-hs.cabal └── smallpt-hs.hs /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Vo Minh Thu 2010 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Vo Minh Thu nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: bench profile smallpt-hs 2 | 3 | profile.prof: profile 4 | ./profile +RTS -p 5 | 6 | smallpt.o: cbits/smallpt.cpp 7 | g++ -O3 cbits/smallpt.cpp -c 8 | 9 | bench: smallpt.o bench.hs Smallpt/Storable.hs Smallpt/Unboxed.hs Smallpt/Mutable.hs 10 | ghc --make -O2 \ 11 | bench.hs smallpt.o -o bench -lstdc++ 12 | 13 | profile: smallpt.o profile.hs Smallpt/Storable.hs Smallpt/Unboxed.hs Smallpt/Mutable.hs 14 | ghc --make -O2 \ 15 | -prof -auto-all \ 16 | profile.hs smallpt.o -o profile -lstdc++ 17 | 18 | smallpt-hs: smallpt-hs.hs 19 | ghc --make -O2 -XForeignFunctionInterface smallpt-hs.hs -o smallpt-hs 20 | 21 | clean: 22 | rm -rf *.o *.hi Smallpt/*.o Smallpt/*.hi smallpt.o bench profile smallpt-hs 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | smallpt-hs 2 | ========== 3 | 4 | **Update**: [bollu](https://github.com/bollu) and 5 | [davean](https://github.com/davean) have made an [optmized 6 | version](https://github.com/bollu/smallpt-opt). 7 | 8 | This is a port of [smallpt](http://www.kevinbeason.com/smallpt/), a global 9 | illumination path tracer written in 99 lines of C++. The port is written in 10 | 99 lines of Haskell. 11 | 12 | There are two major differences: performance and argument parsing. The Haskell 13 | code compiled with GHC 6.12.1 is about 4.5 times slower than the C++ version. 14 | (I only tested on my anemic Atom N450-powered netbook...) The C++ code takes an 15 | optional argument, which should be a integer greater than 4. 16 | 17 | Give it a spin 18 | -------------- 19 | 20 | The complete package contains more than the 99 lines smallpt-hs.hs file. There 21 | are other variants with a criterion wrapper to benchmark the code. The cbits 22 | directory contains the original smallpt.cpp file modified to be expose the main 23 | entry point as a C symbol callable from Haskell via FFI. 24 | 25 | Every attempt so far use the vector package. The 99 lines file is derived from 26 | Smallpt/Mutable.hs. The Storable code doesn't improve the performance and is 27 | less convenient to use. The Unboxed code lose in performance because the Vec 28 | type can't benefit from an explicit unpack pragma. 29 | 30 | If you can make the code faster or easier to read, please let me know! 31 | 32 | License 33 | ------- 34 | 35 | Although the LICENSE file is a BSD3 license, I should contact Kevin Beason (the 36 | original author of the C++ code) to make sure it is ok. The linked site above 37 | has the original LICENSE. 38 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | import Distribution.Simple 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /Smallpt/Mutable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | module Smallpt.Mutable where 3 | import qualified Data.Vector as V 4 | import qualified Data.Vector.Mutable as VM 5 | import Data.List (find, minimumBy, foldl') 6 | import Data.IORef 7 | import Text.Printf 8 | import Foreign 9 | import Foreign.C.Types 10 | import System.IO (stderr, withFile, IOMode(..)) 11 | -- position, also color (r,g,b) 12 | data Vec = Vec {-# UNPACK #-} !CDouble {-# UNPACK #-} !CDouble {-# UNPACK #-} !CDouble 13 | zerov = Vec 0 0 0 14 | addv (Vec a b c) (Vec x y z) = Vec (a+x) (b+y) (c+z) 15 | subv (Vec a b c) (Vec x y z) = Vec (a-x) (b-y) (c-z) 16 | mulvs (Vec a b c) x = Vec (a*x) (b*x) (c*x) 17 | mulv (Vec a b c) (Vec x y z) = Vec (a*x) (b*y) (c*z) 18 | len (Vec a b c) = sqrt $ a*a+b*b+c*c 19 | norm v = v `mulvs` (1/len v) 20 | dot (Vec a b c) (Vec x y z) = a*x+b*y+c*z 21 | cross (Vec a b c) (Vec x y z) = Vec (b*z-c*y) (c*x-a*z) (a*y-b*x) 22 | maxv (Vec a b c) = maximum [a,b,c] 23 | 24 | data Ray = Ray Vec Vec -- origin, direction 25 | 26 | data Refl = DIFF | SPEC | REFR -- material types, used in radiance 27 | 28 | -- radius, position, emission, color, reflection 29 | data Sphere = Sphere {-# UNPACK #-} !CDouble Vec Vec Vec {-# UNPACK #-} !Refl 30 | intersect (Ray o d) (Sphere r p e c refl) = 31 | if det<0 then Nothing else f (b-sdet) (b+sdet) 32 | where op = p `subv` o 33 | eps = 1e-4 34 | b = op `dot` d 35 | det = b*b - (op `dot` op) + r*r 36 | sdet = sqrt det 37 | f a b = if a>eps then Just a else if b>eps then Just b else Nothing 38 | 39 | spheres = let s = Sphere ; z = zerov ; (*) = mulvs ; v = Vec in 40 | [ s 1e5 (v (1e5+1) 40.8 81.6) z (v 0.75 0.25 0.25) DIFF --Left 41 | , s 1e5 (v (-1e5+99) 40.8 81.6) z (v 0.25 0.25 0.75) DIFF --Rght 42 | , s 1e5 (v 50 40.8 1e5) z (v 0.75 0.75 0.75) DIFF --Back 43 | , s 1e5 (v 50 40.8 (-1e5+170)) z z DIFF --Frnt 44 | , s 1e5 (v 50 1e5 81.6) z (v 0.75 0.75 0.75) DIFF --Botm 45 | , s 1e5 (v 50 (-1e5+81.6) 81.6) z (v 0.75 0.75 0.75) DIFF --Top 46 | , s 16.5(v 27 16.5 47) z ((v 1 1 1)* 0.999) SPEC --Mirr 47 | , s 16.5(v 73 16.5 78) z ((v 1 1 1)* 0.999) REFR --Glas 48 | , s 600 (v 50 (681.6-0.27) 81.6) (v 12 12 12) z DIFF]--Lite 49 | 50 | clamp x = if x<0 then 0 else if x>1 then 1 else x 51 | 52 | toInt :: CDouble -> Int 53 | toInt x = floor $ clamp x ** (1/2.2) * 255 + 0.5 54 | 55 | intersects ray = (k, s) 56 | where (k,s) = foldl' f (Nothing,undefined) spheres 57 | f (k,sp) s = case (k,intersect ray s) of 58 | (Nothing,Just x) -> (Just x,s) 59 | (Just y,Just x) | x < y -> (Just x,s) 60 | _ -> (k,sp) 61 | 62 | radiance :: Ray -> CInt -> Ptr CUShort -> IO Vec 63 | radiance ray@(Ray o d) depth xi = case intersects ray of 64 | (Nothing,_) -> return zerov 65 | (Just t,Sphere r p e c refl) -> do 66 | let x = o `addv` (d `mulvs` t) 67 | n = norm $ x `subv` p 68 | nl = if n `dot` d < 0 then n else n `mulvs` (-1) 69 | pr = maxv c 70 | depth' = depth + 1 71 | continue f = case refl of 72 | DIFF -> do 73 | r1 <- ((2*pi)*) `fmap` erand48 xi 74 | r2 <- erand48 xi 75 | let r2s = sqrt r2 76 | w@(Vec wx _ _) = nl 77 | u = norm $ (if abs wx > 0.1 then (Vec 0 1 0) else (Vec 1 0 0)) `cross` w 78 | v = w `cross` u 79 | d' = norm $ (u`mulvs`(cos r1*r2s)) `addv` (v`mulvs`(sin r1*r2s)) `addv` (w`mulvs`sqrt (1-r2)) 80 | rad <- radiance (Ray x d') depth' xi 81 | return $ e `addv` (f `mulv` rad) 82 | 83 | SPEC -> do 84 | let d' = d `subv` (n `mulvs` (2 * (n`dot`d))) 85 | rad <- radiance (Ray x d') depth' xi 86 | return $ e `addv` (f `mulv` rad) 87 | 88 | REFR -> do 89 | let reflRay = Ray x (d `subv` (n `mulvs` (2* n`dot`d))) -- Ideal dielectric REFRACTION 90 | into = n`dot`nl > 0 -- Ray from outside going in? 91 | nc = 1 92 | nt = 1.5 93 | nnt = if into then nc/nt else nt/nc 94 | ddn= d`dot`nl 95 | cos2t = 1-nnt*nnt*(1-ddn*ddn) 96 | if cos2t<0 -- Total internal reflection 97 | then do 98 | rad <- radiance reflRay depth' xi 99 | return $ e `addv` (f `mulv` rad) 100 | else do 101 | let tdir = norm $ (d`mulvs`nnt `subv` (n`mulvs`((if into then 1 else -1)*(ddn*nnt+sqrt cos2t)))) 102 | a=nt-nc 103 | b=nt+nc 104 | r0=a*a/(b*b) 105 | c = 1-(if into then -ddn else tdir`dot`n) 106 | re=r0+(1-r0)*c*c*c*c*c 107 | tr=1-re 108 | pp=0.25+0.5*re 109 | rp=re/pp 110 | tp=tr/(1-pp) 111 | rad <- 112 | if depth>2 113 | then do er <- erand48 xi 114 | if er5 123 | then do 124 | er <- erand48 xi 125 | if er < pr then continue $ c `mulvs` (1/pr) 126 | else return e 127 | else continue c 128 | 129 | smallpt :: Int -> Int -> Int -> IO () 130 | smallpt w h nsamps = do 131 | let samps = nsamps `div` 4 132 | org = Vec 50 52 295.6 133 | dir = norm $ Vec 0 (-0.042612) (-1) 134 | cx = Vec (fromIntegral w * 0.5135 / fromIntegral h) 0 0 135 | cy = norm (cx `cross` dir) `mulvs` 0.5135 136 | c <- VM.newWith (w * h) zerov 137 | allocaArray 3 $ \xi -> 138 | flip mapM_ [0..h-1] $ \y -> do 139 | --hPrintf stderr "\rRendering (%d spp) %5.2f%%" (samps*4::Int) (100.0*fromIntegral y/(fromIntegral h-1)::Double) 140 | writeXi xi y 141 | flip mapM_ [0..w-1] $ \x -> do 142 | let i = (h-y-1) * w + x 143 | flip mapM_ [0..1] $ \sy -> do 144 | flip mapM_ [0..1] $ \sx -> do 145 | r <- newIORef zerov 146 | flip mapM_ [0..samps-1] $ \s -> do 147 | r1 <- (2*) `fmap` erand48 xi 148 | let dx = if r1<1 then sqrt r1-1 else 1-sqrt(2-r1) 149 | r2 <- (2*) `fmap` erand48 xi 150 | let dy = if r2<1 then sqrt r2-1 else 1-sqrt(2-r2) 151 | d = (cx `mulvs` (((sx + 0.5 + dx)/2 + fromIntegral x)/fromIntegral w - 0.5)) `addv` 152 | (cy `mulvs` (((sy + 0.5 + dy)/2 + fromIntegral y)/fromIntegral h - 0.5)) `addv` dir 153 | rad <- radiance (Ray (org`addv`(d`mulvs`140)) (norm d)) 0 xi 154 | -- Camera rays are pushed forward ^^^^^ to start in interior 155 | modifyIORef r (`addv` (rad `mulvs` (1 / fromIntegral samps))) 156 | ci <- VM.unsafeRead c i 157 | Vec rr rg rb <- readIORef r 158 | VM.unsafeWrite c i $ ci `addv` (Vec (clamp rr) (clamp rg) (clamp rb) `mulvs` 0.25) 159 | 160 | withFile "image-mutable.ppm" WriteMode $ \hdl -> do 161 | hPrintf hdl "P3\n%d %d\n%d\n" w h (255::Int) 162 | flip mapM_ [0..w*h-1] $ \i -> do 163 | Vec r g b <- VM.unsafeRead c i 164 | hPrintf hdl "%d %d %d " (toInt r) (toInt g) (toInt b) 165 | 166 | writeXi :: Ptr CUShort -> Int -> IO () 167 | writeXi xi y = do 168 | let y' = fromIntegral y 169 | pokeElemOff xi 0 0 170 | pokeElemOff xi 1 0 171 | pokeElemOff xi 2 (y' * y' * y') 172 | 173 | foreign import ccall unsafe "erand48" 174 | erand48 :: Ptr CUShort -> IO CDouble 175 | 176 | -------------------------------------------------------------------------------- /Smallpt/Storable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | module Smallpt.Storable where 3 | import qualified Data.Vector as V 4 | import qualified Data.Vector.Storable.Mutable as VM 5 | import Data.List (find, minimumBy, foldl') 6 | import Data.IORef 7 | import Text.Printf 8 | import Foreign 9 | import Foreign.C.Types 10 | import System.IO (stderr, withFile, IOMode(..)) 11 | -- position, also color (r,g,b) 12 | data Vec = Vec {-# UNPACK #-} !CDouble {-# UNPACK #-} !CDouble {-# UNPACK #-} !CDouble 13 | zerov = Vec 0 0 0 14 | addv (Vec a b c) (Vec x y z) = Vec (a+x) (b+y) (c+z) 15 | subv (Vec a b c) (Vec x y z) = Vec (a-x) (b-y) (c-z) 16 | mulvs (Vec a b c) x = Vec (a*x) (b*x) (c*x) 17 | mulv (Vec a b c) (Vec x y z) = Vec (a*x) (b*y) (c*z) 18 | len (Vec a b c) = sqrt $ a*a+b*b+c*c 19 | norm v = v `mulvs` (1/len v) 20 | dot (Vec a b c) (Vec x y z) = a*x+b*y+c*z 21 | cross (Vec a b c) (Vec x y z) = Vec (b*z-c*y) (c*x-a*z) (a*y-b*x) 22 | maxv (Vec a b c) = maximum [a,b,c] 23 | 24 | data Ray = Ray Vec Vec -- origin, direction 25 | 26 | data Refl = DIFF | SPEC | REFR -- material types, used in radiance 27 | 28 | -- radius, position, emission, color, reflection 29 | data Sphere = Sphere CDouble Vec Vec Vec Refl 30 | intersect (Ray o d) (Sphere r p e c refl) = 31 | if det<0 then Nothing else f (b-sdet) (b+sdet) 32 | where op = p `subv` o 33 | eps = 1e-4 34 | b = op `dot` d 35 | det = b*b - (op `dot` op) + r*r 36 | sdet = sqrt det 37 | f a b = if a>eps then Just a else if b>eps then Just b else Nothing 38 | 39 | spheres = let s = Sphere ; z = zerov ; (*) = mulvs ; v = Vec in 40 | [ s 1e5 (v (1e5+1) 40.8 81.6) z (v 0.75 0.25 0.25) DIFF --Left 41 | , s 1e5 (v (-1e5+99) 40.8 81.6) z (v 0.25 0.25 0.75) DIFF --Rght 42 | , s 1e5 (v 50 40.8 1e5) z (v 0.75 0.75 0.75) DIFF --Back 43 | , s 1e5 (v 50 40.8 (-1e5+170)) z z DIFF --Frnt 44 | , s 1e5 (v 50 1e5 81.6) z (v 0.75 0.75 0.75) DIFF --Botm 45 | , s 1e5 (v 50 (-1e5+81.6) 81.6) z (v 0.75 0.75 0.75) DIFF --Top 46 | , s 16.5(v 27 16.5 47) z ((v 1 1 1)* 0.999) SPEC --Mirr 47 | , s 16.5(v 73 16.5 78) z ((v 1 1 1)* 0.999) REFR --Glas 48 | , s 600 (v 50 (681.6-0.27) 81.6) (v 12 12 12) z DIFF]--Lite 49 | 50 | clamp x = if x<0 then 0 else if x>1 then 1 else x 51 | 52 | toInt :: CDouble -> Int 53 | toInt x = floor $ clamp x ** (1/2.2) * 255 + 0.5 54 | 55 | intersects ray = (k, s) 56 | where (k,s) = foldl' f (Nothing,undefined) spheres 57 | f (k,sp) s = case (k,intersect ray s) of 58 | (Nothing,Just x) -> (Just x,s) 59 | (Just y,Just x) | x < y -> (Just x,s) 60 | _ -> (k,sp) 61 | 62 | radiance :: Ray -> CInt -> Ptr CUShort -> IO Vec 63 | radiance ray@(Ray o d) depth xi = case intersects ray of 64 | (Nothing,_) -> return zerov 65 | (Just t,Sphere r p e c refl) -> do 66 | let x = o `addv` (d `mulvs` t) 67 | n = norm $ x `subv` p 68 | nl = if n `dot` d < 0 then n else n `mulvs` (-1) 69 | pr = maxv c 70 | depth' = depth + 1 71 | continue f = case refl of 72 | DIFF -> do 73 | r1 <- ((2*pi)*) `fmap` erand48 xi 74 | r2 <- erand48 xi 75 | let r2s = sqrt r2 76 | w@(Vec wx _ _) = nl 77 | u = norm $ (if abs wx > 0.1 then (Vec 0 1 0) else (Vec 1 0 0)) `cross` w 78 | v = w `cross` u 79 | d' = norm $ (u`mulvs`(cos r1*r2s)) `addv` (v`mulvs`(sin r1*r2s)) `addv` (w`mulvs`sqrt (1-r2)) 80 | rad <- radiance (Ray x d') depth' xi 81 | return $ e `addv` (f `mulv` rad) 82 | 83 | SPEC -> do 84 | let d' = d `subv` (n `mulvs` (2 * (n`dot`d))) 85 | rad <- radiance (Ray x d') depth' xi 86 | return $ e `addv` (f `mulv` rad) 87 | 88 | REFR -> do 89 | let reflRay = Ray x (d `subv` (n `mulvs` (2* n`dot`d))) -- Ideal dielectric REFRACTION 90 | into = n`dot`nl > 0 -- Ray from outside going in? 91 | nc = 1 92 | nt = 1.5 93 | nnt = if into then nc/nt else nt/nc 94 | ddn= d`dot`nl 95 | cos2t = 1-nnt*nnt*(1-ddn*ddn) 96 | if cos2t<0 -- Total internal reflection 97 | then do 98 | rad <- radiance reflRay depth' xi 99 | return $ e `addv` (f `mulv` rad) 100 | else do 101 | let tdir = norm $ (d`mulvs`nnt `subv` (n`mulvs`((if into then 1 else -1)*(ddn*nnt+sqrt cos2t)))) 102 | a=nt-nc 103 | b=nt+nc 104 | r0=a*a/(b*b) 105 | c = 1-(if into then -ddn else tdir`dot`n) 106 | re=r0+(1-r0)*c*c*c*c*c 107 | tr=1-re 108 | pp=0.25+0.5*re 109 | rp=re/pp 110 | tp=tr/(1-pp) 111 | rad <- 112 | if depth>2 113 | then do er <- erand48 xi 114 | if er5 123 | then do 124 | er <- erand48 xi 125 | if er < pr then continue $ c `mulvs` (1/pr) 126 | else return e 127 | else continue c 128 | 129 | smallpt :: Int -> Int -> Int -> IO () 130 | smallpt w h nsamps = do 131 | let samps = nsamps `div` 4 132 | org = Vec 50 52 295.6 133 | dir = norm $ Vec 0 (-0.042612) (-1) 134 | cx = Vec (fromIntegral w * 0.5135 / fromIntegral h) 0 0 135 | cy = norm (cx `cross` dir) `mulvs` 0.5135 136 | c <- VM.newWith (w * h) zerov 137 | allocaArray 3 $ \xi -> 138 | flip mapM_ [0..h-1] $ \y -> do 139 | --hPrintf stderr "\rRendering (%d spp) %5.2f%%" (samps*4::Int) (100.0*fromIntegral y/(fromIntegral h-1)::Double) 140 | writeXi xi y 141 | flip mapM_ [0..w-1] $ \x -> do 142 | let i = (h-y-1) * w + x 143 | flip mapM_ [0..1] $ \sy -> do 144 | flip mapM_ [0..1] $ \sx -> do 145 | r <- newIORef zerov 146 | flip mapM_ [0..samps-1] $ \s -> do 147 | r1 <- (2*) `fmap` erand48 xi 148 | let dx = if r1<1 then sqrt r1-1 else 1-sqrt(2-r1) 149 | r2 <- (2*) `fmap` erand48 xi 150 | let dy = if r2<1 then sqrt r2-1 else 1-sqrt(2-r2) 151 | d = (cx `mulvs` (((sx + 0.5 + dx)/2 + fromIntegral x)/fromIntegral w - 0.5)) `addv` 152 | (cy `mulvs` (((sy + 0.5 + dy)/2 + fromIntegral y)/fromIntegral h - 0.5)) `addv` dir 153 | rad <- radiance (Ray (org`addv`(d`mulvs`140)) (norm d)) 0 xi 154 | -- Camera rays are pushed forward ^^^^^ to start in interior 155 | modifyIORef r (`addv` (rad `mulvs` (1 / fromIntegral samps))) 156 | ci <- VM.unsafeRead c i 157 | Vec rr rg rb <- readIORef r 158 | VM.unsafeWrite c i $ ci `addv` (Vec (clamp rr) (clamp rg) (clamp rb) `mulvs` 0.25) 159 | 160 | withFile "image-storable.ppm" WriteMode $ \hdl -> do 161 | hPrintf hdl "P3\n%d %d\n%d\n" w h (255::Int) 162 | flip mapM_ [0..w*h-1] $ \i -> do 163 | Vec r g b <- VM.unsafeRead c i 164 | hPrintf hdl "%d %d %d " (toInt r) (toInt g) (toInt b) 165 | 166 | writeXi :: Ptr CUShort -> Int -> IO () 167 | writeXi xi y = do 168 | let y' = fromIntegral y 169 | pokeElemOff xi 0 0 170 | pokeElemOff xi 1 0 171 | pokeElemOff xi 2 (y' * y' * y') 172 | 173 | foreign import ccall unsafe "erand48" 174 | erand48 :: Ptr CUShort -> IO CDouble 175 | 176 | instance Storable Vec where 177 | sizeOf _ = sizeOf (undefined :: CDouble) * 3 178 | alignment _ = alignment (undefined :: CDouble) 179 | 180 | {-# INLINE peek #-} 181 | peek p = do 182 | a <- peekElemOff q 0 183 | b <- peekElemOff q 1 184 | c <- peekElemOff q 2 185 | return (Vec a b c) 186 | where 187 | q = castPtr p 188 | 189 | {-# INLINE poke #-} 190 | poke p (Vec a b c) = do 191 | pokeElemOff q 0 a 192 | pokeElemOff q 1 b 193 | pokeElemOff q 2 c 194 | where 195 | q = castPtr p 196 | 197 | -------------------------------------------------------------------------------- /Smallpt/Unboxed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | module Smallpt.Unboxed where 3 | import qualified Data.Vector as V 4 | import qualified Data.Vector.Unboxed.Mutable as VM 5 | import Data.List (find, minimumBy, foldl') 6 | import Data.IORef 7 | import Text.Printf 8 | import Foreign 9 | import Foreign.C.Types 10 | import System.IO (stderr, withFile, IOMode(..)) 11 | -- position, also color (r,g,b) 12 | type Vec = (Double,Double,Double) 13 | zerov = (0,0,0) 14 | addv (a,b,c) (x,y,z) = (a+x, b+y, c+z) 15 | subv (a,b,c) (x,y,z) = (a-x, b-y, c-z) 16 | mulvs (a,b,c) x = (a*x, b*x, c*x) 17 | mulv (a,b,c) (x,y,z) = (a*x, b*y, c*z) 18 | len (a,b,c) = sqrt $ a*a+b*b+c*c 19 | norm v = v `mulvs` (1/len v) 20 | dot (a,b,c) (x,y,z) = a*x+b*y+c*z 21 | cross (a,b,c) (x,y,z) = (b*z-c*y, c*x-a*z, a*y-b*x) 22 | maxv (a,b,c) = maximum [a,b,c] 23 | 24 | data Ray = Ray Vec Vec -- origin, direction 25 | 26 | data Refl = DIFF | SPEC | REFR -- material types, used in radiance 27 | 28 | -- radius, position, emission, color, reflection 29 | data Sphere = Sphere Double Vec Vec Vec Refl 30 | intersect (Ray o d) (Sphere r p e c refl) = 31 | if det<0 then Nothing else f (b-sdet) (b+sdet) 32 | where op = p `subv` o 33 | eps = 1e-4 34 | b = op `dot` d 35 | det = b*b - (op `dot` op) + r*r 36 | sdet = sqrt det 37 | f a b = if a>eps then Just a else if b>eps then Just b else Nothing 38 | 39 | spheres = let s = Sphere ; z = zerov ; (*) = mulvs in 40 | [ s 1e5 (1e5+1, 40.8, 81.6) z (0.75, 0.25, 0.25) DIFF --Left 41 | , s 1e5 (-1e5+99, 40.8, 81.6) z (0.25, 0.25, 0.75) DIFF --Rght 42 | , s 1e5 (50, 40.8, 1e5) z (0.75, 0.75, 0.75) DIFF --Back 43 | , s 1e5 (50, 40.8, -1e5+170) z z DIFF --Frnt 44 | , s 1e5 (50, 1e5, 81.6) z (0.75, 0.75, 0.75) DIFF --Botm 45 | , s 1e5 (50, -1e5+81.6, 81.6) z (0.75, 0.75, 0.75) DIFF --Top 46 | , s 16.5(27, 16.5, 47) z ((1, 1, 1)* 0.999) SPEC --Mirr 47 | , s 16.5(73, 16.5, 78) z ((1, 1, 1)* 0.999) REFR --Glas 48 | , s 600 (50, 681.6-0.27, 81.6) (12, 12, 12) z DIFF]--Lite 49 | 50 | clamp x = if x<0 then 0 else if x>1 then 1 else x 51 | 52 | toInt :: Double -> Int 53 | toInt x = floor $ clamp x ** (1/2.2) * 255 + 0.5 54 | 55 | intersects ray = (k, s) 56 | where (k,s) = foldl' f (Nothing,undefined) spheres 57 | f (k,sp) s = case (k,intersect ray s) of 58 | (Nothing,Just x) -> (Just x,s) 59 | (Just y,Just x) | x < y -> (Just x,s) 60 | _ -> (k,sp) 61 | 62 | radiance :: Ray -> Int -> Ptr CUShort -> IO Vec 63 | radiance ray@(Ray o d) depth xi = case intersects ray of 64 | (Nothing,_) -> return zerov 65 | (Just t,Sphere r p e c refl) -> do 66 | let x = o `addv` (d `mulvs` t) 67 | n = norm $ x `subv` p 68 | nl = if n `dot` d < 0 then n else n `mulvs` (-1) 69 | pr = maxv c 70 | depth' = depth + 1 71 | continue f = case refl of 72 | DIFF -> do 73 | r1 <- ((2*pi)*) `fmap` erand48 xi 74 | r2 <- erand48 xi 75 | let r2s = sqrt r2 76 | w@(wx,_,_) = nl 77 | u = norm $ (if abs wx > 0.1 then (0,1,0) else (1,0,0)) `cross` w 78 | v = w `cross` u 79 | d' = norm $ (u`mulvs`(cos r1*r2s)) `addv` (v`mulvs`(sin r1*r2s)) `addv` (w`mulvs`sqrt (1-r2)) 80 | rad <- radiance (Ray x d') depth' xi 81 | return $ e `addv` (f `mulv` rad) 82 | 83 | SPEC -> do 84 | let d' = d `subv` (n `mulvs` (2 * (n`dot`d))) 85 | rad <- radiance (Ray x d') depth' xi 86 | return $ e `addv` (f `mulv` rad) 87 | 88 | REFR -> do 89 | let reflRay = Ray x (d `subv` (n `mulvs` (2* n`dot`d))) -- Ideal dielectric REFRACTION 90 | into = n`dot`nl > 0 -- Ray from outside going in? 91 | nc = 1 92 | nt = 1.5 93 | nnt = if into then nc/nt else nt/nc 94 | ddn= d`dot`nl 95 | cos2t = 1-nnt*nnt*(1-ddn*ddn) 96 | if cos2t<0 -- Total internal reflection 97 | then do 98 | rad <- radiance reflRay depth' xi 99 | return $ e `addv` (f `mulv` rad) 100 | else do 101 | let tdir = norm $ (d`mulvs`nnt `subv` (n`mulvs`((if into then 1 else -1)*(ddn*nnt+sqrt cos2t)))) 102 | a=nt-nc 103 | b=nt+nc 104 | r0=a*a/(b*b) 105 | c = 1-(if into then -ddn else tdir`dot`n) 106 | re=r0+(1-r0)*c*c*c*c*c 107 | tr=1-re 108 | pp=0.25+0.5*re 109 | rp=re/pp 110 | tp=tr/(1-pp) 111 | rad <- 112 | if depth>2 113 | then do er <- erand48 xi 114 | if er5 123 | then do 124 | er <- erand48 xi 125 | if er < pr then continue $ c `mulvs` (1/pr) 126 | else return e 127 | else continue c 128 | 129 | smallpt :: Int -> Int -> Int -> IO () 130 | smallpt w h nsamps = do 131 | let samps = nsamps `div` 4 132 | org = (50, 52, 295.6) 133 | dir = norm $ (0, -0.042612, -1) 134 | cx = (fromIntegral w * 0.5135 / fromIntegral h, 0, 0) 135 | cy = norm (cx `cross` dir) `mulvs` 0.5135 136 | c <- VM.newWith (w * h) zerov 137 | allocaArray 3 $ \xi -> 138 | flip mapM_ [0..h-1] $ \y -> do 139 | --hPrintf stderr "\rRendering (%d spp) %5.2f%%" (samps*4::Int) (100.0*fromIntegral y/(fromIntegral h-1)::Double) 140 | writeXi xi y 141 | flip mapM_ [0..w-1] $ \x -> do 142 | let i = (h-y-1) * w + x 143 | flip mapM_ [0..1] $ \sy -> do 144 | flip mapM_ [0..1] $ \sx -> do 145 | r <- newIORef zerov 146 | flip mapM_ [0..samps-1] $ \s -> do 147 | r1 <- (2*) `fmap` erand48 xi 148 | let dx = if r1<1 then sqrt r1-1 else 1-sqrt(2-r1) 149 | r2 <- (2*) `fmap` erand48 xi 150 | let dy = if r2<1 then sqrt r2-1 else 1-sqrt(2-r2) 151 | d = (cx `mulvs` (((sx + 0.5 + dx)/2 + fromIntegral x)/fromIntegral w - 0.5)) `addv` 152 | (cy `mulvs` (((sy + 0.5 + dy)/2 + fromIntegral y)/fromIntegral h - 0.5)) `addv` dir 153 | rad <- radiance (Ray (org`addv`(d`mulvs`140)) (norm d)) 0 xi 154 | -- Camera rays are pushed forward ^^^^^ to start in interior 155 | modifyIORef r (`addv` (rad `mulvs` (1 / fromIntegral samps))) 156 | ci <- VM.unsafeRead c i 157 | (rr,rg,rb) <- readIORef r 158 | VM.unsafeWrite c i $ ci `addv` ((clamp rr, clamp rg, clamp rb) `mulvs` 0.25) 159 | 160 | withFile "image-unboxed.ppm" WriteMode $ \hdl -> do 161 | hPrintf hdl "P3\n%d %d\n%d\n" w h (255::Int) 162 | flip mapM_ [0..w*h-1] $ \i -> do 163 | (r,g,b) <- VM.unsafeRead c i 164 | hPrintf hdl "%d %d %d " (toInt r) (toInt g) (toInt b) 165 | 166 | writeXi :: Ptr CUShort -> Int -> IO () 167 | writeXi xi y = do 168 | let y' = fromIntegral y 169 | pokeElemOff xi 0 0 170 | pokeElemOff xi 1 0 171 | pokeElemOff xi 2 (y' * y' * y') 172 | 173 | foreign import ccall unsafe "erand48" 174 | c_erand48 :: Ptr CUShort -> IO CDouble 175 | 176 | erand48 :: Ptr CUShort -> IO Double 177 | erand48 xi = realToFrac `fmap` c_erand48 xi 178 | 179 | -------------------------------------------------------------------------------- /bench.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | module Main where 3 | import Foreign.C.Types 4 | import Criterion.Main 5 | import Smallpt.Mutable 6 | import Smallpt.Storable 7 | import Smallpt.Unboxed 8 | 9 | foreign import ccall unsafe "smallpt" 10 | c_smallpt :: CInt -> CInt -> CInt -> IO () 11 | 12 | main = defaultMain 13 | -- [ bench "c++" $ c_smallpt 20 20 8 14 | [ bench "mutable" $ Smallpt.Mutable.smallpt 20 20 8 ] 15 | -- , bench "storable" $ Smallpt.Storable.smallpt 20 20 8 16 | -- , bench "unboxed" $ Smallpt.Unboxed.smallpt 20 20 8 17 | -- ] 18 | 19 | -------------------------------------------------------------------------------- /cbits/smallpt.cpp: -------------------------------------------------------------------------------- 1 | #include // smallpt, a Path Tracer by Kevin Beason, 2008 2 | #include // Make : g++ -O3 -fopenmp smallpt.cpp -o smallpt 3 | #include // Remove "-fopenmp" for g++ version < 4.2 4 | struct Vec { // Usage: time ./smallpt 5000 && xv image.ppm 5 | double x, y, z; // position, also color (r,g,b) 6 | Vec(double x_=0, double y_=0, double z_=0){ x=x_; y=y_; z=z_; } 7 | Vec operator+(const Vec &b) const { return Vec(x+b.x,y+b.y,z+b.z); } 8 | Vec operator-(const Vec &b) const { return Vec(x-b.x,y-b.y,z-b.z); } 9 | Vec operator*(double b) const { return Vec(x*b,y*b,z*b); } 10 | Vec mult(const Vec &b) const { return Vec(x*b.x,y*b.y,z*b.z); } 11 | Vec& norm(){ return *this = *this * (1/sqrt(x*x+y*y+z*z)); } 12 | double dot(const Vec &b) const { return x*b.x+y*b.y+z*b.z; } // cross: 13 | Vec operator%(Vec&b){return Vec(y*b.z-z*b.y,z*b.x-x*b.z,x*b.y-y*b.x);} 14 | }; 15 | struct Ray { Vec o, d; Ray(Vec o_, Vec d_) : o(o_), d(d_) {} }; 16 | enum Refl_t { DIFF, SPEC, REFR }; // material types, used in radiance() 17 | struct Sphere { 18 | double rad; // radius 19 | Vec p, e, c; // position, emission, color 20 | Refl_t refl; // reflection type (DIFFuse, SPECular, REFRactive) 21 | Sphere(double rad_, Vec p_, Vec e_, Vec c_, Refl_t refl_): 22 | rad(rad_), p(p_), e(e_), c(c_), refl(refl_) {} 23 | double intersect(const Ray &r) const { // returns distance, 0 if nohit 24 | Vec op = p-r.o; // Solve t^2*d.d + 2*t*(o-p).d + (o-p).(o-p)-R^2 = 0 25 | double t, eps=1e-4, b=op.dot(r.d), det=b*b-op.dot(op)+rad*rad; 26 | if (det<0) return 0; else det=sqrt(det); 27 | return (t=b-det)>eps ? t : ((t=b+det)>eps ? t : 0); 28 | } 29 | }; 30 | Sphere spheres[] = {//Scene: radius, position, emission, color, material 31 | Sphere(1e5, Vec( 1e5+1,40.8,81.6), Vec(),Vec(.75,.25,.25),DIFF),//Left 32 | Sphere(1e5, Vec(-1e5+99,40.8,81.6),Vec(),Vec(.25,.25,.75),DIFF),//Rght 33 | Sphere(1e5, Vec(50,40.8, 1e5), Vec(),Vec(.75,.75,.75),DIFF),//Back 34 | Sphere(1e5, Vec(50,40.8,-1e5+170), Vec(),Vec(), DIFF),//Frnt 35 | Sphere(1e5, Vec(50, 1e5, 81.6), Vec(),Vec(.75,.75,.75),DIFF),//Botm 36 | Sphere(1e5, Vec(50,-1e5+81.6,81.6),Vec(),Vec(.75,.75,.75),DIFF),//Top 37 | Sphere(16.5,Vec(27,16.5,47), Vec(),Vec(1,1,1)*.999, SPEC),//Mirr 38 | Sphere(16.5,Vec(73,16.5,78), Vec(),Vec(1,1,1)*.999, REFR),//Glas 39 | Sphere(600, Vec(50,681.6-.27,81.6),Vec(12,12,12), Vec(), DIFF) //Lite 40 | }; 41 | inline double clamp(double x){ return x<0 ? 0 : x>1 ? 1 : x; } 42 | inline int toInt(double x){ return int(pow(clamp(x),1/2.2)*255+.5); } 43 | inline bool intersect(const Ray &r, double &t, int &id){ 44 | double n=sizeof(spheres)/sizeof(Sphere), d, inf=t=1e20; 45 | for(int i=int(n);i--;) if((d=spheres[i].intersect(r))&&df.y && f.x>f.z ? f.x : f.y>f.z ? f.y : f.z; // max refl 55 | if (++depth>5) if (erand48(Xi).1?Vec(0,1):Vec(1))%w).norm(), v=w%u; 59 | Vec d = (u*cos(r1)*r2s + v*sin(r1)*r2s + w*sqrt(1-r2)).norm(); 60 | return obj.e + f.mult(radiance(Ray(x,d),depth,Xi)); 61 | } else if (obj.refl == SPEC) // Ideal SPECULAR reflection 62 | return obj.e + f.mult(radiance(Ray(x,r.d-n*2*n.dot(r.d)),depth,Xi)); 63 | Ray reflRay(x, r.d-n*2*n.dot(r.d)); // Ideal dielectric REFRACTION 64 | bool into = n.dot(nl)>0; // Ray from outside going in? 65 | double nc=1, nt=1.5, nnt=into?nc/nt:nt/nc, ddn=r.d.dot(nl), cos2t; 66 | if ((cos2t=1-nnt*nnt*(1-ddn*ddn))<0) // Total internal reflection 67 | return obj.e + f.mult(radiance(reflRay,depth,Xi)); 68 | Vec tdir = (r.d*nnt - n*((into?1:-1)*(ddn*nnt+sqrt(cos2t)))).norm(); 69 | double a=nt-nc, b=nt+nc, R0=a*a/(b*b), c = 1-(into?-ddn:tdir.dot(n)); 70 | double Re=R0+(1-R0)*c*c*c*c*c,Tr=1-Re,P=.25+.5*Re,RP=Re/P,TP=Tr/(1-P); 71 | return obj.e + f.mult(depth>2 ? (erand48(Xi)

8 | Maintainer: Vo Minh Thu 9 | Stability: Provisional 10 | Category: Graphics 11 | Build-type: Simple 12 | Extra-source-files: README.md 13 | Cabal-version: >=1.6 14 | 15 | Source-repository head 16 | type: git 17 | location: git://github.com/noteed/smallpt-hs.git 18 | 19 | executable smallpt-hs 20 | main-is: smallpt-hs.hs 21 | 22 | build-depends: base >= 4 && < 5, 23 | vector == 0.6.* 24 | 25 | extensions: ForeignFunctionInterface 26 | 27 | -- no -Wall as type signature are purposely missing 28 | ghc-options: -O2 29 | -------------------------------------------------------------------------------- /smallpt-hs.hs: -------------------------------------------------------------------------------- 1 | import qualified Data.Vector.Mutable as VM -- smallpt-hs, a haskell port 2 | import Data.IORef; import Foreign; import Foreign.C.Types -- of smallpt, 3 | import Data.List hiding(intersect); import Text.Printf; import System.IO 4 | data Vec = Vec {-#UNPACK#-}!CDouble -- the 99 lines C++ Path Tracer by 5 | {-position also-}{-#UNPACK#-}!CDouble -- Kevin Beason. Vo Minh Thu, 2010 6 | {-color (r,g,b)-}{-#UNPACK#-}!CDouble deriving (Show,Eq) -- for the port 7 | instance Num Vec where (+) (Vec a b c) (Vec x y z)=Vec (a+x) (b+y) (c+z) 8 | (-) (Vec a b c) (Vec x y z)=Vec (a-x) (b-y) (c-z) 9 | (*) (Vec a b c) (Vec x y z)=Vec (a*x) (b*y) (c*z) 10 | (*.) (Vec a b c) x=Vec (a*x) (b*x) (c*x); vx=Vec 1 0 0; vy=Vec 0 1 0 11 | black = Vec 0 0 0; norm v@(Vec a b c) = v *. (1/sqrt (a*a+b*b+c*c)) 12 | dot (Vec a b c) (Vec x y z) = a*x+b*y+c*z -- cross: 13 | (%.) (Vec a b c) (Vec x y z) = Vec (b*z-c*y) (c*x-a*z) (a*y-b*x) 14 | data Ray = Ray Vec Vec -- origin, direction 15 | data Refl = DIFF | SPEC | REFR -- material types, used in 'radiance' 16 | --radius, position, emission, color, reflection type (DIFFuse, SPECular, 17 | data Sphere = Sphere CDouble Vec Vec Vec Refl -- or REFRactive) 18 | intersect (Ray o d) (Sphere r p e c refl) = 19 | fi (det<0) Nothing $ f (b-sd) (b+sd) where 20 | op=p-o; eps=1e-4; b=op`dot`d; det=b*b-(op`dot`op)+r*r; sd=sqrt det 21 | f a b = fi (a>eps) (Just a) $ fi (b>eps) (Just b) $ Nothing 22 | -- Scene: radius, position, emission, color, material 23 | spheres = let s = Sphere; z = black; v = Vec in 24 | [ s 1e5 (v (1e5+1) 40.8 81.6) z (v 0.75 0.25 0.25) DIFF -- Left 25 | , s 1e5 (v (-1e5+99) 40.8 81.6) z (v 0.25 0.25 0.75) DIFF -- Right 26 | , s 1e5 (v 50 40.8 1e5) z (v 0.75 0.75 0.75) DIFF -- Back 27 | , s 1e5 (v 50 40.8 (-1e5+170)) z z DIFF -- Front 28 | , s 1e5 (v 50 1e5 81.6) z (v 0.75 0.75 0.75) DIFF -- Bottom 29 | , s 1e5 (v 50 (-1e5+81.6) 81.6) z (v 0.75 0.75 0.75) DIFF -- Top 30 | , s 16.5(v 27 16.5 47) z ((v 1 1 1)*.0.999) SPEC -- Mirror 31 | , s 16.5(v 73 16.5 78) z ((v 1 1 1)*.0.999) REFR -- Glass 32 | , s 600 (v 50 (681.6-0.27) 81.6) (v 12 12 12) z DIFF ] -- Light 33 | clamp x = fi (x<0) 0 $ fi (x>1) 1 x 34 | toInt x = floor $ clamp (x::CDouble) ** (1/2.2) * 255 + 0.5 :: Int 35 | intersects ray = foldl' f (Nothing,undefined) spheres where 36 | f (k,sp) s = case (k,intersect ray s) of 37 | (Nothing,Just x)->(Just x,s); (Just y,Just x) | x(Just x,s); 38 | _ -> (k,sp) 39 | radiance ray@(Ray o d) depth xi = case intersects ray of 40 | (Nothing,_) -> return black; (Just t,Sphere r p e c refl) -> do 41 | fi (depth'<=5) (continue c) -- or perform a Russian roulette 42 | (erand48 xi >>= \er -> fi(er do -- ideal DIFFuse reflection 48 | r1 <- ((2*pi)*) `fmap` erand48 xi; r2 <- erand48 xi; let r2s=sqrt r2 49 | let u=norm$fi(abs wx>0.1) vy vx%.w; v=w%.u; w@(Vec wx _ _)=nl 50 | d' = norm$(u*.(cos r1*r2s))+(v*.(sin r1*r2s))+(w*.sqrt(1-r2)) 51 | ((+) e . (*) f) `fmap` radiance (Ray x d') depth' xi 52 | ; SPEC -> let d' = d - (n *. (2 * (n`dot`d))) in -- ideal SPECular refl. 53 | ((+) e . (*) f) `fmap` radiance (Ray x d') depth' xi 54 | ; REFR -> do -- Ideal dielectric REFRACTION; Ray from outside going in? 55 | let reflRay = Ray x (d-(n*.(2*n`dot`d))); into=n`dot`nl>0 56 | nc=1; nt=1.5; nnt= fi into (nc/nt) (nt/nc); ddn=d`dot`nl 57 | cos2t=1-nnt*nnt*(1-ddn*ddn) -- if <0 : Total internal reflection 58 | fi (cos2t<0) (((+) e . (*) f) `fmap` radiance reflRay depth' xi) 59 | (let tdir=norm$(d*.nnt-(n*.(fi into 1 (-1)*(ddn*nnt+sqrt cos2t)))) 60 | a=nt-nc; b=nt+nc; r0=a*a/(b*b); c=1-fi into (-ddn) (tdir`dot`n) 61 | re=r0+(1-r0)*c*c*c*c*c;tr=1-re;q=0.25+re/2;rp=re/q;tp=tr/(1-q) 62 | in ((+) e . (*) f) `fmap` fi (depth>2) (do{er<-erand48 xi; fi(er 73 | -- no parallelism yet 74 | flip mapM_ [0..h-1] $ \y -> do -- loop over image rows 75 | let fmt = "\rRendering (%d spp) %5.2f%%"; flt' = fromIntegral 76 | hPrintf stderr fmt (samps*4::Int) (100*flt' y/(flt' h-1)::Double) 77 | writeXi xi y; flip mapM_ [0..w-1] $ \x -> do 78 | let i = (h-y-1) * w + x in flip mapM_ [0..1] $ \sy -> do 79 | flip mapM_ [0..1] $ \sx -> do 80 | r <- newIORef black; flip mapM_ [0..samps-1] $ \s -> do 81 | { r1<-(2*)`fmap`erand48 xi; let dx=fi (r1<1) (sqrt r1-1) (1-sqrt(2-r1)) 82 | ; r2<-(2*)`fmap`erand48 xi; let dy=fi (r2<1) (sqrt r2-1) (1-sqrt(2-r2)) 83 | ; let d = (cx *. (((sx + 0.5 + dx)/2 + flt x)/flt w - 0.5)) + 84 | (cy *. (((sy + 0.5 + dy)/2 + flt y)/flt h - 0.5)) + dir 85 | ; rad <- radiance (Ray (pos+(d*.140)) (norm d)) 0 xi 86 | -- Camera rays are ^^^^^ pushed forward to start in interior 87 | ; modifyIORef r (+ (rad *. (1 / flt samps)))} 88 | ci <- VM.unsafeRead c i; Vec rr rg rb <- readIORef r 89 | VM.unsafeWrite c i $ ci + (Vec (clamp rr) (clamp rg) 90 | (clamp rb) *. 0.25) 91 | withFile "image.ppm" WriteMode $ \f -> do 92 | hPrintf f "P3\n%d %d\n%d\n" w h (255::Int) 93 | flip mapM_ [0..w*h-1] $ \i -> do { Vec r g b <- VM.unsafeRead c i; 94 | hPrintf f "%d %d %d " (toInt r) (toInt g) (toInt b) } 95 | foreign import ccall unsafe "erand48" erand48::Ptr CUShort->IO CDouble 96 | writeXi xi y = let y' = fromIntegral y in pokeElemOff xi 0 0 97 | >> pokeElemOff xi 1 0 >> pokeElemOff xi 2 (y' * y' * y') 98 | -- compile with ghc --make -O2 -fffi smallpt-hs.hs -o smallpt-hs 99 | fi a b c=if a then b else c; flt=fromIntegral; main=smallpt 200 200 256 100 | --------------------------------------------------------------------------------