├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── animations └── default-ani.yaml ├── app ├── Animate.hs ├── GenerateTree.hs └── Main.hs ├── blackstar.cabal ├── example.png ├── scenes ├── closeup.yaml ├── default-aa.yaml ├── default.yaml ├── fartheraway.yaml ├── lensing-disk.yaml ├── lensing.yaml ├── wideangle-disk.yaml ├── wideangle.yaml └── wideangle1.yaml ├── scripts └── ffmpeg-animate ├── src ├── Animation.hs ├── ConfigFile.hs ├── ImageFilters.hs ├── Raytracer.hs ├── StarMap.hs └── Util.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | blackstar.prof 3 | out.png 4 | texture.jpg 5 | BSC5 6 | SAO.pc 7 | PPM 8 | PPMra 9 | renders 10 | bloomed.png 11 | output 12 | *.png 13 | !example.png 14 | frames* 15 | *.mkv 16 | dist* 17 | .ghc.* 18 | 19 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Sakari Kapanen (c) 2016 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 Author name here 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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Blackstar 2 | A 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. 3 | 4 | ![An example image](https://raw.githubusercontent.com/flannelhead/blackstar/master/example.png) 5 | 6 | ## Features 7 | * Fast, parallel ray tracing 8 | * Rendering [Schwarzschild](https://en.wikipedia.org/wiki/Schwarzschild_metric) black holes 9 | * Rendering accretion disks 10 | * Drawing the celestial sphere using a star catalogue 11 | * Bloom effect 12 | * Antialiasing by 4x supersampling for smoother images 13 | * Easy, YAML based configuration 14 | * A simple CLI 15 | * Batch mode and sequence generator for creating animations 16 | 17 | ## What about the name? 18 | It is a tribute to David Bowie, referring to his last album. 19 | 20 | ## Building 21 | Use [`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`. 22 | 23 | You 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`. 24 | 25 | ### Speeding it up with LLVM 26 | When 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. 27 | 28 | The 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. 29 | 30 | To successfully build with LLVM, you need to: 31 | 32 | * 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. 33 | * 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.) 34 | * Wait patiently 35 | * Enjoy the result! 36 | 37 | You 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. 38 | 39 | ## Usage 40 | When `blackstar` has been built with `stack`, you can run it with 41 | ``` 42 | stack exec blackstar -- [-p|--preview] [-f|--force] [-o|--output=PATH] [-s|--starmap=PATH] SCENENAME 43 | ``` 44 | Notice the two dashes (`--`) which are required to terminate `stack`'s argument list. 45 | 46 | 47 | `cabal` users can run `blackstar` by executing 48 | ``` 49 | cabal run -- [OPTIONS] SCENENAME 50 | ``` 51 | in the root folder of the project. 52 | 53 | Scenes are defined using YAML config files. Look in the `scenes` folder for examples. To render the `default` scene to the directory `output`, run 54 | ``` 55 | stack exec blackstar -- scenes/default.yaml --output output 56 | ``` 57 | in 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. 58 | 59 | The 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. 60 | 61 | If 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. 62 | 63 | There's also a help text which can be seen by running 64 | ``` 65 | stack exec blackstar -- --help 66 | OR 67 | cabal run -- --help 68 | ``` 69 | 70 | Better 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. 71 | 72 | ## Animation 73 | There is a separate YAML config format for specifying animations. For example, see [default-ani.yaml](animations/default-ani.yaml). 74 | 75 | In 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. 76 | ``` 77 | mkdir frames 78 | ``` 79 | Then run `animate`: 80 | ``` 81 | stack exec animate -- animations/default-ani.yaml -o frames 82 | ``` 83 | Now you should find quite a bunch of `.yaml` files in the folder `frames`. 84 | 85 | Make another folder for the output frames: 86 | ``` 87 | mkdir frames-out 88 | ``` 89 | Now you will be able to run `blackstar` in batch mode to render the frames: 90 | ``` 91 | stack exec blackstar -- frames -o frames-out 92 | ``` 93 | This will take quite a while. 94 | 95 | After 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: 96 | ``` 97 | scripts/ffmpeg-animate frames-out/default-ani 98 | ``` 99 | The output video will be rendered to `out.mkv`. 100 | 101 | ## Profiling 102 | Thanks to `stack`, profiling is incredibly easy. Rebuild `blackstar` by running 103 | ``` 104 | stack build --profile 105 | ``` 106 | and then run it with 107 | ``` 108 | stack exec blackstar -- scenes/default.yaml -o output +RTS -p 109 | ``` 110 | The profile will be generated to `blackstar.prof`. 111 | 112 | ## TODO 113 | As always, there's a plenty of room for improvement. For example: 114 | 115 | * Animation: mathematically rigorous non-stationary observer 116 | * Arbitrary textures for accretion disk (or some cool noise generator) 117 | * Redshifting of the accretion disk 118 | * Preview / scene planner GUI ([fltkhs](https://hackage.haskell.org/package/fltkhs)) 119 | 120 | Pull requests are welcome! If you find some cool scenes, I'd appreciate if you contributed them to this repository. 121 | 122 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /animations/default-ani.yaml: -------------------------------------------------------------------------------- 1 | # Animation files are quite similar to scene files. The difference is that you 2 | # can define multiple camera instances which are then fixed to certain points 3 | # of time (normalized to [0, 1[). The frames in between are then generated by 4 | # interpolating between the keyframes using the interpolation method of choice. 5 | 6 | # Scene config is similar to the scene files 7 | scene: 8 | resolution: [1920, 1080] 9 | bloomStrength: 0.7 10 | starIntensity: 0.7 11 | starSaturation: 0.7 12 | diskHSV: [180, 0.1, 1.05] 13 | diskOpacity: 0.95 14 | diskInner: 1.8 15 | diskOuter: 13 16 | supersampling: true 17 | 18 | # The number of frames in the animation 19 | nFrames: 375 20 | # Interpolation method. Currently, 'linear' is the only option 21 | interpolation: 'linear' 22 | 23 | # Specify any number of keyframes you want 24 | keyframes: 25 | - time: 0 # The normalize time of the keyframe. 0 is the first frame, 1 is the last 26 | camera: # Camera config is similar to the scene files 27 | position: [3, 3, -20] 28 | lookAt: [-7, 5, 0] 29 | upVec: [-0.2, 1, 0] 30 | fov: 1.5 31 | - time: 1 32 | camera: 33 | position: [-15, 1, -20] 34 | lookAt: [13, -7, 0] 35 | upVec: [-0.2, 1, 0] 36 | fov: 2 37 | -------------------------------------------------------------------------------- /app/Animate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# OPTIONS_GHC -fno-cse #-} 3 | 4 | module Main where 5 | 6 | import Prelude hiding (writeFile) 7 | import System.Directory 8 | import System.FilePath 9 | import Data.Yaml (decodeFileEither, prettyPrintParseException, encode) 10 | import System.Console.CmdArgs 11 | import Control.Monad (forM_) 12 | import Data.ByteString.Lazy (fromStrict, writeFile) 13 | 14 | import Animation 15 | import Util 16 | 17 | data Animate = Animate { inFile :: FilePath 18 | , output :: FilePath 19 | , force :: Bool } 20 | deriving (Show, Data, Typeable) 21 | 22 | argparser :: Animate 23 | argparser = Animate { inFile = def 24 | &= argPos 0 25 | &= typ "INPUTFILE" 26 | , output = "" 27 | &= help "output directory" 28 | &= typ "PATH" 29 | , force = def 30 | &= help "overwrite images without asking" } 31 | &= summary "Animation helper for Blackstar" 32 | 33 | main :: IO () 34 | main = do 35 | cmdline <- cmdArgs argparser 36 | 37 | let inPath = inFile cmdline 38 | let basename = takeBaseName inPath 39 | inputExists <- doesFileExist inPath 40 | 41 | outPath <- normalizePath =<< case output cmdline of 42 | "" -> getCurrentDirectory 43 | x -> return x 44 | createDirectoryIfMissing True outPath 45 | 46 | if inputExists then do 47 | config <- decodeFileEither inPath 48 | case config of 49 | Right cfg -> 50 | case validateKeyframes $ keyframes cfg of 51 | Right () -> do 52 | let nFr = nFrames cfg 53 | forM_ (zip (generateFrames cfg) [(0 :: Int), 1 ..]) 54 | (\(frame, idx) -> do 55 | let filename = outPath basename ++ "_" ++ 56 | padZero (nFr - 1) idx <.> ".yaml" 57 | let outBl = fromStrict $ encode frame 58 | if force cmdline 59 | then writeFile filename outBl 60 | else promptOverwriteFile filename 61 | (\fname -> writeFile fname outBl) 62 | ) 63 | Left err -> putStrLn err 64 | Left err -> putStrLn $ "Error when decoding config:\n" ++ 65 | prettyPrintParseException err 66 | else putStrLn "Couldn't open input file." 67 | -------------------------------------------------------------------------------- /app/GenerateTree.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Data.ByteString.Lazy as B 4 | import System.Environment (getArgs) 5 | 6 | import Util 7 | import StarMap 8 | 9 | -- Generate and store the k-d star tree from a star catalog 10 | 11 | main :: IO () 12 | main = do 13 | args <- getArgs 14 | case args of 15 | [infile, outfile] -> do 16 | outfile' <- normalizePath outfile 17 | infile' <- normalizePath infile 18 | eitherMap <- readMapFromFile infile' 19 | case eitherMap of 20 | Right stars -> do 21 | putStrLn "Generating the star tree..." 22 | tree <- timeAction "Building the tree" 23 | $ buildStarTree stars 24 | let treeBl = B.fromStrict $ treeToByteString tree 25 | promptOverwriteFile outfile' 26 | (\filename -> B.writeFile filename treeBl) 27 | putStrLn $ "Tree saved to " ++ outfile' ++ "." 28 | Left err -> putStrLn err 29 | _ -> putStrLn "Usage: generate-tree " 30 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# OPTIONS_GHC -fno-cse #-} 3 | 4 | module Main where 5 | 6 | import System.Directory 7 | import Control.Monad (when, forM_) 8 | import Data.Yaml (decodeFileEither, prettyPrintParseException) 9 | import System.Console.CmdArgs 10 | import System.FilePath (takeBaseName, takeExtension, (), (<.>)) 11 | import Data.List (sort) 12 | import System.Console.ANSI (clearScreen, setCursorPosition) 13 | 14 | import Raytracer 15 | import StarMap 16 | import ConfigFile 17 | import ImageFilters 18 | import Util 19 | 20 | data Blackstar = Blackstar { preview :: Bool 21 | , output :: String 22 | , force :: Bool 23 | , starmap :: String 24 | , inputfile :: String } 25 | deriving (Show, Data, Typeable) 26 | 27 | argparser :: Blackstar 28 | argparser = Blackstar { preview = def 29 | &= help "preview render (small size)" 30 | , output = "" 31 | &= help "output directory" 32 | &= typ "PATH" 33 | , force = def 34 | &= help "overwrite images without asking" 35 | , starmap = "stars.kdt" 36 | &= help "path to starmap" 37 | &= typ "PATH" 38 | , inputfile = def 39 | &= argPos 0 40 | &= typ "INPUTFILE" 41 | } &= summary "Blackstar v0.1" 42 | 43 | main :: IO () 44 | main = do 45 | cmdline <- cmdArgs argparser 46 | etree <- readTreeFromFile $ starmap cmdline 47 | case etree of 48 | Right tree -> putStrLn "Starmap successfully read." 49 | >> doStart cmdline tree 50 | Left err -> putStrLn $ "Error decoding star tree: \n" ++ err 51 | 52 | doStart :: Blackstar -> StarTree -> IO () 53 | doStart cmdline tree = do 54 | -- Resolve the output directory 55 | when (output cmdline /= "") 56 | $ createDirectoryIfMissing True (output cmdline) 57 | outdir <- normalizePath =<< case output cmdline of 58 | "" -> getCurrentDirectory 59 | x -> return x 60 | createDirectoryIfMissing True outdir 61 | -- Resolve the input file or directory 62 | filename <- normalizePath $ inputfile cmdline 63 | isDir <- doesDirectoryExist filename 64 | if isDir then do 65 | putStrLn $ filename 66 | ++ " is a directory. Rendering all scenes inside it..." 67 | 68 | inputFiles <- map (filename ) 69 | . sort . filter (\f -> takeExtension f == ".yaml") 70 | <$> getDirectoryContents filename 71 | 72 | forM_ (zip inputFiles [(1 :: Int)..]) $ \(scn, idx) -> do 73 | clearScreen 74 | setCursorPosition 0 0 75 | putStrLn $ "Batch mode progress: " ++ show idx ++ "/" 76 | ++ show (length inputFiles) 77 | handleScene cmdline tree outdir scn 78 | else handleScene cmdline tree outdir filename 79 | 80 | handleScene :: Blackstar -> StarTree -> String -> String -> IO () 81 | handleScene cmdline tree outdir filename = do 82 | let pvw = preview cmdline 83 | let sceneName = takeBaseName filename 84 | putStrLn $ "Reading " ++ filename ++ "..." 85 | cfg <- decodeFileEither filename 86 | let sceneName' = if pvw then "prev-" ++ sceneName else sceneName 87 | case cfg of 88 | Right config -> putStrLn "Scene successfully read." 89 | >> doRender cmdline (prepareScene config pvw) tree 90 | sceneName' outdir 91 | Left err -> putStrLn $ prettyPrintParseException err 92 | 93 | prepareScene :: Config -> Bool -> Config 94 | prepareScene cfg doPreview = let 95 | scn = scene cfg 96 | (w, h) = resolution scn 97 | res = 300 98 | newRes = if w >= h then (res, res * h `div` w) else (res * w `div` h, res) 99 | newScn = if doPreview then scn { resolution = newRes 100 | , supersampling = False 101 | , bloomStrength = 0 } 102 | else scn 103 | in cfg { scene = newScn } 104 | 105 | doRender :: Blackstar -> Config -> StarTree -> String -> String -> IO () 106 | doRender cmdline cfg tree sceneName outdir = do 107 | putStrLn $ "Rendering " ++ sceneName ++ "..." 108 | let scn = scene cfg 109 | img <- timeAction "Rendering" $ render cfg tree 110 | 111 | let outName = outdir sceneName <.> ".png" 112 | 113 | final <- if bloomStrength scn /= 0 114 | then do 115 | putStrLn "Applying bloom..." 116 | bloomed <- bloom (bloomStrength scn) (bloomDivider scn) img 117 | timeAction "Bloom" bloomed 118 | else return img 119 | 120 | putStrLn $ "Saving to " ++ outName ++ "..." 121 | if force cmdline 122 | then writeImg final outName 123 | else promptOverwriteFile outName (writeImg final) 124 | 125 | putStrLn "Everything done. Thank you!" 126 | -------------------------------------------------------------------------------- /blackstar.cabal: -------------------------------------------------------------------------------- 1 | name: blackstar 2 | version: 0.1.0.0 3 | synopsis: A black hole ray tracer 4 | description: A black hole ray tracer written in Haskell 5 | homepage: http://github.com/flannelhead/blackstar#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Sakari Kapanen 9 | maintainer: sakari.m.kapanen@gmail.com 10 | copyright: 2019 Sakari Kapanen 11 | category: Graphics 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: Raytracer 19 | , StarMap 20 | , ConfigFile 21 | , ImageFilters 22 | , Util 23 | , Animation 24 | ghc-options: -Wall 25 | -O2 26 | build-depends: base >= 4.7 && < 5 27 | , data-default 28 | , linear 29 | , lens 30 | , bytestring 31 | , cereal 32 | , vector 33 | , kdt 34 | , yaml 35 | , aeson 36 | , directory 37 | , massiv 38 | , massiv-io 39 | , filepath 40 | , time 41 | , deepseq 42 | default-language: Haskell2010 43 | 44 | executable blackstar 45 | hs-source-dirs: app 46 | main-is: Main.hs 47 | ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N 48 | build-depends: base 49 | , blackstar 50 | , directory 51 | , yaml 52 | , bytestring 53 | , cmdargs 54 | , filepath 55 | , ansi-terminal 56 | default-language: Haskell2010 57 | 58 | executable animate 59 | hs-source-dirs: app 60 | main-is: Animate.hs 61 | ghc-options: -Wall 62 | build-depends: base 63 | , blackstar 64 | , directory 65 | , yaml 66 | , bytestring 67 | , cmdargs 68 | , filepath 69 | default-language: Haskell2010 70 | 71 | executable generate-tree 72 | hs-source-dirs: app 73 | main-is: GenerateTree.hs 74 | ghc-options: -Wall 75 | build-depends: base 76 | , blackstar 77 | , directory 78 | , bytestring 79 | default-language: Haskell2010 80 | 81 | source-repository head 82 | type: git 83 | location: https://github.com/flannelhead/blackstar 84 | -------------------------------------------------------------------------------- /example.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flannelhead/blackstar/40f1f1965292d2c191c9ff961fdd243d50c6f37c/example.png -------------------------------------------------------------------------------- /scenes/closeup.yaml: -------------------------------------------------------------------------------- 1 | camera: 2 | position: [10, 1, -2] 3 | lookAt: [0, 0, 6] 4 | upVec: [0, 1, 0] 5 | fov: 1.2 6 | 7 | scene: 8 | resolution: [1280, 960] 9 | bloomStrength: 0.7 10 | starIntensity: 0.7 11 | starSaturation: 0.7 12 | diskOpacity: 0.95 13 | diskInner: 3 14 | diskOuter: 9 15 | -------------------------------------------------------------------------------- /scenes/default-aa.yaml: -------------------------------------------------------------------------------- 1 | camera: 2 | position: [0, 1, -20] 3 | lookAt: [2, 0, 0] 4 | upVec: [-0.2, 1, 0] 5 | fov: 1.5 6 | 7 | scene: 8 | resolution: [1920, 1080] 9 | bloomStrength: 0.15 10 | starIntensity: 0.4 11 | starSaturation: 1.5 12 | diskColor: [180, 0.1, 1.05] 13 | diskOpacity: 0.95 14 | diskInner: 1.8 15 | diskOuter: 13 16 | supersampling: true 17 | -------------------------------------------------------------------------------- /scenes/default.yaml: -------------------------------------------------------------------------------- 1 | camera: 2 | # All the vectors are [x, y, z] coordinates 3 | position: [0, 1, -20] # The position of the camera 4 | lookAt: [2, 0, 0] # The point to look at 5 | upVec: [-0.2, 1, 0] # The "up" direction vector which determines the 6 | # orientation of the camera 7 | fov: 1.5 # The tangent of the view angle 8 | 9 | scene: 10 | resolution: [1920, 1080] # [width, height] of the image 11 | bloomStrength: 0.15 # The strength (weight) of the bloom effect. Setting this to 12 | # 0 disables it entirely 13 | bloomDivider: 25 # A number x such that r = image width / x is the bloom radius 14 | 15 | starIntensity: 0.4 # The intensity (0 = black, 1 = white) of the stars 16 | starSaturation: 1.5 # The color saturation of the stars 17 | 18 | diskOpacity: 0.95 # Opacity of the accretion disk (0 = fully transparent, 19 | # 1 = fully opaque) 20 | diskInner: 1.8 # The inner radius of the accretion disk 21 | diskOuter: 13 # The outer radius of the accretion disk 22 | diskColor: [180, 0.1, 1.05] # The colour of the accretion disk in the HSI color space. 23 | # H: 0..360, S: 0..1, I: 0..1 24 | 25 | supersampling: false # Set this to true to enable smoothing by supersampling 26 | # a 4x sized image 27 | stepSize: 0.3 # The size of the timestep in the simulation. Usually this value 28 | # should be fine. 29 | -------------------------------------------------------------------------------- /scenes/fartheraway.yaml: -------------------------------------------------------------------------------- 1 | camera: 2 | position: [-25, 1, -60] 3 | lookAt: [-12, -4, 0] 4 | upVec: [0.15, 1, 0] 5 | fov: 2 6 | 7 | scene: 8 | resolution: [1920, 1080] 9 | bloomStrength: 0.15 10 | starIntensity: 0.4 11 | starSaturation: 1.5 12 | diskOpacity: 0.95 13 | diskInner: 3 14 | diskOuter: 12 15 | supersampling: true 16 | -------------------------------------------------------------------------------- /scenes/lensing-disk.yaml: -------------------------------------------------------------------------------- 1 | camera: 2 | position: [30, 0.4, 3] 3 | lookAt: [0, 0, 0] 4 | upVec: [0, 1, 0.2] 5 | fov: 1 6 | 7 | scene: 8 | resolution: [1280, 800] 9 | bloomStrength: 0.15 10 | starIntensity: 0.4 11 | starSaturation: 1.5 12 | diskOpacity: 0.95 13 | diskInner: 3 14 | diskOuter: 12 15 | supersampling: true 16 | -------------------------------------------------------------------------------- /scenes/lensing.yaml: -------------------------------------------------------------------------------- 1 | camera: 2 | position: [30, 0.4, 3] 3 | lookAt: [0, 0, 0] 4 | upVec: [0, 1, 0.2] 5 | fov: 1 6 | 7 | scene: 8 | resolution: [1600, 1200] 9 | bloomStrength: 0.15 10 | starIntensity: 0.4 11 | starSaturation: 1.5 12 | diskOpacity: 0 13 | diskInner: 3 14 | diskOuter: 12 15 | supersampling: true 16 | -------------------------------------------------------------------------------- /scenes/wideangle-disk.yaml: -------------------------------------------------------------------------------- 1 | camera: 2 | position: [-6, 1, -20] 3 | lookAt: [-6, -4, 0] 4 | upVec: [-0.2, 1, 0] 5 | fov: 3.5 6 | 7 | scene: 8 | resolution: [1920, 1080] 9 | bloomStrength: 0.15 10 | starIntensity: 0.4 11 | starSaturation: 1.5 12 | diskOpacity: 0.95 13 | diskInner: 2.5 14 | diskOuter: 12 15 | supersampling: true 16 | -------------------------------------------------------------------------------- /scenes/wideangle.yaml: -------------------------------------------------------------------------------- 1 | camera: 2 | position: [20, 0, 0] 3 | lookAt: [0, 0, 3.5] 4 | upVec: [0, 1, 0] 5 | fov: 2 6 | 7 | scene: 8 | resolution: [1920, 1020] 9 | bloomStrength: 0.15 10 | starIntensity: 0.4 11 | starSaturation: 1.5 12 | diskOpacity: 0 13 | supersampling: true 14 | -------------------------------------------------------------------------------- /scenes/wideangle1.yaml: -------------------------------------------------------------------------------- 1 | camera: 2 | position: [0, 0, 20] 3 | lookAt: [3.5, 0, 0] 4 | upVec: [0, 1, 0] 5 | fov: 2 6 | 7 | scene: 8 | resolution: [1920, 1080] 9 | bloomStrength: 0.15 10 | starIntensity: 0.4 11 | starSaturation: 1.5 12 | diskOpacity: 0 13 | supersampling: true 14 | -------------------------------------------------------------------------------- /scripts/ffmpeg-animate: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Create YouTube quality video from stills using ffmpeg 4 | # 5 | # USAGE: 6 | # ffmpeg-animate PREFIX 7 | # 8 | # Writes to file "out.mkv" in the current directory 9 | 10 | ffmpeg -f image2 -i "${1}_%03d.png" \ 11 | -c:v libx264 -preset slow -crf 18 -pix_fmt yuv420p \ 12 | -r 25 out.mkv 13 | 14 | -------------------------------------------------------------------------------- /src/Animation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveGeneric #-} 2 | 3 | module Animation ( Keyframe(camera, time) 4 | , Animation(scene, nFrames, interpolation, keyframes) 5 | , InterpolationMethod(Linear) 6 | , generateFrames, validateKeyframes ) where 7 | 8 | import Data.List (sortBy) 9 | import Data.Ord (comparing) 10 | import qualified ConfigFile as CF 11 | import Data.Aeson.Types 12 | import Linear ((*^)) 13 | import GHC.Generics 14 | 15 | data Keyframe = Keyframe { camera :: CF.Camera 16 | , time :: Double } 17 | deriving (Generic) 18 | 19 | data InterpolationMethod = Linear 20 | 21 | data Animation = Animation { scene :: CF.Scene 22 | , nFrames :: Int 23 | , interpolation :: InterpolationMethod 24 | , keyframes :: [Keyframe] } 25 | deriving (Generic) 26 | 27 | instance FromJSON Keyframe 28 | 29 | instance FromJSON InterpolationMethod where 30 | parseJSON str = do 31 | (str' :: String) <- parseJSON str 32 | return $ case str' of 33 | "linear" -> Linear 34 | _ -> Linear 35 | 36 | instance FromJSON Animation 37 | 38 | validateKeyframes :: [Keyframe] -> Either String () 39 | validateKeyframes [] = Left "Must have at least two keyframes" 40 | validateKeyframes [_] = validateKeyframes [] 41 | validateKeyframes frs = if time (head frs) == 0 && time (last frs) == 1 42 | then Right () 43 | else Left "First keyframe must have time == 0, last time == 1" 44 | 45 | generateFrames :: Animation -> [CF.Config] 46 | generateFrames animation = let 47 | stepsize = (1 :: Double) / fromIntegral (nFrames animation - 1) 48 | -- Take the first keyframe from the scene in the config 49 | -- Also sort the frames by time 50 | frames = sortBy (comparing time) $ keyframes animation 51 | points = (* stepsize) . fromIntegral <$> [0 .. nFrames animation - 1] 52 | in map (makeFrame animation frames) points 53 | 54 | makeFrame :: Animation -> [Keyframe] -> Double -> CF.Config 55 | makeFrame animation frames point = let 56 | scn = scene animation 57 | mtd = interpolation animation 58 | in CF.Config { CF.camera = interpolate mtd frames point 59 | , CF.scene = scn } 60 | 61 | interpolate :: InterpolationMethod -> [Keyframe] -> Double -> CF.Camera 62 | interpolate method frames t = let 63 | findFrames (fr1 : fr2 : frs) = if t >= time fr1 && t < time fr2 64 | then (fr1, fr2) 65 | else findFrames (fr2 : frs) 66 | findFrames [fr] = (fr, fr { time = time fr + 1 } ) 67 | 68 | (f1, f2) = findFrames frames 69 | t' = (t - time f1) / (time f2 - time f1) 70 | 71 | f :: Fractional a => (Double -> a -> a) -> a -> a -> a 72 | f = interpolationFunction method t' 73 | 74 | cam1 = camera f1 75 | cam2 = camera f2 76 | in CF.Camera { CF.fov = f (*) (CF.fov cam1) (CF.fov cam2) 77 | , CF.position = f (*^) (CF.position cam1) (CF.position cam2) 78 | , CF.lookAt = f (*^) (CF.lookAt cam1) (CF.lookAt cam2) 79 | , CF.upVec = f (*^) (CF.upVec cam1) (CF.upVec cam2) } 80 | 81 | interpolationFunction :: Fractional a => InterpolationMethod -> Double 82 | -> (Double -> a -> a) 83 | -> a -> a -> a 84 | {-# INLINE interpolationFunction #-} 85 | interpolationFunction method t times a b = case method of 86 | Linear -> a + t `times` (b - a) 87 | -------------------------------------------------------------------------------- /src/ConfigFile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, FlexibleInstances, DeriveGeneric #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | module ConfigFile 5 | ( Scene( Scene, safeDistance, stepSize, bloomStrength, bloomDivider 6 | , starIntensity, starSaturation, supersampling 7 | , diskColor, diskOpacity, diskInner, diskOuter, resolution ) 8 | , Camera( Camera, position, lookAt, upVec, fov ) 9 | , Config( Config, camera, scene ) ) where 10 | 11 | import Data.Aeson.Types 12 | import Linear 13 | import GHC.Generics 14 | import Graphics.ColorSpace 15 | 16 | data Config = Config { scene :: Scene 17 | , camera :: Camera } 18 | deriving (Generic) 19 | 20 | data Scene = Scene { safeDistance :: !Double 21 | , stepSize :: !Double 22 | , bloomStrength :: !Double 23 | , bloomDivider :: !Int 24 | , starIntensity :: !Double 25 | , starSaturation :: !Double 26 | , diskColor :: !(Pixel HSI Double) 27 | , diskOpacity :: !Double 28 | , diskInner :: !Double 29 | , diskOuter :: !Double 30 | , resolution :: !(Int, Int) 31 | , supersampling :: !Bool } 32 | deriving (Generic) 33 | 34 | data Camera = Camera { position :: !(V3 Double) 35 | , lookAt :: !(V3 Double) 36 | , upVec :: !(V3 Double) 37 | , fov :: !Double } 38 | deriving (Generic) 39 | 40 | instance FromJSON (V3 Double) where 41 | parseJSON vec = do 42 | [x, y, z] <- parseJSON vec 43 | return $ V3 x y z 44 | 45 | instance ToJSON (V3 Double) where 46 | toJSON (V3 x y z) = toJSON [x, y, z] 47 | 48 | instance FromJSON (Pixel HSI Double) where 49 | parseJSON hsi = do 50 | [x, y, z] <- parseJSON hsi 51 | return $ PixelHSI (x / 360) y z 52 | 53 | instance ToJSON (Pixel HSI Double) where 54 | toJSON (PixelHSI h s i) = toJSON [360 * h, s, i] 55 | 56 | instance FromJSON Config 57 | 58 | instance ToJSON Config where 59 | toEncoding = genericToEncoding defaultOptions 60 | 61 | instance FromJSON Camera 62 | 63 | instance ToJSON Camera where 64 | toEncoding = genericToEncoding defaultOptions 65 | 66 | instance FromJSON Scene where 67 | parseJSON (Object v) = Scene 0 <$> 68 | v .:? "stepSize" .!= 0.3 <*> 69 | v .:? "bloomStrength" .!= 0.4 <*> 70 | v .:? "bloomDivider" .!= 25 <*> 71 | v .:? "starIntensity" .!= 0.7 <*> 72 | v .:? "starSaturation" .!= 0.7 <*> 73 | v .:? "diskColor" 74 | .!= PixelHSI 0.16 0.1 0.95 <*> 75 | v .:? "diskOpacity" .!= 0 <*> 76 | v .:? "diskInner" .!= 3 <*> 77 | v .:? "diskOuter" .!= 12 <*> 78 | v .:? "resolution" .!= (1280, 720) <*> 79 | v .:? "supersampling" .!= False 80 | 81 | parseJSON invalid = typeMismatch "Object" invalid 82 | 83 | instance ToJSON Scene where 84 | toEncoding = genericToEncoding defaultOptions 85 | -------------------------------------------------------------------------------- /src/ImageFilters.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE StrictData #-} 3 | {-# LANGUAGE Strict #-} 4 | 5 | module ImageFilters (bloom, supersample) where 6 | 7 | import qualified Data.Vector.Unboxed as U 8 | import qualified Data.Vector.Unboxed.Mutable as MU 9 | import Data.Massiv.Array 10 | import Data.Massiv.Array.Manifest.Vector 11 | import Data.Massiv.Array.Unsafe 12 | import Data.Massiv.Array.IO 13 | import Control.Monad (replicateM_) 14 | import Control.Applicative (liftA2) 15 | import Graphics.ColorSpace 16 | 17 | ix1d :: Int -> Int -> Int -> Int 18 | {-# INLINE ix1d #-} 19 | ix1d !w !y !x = y*w + x 20 | 21 | add :: Pixel RGB Double -> Pixel RGB Double -> Pixel RGB Double 22 | add = liftA2 (+) 23 | sub :: Pixel RGB Double -> Pixel RGB Double -> Pixel RGB Double 24 | sub = liftA2 (-) 25 | mul :: Double -> Pixel RGB Double -> Pixel RGB Double 26 | mul a = fmap (a *) 27 | 28 | boxBlur :: Int -> Int -> Image U RGB Double -> IO (Image U RGB Double) 29 | boxBlur !r !passes img = let 30 | myDims@(h :. w) = size img 31 | rows' = U.enumFromN (0 :: Int) h 32 | cols' = U.enumFromN (0 :: Int) w 33 | 34 | -- Functions to safely index a vector representing an image with specialized 35 | -- horizontal / vertical bound checks. Out of bounds indices return a black 36 | -- pixel. 37 | {-# INLINE ixh #-} 38 | {-# INLINE ixv #-} 39 | {-# INLINE ix1d' #-} 40 | ix1d' = ix1d w 41 | ixh v y x 42 | | x < 0 || x >= w = PixelRGB 0 0 0 43 | | otherwise = U.unsafeIndex v $ ix1d' y x 44 | ixv v x y 45 | | y < 0 || y >= h = PixelRGB 0 0 0 46 | | otherwise = U.unsafeIndex v $ ix1d' y x 47 | 48 | -- Normalize by the "width" of the kernel 49 | normFactor :: Double 50 | {-# INLINE normFactor #-} 51 | normFactor = 1 / (2*fromIntegral r + 1) 52 | 53 | {-# INLINE blur #-} 54 | blur writeToVec crds ix1df readf vecIn y = let 55 | {-# INLINE pix #-} 56 | -- A function to yield a pixel from the image vector 57 | pix = readf vecIn y 58 | -- Starting value 59 | startVal = U.foldl1' add . U.map pix . U.unsafeTake r $ crds 60 | {-# INLINE accumulate #-} 61 | accumulate !rgb x = do 62 | let newRGB = (rgb `add` pix (x+r)) `sub` pix (x-r) 63 | _ <- writeToVec (ix1df y x) $ mul normFactor newRGB 64 | return newRGB 65 | -- Sweep over the row / col of the image 66 | in U.foldM'_ accumulate startVal crds 67 | in do 68 | mv <- U.thaw $ toVector img 69 | let wrt = MU.unsafeWrite mv 70 | replicateM_ passes $ do 71 | -- First blur horizontally 72 | tmp1 <- U.freeze mv 73 | U.mapM_ (blur wrt cols' ix1d' ixh tmp1) rows' 74 | -- Then vertically 75 | tmp2 <- U.freeze mv 76 | U.mapM_ (blur wrt rows' (flip ix1d') ixv tmp2) cols' 77 | out <- U.unsafeFreeze mv 78 | return $ fromVector Par myDims out 79 | 80 | bloom :: Double -> Int -> Image U RGB Double -> IO (Image U RGB Double) 81 | bloom strength divider img = do 82 | let myDims@(_ :. w) = size img 83 | blurred <- boxBlur (w `div` divider) 3 img 84 | return . makeArrayR U Par myDims 85 | $ \ix -> img `unsafeIndex` ix `add` 86 | mul strength (blurred `unsafeIndex` ix) 87 | 88 | supersample :: Image U RGB Double -> Image U RGB Double 89 | supersample img = let 90 | h :. w = size img 91 | {-# INLINE pix #-} 92 | pix y x = img `unsafeIndex` (y :. x) 93 | {-# INLINE f #-} 94 | f (y :. x) = mul 0.25 95 | $ pix (2*y) (2*x) `add` pix (2*y+1) (2*x) `add` pix (2*y) (2*x+1) 96 | `add` pix (2*y+1) (2*x+1) 97 | in makeArrayR U Par (Sz ((h `div` 2) :. (w `div` 2))) f 98 | -------------------------------------------------------------------------------- /src/Raytracer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StrictData #-} 2 | {-# LANGUAGE Strict #-} 3 | 4 | module Raytracer (render, writeImg) where 5 | 6 | import Linear hiding (lookAt, mult, trace) 7 | import qualified Linear as L 8 | import Control.Applicative 9 | import Control.Lens 10 | import Data.Default 11 | import Data.Massiv.Array as A 12 | import Data.Massiv.Array.IO 13 | import Graphics.ColorSpace 14 | import Prelude as P 15 | 16 | import StarMap 17 | import ConfigFile 18 | import ImageFilters 19 | 20 | data Layer = Layer (Pixel RGBA Double) | Bottom (Pixel RGBA Double) | None 21 | data PhotonState = PhotonState (V3 Double) (V3 Double) 22 | 23 | sRGB :: Double -> Double 24 | sRGB x = let 25 | a = 0.055 26 | in if x < 0.0031308 then 12.92 * x 27 | else (1 + a) * x ** (1.0 / 2.4) - a 28 | 29 | writeImg :: Image U RGB Double -> FilePath -> IO () 30 | writeImg img path = 31 | writeArray PNG def path 32 | . A.map (toWord8 . fmap sRGB) $ img 33 | 34 | blend :: Pixel RGBA Double -> Pixel RGBA Double -> Pixel RGBA Double 35 | blend src@(PixelRGBA _ _ _ ta) = let 36 | comp tc bc = tc + bc * (1 - ta) 37 | in liftA2 comp src 38 | 39 | -- Generate the sight rays ie. initial conditions for the integration 40 | generateRay :: Config -> Ix2 -> PhotonState 41 | generateRay cfg (y' :. x') = PhotonState vel pos 42 | where cam = camera cfg 43 | pos = position cam 44 | scn = scene cfg 45 | w = fromIntegral . fst $ resolution scn 46 | h = fromIntegral . snd $ resolution scn 47 | matr = L.lookAt pos (lookAt cam) (upVec cam) ^. _m33 48 | vel = L.normalize . (L.transpose matr !*) 49 | $ V3 (fov cam * (fromIntegral x' / w - 0.5)) 50 | (fov cam * (0.5 - fromIntegral y' / h) * h/w) 51 | (-1) 52 | 53 | render :: Config -> StarTree -> Image U RGB Double 54 | render cfg startree = let 55 | scn = scene cfg 56 | cam = camera cfg 57 | (w, h) = resolution scn 58 | res@(w', h') = if supersampling scn then (2*w, 2*h) else (w, h) 59 | scn' = scn { safeDistance = 60 | max (50^(2 :: Int)) (2 * quadrance (position cam)) 61 | , diskInner = diskInner scn ^ (2 :: Int) 62 | , diskOuter = diskOuter scn ^ (2 :: Int) 63 | , resolution = res } 64 | cfg' = cfg { scene = scn' } 65 | diskRGB = toPixelRGB $ diskColor scn 66 | img = makeArrayR U Par (h' :. w') $ traceRay cfg' diskRGB startree :: Image U RGB Double 67 | in if supersampling scn then supersample img else img 68 | 69 | traceRay :: Config -> Pixel RGB Double -> StarTree -> Ix2 70 | -> Pixel RGB Double 71 | traceRay cfg diskRGB startree pt = let 72 | ray@(PhotonState vel pos) = generateRay cfg pt 73 | h2 = quadrance $ pos `cross` vel 74 | scn = scene cfg 75 | in dropAlpha . colorize scn diskRGB startree h2 $ ray 76 | 77 | colorize :: Scene -> Pixel RGB Double -> StarTree -> Double -> PhotonState 78 | -> Pixel RGBA Double 79 | colorize scn diskRGB startree h2 crd = let 80 | colorize' rgba crd' = let 81 | newCrd = rk4 (stepSize scn) h2 crd' 82 | in case findColor scn diskRGB startree crd' newCrd of 83 | Layer rgba' -> colorize' (blend rgba rgba') newCrd 84 | Bottom rgba' -> blend rgba rgba' 85 | None -> colorize' rgba newCrd 86 | in colorize' (PixelRGBA 0 0 0 0) crd 87 | 88 | findColor :: Scene -> Pixel RGB Double -> StarTree -> PhotonState -> PhotonState 89 | -> Layer 90 | {-# INLINE findColor #-} 91 | findColor scn diskRGB startree (PhotonState vel pos@(V3 _ y _)) 92 | (PhotonState _ newPos@(V3 _ y' _)) 93 | | r2 < 1 = Bottom (PixelRGBA 0 0 0 1) -- already passed the event horizon 94 | | r2 > safeDistance scn = Bottom . addAlpha 1.0 95 | $ starLookup startree (starIntensity scn) (starSaturation scn) vel 96 | | diskOpacity scn /= 0 && signum y' /= signum y 97 | && r2ave > diskInner scn && r2ave < diskOuter scn 98 | = Layer $ diskColor' scn diskRGB (sqrt r2ave) 99 | | otherwise = None 100 | where r2 = quadrance pos 101 | r2' = quadrance newPos 102 | r2ave = (y'*r2 - y*r2') / (y' - y) 103 | 104 | diskColor' :: Scene -> Pixel RGB Double -> Double -> Pixel RGBA Double 105 | {-# INLINE diskColor' #-} 106 | diskColor' scn diskRGB r = let 107 | rInner = sqrt (diskInner scn) 108 | rOuter = sqrt (diskOuter scn) 109 | intensity = sin (pi * ((rOuter - r) / (rOuter - rInner)) ^ (2 :: Int)) 110 | rgb = fmap (* intensity) diskRGB 111 | in addAlpha (intensity * diskOpacity scn) rgb 112 | 113 | rk4 :: Double -> Double -> PhotonState -> PhotonState 114 | {-# INLINE rk4 #-} 115 | rk4 h h2 y = let 116 | mul :: Double -> PhotonState -> PhotonState 117 | {-# INLINE mul #-} 118 | mul a (PhotonState u v) = PhotonState (u ^* a) (v ^* a) 119 | 120 | add :: PhotonState -> PhotonState -> PhotonState 121 | {-# INLINE add #-} 122 | add (PhotonState x z) (PhotonState u v) = PhotonState (x ^+^ u) (z ^+^ v) 123 | 124 | f :: PhotonState -> PhotonState 125 | {-# INLINE f #-} 126 | f (PhotonState vel pos) = 127 | PhotonState (-1.5*h2 / (norm pos ^ (5 :: Int)) *^ pos) vel 128 | 129 | k1 = f y 130 | k2 = f $ y `add` mul (h / 2) k1 131 | k3 = f $ y `add` mul (h / 2) k2 132 | k4 = f $ y `add` mul h k3 133 | sumK = k1 `add` mul 2 k2 `add` mul 2 k3 `add` k4 134 | in y `add` mul (h / 6) sumK 135 | -------------------------------------------------------------------------------- /src/StarMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 2 | {-# LANGUAGE StrictData #-} 3 | {-# LANGUAGE Strict #-} 4 | 5 | {-# OPTIONS_GHC -fno-warn-orphans #-} 6 | 7 | module StarMap 8 | ( Star, StarTree, StoredStarTree 9 | , readMapFromFile, treeToByteString, readTreeFromFile 10 | , buildStarTree, starLookup ) where 11 | 12 | import Control.Monad 13 | import Control.Applicative (liftA2) 14 | import Data.Word 15 | import Data.Char 16 | import Data.Foldable 17 | import qualified Data.ByteString as B 18 | import Data.Serialize as S 19 | import Data.KdMap.Static 20 | import Linear as L 21 | import Graphics.ColorSpace 22 | 23 | import Util 24 | 25 | type Star = (V3 Double, (Int, Double, Double)) 26 | type StarTree = KdMap Double (V3 Double) (Int, Double, Double) 27 | type StoredStar = (V3 Double, (Int, Char)) 28 | type StoredStarTree = KdMap Double (V3 Double) (Int, Char) 29 | 30 | instance Serialize StoredStarTree 31 | instance Serialize (TreeNode Double (V3 Double) (Int, Char)) 32 | 33 | -- We can't serialize functions but let's hack around it so that we can 34 | -- serialize the KdMap anyway 35 | instance Serialize (SquaredDistanceFn Double (V3 Double)) where 36 | put _ = put (0 :: Word8) 37 | get = skip 1 >> return (defaultSqrDist toList) 38 | 39 | instance Serialize (PointAsListFn Double (V3 Double)) where 40 | put _ = put (0 :: Word8) 41 | get = skip 1 >> return toList 42 | 43 | -- Parse the star list in the binary format specified at 44 | -- http://tdc-www.harvard.edu/software/catalogs/ppm.entry.html 45 | readMap :: Get [StoredStar] 46 | readMap = do 47 | -- Skip the header 48 | skip 28 49 | nBytes <- remaining 50 | replicateM (nBytes `div` 28) $ do 51 | ra <- getFloat64be 52 | dec <- getFloat64be 53 | spectral <- getWord8 54 | skip 1 55 | mag <- getInt16be 56 | skip 8 57 | return ( raDecToCartesian ra dec 58 | , (fromIntegral mag, chr $ fromIntegral spectral) ) 59 | 60 | starColor' :: (Int, Char) -> (Int, Double, Double) 61 | starColor' (mag, ch) = let (h, s) = starColor ch in (mag, h, s) 62 | 63 | -- Some nice colour values for different spectral types 64 | starColor :: Char -> (Double, Double) 65 | starColor 'O' = (0.631, 0.39) 66 | starColor 'B' = (0.628, 0.33) 67 | starColor 'A' = (0.622, 0.21) 68 | starColor 'F' = (0.650, 0.03) 69 | starColor 'G' = (0.089, 0.09) 70 | starColor 'K' = (0.094, 0.29) 71 | starColor 'M' = (0.094, 0.56) 72 | starColor _ = (0, 0) 73 | 74 | raDecToCartesian :: Double -> Double -> V3 Double 75 | raDecToCartesian ra dec = V3 (cos dec*cos ra) (cos dec*sin ra) (sin dec) 76 | 77 | readMapFromFile :: FilePath -> IO (Either String [StoredStar]) 78 | readMapFromFile path = do 79 | ebs <- readSafe path 80 | return $ ebs >>= runGet readMap 81 | 82 | readTreeFromFile :: FilePath -> IO (Either String StarTree) 83 | readTreeFromFile path = do 84 | ebs <- readSafe path 85 | return $ fmap starColor' <$> (S.decode =<< ebs) 86 | 87 | treeToByteString :: StoredStarTree -> B.ByteString 88 | treeToByteString = S.encode 89 | 90 | buildStarTree :: [StoredStar] -> StoredStarTree 91 | buildStarTree = build toList 92 | 93 | starLookup :: StarTree -> Double -> Double -> V3 Double -> Pixel RGB Double 94 | {-# INLINE starLookup #-} 95 | starLookup starmap intensity saturation vel = let 96 | -- The magnitude value tells about the intensity of the star. The 97 | -- brighter the star, the smaller the magnitude. These constants are 98 | -- used for adjusting the dynamics of the rendered celestial sphere. 99 | max_brightness = 950 -- the "maximum brightness" magnitude 100 | dynamic = 50 -- "dynamic range": magnitude change that doubles intensity 101 | w = 0.0005 -- width parameter of the gaussian function 102 | 103 | nvel = L.normalize vel 104 | stars = inRadius starmap (3 * w) nvel 105 | 106 | renderPixel (pos, (mag, hue, sat)) = let 107 | d2 = qd pos nvel 108 | a = log 2 / dynamic 109 | -- Conversion from the log magnitude scale to linear brightness 110 | -- and a Gaussian intensity function. This determines the apparent size 111 | -- and brightness of the star. 112 | val = (* intensity) . min 1 113 | . exp $ a * (max_brightness - fromIntegral mag) - d2 / (2 * w^(2 :: Int)) 114 | in toPixelRGB $ PixelHSI hue (saturation * sat) val 115 | in fmap (min 1) . foldl' (liftA2 (+)) (PixelRGB 0 0 0) $ renderPixel <$> stars 116 | -------------------------------------------------------------------------------- /src/Util.hs: -------------------------------------------------------------------------------- 1 | module Util ( promptOverwriteFile, readSafe, normalizePath 2 | , timeAction, padZero ) where 3 | 4 | import System.Directory 5 | import System.IO 6 | import qualified Data.ByteString as B 7 | import Data.Time.Clock.POSIX (getPOSIXTime) 8 | import System.FilePath 9 | import Control.DeepSeq 10 | 11 | readSafe :: FilePath -> IO (Either String B.ByteString) 12 | readSafe path = do 13 | exists <- doesFileExist path 14 | if exists then Right <$> B.readFile path 15 | else return . Left $ "Error: file " ++ path 16 | ++ " doesn't exist.\n" 17 | 18 | promptOverwriteFile :: FilePath -> (FilePath -> IO ()) -> IO () 19 | promptOverwriteFile path doWrite = do 20 | doesExist <- doesFileExist path 21 | if doesExist then do 22 | putStr $ "Overwrite " ++ path ++ "? [y/N] " 23 | hFlush stdout 24 | answer <- getLine 25 | if answer == "y" || answer == "Y" then doWrite path 26 | else putStrLn "Nothing was written." 27 | else doWrite path 28 | 29 | normalizePath :: FilePath -> IO FilePath 30 | normalizePath path = (dropTrailingPathSeparator . normalise) 31 | <$> makeRelativeToCurrentDirectory path 32 | 33 | timeAction :: NFData a => String -> a -> IO a 34 | timeAction actionName value = do 35 | time1 <- (round <$> getPOSIXTime) :: IO Int 36 | let res = value 37 | time2 <- round <$> (res `deepseq` getPOSIXTime) 38 | let secs = time2 - time1 39 | putStrLn $ actionName ++ " completed in " ++ show (secs `div` 60) 40 | ++ " min " ++ show (secs `rem` 60) ++ " sec." 41 | return res 42 | 43 | padZero :: Int -> Int -> String 44 | padZero maxVal val = let 45 | nDigits x = (floor . logBase 10 $ (fromIntegral x :: Double)) + 1 46 | nZeros = nDigits maxVal - nDigits val 47 | zeros = replicate nZeros '0' 48 | in zeros ++ show val 49 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.16 2 | flags: {} 3 | extra-package-dbs: [] 4 | packages: 5 | - '.' 6 | --------------------------------------------------------------------------------