[ { "path": ".gitignore", "content": ".stack-work\nblackstar.prof\nout.png\ntexture.jpg\nBSC5\nSAO.pc\nPPM\nPPMra\nrenders\nbloomed.png\noutput\n*.png\n!example.png\nframes*\n*.mkv\ndist*\n.ghc.*\n\n" }, { "path": "LICENSE", "content": "Copyright Sakari Kapanen (c) 2016\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n * Redistributions of source code must retain the above copyright\n notice, this list of conditions and the following disclaimer.\n\n * Redistributions in binary form must reproduce the above\n copyright notice, this list of conditions and the following\n disclaimer in the documentation and/or other materials provided\n with the distribution.\n\n * Neither the name of Author name here nor the names of other\n contributors may be used to endorse or promote products derived\n from this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS\n\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT\nLIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR\nA PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT\nOWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\nSPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT\nLIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,\nDATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY\nTHEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\n" }, { "path": "README.md", "content": "# Blackstar\nA black hole ray tracer written in Haskell. There's [an article](https://flannelhead.github.io/projects/blackstar.html) about this on my homepage. I've also written a [theoretical writeup](https://flannelhead.github.io/posts/2016-03-06-photons-and-black-holes.html) on Schwarzschild geodesics.\n\n![An example image](https://raw.githubusercontent.com/flannelhead/blackstar/master/example.png)\n\n## Features\n* Fast, parallel ray tracing\n* Rendering [Schwarzschild](https://en.wikipedia.org/wiki/Schwarzschild_metric) black holes\n* Rendering accretion disks\n* Drawing the celestial sphere using a star catalogue\n* Bloom effect\n* Antialiasing by 4x supersampling for smoother images\n* Easy, YAML based configuration\n* A simple CLI\n* Batch mode and sequence generator for creating animations\n\n## What about the name?\nIt is a tribute to David Bowie, referring to his last album.\n\n## Building\nUse [`stack`](http://docs.haskellstack.org/en/stable/README/) to build this. First clone the repo, then run `stack build` and follow the instructions given by `stack`. You should be able to build `blackstar` on any platform where you can install `stack`.\n\nYou will have to build the star lookup tree first. Download the [PPM star catalog](http://tdc-www.harvard.edu/software/catalogs/ppm.html) [this archive](http://tdc-www.harvard.edu/software/catalogs/ppm.tar.gz) and extract the file `PPM` to the root folder of this project. Then run `stack exec generate-tree PPM stars.kdt` and the tree will be generated and saved to the file `stars.kdt`.\n\n### Speeding it up with LLVM\nWhen doing large or batch renders, it is recommended to build `blackstar` using GHC's LLVM backend. GHC produces LLVM bytecode and LLVM produces fast native code from GHC's output. In my tests I've noticed ~1.5x speedups.\n\nThe LLVM backend isn't used by default since one needs to install (and usually build) a specific version of LLVM separately. Moreover, the build time is significantly higher with LLVM, so one doesn't definitely want to use it while hacking on the code.\n\nTo successfully build with LLVM, you need to:\n\n* Download and [build](http://llvm.org/docs/GettingStarted.html#getting-started-quickly-a-summary) [LLVM 6.0.1](http://llvm.org/releases/download.html#6.0.1). You can skip the Clang parts. After the build, you should make sure the tools `llc` and `opt` are found in your `PATH`. Notice that these aren't included in the prebuilt LLVM binaries, that's why you'll need to build it.\n* Build `blackstar` with `stack build --ghc-options -fllvm`. (If you've just built it, run `stack clean` first to ensure it really gets rebuilt with LLVM.)\n* Wait patiently\n* Enjoy the result!\n\nYou don't necessarily have to use LLVM at all. However, if you can acquire binaries of the right LLVM version, that will give you some speedups.\n\n## Usage\nWhen `blackstar` has been built with `stack`, you can run it with\n```\nstack exec blackstar -- [-p|--preview] [-f|--force] [-o|--output=PATH] [-s|--starmap=PATH] SCENENAME\n```\nNotice the two dashes (`--`) which are required to terminate `stack`'s argument list.\n\n\n`cabal` users can run `blackstar` by executing\n```\ncabal run -- [OPTIONS] SCENENAME\n```\nin the root folder of the project.\n\nScenes are defined using YAML config files. Look in the `scenes` folder for examples. To render the `default` scene to the directory `output`, run\n```\nstack exec blackstar -- scenes/default.yaml --output output\n```\nin the root directory of the project. The `--output` flag specifies the output directory. By default, `blackstar` searches for a starmap in the path `./stars.kdt`, but a different path can be specified using the `--starmap` flag.\n\nThe rendered files are named `scenename.png` and `scenename-bloomed.png`. The `--preview` flag can be used to render small-sized previews of the scene while adjusting the parameters. The `--force` flag will cause `blackstar` to overwrite output images without a prompt.\n\nIf a directory is given as the input scene path, `blackstar` searches non-recursively for YAML files in that directory and tries to render them. The scenes are placed in the specified output directory.\n\nThere's also a help text which can be seen by running\n```\nstack exec blackstar -- --help\nOR\ncabal run -- --help\n```\n\nBetter images can be achieved by rendering larger than the target size and then scaling down (some antialiasing is achieved). This is called supersampling and is implemented in `blackstar`. It can be enabled by setting `supersampling` to true in the YAML config file — see `scenes/default-aa.yaml` for an example.\n\n## Animation\nThere is a separate YAML config format for specifying animations. For example, see [default-ani.yaml](animations/default-ani.yaml).\n\nIn the first pass, the animation file must be rendered into separate config files for each frame. The `animate` executable takes care of this. First, create a directory where the frame config files will be put.\n```\nmkdir frames\n```\nThen run `animate`:\n```\nstack exec animate -- animations/default-ani.yaml -o frames\n```\nNow you should find quite a bunch of `.yaml` files in the folder `frames`.\n\nMake another folder for the output frames:\n```\nmkdir frames-out\n```\nNow you will be able to run `blackstar` in batch mode to render the frames:\n```\nstack exec blackstar -- frames -o frames-out\n```\nThis will take quite a while.\n\nAfter the frames have been rendered, generate a video from the `*.png` still with your utility of preference. You can also use my script `scripts/ffmpeg-animate`, which uses `ffmpeg`. You only need to give it the prefix of the numbered frames:\n```\nscripts/ffmpeg-animate frames-out/default-ani\n```\nThe output video will be rendered to `out.mkv`.\n\n## Profiling\nThanks to `stack`, profiling is incredibly easy. Rebuild `blackstar` by running\n```\nstack build --profile\n```\nand then run it with\n```\nstack exec blackstar -- scenes/default.yaml -o output +RTS -p\n```\nThe profile will be generated to `blackstar.prof`.\n\n## TODO\nAs always, there's a plenty of room for improvement. For example:\n\n* Animation: mathematically rigorous non-stationary observer\n* Arbitrary textures for accretion disk (or some cool noise generator)\n* Redshifting of the accretion disk\n* Preview / scene planner GUI ([fltkhs](https://hackage.haskell.org/package/fltkhs))\n\nPull requests are welcome! If you find some cool scenes, I'd appreciate if you contributed them to this repository.\n\n" }, { "path": "Setup.hs", "content": "import Distribution.Simple\nmain = defaultMain\n" }, { "path": "animations/default-ani.yaml", "content": "# Animation files are quite similar to scene files. The difference is that you\n# can define multiple camera instances which are then fixed to certain points\n# of time (normalized to [0, 1[). The frames in between are then generated by\n# interpolating between the keyframes using the interpolation method of choice.\n\n# Scene config is similar to the scene files\nscene:\n resolution: [1920, 1080]\n bloomStrength: 0.7\n starIntensity: 0.7\n starSaturation: 0.7\n diskHSV: [180, 0.1, 1.05]\n diskOpacity: 0.95\n diskInner: 1.8\n diskOuter: 13\n supersampling: true\n\n# The number of frames in the animation\nnFrames: 375\n# Interpolation method. Currently, 'linear' is the only option\ninterpolation: 'linear'\n\n# Specify any number of keyframes you want\nkeyframes:\n- time: 0 # The normalize time of the keyframe. 0 is the first frame, 1 is the last\n camera: # Camera config is similar to the scene files\n position: [3, 3, -20]\n lookAt: [-7, 5, 0]\n upVec: [-0.2, 1, 0]\n fov: 1.5\n- time: 1\n camera:\n position: [-15, 1, -20]\n lookAt: [13, -7, 0]\n upVec: [-0.2, 1, 0]\n fov: 2\n" }, { "path": "app/Animate.hs", "content": "{-# LANGUAGE DeriveDataTypeable #-}\n{-# OPTIONS_GHC -fno-cse #-}\n\nmodule Main where\n\nimport Prelude hiding (writeFile)\nimport System.Directory\nimport System.FilePath\nimport Data.Yaml (decodeFileEither, prettyPrintParseException, encode)\nimport System.Console.CmdArgs\nimport Control.Monad (forM_)\nimport Data.ByteString.Lazy (fromStrict, writeFile)\n\nimport Animation\nimport Util\n\ndata Animate = Animate { inFile :: FilePath\n , output :: FilePath\n , force :: Bool }\n deriving (Show, Data, Typeable)\n\nargparser :: Animate\nargparser = Animate { inFile = def\n &= argPos 0\n &= typ \"INPUTFILE\"\n , output = \"\"\n &= help \"output directory\"\n &= typ \"PATH\"\n , force = def\n &= help \"overwrite images without asking\" }\n &= summary \"Animation helper for Blackstar\"\n\nmain :: IO ()\nmain = do\n cmdline <- cmdArgs argparser\n\n let inPath = inFile cmdline\n let basename = takeBaseName inPath\n inputExists <- doesFileExist inPath\n\n outPath <- normalizePath =<< case output cmdline of\n \"\" -> getCurrentDirectory\n x -> return x\n createDirectoryIfMissing True outPath\n\n if inputExists then do\n config <- decodeFileEither inPath\n case config of\n Right cfg ->\n case validateKeyframes $ keyframes cfg of\n Right () -> do\n let nFr = nFrames cfg\n forM_ (zip (generateFrames cfg) [(0 :: Int), 1 ..])\n (\\(frame, idx) -> do\n let filename = outPath basename ++ \"_\" ++\n padZero (nFr - 1) idx <.> \".yaml\"\n let outBl = fromStrict $ encode frame\n if force cmdline\n then writeFile filename outBl\n else promptOverwriteFile filename \n (\\fname -> writeFile fname outBl)\n )\n Left err -> putStrLn err\n Left err -> putStrLn $ \"Error when decoding config:\\n\" ++\n prettyPrintParseException err\n else putStrLn \"Couldn't open input file.\"\n" }, { "path": "app/GenerateTree.hs", "content": "module Main where\n\nimport qualified Data.ByteString.Lazy as B\nimport System.Environment (getArgs)\n\nimport Util\nimport StarMap\n\n-- Generate and store the k-d star tree from a star catalog\n\nmain :: IO ()\nmain = do\n args <- getArgs\n case args of\n [infile, outfile] -> do\n outfile' <- normalizePath outfile\n infile' <- normalizePath infile\n eitherMap <- readMapFromFile infile'\n case eitherMap of\n Right stars -> do\n putStrLn \"Generating the star tree...\"\n tree <- timeAction \"Building the tree\"\n $ buildStarTree stars\n let treeBl = B.fromStrict $ treeToByteString tree\n promptOverwriteFile outfile'\n (\\filename -> B.writeFile filename treeBl)\n putStrLn $ \"Tree saved to \" ++ outfile' ++ \".\"\n Left err -> putStrLn err\n _ -> putStrLn \"Usage: generate-tree \"\n" }, { "path": "app/Main.hs", "content": "{-# LANGUAGE DeriveDataTypeable #-}\n{-# OPTIONS_GHC -fno-cse #-}\n\nmodule Main where\n\nimport System.Directory\nimport Control.Monad (when, forM_)\nimport Data.Yaml (decodeFileEither, prettyPrintParseException)\nimport System.Console.CmdArgs\nimport System.FilePath (takeBaseName, takeExtension, (), (<.>))\nimport Data.List (sort)\nimport System.Console.ANSI (clearScreen, setCursorPosition)\n\nimport Raytracer\nimport StarMap\nimport ConfigFile\nimport ImageFilters\nimport Util\n\ndata Blackstar = Blackstar { preview :: Bool\n , output :: String\n , force :: Bool\n , starmap :: String\n , inputfile :: String }\n deriving (Show, Data, Typeable)\n\nargparser :: Blackstar\nargparser = Blackstar { preview = def\n &= help \"preview render (small size)\"\n , output = \"\"\n &= help \"output directory\"\n &= typ \"PATH\"\n , force = def\n &= help \"overwrite images without asking\"\n , starmap = \"stars.kdt\"\n &= help \"path to starmap\"\n &= typ \"PATH\"\n , inputfile = def\n &= argPos 0\n &= typ \"INPUTFILE\"\n } &= summary \"Blackstar v0.1\"\n\nmain :: IO ()\nmain = do\n cmdline <- cmdArgs argparser\n etree <- readTreeFromFile $ starmap cmdline\n case etree of\n Right tree -> putStrLn \"Starmap successfully read.\"\n >> doStart cmdline tree\n Left err -> putStrLn $ \"Error decoding star tree: \\n\" ++ err\n\ndoStart :: Blackstar -> StarTree -> IO ()\ndoStart cmdline tree = do\n -- Resolve the output directory\n when (output cmdline /= \"\")\n $ createDirectoryIfMissing True (output cmdline)\n outdir <- normalizePath =<< case output cmdline of\n \"\" -> getCurrentDirectory\n x -> return x\n createDirectoryIfMissing True outdir\n -- Resolve the input file or directory\n filename <- normalizePath $ inputfile cmdline\n isDir <- doesDirectoryExist filename\n if isDir then do\n putStrLn $ filename\n ++ \" is a directory. Rendering all scenes inside it...\"\n\n inputFiles <- map (filename )\n . sort . filter (\\f -> takeExtension f == \".yaml\")\n <$> getDirectoryContents filename\n\n forM_ (zip inputFiles [(1 :: Int)..]) $ \\(scn, idx) -> do\n clearScreen\n setCursorPosition 0 0\n putStrLn $ \"Batch mode progress: \" ++ show idx ++ \"/\"\n ++ show (length inputFiles)\n handleScene cmdline tree outdir scn\n else handleScene cmdline tree outdir filename\n\nhandleScene :: Blackstar -> StarTree -> String -> String -> IO ()\nhandleScene cmdline tree outdir filename = do\n let pvw = preview cmdline\n let sceneName = takeBaseName filename\n putStrLn $ \"Reading \" ++ filename ++ \"...\"\n cfg <- decodeFileEither filename\n let sceneName' = if pvw then \"prev-\" ++ sceneName else sceneName\n case cfg of\n Right config -> putStrLn \"Scene successfully read.\"\n >> doRender cmdline (prepareScene config pvw) tree\n sceneName' outdir\n Left err -> putStrLn $ prettyPrintParseException err\n\nprepareScene :: Config -> Bool -> Config\nprepareScene cfg doPreview = let\n scn = scene cfg\n (w, h) = resolution scn\n res = 300\n newRes = if w >= h then (res, res * h `div` w) else (res * w `div` h, res)\n newScn = if doPreview then scn { resolution = newRes\n , supersampling = False\n , bloomStrength = 0 }\n else scn\n in cfg { scene = newScn }\n\ndoRender :: Blackstar -> Config -> StarTree -> String -> String -> IO ()\ndoRender cmdline cfg tree sceneName outdir = do\n putStrLn $ \"Rendering \" ++ sceneName ++ \"...\"\n let scn = scene cfg\n img <- timeAction \"Rendering\" $ render cfg tree\n\n let outName = outdir sceneName <.> \".png\"\n\n final <- if bloomStrength scn /= 0\n then do\n putStrLn \"Applying bloom...\"\n bloomed <- bloom (bloomStrength scn) (bloomDivider scn) img\n timeAction \"Bloom\" bloomed\n else return img\n\n putStrLn $ \"Saving to \" ++ outName ++ \"...\"\n if force cmdline\n then writeImg final outName\n else promptOverwriteFile outName (writeImg final)\n\n putStrLn \"Everything done. Thank you!\"\n" }, { "path": "blackstar.cabal", "content": "name: blackstar\nversion: 0.1.0.0\nsynopsis: A black hole ray tracer\ndescription: A black hole ray tracer written in Haskell\nhomepage: http://github.com/flannelhead/blackstar#readme\nlicense: BSD3\nlicense-file: LICENSE\nauthor: Sakari Kapanen\nmaintainer: sakari.m.kapanen@gmail.com\ncopyright: 2019 Sakari Kapanen\ncategory: Graphics\nbuild-type: Simple\n-- extra-source-files:\ncabal-version: >=1.10\n\nlibrary\n hs-source-dirs: src\n exposed-modules: Raytracer\n , StarMap\n , ConfigFile\n , ImageFilters\n , Util\n , Animation\n ghc-options: -Wall\n -O2\n build-depends: base >= 4.7 && < 5\n , data-default\n , linear\n , lens\n , bytestring\n , cereal\n , vector\n , kdt\n , yaml\n , aeson\n , directory\n , massiv\n , massiv-io\n , filepath\n , time\n , deepseq\n default-language: Haskell2010\n\nexecutable blackstar\n hs-source-dirs: app\n main-is: Main.hs\n ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N\n build-depends: base\n , blackstar\n , directory\n , yaml\n , bytestring\n , cmdargs\n , filepath\n , ansi-terminal\n default-language: Haskell2010\n\nexecutable animate\n hs-source-dirs: app\n main-is: Animate.hs\n ghc-options: -Wall\n build-depends: base\n , blackstar\n , directory\n , yaml\n , bytestring\n , cmdargs\n , filepath\n default-language: Haskell2010\n\nexecutable generate-tree\n hs-source-dirs: app\n main-is: GenerateTree.hs\n ghc-options: -Wall\n build-depends: base\n , blackstar\n , directory\n , bytestring\n default-language: Haskell2010\n\nsource-repository head\n type: git\n location: https://github.com/flannelhead/blackstar\n" }, { "path": "scenes/closeup.yaml", "content": "camera:\n position: [10, 1, -2]\n lookAt: [0, 0, 6]\n upVec: [0, 1, 0]\n fov: 1.2\n\nscene:\n resolution: [1280, 960]\n bloomStrength: 0.7\n starIntensity: 0.7\n starSaturation: 0.7\n diskOpacity: 0.95\n diskInner: 3\n diskOuter: 9\n" }, { "path": "scenes/default-aa.yaml", "content": "camera:\n position: [0, 1, -20]\n lookAt: [2, 0, 0]\n upVec: [-0.2, 1, 0]\n fov: 1.5\n\nscene:\n resolution: [1920, 1080]\n bloomStrength: 0.15\n starIntensity: 0.4\n starSaturation: 1.5\n diskColor: [180, 0.1, 1.05]\n diskOpacity: 0.95\n diskInner: 1.8\n diskOuter: 13\n supersampling: true\n" }, { "path": "scenes/default.yaml", "content": "camera:\n # All the vectors are [x, y, z] coordinates\n position: [0, 1, -20] # The position of the camera\n lookAt: [2, 0, 0] # The point to look at\n upVec: [-0.2, 1, 0] # The \"up\" direction vector which determines the\n # orientation of the camera\n fov: 1.5 # The tangent of the view angle\n\nscene:\n resolution: [1920, 1080] # [width, height] of the image\n bloomStrength: 0.15 # The strength (weight) of the bloom effect. Setting this to\n # 0 disables it entirely\n bloomDivider: 25 # A number x such that r = image width / x is the bloom radius\n\n starIntensity: 0.4 # The intensity (0 = black, 1 = white) of the stars\n starSaturation: 1.5 # The color saturation of the stars\n\n diskOpacity: 0.95 # Opacity of the accretion disk (0 = fully transparent,\n # 1 = fully opaque)\n diskInner: 1.8 # The inner radius of the accretion disk\n diskOuter: 13 # The outer radius of the accretion disk\n diskColor: [180, 0.1, 1.05] # The colour of the accretion disk in the HSI color space.\n # H: 0..360, S: 0..1, I: 0..1\n\n supersampling: false # Set this to true to enable smoothing by supersampling\n # a 4x sized image\n stepSize: 0.3 # The size of the timestep in the simulation. Usually this value\n # should be fine.\n" }, { "path": "scenes/fartheraway.yaml", "content": "camera:\n position: [-25, 1, -60]\n lookAt: [-12, -4, 0]\n upVec: [0.15, 1, 0]\n fov: 2\n\nscene:\n resolution: [1920, 1080]\n bloomStrength: 0.15\n starIntensity: 0.4\n starSaturation: 1.5\n diskOpacity: 0.95\n diskInner: 3\n diskOuter: 12\n supersampling: true\n" }, { "path": "scenes/lensing-disk.yaml", "content": "camera:\n position: [30, 0.4, 3]\n lookAt: [0, 0, 0]\n upVec: [0, 1, 0.2]\n fov: 1\n\nscene:\n resolution: [1280, 800]\n bloomStrength: 0.15\n starIntensity: 0.4\n starSaturation: 1.5\n diskOpacity: 0.95\n diskInner: 3\n diskOuter: 12\n supersampling: true\n" }, { "path": "scenes/lensing.yaml", "content": "camera:\n position: [30, 0.4, 3]\n lookAt: [0, 0, 0]\n upVec: [0, 1, 0.2]\n fov: 1\n\nscene:\n resolution: [1600, 1200]\n bloomStrength: 0.15\n starIntensity: 0.4\n starSaturation: 1.5\n diskOpacity: 0\n diskInner: 3\n diskOuter: 12\n supersampling: true\n" }, { "path": "scenes/wideangle-disk.yaml", "content": "camera:\n position: [-6, 1, -20]\n lookAt: [-6, -4, 0]\n upVec: [-0.2, 1, 0]\n fov: 3.5\n\nscene:\n resolution: [1920, 1080]\n bloomStrength: 0.15\n starIntensity: 0.4\n starSaturation: 1.5\n diskOpacity: 0.95\n diskInner: 2.5\n diskOuter: 12\n supersampling: true\n" }, { "path": "scenes/wideangle.yaml", "content": "camera:\n position: [20, 0, 0]\n lookAt: [0, 0, 3.5]\n upVec: [0, 1, 0]\n fov: 2\n\nscene:\n resolution: [1920, 1020]\n bloomStrength: 0.15\n starIntensity: 0.4\n starSaturation: 1.5\n diskOpacity: 0\n supersampling: true\n" }, { "path": "scenes/wideangle1.yaml", "content": "camera:\n position: [0, 0, 20]\n lookAt: [3.5, 0, 0]\n upVec: [0, 1, 0]\n fov: 2\n\nscene:\n resolution: [1920, 1080]\n bloomStrength: 0.15\n starIntensity: 0.4\n starSaturation: 1.5\n diskOpacity: 0\n supersampling: true\n" }, { "path": "scripts/ffmpeg-animate", "content": "#!/bin/sh\n\n# Create YouTube quality video from stills using ffmpeg\n#\n# USAGE:\n# ffmpeg-animate PREFIX\n#\n# Writes to file \"out.mkv\" in the current directory\n\nffmpeg -f image2 -i \"${1}_%03d.png\" \\\n -c:v libx264 -preset slow -crf 18 -pix_fmt yuv420p \\\n -r 25 out.mkv\n\n" }, { "path": "src/Animation.hs", "content": "{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveGeneric #-}\n\nmodule Animation ( Keyframe(camera, time)\n , Animation(scene, nFrames, interpolation, keyframes)\n , InterpolationMethod(Linear)\n , generateFrames, validateKeyframes ) where\n\nimport Data.List (sortBy)\nimport Data.Ord (comparing)\nimport qualified ConfigFile as CF\nimport Data.Aeson.Types\nimport Linear ((*^))\nimport GHC.Generics\n\ndata Keyframe = Keyframe { camera :: CF.Camera\n , time :: Double }\n deriving (Generic)\n\ndata InterpolationMethod = Linear\n\ndata Animation = Animation { scene :: CF.Scene\n , nFrames :: Int\n , interpolation :: InterpolationMethod\n , keyframes :: [Keyframe] }\n deriving (Generic)\n\ninstance FromJSON Keyframe\n\ninstance FromJSON InterpolationMethod where\n parseJSON str = do\n (str' :: String) <- parseJSON str\n return $ case str' of\n \"linear\" -> Linear\n _ -> Linear\n\ninstance FromJSON Animation\n\nvalidateKeyframes :: [Keyframe] -> Either String ()\nvalidateKeyframes [] = Left \"Must have at least two keyframes\"\nvalidateKeyframes [_] = validateKeyframes []\nvalidateKeyframes frs = if time (head frs) == 0 && time (last frs) == 1\n then Right ()\n else Left \"First keyframe must have time == 0, last time == 1\"\n\ngenerateFrames :: Animation -> [CF.Config]\ngenerateFrames animation = let\n stepsize = (1 :: Double) / fromIntegral (nFrames animation - 1)\n -- Take the first keyframe from the scene in the config\n -- Also sort the frames by time\n frames = sortBy (comparing time) $ keyframes animation\n points = (* stepsize) . fromIntegral <$> [0 .. nFrames animation - 1]\n in map (makeFrame animation frames) points\n\nmakeFrame :: Animation -> [Keyframe] -> Double -> CF.Config\nmakeFrame animation frames point = let\n scn = scene animation\n mtd = interpolation animation\n in CF.Config { CF.camera = interpolate mtd frames point\n , CF.scene = scn }\n\ninterpolate :: InterpolationMethod -> [Keyframe] -> Double -> CF.Camera\ninterpolate method frames t = let\n findFrames (fr1 : fr2 : frs) = if t >= time fr1 && t < time fr2\n then (fr1, fr2)\n else findFrames (fr2 : frs)\n findFrames [fr] = (fr, fr { time = time fr + 1 } )\n\n (f1, f2) = findFrames frames\n t' = (t - time f1) / (time f2 - time f1)\n\n f :: Fractional a => (Double -> a -> a) -> a -> a -> a\n f = interpolationFunction method t'\n\n cam1 = camera f1\n cam2 = camera f2\n in CF.Camera { CF.fov = f (*) (CF.fov cam1) (CF.fov cam2)\n , CF.position = f (*^) (CF.position cam1) (CF.position cam2)\n , CF.lookAt = f (*^) (CF.lookAt cam1) (CF.lookAt cam2)\n , CF.upVec = f (*^) (CF.upVec cam1) (CF.upVec cam2) }\n\ninterpolationFunction :: Fractional a => InterpolationMethod -> Double\n -> (Double -> a -> a)\n -> a -> a -> a\n{-# INLINE interpolationFunction #-}\ninterpolationFunction method t times a b = case method of\n Linear -> a + t `times` (b - a)\n" }, { "path": "src/ConfigFile.hs", "content": "{-# LANGUAGE OverloadedStrings, FlexibleInstances, DeriveGeneric #-}\n{-# OPTIONS_GHC -fno-warn-orphans #-}\n\nmodule ConfigFile\n ( Scene( Scene, safeDistance, stepSize, bloomStrength, bloomDivider\n , starIntensity, starSaturation, supersampling\n , diskColor, diskOpacity, diskInner, diskOuter, resolution )\n , Camera( Camera, position, lookAt, upVec, fov )\n , Config( Config, camera, scene ) ) where\n\nimport Data.Aeson.Types\nimport Linear\nimport GHC.Generics\nimport Graphics.ColorSpace\n\ndata Config = Config { scene :: Scene\n , camera :: Camera }\n deriving (Generic)\n\ndata Scene = Scene { safeDistance :: !Double\n , stepSize :: !Double\n , bloomStrength :: !Double\n , bloomDivider :: !Int\n , starIntensity :: !Double\n , starSaturation :: !Double\n , diskColor :: !(Pixel HSI Double)\n , diskOpacity :: !Double\n , diskInner :: !Double\n , diskOuter :: !Double\n , resolution :: !(Int, Int)\n , supersampling :: !Bool }\n deriving (Generic)\n\ndata Camera = Camera { position :: !(V3 Double)\n , lookAt :: !(V3 Double)\n , upVec :: !(V3 Double)\n , fov :: !Double }\n deriving (Generic)\n\ninstance FromJSON (V3 Double) where\n parseJSON vec = do\n [x, y, z] <- parseJSON vec\n return $ V3 x y z\n\ninstance ToJSON (V3 Double) where\n toJSON (V3 x y z) = toJSON [x, y, z]\n\ninstance FromJSON (Pixel HSI Double) where\n parseJSON hsi = do\n [x, y, z] <- parseJSON hsi\n return $ PixelHSI (x / 360) y z\n\ninstance ToJSON (Pixel HSI Double) where\n toJSON (PixelHSI h s i) = toJSON [360 * h, s, i]\n\ninstance FromJSON Config\n\ninstance ToJSON Config where\n toEncoding = genericToEncoding defaultOptions\n\ninstance FromJSON Camera\n\ninstance ToJSON Camera where\n toEncoding = genericToEncoding defaultOptions\n\ninstance FromJSON Scene where\n parseJSON (Object v) = Scene 0 <$>\n v .:? \"stepSize\" .!= 0.3 <*>\n v .:? \"bloomStrength\" .!= 0.4 <*>\n v .:? \"bloomDivider\" .!= 25 <*>\n v .:? \"starIntensity\" .!= 0.7 <*>\n v .:? \"starSaturation\" .!= 0.7 <*>\n v .:? \"diskColor\"\n .!= PixelHSI 0.16 0.1 0.95 <*>\n v .:? \"diskOpacity\" .!= 0 <*>\n v .:? \"diskInner\" .!= 3 <*>\n v .:? \"diskOuter\" .!= 12 <*>\n v .:? \"resolution\" .!= (1280, 720) <*>\n v .:? \"supersampling\" .!= False\n\n parseJSON invalid = typeMismatch \"Object\" invalid\n\ninstance ToJSON Scene where\n toEncoding = genericToEncoding defaultOptions\n" }, { "path": "src/ImageFilters.hs", "content": "{-# LANGUAGE BangPatterns #-}\n{-# LANGUAGE StrictData #-}\n{-# LANGUAGE Strict #-}\n\nmodule ImageFilters (bloom, supersample) where\n\nimport qualified Data.Vector.Unboxed as U\nimport qualified Data.Vector.Unboxed.Mutable as MU\nimport Data.Massiv.Array\nimport Data.Massiv.Array.Manifest.Vector\nimport Data.Massiv.Array.Unsafe\nimport Data.Massiv.Array.IO\nimport Control.Monad (replicateM_)\nimport Control.Applicative (liftA2)\nimport Graphics.ColorSpace\n\nix1d :: Int -> Int -> Int -> Int\n{-# INLINE ix1d #-}\nix1d !w !y !x = y*w + x\n\nadd :: Pixel RGB Double -> Pixel RGB Double -> Pixel RGB Double\nadd = liftA2 (+)\nsub :: Pixel RGB Double -> Pixel RGB Double -> Pixel RGB Double\nsub = liftA2 (-)\nmul :: Double -> Pixel RGB Double -> Pixel RGB Double\nmul a = fmap (a *)\n\nboxBlur :: Int -> Int -> Image U RGB Double -> IO (Image U RGB Double)\nboxBlur !r !passes img = let\n myDims@(h :. w) = size img\n rows' = U.enumFromN (0 :: Int) h\n cols' = U.enumFromN (0 :: Int) w\n\n -- Functions to safely index a vector representing an image with specialized\n -- horizontal / vertical bound checks. Out of bounds indices return a black\n -- pixel.\n {-# INLINE ixh #-}\n {-# INLINE ixv #-}\n {-# INLINE ix1d' #-}\n ix1d' = ix1d w\n ixh v y x\n | x < 0 || x >= w = PixelRGB 0 0 0\n | otherwise = U.unsafeIndex v $ ix1d' y x\n ixv v x y\n | y < 0 || y >= h = PixelRGB 0 0 0\n | otherwise = U.unsafeIndex v $ ix1d' y x\n\n -- Normalize by the \"width\" of the kernel\n normFactor :: Double\n {-# INLINE normFactor #-}\n normFactor = 1 / (2*fromIntegral r + 1)\n\n {-# INLINE blur #-}\n blur writeToVec crds ix1df readf vecIn y = let\n {-# INLINE pix #-}\n -- A function to yield a pixel from the image vector\n pix = readf vecIn y\n -- Starting value\n startVal = U.foldl1' add . U.map pix . U.unsafeTake r $ crds\n {-# INLINE accumulate #-}\n accumulate !rgb x = do\n let newRGB = (rgb `add` pix (x+r)) `sub` pix (x-r)\n _ <- writeToVec (ix1df y x) $ mul normFactor newRGB\n return newRGB\n -- Sweep over the row / col of the image\n in U.foldM'_ accumulate startVal crds\n in do\n mv <- U.thaw $ toVector img\n let wrt = MU.unsafeWrite mv\n replicateM_ passes $ do\n -- First blur horizontally\n tmp1 <- U.freeze mv\n U.mapM_ (blur wrt cols' ix1d' ixh tmp1) rows'\n -- Then vertically\n tmp2 <- U.freeze mv\n U.mapM_ (blur wrt rows' (flip ix1d') ixv tmp2) cols'\n out <- U.unsafeFreeze mv\n return $ fromVector Par myDims out\n\nbloom :: Double -> Int -> Image U RGB Double -> IO (Image U RGB Double)\nbloom strength divider img = do\n let myDims@(_ :. w) = size img\n blurred <- boxBlur (w `div` divider) 3 img\n return . makeArrayR U Par myDims\n $ \\ix -> img `unsafeIndex` ix `add`\n mul strength (blurred `unsafeIndex` ix)\n\nsupersample :: Image U RGB Double -> Image U RGB Double\nsupersample img = let\n h :. w = size img\n {-# INLINE pix #-}\n pix y x = img `unsafeIndex` (y :. x)\n {-# INLINE f #-}\n f (y :. x) = mul 0.25\n $ pix (2*y) (2*x) `add` pix (2*y+1) (2*x) `add` pix (2*y) (2*x+1)\n `add` pix (2*y+1) (2*x+1)\n in makeArrayR U Par (Sz ((h `div` 2) :. (w `div` 2))) f\n" }, { "path": "src/Raytracer.hs", "content": "{-# LANGUAGE StrictData #-}\n{-# LANGUAGE Strict #-}\n\nmodule Raytracer (render, writeImg) where\n\nimport Linear hiding (lookAt, mult, trace)\nimport qualified Linear as L\nimport Control.Applicative\nimport Control.Lens\nimport Data.Default\nimport Data.Massiv.Array as A\nimport Data.Massiv.Array.IO\nimport Graphics.ColorSpace\nimport Prelude as P\n\nimport StarMap\nimport ConfigFile\nimport ImageFilters\n\ndata Layer = Layer (Pixel RGBA Double) | Bottom (Pixel RGBA Double) | None\ndata PhotonState = PhotonState (V3 Double) (V3 Double)\n\nsRGB :: Double -> Double\nsRGB x = let\n a = 0.055\n in if x < 0.0031308 then 12.92 * x\n else (1 + a) * x ** (1.0 / 2.4) - a\n\nwriteImg :: Image U RGB Double -> FilePath -> IO ()\nwriteImg img path =\n writeArray PNG def path\n . A.map (toWord8 . fmap sRGB) $ img\n\nblend :: Pixel RGBA Double -> Pixel RGBA Double -> Pixel RGBA Double\nblend src@(PixelRGBA _ _ _ ta) = let\n comp tc bc = tc + bc * (1 - ta)\n in liftA2 comp src\n\n-- Generate the sight rays ie. initial conditions for the integration\ngenerateRay :: Config -> Ix2 -> PhotonState\ngenerateRay cfg (y' :. x') = PhotonState vel pos\n where cam = camera cfg\n pos = position cam\n scn = scene cfg\n w = fromIntegral . fst $ resolution scn\n h = fromIntegral . snd $ resolution scn\n matr = L.lookAt pos (lookAt cam) (upVec cam) ^. _m33\n vel = L.normalize . (L.transpose matr !*)\n $ V3 (fov cam * (fromIntegral x' / w - 0.5))\n (fov cam * (0.5 - fromIntegral y' / h) * h/w)\n (-1)\n\nrender :: Config -> StarTree -> Image U RGB Double\nrender cfg startree = let\n scn = scene cfg\n cam = camera cfg\n (w, h) = resolution scn\n res@(w', h') = if supersampling scn then (2*w, 2*h) else (w, h)\n scn' = scn { safeDistance =\n max (50^(2 :: Int)) (2 * quadrance (position cam))\n , diskInner = diskInner scn ^ (2 :: Int)\n , diskOuter = diskOuter scn ^ (2 :: Int)\n , resolution = res }\n cfg' = cfg { scene = scn' }\n diskRGB = toPixelRGB $ diskColor scn\n img = makeArrayR U Par (h' :. w') $ traceRay cfg' diskRGB startree :: Image U RGB Double\n in if supersampling scn then supersample img else img\n\ntraceRay :: Config -> Pixel RGB Double -> StarTree -> Ix2\n -> Pixel RGB Double\ntraceRay cfg diskRGB startree pt = let\n ray@(PhotonState vel pos) = generateRay cfg pt\n h2 = quadrance $ pos `cross` vel\n scn = scene cfg\n in dropAlpha . colorize scn diskRGB startree h2 $ ray\n\ncolorize :: Scene -> Pixel RGB Double -> StarTree -> Double -> PhotonState\n -> Pixel RGBA Double\ncolorize scn diskRGB startree h2 crd = let\n colorize' rgba crd' = let\n newCrd = rk4 (stepSize scn) h2 crd'\n in case findColor scn diskRGB startree crd' newCrd of\n Layer rgba' -> colorize' (blend rgba rgba') newCrd\n Bottom rgba' -> blend rgba rgba'\n None -> colorize' rgba newCrd\n in colorize' (PixelRGBA 0 0 0 0) crd\n\nfindColor :: Scene -> Pixel RGB Double -> StarTree -> PhotonState -> PhotonState\n -> Layer\n{-# INLINE findColor #-}\nfindColor scn diskRGB startree (PhotonState vel pos@(V3 _ y _))\n (PhotonState _ newPos@(V3 _ y' _))\n | r2 < 1 = Bottom (PixelRGBA 0 0 0 1) -- already passed the event horizon\n | r2 > safeDistance scn = Bottom . addAlpha 1.0\n $ starLookup startree (starIntensity scn) (starSaturation scn) vel\n | diskOpacity scn /= 0 && signum y' /= signum y\n && r2ave > diskInner scn && r2ave < diskOuter scn\n = Layer $ diskColor' scn diskRGB (sqrt r2ave)\n | otherwise = None\n where r2 = quadrance pos\n r2' = quadrance newPos\n r2ave = (y'*r2 - y*r2') / (y' - y)\n\ndiskColor' :: Scene -> Pixel RGB Double -> Double -> Pixel RGBA Double\n{-# INLINE diskColor' #-}\ndiskColor' scn diskRGB r = let\n rInner = sqrt (diskInner scn)\n rOuter = sqrt (diskOuter scn)\n intensity = sin (pi * ((rOuter - r) / (rOuter - rInner)) ^ (2 :: Int))\n rgb = fmap (* intensity) diskRGB\n in addAlpha (intensity * diskOpacity scn) rgb\n\nrk4 :: Double -> Double -> PhotonState -> PhotonState\n{-# INLINE rk4 #-}\nrk4 h h2 y = let\n mul :: Double -> PhotonState -> PhotonState\n {-# INLINE mul #-}\n mul a (PhotonState u v) = PhotonState (u ^* a) (v ^* a)\n\n add :: PhotonState -> PhotonState -> PhotonState\n {-# INLINE add #-}\n add (PhotonState x z) (PhotonState u v) = PhotonState (x ^+^ u) (z ^+^ v)\n\n f :: PhotonState -> PhotonState\n {-# INLINE f #-}\n f (PhotonState vel pos) =\n PhotonState (-1.5*h2 / (norm pos ^ (5 :: Int)) *^ pos) vel\n\n k1 = f y \n k2 = f $ y `add` mul (h / 2) k1\n k3 = f $ y `add` mul (h / 2) k2\n k4 = f $ y `add` mul h k3\n sumK = k1 `add` mul 2 k2 `add` mul 2 k3 `add` k4\n in y `add` mul (h / 6) sumK\n" }, { "path": "src/StarMap.hs", "content": "{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}\n{-# LANGUAGE StrictData #-}\n{-# LANGUAGE Strict #-}\n\n{-# OPTIONS_GHC -fno-warn-orphans #-}\n\nmodule StarMap\n ( Star, StarTree, StoredStarTree\n , readMapFromFile, treeToByteString, readTreeFromFile\n , buildStarTree, starLookup ) where\n\nimport Control.Monad\nimport Control.Applicative (liftA2)\nimport Data.Word\nimport Data.Char\nimport Data.Foldable\nimport qualified Data.ByteString as B\nimport Data.Serialize as S\nimport Data.KdMap.Static\nimport Linear as L\nimport Graphics.ColorSpace\n\nimport Util\n\ntype Star = (V3 Double, (Int, Double, Double))\ntype StarTree = KdMap Double (V3 Double) (Int, Double, Double)\ntype StoredStar = (V3 Double, (Int, Char))\ntype StoredStarTree = KdMap Double (V3 Double) (Int, Char)\n\ninstance Serialize StoredStarTree\ninstance Serialize (TreeNode Double (V3 Double) (Int, Char))\n\n-- We can't serialize functions but let's hack around it so that we can\n-- serialize the KdMap anyway\ninstance Serialize (SquaredDistanceFn Double (V3 Double)) where\n put _ = put (0 :: Word8)\n get = skip 1 >> return (defaultSqrDist toList)\n\ninstance Serialize (PointAsListFn Double (V3 Double)) where\n put _ = put (0 :: Word8)\n get = skip 1 >> return toList\n\n-- Parse the star list in the binary format specified at\n-- http://tdc-www.harvard.edu/software/catalogs/ppm.entry.html\nreadMap :: Get [StoredStar]\nreadMap = do\n -- Skip the header\n skip 28\n nBytes <- remaining\n replicateM (nBytes `div` 28) $ do\n ra <- getFloat64be\n dec <- getFloat64be\n spectral <- getWord8\n skip 1\n mag <- getInt16be\n skip 8\n return ( raDecToCartesian ra dec\n , (fromIntegral mag, chr $ fromIntegral spectral) )\n\nstarColor' :: (Int, Char) -> (Int, Double, Double)\nstarColor' (mag, ch) = let (h, s) = starColor ch in (mag, h, s)\n\n-- Some nice colour values for different spectral types\nstarColor :: Char -> (Double, Double)\nstarColor 'O' = (0.631, 0.39)\nstarColor 'B' = (0.628, 0.33)\nstarColor 'A' = (0.622, 0.21)\nstarColor 'F' = (0.650, 0.03)\nstarColor 'G' = (0.089, 0.09)\nstarColor 'K' = (0.094, 0.29)\nstarColor 'M' = (0.094, 0.56)\nstarColor _ = (0, 0)\n\nraDecToCartesian :: Double -> Double -> V3 Double\nraDecToCartesian ra dec = V3 (cos dec*cos ra) (cos dec*sin ra) (sin dec)\n\nreadMapFromFile :: FilePath -> IO (Either String [StoredStar])\nreadMapFromFile path = do\n ebs <- readSafe path\n return $ ebs >>= runGet readMap\n\nreadTreeFromFile :: FilePath -> IO (Either String StarTree)\nreadTreeFromFile path = do\n ebs <- readSafe path\n return $ fmap starColor' <$> (S.decode =<< ebs)\n\ntreeToByteString :: StoredStarTree -> B.ByteString\ntreeToByteString = S.encode\n\nbuildStarTree :: [StoredStar] -> StoredStarTree\nbuildStarTree = build toList\n\nstarLookup :: StarTree -> Double -> Double -> V3 Double -> Pixel RGB Double\n{-# INLINE starLookup #-}\nstarLookup starmap intensity saturation vel = let\n -- The magnitude value tells about the intensity of the star. The\n -- brighter the star, the smaller the magnitude. These constants are\n -- used for adjusting the dynamics of the rendered celestial sphere.\n max_brightness = 950 -- the \"maximum brightness\" magnitude\n dynamic = 50 -- \"dynamic range\": magnitude change that doubles intensity\n w = 0.0005 -- width parameter of the gaussian function\n\n nvel = L.normalize vel\n stars = inRadius starmap (3 * w) nvel\n\n renderPixel (pos, (mag, hue, sat)) = let\n d2 = qd pos nvel\n a = log 2 / dynamic\n -- Conversion from the log magnitude scale to linear brightness\n -- and a Gaussian intensity function. This determines the apparent size\n -- and brightness of the star.\n val = (* intensity) . min 1\n . exp $ a * (max_brightness - fromIntegral mag) - d2 / (2 * w^(2 :: Int))\n in toPixelRGB $ PixelHSI hue (saturation * sat) val\n in fmap (min 1) . foldl' (liftA2 (+)) (PixelRGB 0 0 0) $ renderPixel <$> stars\n" }, { "path": "src/Util.hs", "content": "module Util ( promptOverwriteFile, readSafe, normalizePath\n , timeAction, padZero ) where\n\nimport System.Directory\nimport System.IO\nimport qualified Data.ByteString as B\nimport Data.Time.Clock.POSIX (getPOSIXTime)\nimport System.FilePath\nimport Control.DeepSeq\n\nreadSafe :: FilePath -> IO (Either String B.ByteString)\nreadSafe path = do\n exists <- doesFileExist path\n if exists then Right <$> B.readFile path\n else return . Left $ \"Error: file \" ++ path\n ++ \" doesn't exist.\\n\"\n\npromptOverwriteFile :: FilePath -> (FilePath -> IO ()) -> IO ()\npromptOverwriteFile path doWrite = do\n doesExist <- doesFileExist path\n if doesExist then do\n putStr $ \"Overwrite \" ++ path ++ \"? [y/N] \"\n hFlush stdout\n answer <- getLine\n if answer == \"y\" || answer == \"Y\" then doWrite path\n else putStrLn \"Nothing was written.\"\n else doWrite path\n\nnormalizePath :: FilePath -> IO FilePath\nnormalizePath path = (dropTrailingPathSeparator . normalise)\n <$> makeRelativeToCurrentDirectory path\n\ntimeAction :: NFData a => String -> a -> IO a\ntimeAction actionName value = do\n time1 <- (round <$> getPOSIXTime) :: IO Int\n let res = value\n time2 <- round <$> (res `deepseq` getPOSIXTime)\n let secs = time2 - time1\n putStrLn $ actionName ++ \" completed in \" ++ show (secs `div` 60)\n ++ \" min \" ++ show (secs `rem` 60) ++ \" sec.\"\n return res\n\npadZero :: Int -> Int -> String\npadZero maxVal val = let\n nDigits x = (floor . logBase 10 $ (fromIntegral x :: Double)) + 1\n nZeros = nDigits maxVal - nDigits val\n zeros = replicate nZeros '0'\n in zeros ++ show val\n" }, { "path": "stack.yaml", "content": "resolver: lts-13.16\nflags: {}\nextra-package-dbs: []\npackages:\n- '.'\n" } ]