{- WETT -} module RayTracingMain where import Text.Read (readEither) import Data.List (isPrefixOf) import Data.Char (isSpace) import Data.Bifunctor (Bifunctor(bimap, first, second)) import Data.Either (lefts, rights, isLeft) import System.Environment (getArgs) import System.IO (IOMode(WriteMode), withBinaryFile) -- import Control.Parallel.Strategies (Strategy, evalTuple3, parMap, evalTuple2, parListChunk, parList, evalList, using, rseq) import RayTracing ( Camera, Scene(Scene), Object, Obstruction, Light(Light), Beamer, Material(Material), fromTuple, pointBeams, rectBeams, sphere, plane, oneWayPlane, boundedPlane, rectPrism, standardCamera, dofCamera, hRenderAndWrite ) {- MCCOMMENT A parallelised ray tracer for haskell. The submission(s) are in the folder renders/submission. Since I'm probably only allowed to submit one image, my final submission is renders/submission/infmirror.png, but I encourage you to take a look at the other images as well (since Isabelle is kinda your thing...). A note on building: to take advantage of parallelisation, the project needs to be built with parallelisation enabled. If you use stack, this should be taken care of in the submitted exercise.cabal, or you can use the following options to GHC: ghc -o rtrace -O2 -threaded -with-rtsopts=-N8 src/RayTracing.hs src/RayTracingMain.hs I've baked in -N8 for my 8-thread CPU (4 cores with SMT), but you might want to adjust for your setup. Building with -rtsopts allows +RTS -NX to specifiy the number of GHC "capabilites" (threads) at runtime but this way there is no chance of forgetting. You can use the linux command time to check if parallelisation is working, the user time should be significantly higher than the real time (about 8 times, here). Or search for "PARALLEL_TEST" in this file. Also note that -Wall At runtime, the necessary files describing the scene are provided, followed by the width, height, and bounces parameters. Since all of these render take quite a long time, if you're just interested in giving the tracer a test, consider lowering the resulution (width and height) by equal factors or lowering the number of bounces. Note that the bounces must be at least 2 for mirrors to show anything. The submissions can be generated with the given commands. Assumes the use of stack, otherwise just replace the 'stack run rtrace --' with the compiled executable's name :) 1. renders/submission/infmirror.png stack run rtrace -- renders/infmirror.png scenes/infmirror/lights.hson scenes/infmirror/materials.hson scenes/infmirror/objects.hson scenes/infmirror/scene.hson scenes/infmirror/camera.hson 1280 960 6 Inspired by https://en.wikipedia.org/wiki/Ray_tracing_(graphics)#/media/File:Ray-traced_steel_balls.jpg Render time on my machine: ca. 2 hours. Render time at 160x120 with and 2 bounces (change last 3 arguments to command): ca. 30 sec. Render time at 320x240 with scenes/infmirror/lights.hson replaced with scenes/infmirror/lights_fast.hson: ca. 30 sec (This uses less dense area lights, which cause visible banding but are fine for testing) 2. renders/submission/isabelle.png and renders/submission/isabelle_rtx.png stack run rtrace -- renders/isabelle.png scenes/isabelle/lights.hson scenes/isabelle/materials.hson scenes/isabelle/objects.hson scenes/isabelle/scene.hson scenes/isabelle/camera.hson 2048 2048 2 Render time on my machine: ca. 35 minutes. Render time at 256x256: ca. 40 sec. 3. renders/submission/demo.png Inspired by https://blog.demofox.org/2016/09/21/path-tracing-getting-started-with-diffuse-and-emissive/ stack run rtrace -- renders/demo.png scenes/demo/lights.hson scenes/demo/materials.hson scenes/demo/objects.hson scenes/demo/scene.hson scenes/demo/camera.hson 2048 2048 4 Render time on my machine: ca. 2 hours, although I forgot to time this one and have since improved the performance. Render time at 256x256: ca. 2 minutes. The source structure as follows: RayTracingMain.hs: does all the parsing of input files. Rather uninteresting and poorly documented. RayTracing.hs: The actual ray tracing implementation. The more interesting part and well-commented. -} -- import System.Random (Random (randomR), mkStdGen) -- What is HSON? HSON is to Haskell as JSON is to JavaScript (HaSkellObjectNotation vs. JavaScriptObjectNotation) -- See sample .hson files for the meaning of fields in the following HSON types. -- Comments are allowed but must begin a line (or be preceded entirely be whitespace) -- Is there a better way to parse config files? Yes, type RGBTuple = (Double, Double, Double) type LightHson = [(String, (RGBTuple, RGBTuple, (String, String)))] type ReflectorParser = (String, String -> Either String Beamer) type MaterialHson = [(String, (RGBTuple, RGBTuple, RGBTuple, RGBTuple, RGBTuple, RGBTuple))] type ObjectHson = [(String, (String, (String, String)))] type ObstructionParser = (String, String -> Either String Obstruction) type CameraHson = (String, String) type CameraParser = (String, String -> Either String Camera) type SceneHson = ([String], [String], RGBTuple, RGBTuple, RGBTuple) standardReflectors :: [ReflectorParser] standardReflectors = [("point", \s -> bimap (++ ": expecting (, , ) but got " ++ show s) (pointBeams . fromTuple) $ readEither s), ("rect_area", \s -> bimap (++ ": expecting () but got " ++ show s) (\(sp, o, v1, v2, w) -> rectBeams sp (fromTuple o) (fromTuple v1) (fromTuple v2) w) $ readEither s)] standardObstructions :: [ObstructionParser] standardObstructions = [("sphere", \s -> bimap (++ ": expecting ((, , ), ) but got " ++ show s) (uncurry sphere . first fromTuple) $ readEither s), ("plane", \s -> bimap (++ ": expecting ((, , ), (, , )) but got " ++ show s) (uncurry plane . bimap fromTuple fromTuple) $ readEither s), ("one_way_plane", \s -> bimap (++ ": expecting ((, , ), (, , )) but got " ++ show s) (uncurry oneWayPlane . bimap fromTuple fromTuple) $ readEither s), ("bounded_plane", \s -> bimap (++ ": expecting ((, , ), (, , ), (, , )) but got " ++ show s) (\(o, w, h) -> boundedPlane plane (fromTuple o) (fromTuple w) (fromTuple h)) $ readEither s), ("rect_prism", \s -> bimap (++ ": expecting ((, , ), (, , ), (, , ), depth, height) but got " ++ show s) (\(c, v1, v2, d, h) -> rectPrism (fromTuple c) (fromTuple v1) (fromTuple v2) d h) $ readEither s)] standardCameras :: [CameraParser] standardCameras = [("standard", \s -> bimap (++ ": expecting (, , , ) but got " ++ s) (\(from, to, fov, up) -> standardCamera (fromTuple from) (fromTuple to) fov (fromTuple up)) $ readEither s), ("standard_dof", \s -> bimap (++ ": expecting (, , , , , , ) but got " ++ s) (\(d, r, c, from, to, fov, up) -> dofCamera d r c (fromTuple from) (fromTuple to) fov (fromTuple up)) $ readEither s)] collectLefts :: ([a] -> a) -> [Either a b] -> Either a [b] collectLefts f es | any isLeft es = Left $ f $ lefts es | otherwise = Right $ rights es parseLights :: [ReflectorParser] -> String -> Either String [(String, Light)] parseLights ps inp = first ("While parsing lights:\n" ++ ) $ do hson <- readEither inp :: Either String LightHson beamerParsers <- collectLefts (unlines . ("Unknown beamers:" :)) $ map (\h@(name, _) -> let k = fst $ lkv h in maybe (Left $ k ++ " in " ++ name) Right $ (`lookup` ps) k) hson parsedBeamers <- collectLefts (unlines . ("Could not parse beamers:" :)) $ zipWith (\p h -> p $ snd $ lkv h) beamerParsers hson return $ zipWith (\(name, (spec, diff, _)) beamer -> (name, Light beamer (fromTuple spec) (fromTuple diff))) hson parsedBeamers where lkv (_, (_, _, l)) = l parseMaterials :: String -> Either String [(String, Material)] parseMaterials inp = first ("While parsing materials:\n" ++ ) $ do hson <- readEither inp :: Either String MaterialHson return $ map (second toMaterial) hson where toMaterial (spec, diff, amb, emi, shiny, refl) = Material (fromTuple spec) (fromTuple diff) (fromTuple amb) (fromTuple emi) (fromTuple shiny) (fromTuple refl) parseObjects :: [(String, Material)] -> [ObstructionParser] -> String -> Either String [(String, Object)] parseObjects ms ps inp = first ("While parsing objects:\n" ++ ) $ do hson <- readEither inp :: Either String ObjectHson obstructionParsers <- collectLefts (unlines . ("Unknown obstructions:" :)) $ map (\h@(name, _) -> let k = fst $ lkv h in maybe (Left $ k ++ " in " ++ name) Right $ (`lookup` ps) k) hson parsedObstructions <- collectLefts (unlines . ("Could not parse obstructions:" :)) $ zipWith (\p h -> p $ snd $ lkv h) obstructionParsers hson materials <- collectLefts (unlines . ("Unknown materials:" :)) $ map (\h@(name, _) -> let m = mat h in maybe (Left $ m ++ " in " ++ name) Right $ (`lookup` ms) m) hson return $ zipWith3 (\(name, _) ob m -> (name, (m, ob))) hson parsedObstructions materials where lkv (_, (_, l)) = l mat (_, (l, _)) = l parseScene :: [(String, Light)] -> [(String, Object)] -> String -> Either String Scene parseScene ls os inp = first ("While parsing scene:\n" ++ ) $ do (lightStrings, objectStrings, amb, emi, bg) <- readEither inp :: Either String SceneHson lights <- collectLefts (unlines . ("Unknown lights:" :)) $ map (\name -> maybe (Left name) Right $ (`lookup` ls) name) lightStrings objects <- collectLefts (unlines . ("Unknown objects:" :)) $ map (\name -> maybe (Left name) Right $ (`lookup` os) name) objectStrings return $ Scene lights objects (fromTuple amb) (fromTuple emi) (fromTuple bg) parseCamera :: [CameraParser] -> String -> Either String Camera parseCamera cp inp = first ("File parsing camera:\n" ++ ) $ do (k, v) <- readEither inp :: Either String CameraHson camParser <- maybe (Left $ "Unknown camera: " ++ k) Right $ lookup k cp camParser v parse :: (String -> Either String a) -> String -> Either String a parse f = f . unlines . filter (not . ("--" `isPrefixOf`) . dropWhile isSpace) . lines stopOnError :: Either String a -> IO a stopOnError = either errorWithoutStackTrace return readHson :: (String -> Either String a) -> String -> IO a readHson f fname = stopOnError . parse f =<< readFile fname readLights :: String -> IO [(String, Light)] readLights = readHson (parseLights standardReflectors) readMaterials :: String -> IO [(String, Material)] readMaterials = readHson parseMaterials readObjects :: [(String, Material)] -> String -> IO [(String, Object)] readObjects ms = readHson (parseObjects ms standardObstructions) readScene :: [(String, Light)] -> [(String, Object)] -> String -> IO Scene readScene ls os = readHson (parseScene ls os) readCamera :: String -> IO Camera readCamera = readHson (parseCamera standardCameras) errorUsage :: a errorUsage = errorWithoutStackTrace "Usage: rtrace output.png lights.hson materials.hson objects.hson scene.hson camera.hson (width height (bounces))" main :: IO () main = do args <- getArgs (outFPath, scene, cam, size, bounces) <- case args of outFPath : lFile : matFile : objFile : scFile : camFile : remain -> do let (size, bounces) = case remain of w : h : remain2 -> ((read w, read h), case remain2 of [b] -> read b [] -> 16 _ -> errorUsage) [] -> ((1024, 1024), 16) _ -> errorUsage ls <- readLights lFile mats <- readMaterials matFile objs <- readObjects mats objFile scene <- readScene ls objs scFile cam <- readCamera camFile return (outFPath, scene, cam, size, bounces) _ -> errorUsage withBinaryFile outFPath WriteMode (hRenderAndWrite scene cam size bounces) {-TTEW-} -- PARALLEL_TEST -- code to make sure parallelism is properly configured -- comment out the main function above -- uncomment the import "import Control.Parallel.Strategies (..." at the top of the file -- uncomment the code below -- comment out one of the main functions below -- stack build && time stack run rtrace (or equivalent) -- the version with `using` should be significantly (ca. 8 times, provided with at least 8 CPU threads) faster -- isPrime :: Int -> Bool -- isPrime n | n < 2 = False -- isPrime n = go 2 -- where go x -- | x * x > n = True -- | n `mod` x == 0 = False -- | otherwise = x `seq` go (x + 1) -- start :: Int -- start = 10000000000000000 -- main :: IO () -- -- main = print (map (\x -> (x, isPrime x)) [start..start + 512]) -- main = print (map (\x -> (x, isPrime x)) [start..start + 512] `using` parListChunk 16 (evalTuple2 rseq rseq))