├── .gitignore ├── App.hs ├── BoundedSequence.hs ├── ConcurrentSegments.hs ├── CoordTransf.hs ├── CornellBox.hs ├── FileModChecker.hs ├── Font.hs ├── Fractal2D.hs ├── FrameBuffer.hs ├── GLFWHelpers.hs ├── GLHelpers.hs ├── GLSLHelpers.hs ├── HDREnvMap.hs ├── LICENSE ├── Main.hs ├── QQPlainText.hs ├── QuadRendering.hs ├── QuadShaderSource.hs ├── QuadTypes.hs ├── README.md ├── Setup.hs ├── ShaderRendering.hs ├── ShaderRenderingVertexShaderSrc.hs ├── Timing.hs ├── Trace.hs ├── fragment.shd ├── img ├── julia_set.png ├── mandelbulb.png ├── prefiltered.png └── rmdf.png ├── latlong_envmaps ├── download_hdr_environments.txt └── uffizi_512.hdr ├── rmdf.cabal └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox/ 2 | cabal.sandbox.config 3 | dist/ 4 | rmdf.prof 5 | *.png 6 | latlong_envmaps/*.hdr 7 | .stack-work/ 8 | -------------------------------------------------------------------------------- /App.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE RecordWildCards, TemplateHaskell, LambdaCase, FlexibleContexts #-} 3 | 4 | module App ( AppState(..) 5 | , AppEnv(..) 6 | , Mode(..) 7 | , AppT 8 | , runAppT 9 | , run 10 | -- Export to silence warnings 11 | , aeFontTexture 12 | , aeQR 13 | ) where 14 | 15 | import Control.Lens 16 | import Control.Monad.Reader 17 | import Control.Monad.State 18 | import Control.Monad.STM 19 | import Control.Concurrent.STM.TQueue 20 | import qualified Graphics.Rendering.OpenGL as GL 21 | import qualified Graphics.UI.GLFW as GLFW 22 | import Text.Printf 23 | import Data.Time 24 | import Data.List 25 | import Data.Maybe 26 | 27 | import GLFWHelpers 28 | import GLHelpers 29 | import Timing 30 | import Trace 31 | import Font 32 | import FrameBuffer 33 | import Fractal2D 34 | import ShaderRendering 35 | import QuadRendering 36 | import qualified BoundedSequence as BS 37 | 38 | data Mode = ModeMandelBrot 39 | | ModeMandelBrotSmooth 40 | | ModeJuliaAnim 41 | | ModeJuliaAnimSmooth 42 | | ModeDECornellBoxShader 43 | | ModeDETestShader 44 | | ModeMBPower8Shader 45 | | ModeMBGeneralShader 46 | deriving (Enum, Eq, Bounded, Show) 47 | 48 | data AppState = AppState { _asCurTick :: !Double 49 | , _asLastEscPress :: !Double 50 | , _asFrameTimes :: BS.BoundedSequence Double 51 | , _asMode :: !Mode 52 | , _asFBScale :: !Float 53 | , _asLastShdErr :: !String 54 | , _asTiling :: !Bool 55 | , _asFrameIdx :: !Int 56 | , _asTakeScreenShot :: !Bool 57 | } 58 | 59 | data AppEnv = AppEnv { _aeWindow :: GLFW.Window 60 | , _aeGLFWEventsQueue :: TQueue GLFWEvent 61 | , _aeFontTexture :: GL.TextureObject 62 | , _aeFB :: FrameBuffer 63 | , _aeQR :: QuadRenderer 64 | , _aeSR :: ShaderRenderer 65 | , _aeShaderModChecker :: IO Bool 66 | } 67 | 68 | makeLenses ''AppState 69 | makeLenses ''AppEnv 70 | 71 | -- Our application runs in a reader / state / IO transformer stack 72 | 73 | type AppT m = StateT AppState (ReaderT AppEnv m) 74 | type AppIO = AppT IO 75 | 76 | runAppT :: Monad m => AppState -> AppEnv -> AppT m a -> m a 77 | runAppT s e f = flip runReaderT e . flip evalStateT s $ f 78 | 79 | processAllEvents :: MonadIO m => TQueue a -> (a -> m ()) -> m () 80 | processAllEvents tq processEvent = 81 | (liftIO . atomically $ tryReadTQueue tq) >>= \case 82 | Just e -> processEvent e >> processAllEvents tq processEvent 83 | _ -> return () 84 | 85 | processGLFWEvent :: GLFWEvent -> AppIO () 86 | processGLFWEvent ev = 87 | case ev of 88 | GLFWEventError e s -> do 89 | window <- view aeWindow 90 | liftIO $ do 91 | traceS TLError $ "GLFW Error " ++ show e ++ " " ++ show s 92 | GLFW.setWindowShouldClose window True 93 | GLFWEventKey win k {- sc -} _ ks {- mk -} _ | ks == GLFW.KeyState'Pressed -> 94 | case k of 95 | GLFW.Key'Escape -> do 96 | lastPress <- use asLastEscPress 97 | tick <- use asCurTick 98 | -- Only close when ESC has been pressed twice quickly 99 | when (tick - lastPress < 0.5) . 100 | liftIO $ GLFW.setWindowShouldClose win True 101 | asLastEscPress .= tick 102 | -- Mode / scaling switch is a render settings change 103 | GLFW.Key'Minus -> asMode %= wrapPred >> onRenderSettingsChage 104 | GLFW.Key'Equal -> asMode %= wrapSucc >> onRenderSettingsChage 105 | GLFW.Key'Comma -> asFBScale %= max 0.125 . (/ 2) >> resize 106 | GLFW.Key'Period -> asFBScale %= min 16 . (* 2) >> resize 107 | GLFW.Key'S -> asTakeScreenShot .= True 108 | GLFW.Key'T -> asTiling %= not >> onRenderSettingsChage 109 | _ -> return () 110 | GLFWEventFramebufferSize {- win -} _ {- w -} _ {- h -} _ -> resize 111 | -- TODO: Mouse control for orbiting camera 112 | -- GLFWEventWindowSize {- win -} _ w h -> do 113 | -- liftIO $ traceS TLInfo $ printf "Window resized: %i x %i" w h 114 | -- return () 115 | -- GLFWEventMouseButton win bttn st mk -> do 116 | -- return () 117 | -- GLFWEventCursorPos win x y -> do 118 | -- return () 119 | -- GLFWEventScroll win x y -> do 120 | -- return () 121 | _ -> return () 122 | 123 | -- Handle changes in window and frame buffer size / scaling 124 | resize :: AppIO () 125 | resize = do 126 | scale <- use asFBScale 127 | window <- view aeWindow 128 | fb <- view aeFB 129 | liftIO $ do (w, h) <- GLFW.getFramebufferSize window 130 | setupViewport w h 131 | resizeFrameBuffer fb 132 | (round $ fromIntegral w * scale) 133 | (round $ fromIntegral h * scale) 134 | onRenderSettingsChage 135 | 136 | -- Move through an enumeration, but wrap around when hitting the end 137 | wrapSucc, wrapPred :: (Enum a, Bounded a, Eq a) => a -> a 138 | wrapSucc a | a == maxBound = minBound 139 | | otherwise = succ a 140 | wrapPred a | a == minBound = maxBound 141 | | otherwise = pred a 142 | 143 | draw :: AppIO () 144 | draw = do 145 | AppEnv { .. } <- ask 146 | AppState { .. } <- get 147 | -- Clear 148 | liftIO $ do 149 | GL.clearColor GL.$= (GL.Color4 1 0 1 1 :: GL.Color4 GL.GLclampf) 150 | GL.clear [GL.ColorBuffer, GL.DepthBuffer] 151 | GL.depthFunc GL.$= Just GL.Lequal 152 | -- Draw shader into our frame buffer texture 153 | let fillFB = void . fillFrameBuffer _aeFB 154 | drawFB = void . drawIntoFrameBuffer _aeFB 155 | tileIdx | _asTiling = Just _asFrameIdx 156 | | otherwise = Nothing 157 | drawShader shd w h = drawShaderTile _aeSR shd tileIdx w h _asCurTick 158 | in liftIO $ case _asMode of 159 | ModeJuliaAnim -> fillFB $ \w h fbVec -> juliaAnimated w h fbVec False _asCurTick 160 | ModeJuliaAnimSmooth -> fillFB $ \w h fbVec -> juliaAnimated w h fbVec True _asCurTick 161 | ModeMandelBrot -> fillFB $ \w h fbVec -> mandelbrot w h fbVec False 162 | ModeMandelBrotSmooth -> fillFB $ \w h fbVec -> mandelbrot w h fbVec True 163 | ModeDECornellBoxShader -> drawFB $ \w h -> drawShader FSDECornellBoxShader w h 164 | ModeDETestShader -> drawFB $ \w h -> drawShader FSDETestShader w h 165 | ModeMBPower8Shader -> drawFB $ \w h -> drawShader FSMBPower8Shader w h 166 | ModeMBGeneralShader -> drawFB $ \w h -> drawShader FSMBGeneralShader w h 167 | -- Render everything quad based 168 | (liftIO $ GLFW.getFramebufferSize _aeWindow) >>= \(w, h) -> 169 | void . withQuadRenderBuffer _aeQR w h $ \qb -> do 170 | -- Draw frame buffer contents 171 | liftIO $ drawFrameBuffer _aeFB qb 0 0 (fromIntegral w) (fromIntegral h) 172 | -- FPS counter and mode display 173 | liftIO $ drawQuad qb 174 | 0 (fromIntegral h - 24) 175 | (fromIntegral w) (fromIntegral h) 176 | 2 177 | FCBlack 178 | (TRBlend 0.5) 179 | Nothing 180 | QuadUVDefault 181 | ftStr <- updateAndReturnFrameTimes 182 | (fbWdh, fbHgt) <- liftIO $ getFrameBufferDim _aeFB 183 | liftIO . drawTextWithShadow _aeFontTexture qb 3 (h - 12) $ 184 | printf ( "Mode %i/%i [-][=]: %s | [S]creenshot | 2x[ESC] Exit | " ++ 185 | "[T]iles: %s\nFB Scaling [,][.]: %fx, %ix%i | %s" 186 | ) 187 | (fromEnum _asMode + 1 :: Int) 188 | (fromEnum (maxBound :: Mode) + 1 :: Int) 189 | (fromMaybe (show _asMode) . stripPrefix "Mode" $ show _asMode) 190 | (if _asTiling then "On" else "Off") 191 | _asFBScale 192 | fbWdh 193 | fbHgt 194 | ftStr 195 | -- Display any shader compilation errors from the last reload in a text overlay 196 | unless (null _asLastShdErr) $ 197 | let wrap = concat 198 | . intersperse "\n" 199 | . map (foldr (\(i, c) str -> if i > 0 && i `mod` lineWdh == 0 200 | then c : '\n' : str 201 | else c : str 202 | ) "" . zip ([0..] :: [Int]) 203 | ) 204 | . filter (/= "\n") 205 | . filter (/= "\0") -- No idea why that's in there... 206 | . groupBy (\a b -> a /= '\n' && b /= '\n') 207 | $ _asLastShdErr 208 | lineWdh = (w - 20) `div` 6 - 1 209 | errHgt = (+ 3) . (* 11) . succ . length . filter (== '\n') $ wrap 210 | errY = h `div` 2 + errHgt `div` 2 211 | in liftIO $ do drawTextWithShadow _aeFontTexture qb 10 (errY - 12) wrap 212 | drawQuad qb 213 | 7 (fromIntegral errY) 214 | (fromIntegral $ w - 7) (fromIntegral $ errY - errHgt) 215 | 2 216 | FCBlack 217 | (TRBlend 0.5) 218 | Nothing 219 | QuadUVDefault 220 | 221 | updateAndReturnFrameTimes :: MonadState AppState m => m String 222 | updateAndReturnFrameTimes = do 223 | frameTimes <- use $ asFrameTimes.to BS.toList 224 | curTick <- use asCurTick 225 | tiling <- use asTiling 226 | asFrameTimes %= BS.push_ curTick 227 | let frameDeltas = case frameTimes of (x:xs) -> goFD x xs; _ -> [] 228 | goFD prev (x:xs) = (prev - x) : goFD x xs 229 | goFD _ [] = [] 230 | fdMean = sum frameDeltas / (fromIntegral $ length frameDeltas) 231 | fdWorst = case frameDeltas of [] -> 0; xs -> maximum xs 232 | fdBest = case frameDeltas of [] -> 0; xs -> minimum xs 233 | in return $ printf "%.2f%s/%.1fms (Worst: %.2f, Best: %.2f)" 234 | (1.0 / fdMean) 235 | (if tiling then "TPS" else "FPS") 236 | (fdMean * 1000) 237 | (1.0 / fdWorst) 238 | (1.0 / fdBest) 239 | 240 | drawTextWithShadow :: GL.TextureObject -> QuadRenderBuffer -> Int -> Int -> String -> IO () 241 | drawTextWithShadow tex qb x y str = do 242 | drawText tex qb (x + 1) (y - 1) 0x00000000 str 243 | drawText tex qb x y 0x0000FF00 str 244 | 245 | -- Check if our shader file has been modified on disk and reload shaders if it has been 246 | checkShaderModified :: AppIO () 247 | checkShaderModified = do 248 | checker <- view aeShaderModChecker 249 | modified <- liftIO checker 250 | when modified $ 251 | view aeSR >>= liftIO . loadAndCompileShaders >>= 252 | \case Left err -> do liftIO . traceS TLError $ "Failed to reload shaders:\n" ++ err 253 | asLastShdErr .= err 254 | Right s -> do liftIO . traceS TLInfo $ printf "Reloaded shaders in %.2fs" s 255 | asLastShdErr .= "" 256 | onRenderSettingsChage 257 | 258 | checkTakeScreenShot :: AppIO () 259 | checkTakeScreenShot = do 260 | takeSS <- use asTakeScreenShot 261 | tiling <- use asTiling 262 | idx <- use asFrameIdx 263 | -- Are we asked to take a screen shot? 264 | when takeSS $ 265 | -- Are we drawing full frames or have we just finished the last tile? 266 | when (not tiling || isTileIdxLastTile idx) $ do 267 | view aeFB >>= \fb -> liftIO $ saveFrameBufferToPNG fb . 268 | map (\c -> if c `elem` ['/', '\\', ':', ' '] then '-' else c) 269 | . printf "Screenshot-%s.png" =<< show <$> getZonedTime 270 | asTakeScreenShot .= False 271 | 272 | onRenderSettingsChage :: MonadState AppState m => m () 273 | onRenderSettingsChage = do 274 | -- Reset frame time measurements and frame index when the rendering settings have 275 | -- changed. Also cancel any outstanding screen shot requests 276 | asFrameTimes %= BS.clear 277 | asFrameIdx .= 0 278 | asTakeScreenShot .= False 279 | 280 | run :: AppIO () 281 | run = do 282 | -- Setup OpenGL / GLFW 283 | window <- view aeWindow 284 | resize 285 | liftIO $ GLFW.swapInterval 0 286 | -- Main loop 287 | let loop = do 288 | asCurTick <~ liftIO getTick 289 | tqGLFW <- view aeGLFWEventsQueue 290 | processAllEvents tqGLFW processGLFWEvent 291 | checkShaderModified 292 | -- GLFW / OpenGL 293 | draw 294 | liftIO $ {-# SCC swapAndPoll #-} do 295 | -- GL.flush 296 | -- GL.finish 297 | GLFW.swapBuffers window 298 | GLFW.pollEvents 299 | traceOnGLError $ Just "main loop" 300 | -- Can take a screen shot after the last tile has been rendered 301 | checkTakeScreenShot 302 | -- Drop the first three frame deltas, they are often outliers 303 | use asFrameIdx >>= \idx -> when (idx < 3) (asFrameTimes %= BS.clear) 304 | asFrameIdx += 1 305 | -- Done? 306 | flip unless loop =<< liftIO (GLFW.windowShouldClose window) 307 | in loop 308 | 309 | -------------------------------------------------------------------------------- /BoundedSequence.hs: -------------------------------------------------------------------------------- 1 | 2 | module BoundedSequence ( BoundedSequence 3 | , empty 4 | , push 5 | , push_ 6 | , pop 7 | , toList 8 | , clear 9 | ) where 10 | 11 | import qualified Data.Sequence as S 12 | import qualified Data.Foldable 13 | 14 | -- Sequence with a stack interface which drops elements pushed over a specified depth 15 | 16 | data BoundedSequence a = BoundedSequence !(S.Seq a) !Int 17 | deriving (Show) 18 | 19 | empty :: Int -> BoundedSequence a 20 | empty limit | limit >= 1 = BoundedSequence S.empty limit 21 | | otherwise = error "limit for BoundedSequence needs to be >= 1" 22 | 23 | -- Push element on the stack, truncate at the other end if we reached the limit, 24 | -- return new stack and truncated element (if over the limit) 25 | push :: a -> BoundedSequence a -> (BoundedSequence a, Maybe a) 26 | push x (BoundedSequence s limit) = 27 | let seqDropR sd = case S.viewr sd of (s' S.:> e) -> (s', Just e) 28 | S.EmptyR -> (sd, Nothing) 29 | boundedS | S.length s >= limit = seqDropR s 30 | | otherwise = (s, Nothing) 31 | in case boundedS of (s', e) -> (BoundedSequence (x S.<| s') limit, e) 32 | 33 | push_ :: a -> BoundedSequence a -> BoundedSequence a 34 | push_ x s = fst $ push x s 35 | 36 | -- LIFO pop 37 | pop :: BoundedSequence a -> (Maybe a, BoundedSequence a) 38 | pop bs@(BoundedSequence s limit) = 39 | case S.viewl s of (x S.:< s') -> (Just x , BoundedSequence s' limit) 40 | S.EmptyL -> (Nothing, bs) 41 | 42 | toList :: BoundedSequence a -> [a] 43 | toList (BoundedSequence s _) = Data.Foldable.toList s 44 | 45 | clear :: BoundedSequence a -> BoundedSequence a 46 | clear (BoundedSequence _ limit) = BoundedSequence S.empty limit 47 | 48 | -------------------------------------------------------------------------------- /ConcurrentSegments.hs: -------------------------------------------------------------------------------- 1 | 2 | module ConcurrentSegments ( makeNSegments 3 | , forSegmentsConcurrently 4 | ) where 5 | 6 | import Data.Maybe 7 | import Control.Concurrent.Async 8 | import GHC.Conc (getNumProcessors) 9 | 10 | -- Module for splitting an interval into even segments and processing them concurrently. 11 | -- Typical use case would be a 1D or 2D array that is supposed to be processed on all 12 | -- available cores 13 | 14 | makeNSegments :: Int -> Int -> Int -> [(Int, Int)] 15 | makeNSegments nseg low high 16 | | low >= high = [] 17 | | nsegc <= 0 = [] 18 | | nsegc == 1 = [(low, high)] 19 | | otherwise = map (\i -> (low + i * segl, low + (i + 1) * segl)) [0..nsegc - 2] ++ end 20 | where range = high - low 21 | segl = range `div` nsegc 22 | end = [(low + (nsegc - 1) * segl, high)] 23 | nsegc = min nseg $ high - low 24 | 25 | forSegmentsConcurrently :: Maybe Int -> Int -> Int -> (Int -> Int -> IO a) -> IO [a] 26 | forSegmentsConcurrently mbNSeg low high f = do 27 | nseg <- fromMaybe getNumProcessors $ return <$> mbNSeg 28 | mapConcurrently (uncurry f) $ makeNSegments nseg low high 29 | 30 | -------------------------------------------------------------------------------- /CoordTransf.hs: -------------------------------------------------------------------------------- 1 | 2 | module CoordTransf ( sphericalToCartesian 3 | , cartesianToSpherical 4 | , worldToLocal 5 | , localToWorld 6 | , sphericalToEnvironmentUV 7 | , sphericalToEnvironmentPx 8 | , environmentUVToSpherical 9 | , environmentPxToSpherical 10 | ) where 11 | 12 | import Control.Exception 13 | import Control.Lens 14 | import Linear 15 | 16 | -- Coordinate system transforms, Haskell port from my own code inside 17 | -- http://www.blitzcode.net/3d_1.shtml#Product_Importance_Sampling 18 | -- 19 | -- We use right handed systems everywhere, world space having Y as up, X going 20 | -- right and Z out of the screen (OpenGL style). Surface local coordinates 21 | -- have Z going up and X/Y as right / up on the surface. Spherical coordinates 22 | -- have Theta as the polar angle [0, Pi] relative to the Z axis and Phi as the 23 | -- azimuthal angle [0, 2Pi) in the X, Y plane relative to X axis. Environment 24 | -- maps and other data stored in latitude / longitude format has down (-Y, 25 | -- theta = Pi) at y = 0 and forward (-Z, phi = Pi/2) at x = width / 2. 26 | 27 | sphericalToCartesian :: Float -> Float -> V3 Float 28 | sphericalToCartesian theta phi = 29 | (theta >= 0 && theta <= pi) `assert` 30 | (phi >= 0 && phi <= 2 * pi) `assert` 31 | V3 (sin theta * cos phi) 32 | (sin theta * sin phi) 33 | (cos theta ) 34 | 35 | cartesianToSpherical :: V3 Float -> (Float, Float) 36 | cartesianToSpherical dir = 37 | (theta >= 0 && theta <= pi) `assert` 38 | (phi >= 0 && phi < 2 * pi) `assert` 39 | (theta, phi) 40 | where theta = acos $ clamp (dir ^. _z) (-1) 1 41 | phi'' = atan2 (dir ^. _y) (dir ^. _x) 42 | phi' = if phi'' < 0 then phi'' + 2 * pi else phi'' 43 | phi = if phi' == 2 * pi then 0 else phi' 44 | clamp v mi ma = max mi $ min ma v 45 | 46 | worldToLocal :: V3 Float -> V3 Float 47 | worldToLocal world = V3 (dot world x) (dot world y) (dot world n) 48 | where n = V3 0 1 0 49 | x = V3 1 0 0 50 | y = V3 0 0 (-1) 51 | 52 | localToWorld :: V3 Float -> V3 Float 53 | localToWorld local = V3 (local^._x * x^._x + local^._y * y^._x + local^._z * n^._x) 54 | (local^._x * x^._y + local^._y * y^._y + local^._z * n^._y) 55 | (local^._x * x^._z + local^._y * y^._z + local^._z * n^._z) 56 | where n = V3 0 1 0 57 | x = V3 1 0 0 58 | y = V3 0 0 (-1) 59 | 60 | sphericalToEnvironmentUV :: Float -> Float -> (Float, Float) 61 | sphericalToEnvironmentUV theta phi = (u, v) 62 | where -- Forward is in the center of our HDR image. Our coordinate system 63 | -- conventions say Phi = 0 means it is aligned with the X-axis, pointing 64 | -- right. Add Pi / 2 which rotates 90 degrees CCW, we're aligned now 65 | phi' = phi + pi / 2; 66 | phi'' = if phi' > 2 * pi then phi' - 2 * pi else phi' 67 | -- We assume our images are stored CW, Phi rotates CCW around Z. Invert 68 | phi''' = 2 * pi - phi'' 69 | u = phi''' / (pi * 2) 70 | v = theta / pi 71 | 72 | sphericalToEnvironmentPx :: Float -> Float -> Int -> (Int, Int) 73 | sphericalToEnvironmentPx theta phi width = (x, y) 74 | where (u, v) = sphericalToEnvironmentUV theta phi 75 | height = width `div` 2 76 | x = round $ u * fromIntegral width 77 | y' = round $ v * fromIntegral height 78 | y = if y' == height then y' - 1 else y' 79 | 80 | environmentUVToSpherical :: Float -> Float -> (Float, Float) 81 | environmentUVToSpherical u v = (theta, phi) 82 | where theta = v * pi 83 | phi'' = u * pi * 2 + pi / 2 84 | phi' = if phi'' >= pi * 2 then phi'' - pi * 2 else phi'' 85 | phi = 2 * pi - phi' 86 | 87 | environmentPxToSpherical :: Int -> Int -> Int -> (Float, Float) 88 | environmentPxToSpherical x y width = environmentUVToSpherical u v 89 | where height = width `div` 2 90 | u = fromIntegral x / fromIntegral (width - 1) 91 | v = fromIntegral y / fromIntegral (height - 1) 92 | 93 | -------------------------------------------------------------------------------- /CornellBox.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE OverloadedLists #-} 3 | 4 | module CornellBox ( mkCornellBoxVerticesTex 5 | , cornellBox 6 | ) where 7 | 8 | import Control.Exception 9 | import qualified Data.Vector as V 10 | import qualified Graphics.Rendering.OpenGL as GL 11 | import Foreign.Marshal.Array 12 | import Linear 13 | 14 | import GLHelpers 15 | 16 | -- Build a 1D OpenGL floating point texture containing the vertices of 17 | -- the triangulated Cornell Box geometry, scaled and centered to [-1, 1] 18 | -- 19 | -- http://www.graphics.cornell.edu/online/box/data.html 20 | 21 | mkCornellBoxVerticesTex :: IO GL.TextureObject 22 | mkCornellBoxVerticesTex = 23 | bracketOnError GL.genObjectName GL.deleteObjectName $ \tex -> do 24 | GL.textureBinding GL.Texture1D GL.$= Just tex 25 | setTextureFiltering GL.Texture1D TFNone 26 | let numQuad = V.length cornellBox `div` 4 27 | numTri = numQuad * 2 28 | numVtx = numTri * 3 29 | toUnit = 559.2 / 2 30 | scale = 1 / (sqrt (2 * 2 + 2 * 2 + 2 * 2) / 2) * 0.99 31 | vtx = flip concatMap ([0..numQuad - 1] :: [Int]) $ \quadIdx -> 32 | [ ((cornellBox V.! (quadIdx * 4 + 0)) / toUnit - 1) ^* scale 33 | , ((cornellBox V.! (quadIdx * 4 + 1)) / toUnit - 1) ^* scale 34 | , ((cornellBox V.! (quadIdx * 4 + 3)) / toUnit - 1) ^* scale 35 | , ((cornellBox V.! (quadIdx * 4 + 3)) / toUnit - 1) ^* scale 36 | , ((cornellBox V.! (quadIdx * 4 + 1)) / toUnit - 1) ^* scale 37 | , ((cornellBox V.! (quadIdx * 4 + 2)) / toUnit - 1) ^* scale 38 | ] 39 | in withArray vtx $ GL.texImage1D GL.Texture1D 40 | GL.NoProxy 41 | 0 42 | GL.RGB32F 43 | (GL.TextureSize1D $ fromIntegral numVtx) 44 | 0 45 | . GL.PixelData GL.RGB GL.Float 46 | return tex 47 | 48 | cornellBox :: V.Vector (V3 Float) 49 | cornellBox = 50 | [ -- Floor (White) 51 | V3 552.8 0.0 0.0 52 | , V3 0.0 0.0 0.0 53 | , V3 0.0 0.0 559.2 54 | , V3 549.6 0.0 559.2 55 | 56 | -- Ceiling (White) 57 | , V3 556.0 548.8 0.0 58 | , V3 556.0 548.8 559.2 59 | , V3 0.0 548.8 559.2 60 | , V3 0.0 548.8 0.0 61 | 62 | -- Back Wall (White) 63 | , V3 549.6 0.0 559.2 64 | , V3 0.0 0.0 559.2 65 | , V3 0.0 548.8 559.2 66 | , V3 556.0 548.8 559.2 67 | 68 | -- Right Wall (Green) 69 | , V3 0.0 0.0 559.2 70 | , V3 0.0 0.0 0.0 71 | , V3 0.0 548.8 0.0 72 | , V3 0.0 548.8 559.2 73 | 74 | -- Left Wall (Red) 75 | , V3 552.8 0.0 0.0 76 | , V3 549.6 0.0 559.2 77 | , V3 556.0 548.8 559.2 78 | , V3 556.0 548.8 0.0 79 | 80 | -- Light (Small offset to avoid surface acne) 81 | , V3 343.0 (548.8 - 0.1) 227.0 82 | , V3 343.0 (548.8 - 0.1) 332.0 83 | , V3 213.0 (548.8 - 0.1) 332.0 84 | , V3 213.0 (548.8 - 0.1) 227.0 85 | 86 | -- Short Block (White) 87 | , V3 130.0 165.0 65.0 88 | , V3 82.0 165.0 225.0 89 | , V3 240.0 165.0 272.0 90 | , V3 290.0 165.0 114.0 91 | , V3 290.0 0.0 114.0 92 | , V3 290.0 165.0 114.0 93 | , V3 240.0 165.0 272.0 94 | , V3 240.0 0.0 272.0 95 | , V3 130.0 0.0 65.0 96 | , V3 130.0 165.0 65.0 97 | , V3 290.0 165.0 114.0 98 | , V3 290.0 0.0 114.0 99 | , V3 82.0 0.0 225.0 100 | , V3 82.0 165.0 225.0 101 | , V3 130.0 165.0 65.0 102 | , V3 130.0 0.0 65.0 103 | , V3 240.0 0.0 272.0 104 | , V3 240.0 165.0 272.0 105 | , V3 82.0 165.0 225.0 106 | , V3 82.0 0.0 225.0 107 | 108 | -- Tall Block (White) 109 | , V3 423.0 330.0 247.0 110 | , V3 265.0 330.0 296.0 111 | , V3 314.0 330.0 456.0 112 | , V3 472.0 330.0 406.0 113 | , V3 423.0 0.0 247.0 114 | , V3 423.0 330.0 247.0 115 | , V3 472.0 330.0 406.0 116 | , V3 472.0 0.0 406.0 117 | , V3 472.0 0.0 406.0 118 | , V3 472.0 330.0 406.0 119 | , V3 314.0 330.0 456.0 120 | , V3 314.0 0.0 456.0 121 | , V3 314.0 0.0 456.0 122 | , V3 314.0 330.0 456.0 123 | , V3 265.0 330.0 296.0 124 | , V3 265.0 0.0 296.0 125 | , V3 265.0 0.0 296.0 126 | , V3 265.0 330.0 296.0 127 | , V3 423.0 330.0 247.0 128 | , V3 423.0 0.0 247.0 129 | ] 130 | 131 | -------------------------------------------------------------------------------- /FileModChecker.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | module FileModChecker ( mkFileModChecker 5 | , FileMod 6 | , isModified 7 | , checkModifedAsync 8 | ) where 9 | 10 | import Data.Time 11 | import System.Directory 12 | import Control.Monad 13 | import Control.Concurrent 14 | import Control.Concurrent.Async 15 | 16 | import Timing 17 | 18 | -- Check for modifications in a file by comparing its time stamp at regular intervals. 19 | -- Usage is either call mkFileModChecker, poll with isModified and maintain the FileMod 20 | -- state manually or launch a worker thread with checkModifedAsync and poll using the 21 | -- supplied function 22 | 23 | data FileMod = FileMod { fmFileName :: !FilePath 24 | , fmLastTimeStamp :: !UTCTime 25 | , fmLastCheck :: !Double 26 | , fmCheckInterval :: !Double 27 | } 28 | 29 | mkFileModChecker :: FilePath -> Double -> IO FileMod 30 | mkFileModChecker fmFileName fmCheckInterval = do 31 | fmLastCheck <- getTick 32 | fmLastTimeStamp <- getModificationTime fmFileName 33 | return $ FileMod { .. } 34 | 35 | isModified :: FileMod -> IO (FileMod, Bool) 36 | isModified fm@FileMod { .. } = do 37 | tick <- getTick 38 | if tick - fmLastCheck < fmCheckInterval 39 | then return (fm, False) 40 | else do ts <- getModificationTime fmFileName 41 | return ( fm { fmLastCheck = tick, fmLastTimeStamp = ts } 42 | , ts /= fmLastTimeStamp 43 | ) 44 | 45 | checkModifedAsync :: FilePath -> Double -> IO (IO Bool) 46 | checkModifedAsync fn interval = do 47 | mv <- newMVar False 48 | tsInit <- getModificationTime fn 49 | void . async $ 50 | let loop ts = do threadDelay . round $ interval * 1000 * 1000 51 | ts' <- getModificationTime fn 52 | when (ts /= ts') $ modifyMVar_ mv (\_ -> return True) 53 | loop ts' 54 | in loop tsInit 55 | return $ modifyMVar mv (\isMod -> return (False, isMod)) 56 | 57 | -------------------------------------------------------------------------------- /Font.hs: -------------------------------------------------------------------------------- 1 | 2 | module Font (withFontTexture, drawText) where 3 | 4 | import Data.Word (Word8, Word32) 5 | import Data.Bits (shiftL, shiftR, (.&.)) 6 | import Data.Char (ord) 7 | import qualified Foreign.Marshal.Array (withArray) 8 | import qualified Data.Vector.Unboxed as VU 9 | import qualified Graphics.Rendering.OpenGL as GL 10 | import qualified Graphics.Rendering.OpenGL.GLU as GLU (build2DMipmaps) 11 | import Control.Exception 12 | import Control.Monad 13 | 14 | import GLHelpers 15 | import QuadRendering 16 | 17 | withFontTexture :: (GL.TextureObject -> IO a) -> IO a 18 | withFontTexture f = do 19 | traceOnGLError $ Just "withFontTexture begin" 20 | r <- bracket 21 | GL.genObjectName 22 | GL.deleteObjectName 23 | $ \tex -> do 24 | -- Font texture 25 | GL.textureBinding GL.Texture2D GL.$= Just tex 26 | setTextureFiltering GL.Texture2D TFMinOnly 27 | -- Convert font grid bitmap image from Word32 list into byte array 28 | let fontImgArray = 29 | VU.fromListN (fontGridWdh * fontGridHgt * fontCharWdh * fontCharHgt `div` 8) . 30 | concatMap (\x -> map (extractByte x) [0..3]) $ miscFixed6x12Data 31 | :: VU.Vector Word8 32 | -- Extract bits (reversed in byte), store transparent / opaque pixels in square texture 33 | let fontTex = [toRGBA $ texel x y | y <- [0..fontTexWdh - 1], x <- [0..fontTexWdh - 1]] 34 | where texel x y = (srcLookup x y .&. (1 `shiftL` (7 - (srcIdx x y `mod` 8)))) 35 | srcLookup x y | (x < fontImgWdh && y < fontImgHgt) = 36 | fontImgArray VU.! (srcIdx x y `div` 8) 37 | | otherwise = 0 38 | srcIdx x y = x + y * fontImgWdh 39 | toRGBA a = case a of 0 -> 0x0FFFFFF; _ -> 0xFFFFFFFF :: Word32 40 | Foreign.Marshal.Array.withArray fontTex $ \ptr -> 41 | -- TODO: Just use GPU MIP-map generation 42 | GLU.build2DMipmaps GL.Texture2D GL.RGBA' 43 | (fromIntegral fontTexWdh) 44 | (fromIntegral fontTexWdh) 45 | (GL.PixelData GL.RGBA GL.UnsignedByte ptr) 46 | traceOnGLError $ Just "withFontTexture begin inner" 47 | f tex 48 | traceOnGLError $ Just "withFontTexture after cleanup" 49 | return r 50 | 51 | drawText :: GL.TextureObject -> QuadRenderBuffer -> Int -> Int -> Word32 -> String -> IO () 52 | drawText tex qb x y color str = do 53 | let charAndPos = filter (\(_, _, c) -> c /= '\n') . 54 | scanl (\(x', y', _) a -> if a == '\n' 55 | then ((-1) , y' - 1, a) 56 | else (x' + 1, y' , a) 57 | ) ((-1), 0, '\n') $ str 58 | forM_ charAndPos $ \(xc, yc, chr) -> 59 | let xoffs = xc * fontCharWdh 60 | yoffs = yc * (fontCharHgt - 1) 61 | idx = ord chr 62 | tx = (idx `mod` fontGridWdh); 63 | ty = fontGridHgt - ((idx - (idx `mod` fontGridWdh)) `div` fontGridWdh + 1); 64 | ftx = fromIntegral (tx * fontCharWdh) / fromIntegral fontTexWdh; 65 | fty = fromIntegral (ty * fontCharHgt) / fromIntegral fontTexWdh; 66 | fontCharWdhTex = fromIntegral fontCharWdh / fromIntegral fontTexWdh 67 | fontCharHgtTex = fromIntegral fontCharHgt / fromIntegral fontTexWdh 68 | channel i = fromIntegral (extractByte color i) / 255.0 69 | in drawQuad qb 70 | (fromIntegral $ x + xoffs) 71 | (fromIntegral $ y + yoffs) 72 | (fromIntegral $ x + xoffs + fontCharWdh) 73 | (fromIntegral $ y + yoffs + fontCharHgt) 74 | 1 75 | (FCSolid $ RGBA (channel 0) (channel 1) (channel 2) 1) 76 | TRSrcAlpha 77 | (Just tex) 78 | $ QuadUV ftx fty (ftx + fontCharWdhTex) (fty + fontCharHgtTex) 79 | 80 | extractByte :: Word32 -> Int -> Word8 81 | extractByte x i = fromIntegral $ (x .&. (0xFF `shiftL` (i * 8))) `shiftR` (i * 8) 82 | 83 | -- Bit packed font data for a 16 x 16 charcter grid of 6 x 12 pixel characters 84 | fontGridWdh, fontGridHgt, fontImgWdh, fontImgHgt, fontCharWdh, fontCharHgt, fontTexWdh :: Int 85 | fontGridWdh = 16 86 | fontGridHgt = 16 87 | fontImgWdh = 96 88 | fontImgHgt = 192 89 | fontCharWdh = 6 90 | fontCharHgt = 12 91 | fontTexWdh = 256 92 | miscFixed6x12Data :: [Word32] 93 | miscFixed6x12Data = 94 | [ 0x00000000, 0x00000000, 0x20080200, 0x00000000, 0x00000000, 0x10080100, 0x711c2772, 0xc7f100c7 95 | , 0x088f701c, 0x8aa2288a, 0x28ca8828, 0x944889a2, 0x8aa2288a, 0x28aa8028, 0xa2288aa2, 0x8aa2288b 96 | , 0x289abe28, 0xa2288aa2, 0x711cc77a, 0x287a00c7, 0x222f8aa2, 0x00000008, 0x00000800, 0x00080000 97 | , 0x5208c252, 0x820000c5, 0x14885014, 0x2104a421, 0x010100a0, 0x00400008, 0x00000050, 0x00000000 98 | , 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00001800, 0x00000000, 0x00000000 99 | , 0x00000400, 0x00000000, 0x799ee779, 0xc7719ce7, 0x1cc7711c, 0x8aa2288a, 0x0882222a, 0x08822020 100 | , 0x799ee779, 0xcff320e7, 0x0882203c, 0x08822008, 0x288aa222, 0x088220a2, 0x711cc771, 0xc7711cc7 101 | , 0x1886611c, 0x00000000, 0x00000080, 0x00000000, 0x512c8520, 0x85200040, 0x14852014, 0x001a4240 102 | , 0x42400080, 0x00424000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000 103 | , 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00800000, 0x00000000, 0x711c2772, 0xc77100c7 104 | , 0x2c84701c, 0x8aa2284a, 0x28caa228, 0x228788a2, 0x8aa2684a, 0x28aa9428, 0xa48488a2, 0x8aa2a8ea 105 | , 0x28aa8828, 0xa88488a2, 0x8aa2284b, 0x28aa9428, 0xa44489a2, 0x8aa2284a, 0x289aa228, 0x22278aa2 106 | , 0x711c2772, 0x287200c7, 0x1c248aa2, 0x00000000, 0x00080000, 0x00000000, 0x5208c202, 0x820000c5 107 | , 0x00805014, 0x2104a401, 0x010100a0, 0x00400008, 0x00000000, 0x00001800, 0x00000000, 0x00000000 108 | , 0x00000400, 0x00000000, 0x8aa2288a, 0xeffb9c2b, 0x1cc771be, 0x8aa2288a, 0x0882222a, 0x08822020 109 | , 0x8aa2288a, 0x0882202a, 0x08822020, 0xfbbeeffb, 0xcff320ef, 0x0882203c, 0x8aa2288a, 0x0882202a 110 | , 0x08822020, 0x8aa2288a, 0x0882222a, 0x08822020, 0x711cc771, 0xeffb9cc7, 0x1cc771be, 0x00000000 111 | , 0x00000080, 0x00000000, 0x512c8520, 0x85200040, 0x14852014, 0x001a4240, 0x42400080, 0x00424000 112 | , 0x02000000, 0x00600000, 0x00000000, 0x02000000, 0x00100000, 0x00000000, 0x0300e003, 0x000080a2 113 | , 0x1ce11028, 0x02000000, 0x00008062, 0x22811014, 0x02008000, 0x00008022, 0x9047780a, 0x02008000 114 | , 0x00008c26, 0x08255014, 0x0200e003, 0x00008c2e, 0x08a33028, 0x40188730, 0xc701800e, 0x004d5100 115 | , 0x20048248, 0x8000800e, 0x08024100, 0x10080148, 0x82008007, 0x00044100, 0x00040530, 0x85010000 116 | , 0x0002c300, 0x00180200, 0x82000000, 0x000c4100, 0x00000000, 0x00000000, 0x00000000, 0x00000200 117 | , 0x00000000, 0x00000000, 0xa82c8700, 0xe0011c82, 0x8007000a, 0x50928a00, 0x10020282, 0x40080814 118 | , 0x8b108a00, 0x50020ce2, 0x400a0828, 0x50b88a00, 0x90021280, 0x40caf914, 0xab108700, 0x570212e2 119 | , 0x400b000a, 0x01120200, 0x10020c42, 0x40080000, 0x020c8000, 0xe3011022, 0x80070000, 0x00000000 120 | , 0x05500e00, 0x3e000000, 0x00000000, 0x03000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000 121 | , 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000 122 | , 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000 123 | , 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000 124 | , 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000 125 | , 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000 126 | , 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000 127 | , 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000 128 | , 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000 129 | , 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000 130 | , 0x00002080, 0x00020000, 0x00000000, 0x00002080, 0x00010000, 0x00002104, 0x193ce8f1, 0x8f8814a2 131 | , 0x00802088, 0x2202288a, 0x44512a65, 0x00802008, 0x221c288a, 0x2222aa28, 0x00892008, 0x22a02c8a 132 | , 0x2152a228, 0x804a2010, 0xfa1eebf1, 0x2f8aa228, 0x80842088, 0x20000000, 0x00000000, 0x00802008 133 | , 0x20000000, 0x00000000, 0x00802008, 0x00000000, 0x00000000, 0x00002104, 0x00000000, 0x00000000 134 | , 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x03001c00, 0x00000000, 0x00000000 135 | , 0x04000200, 0x00000080, 0x791cef01, 0xc0891ec4, 0x9ca872a2, 0x8aa22802, 0x80882204, 0xa2a822a4 136 | , 0x8ba0e801, 0x808822c4, 0xa2a822b8, 0x8aa22800, 0x8088222e, 0xa2ac22a4, 0x791ccf01, 0x81f11cc4 137 | , 0x1c4b23a2, 0x08000810, 0x00808004, 0x00002020, 0x08000820, 0x80800003, 0x000060a0, 0x00000040 138 | , 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000 139 | , 0x00000000, 0x00000000, 0x3e000000, 0x00000000, 0x00000000, 0x00c0011c, 0x219ca881, 0x8f8814c2 140 | , 0x00400890, 0x22224982, 0x88882a25, 0x00401010, 0x2202aa82, 0x84502a25, 0x00401010, 0x221c2ff2 141 | , 0x8220a228, 0x00402010, 0x22a0288a, 0x4151a228, 0x00404010, 0x22a2288a, 0x208aa228, 0x80484090 142 | , 0xfa1ccff1, 0x2f8aa228, 0x00458090, 0x00000000, 0x00000000, 0x00c2011c, 0x00000000, 0x00000000 143 | , 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000 144 | , 0x00000000, 0x00000000, 0xf31c2f72, 0xc6891ce8, 0x9c28fa22, 0x4aa22482, 0x89882208, 0xa2288224 145 | , 0x4aa024ba, 0x81882608, 0xa2298228, 0x4b20e7ab, 0x81f820cf, 0xa22a8230, 0x4aa024ba, 0x81882008 146 | , 0xa2ac8228, 0x4aa2248a, 0x81882208, 0xa2688324, 0xf31ccf71, 0xc3899cef, 0x9c2882a2, 0x00000000 147 | , 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000 148 | , 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000030, 0x119ccf31, 0x867108c7 149 | , 0x08000018, 0x12228448, 0x46888828, 0x00041018, 0xf8028248, 0x20888828, 0x08e22300, 0x900c8148 150 | , 0xe671042f, 0x08014018, 0x53848048, 0x268a04c8, 0x04e22318, 0x32828849, 0x208a0204, 0x22041000 151 | , 0x133e8730, 0xc0713ee3, 0x1c000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000 152 | , 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x20000000 153 | , 0x00110000, 0x0000c000, 0x72148000, 0x82208066, 0x20066000, 0xaa3e0000, 0x8a200069, 0x10066088 154 | , 0x29148000, 0x4740800a, 0x10000008, 0x70148000, 0x42400084, 0x08e0033e, 0xa03e8000, 0x4740004a 155 | , 0x04000008, 0xab148500, 0x8a20082a, 0x04000088, 0x73008500, 0x82200824, 0x02000000, 0x20000500 156 | , 0x00110800, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000 157 | , 0xfc000000, 0x80200082, 0x00000000, 0x00000000, 0x80200082, 0x00000000, 0x00000000, 0x8f200082 158 | , 0x000b51be, 0x003f0000, 0x80200082, 0x80045100, 0x00000000, 0x81200082, 0x00e453b0, 0x00c00f00 159 | , 0x86fc3ffe, 0x0c8e500c, 0x00000000, 0x88000882, 0x0ce4fb02, 0x00000000, 0x86000882, 0x8044000c 160 | , 0x0000f003, 0x81000882, 0x004300b0, 0x00000000, 0x80000882, 0x00000000, 0x00000000, 0x80000882 161 | , 0x00000000, 0x000000fc, 0x80000882, 0x00000000, 0x00400500, 0x00000000, 0x08002000, 0x00800a00 162 | , 0x00000000, 0x08002000, 0x204405a8, 0x00f800a2, 0x08002000, 0x20848a00, 0x000000a3, 0x08002000 163 | , 0x3044c589, 0x002000c2, 0x08002000, 0xa084ea03, 0x002080a3, 0xff03e038, 0xb96ec589, 0x00f800c0 164 | , 0x08020008, 0xc2a88a00, 0x00200c0e, 0x08020008, 0x827805a8, 0x00201208, 0x08020008, 0xe2a80a00 165 | , 0x00001208, 0x08020008, 0x01680500, 0x00000c88, 0x08020008, 0x00800a00, 0x00000000, 0x08020008 166 | ] 167 | 168 | -------------------------------------------------------------------------------- /Fractal2D.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE BangPatterns, TypeFamilies #-} 3 | 4 | module Fractal2D ( mandelbrot 5 | , juliaAnimated 6 | ) where 7 | 8 | import Control.Loop 9 | import Control.Monad 10 | import Data.Complex 11 | import Data.Word 12 | import Data.Bits 13 | import qualified Data.Vector.Storable.Mutable as VSM 14 | 15 | import ConcurrentSegments 16 | 17 | -- A few simple 2D fractals, just for testing 18 | 19 | magnitudeSq :: RealFloat a => Complex a -> a 20 | magnitudeSq c = realPart c * realPart c + imagPart c * imagPart c 21 | 22 | -- http://linas.org/art-gallery/escape/escape.html 23 | -- http://en.wikipedia.org/wiki/Mandelbrot_set#Continuous_.28smooth.29_coloring 24 | fractionalIterCnt :: Int -> Complex Float -> Float 25 | fractionalIterCnt iter escZ = max 0 $ fromIntegral iter - (log (log $ magnitudeSq escZ)) / log 2 26 | 27 | -- Mandelbrot Set 28 | -- 29 | -- http://en.wikipedia.org/wiki/Mandelbrot_set#Computer_drawings 30 | mandelbrot :: Int -> Int -> VSM.IOVector Word32 -> Bool -> IO () 31 | mandelbrot w h fb smooth = 32 | forLoop 0 (< h) (+ 1) $ \py -> forLoop 0 (< w) (+ 1) $ \px -> 33 | let idx = px + py * w 34 | fpx = fromIntegral px :: Float 35 | fpy = fromIntegral py :: Float 36 | fw = fromIntegral w :: Float 37 | fh = fromIntegral h :: Float 38 | ratio = fw / fh 39 | y = (fpy / fh) * 2 - 1 -- Y axis is [-1, +1] 40 | xshift = (- 2) - ((2 * ratio - 2.5) * 0.5) 41 | x = (fpx / fw) * 2 * ratio + xshift -- Keep aspect and center [-1, +0.5] 42 | c = x :+ y 43 | maxIter = 40 44 | (iCnt, escZ) = go (0 :: Int) (0 :+ 0) 45 | go iter z | (iter == maxIter) || -- Iteration limit? 46 | magnitudeSq z > 4 * 4 = (iter, z) -- Hit escape radius? 47 | | otherwise = let newZ = z * z + c 48 | in if newZ == z -- Simple 1-cycle detection 49 | then (maxIter, z) 50 | else go (iter + 1) newZ 51 | icCont | iCnt == maxIter = fromIntegral maxIter -- Interior in case of limit 52 | | otherwise = fractionalIterCnt iCnt escZ 53 | toGreen v = v `unsafeShiftL` 8 54 | in VSM.unsafeWrite fb idx . toGreen . truncate $ 55 | if smooth 56 | then icCont / fromIntegral maxIter * 255 :: Float 57 | else fromIntegral iCnt / fromIntegral maxIter * 255 :: Float 58 | 59 | -- Julia Set, computed in parallel 60 | -- 61 | -- http://en.wikipedia.org/wiki/Julia_set 62 | -- http://www.relativitybook.com/CoolStuff/julia_set.html 63 | juliaAnimated :: Int -> Int -> VSM.IOVector Word32 -> Bool -> Double -> IO () 64 | juliaAnimated w h fb smooth tick = 65 | let !fTick = realToFrac tick :: Float 66 | !scaledTick = snd (properFraction $ fTick / 17 :: (Int, Float)) 67 | !scaledTick2 = snd (properFraction $ fTick / 61 :: (Int, Float)) 68 | !scaledTick3 = snd (properFraction $ fTick / 71 :: (Int, Float)) 69 | !twoPi = scaledTick * 2 * pi 70 | !juliaR = sin twoPi * max 0.7 scaledTick2 71 | !juliaI = cos twoPi * max 0.7 scaledTick3 72 | !fw = fromIntegral w :: Float 73 | !fh = fromIntegral h :: Float 74 | !ratio = fw / fh 75 | !xshift = 1.45 * ratio 76 | !maxIter = 40 77 | doSeg lo hi = forLoop lo (< hi) (+ 1) $ \py -> forLoop 0 (< w) (+ 1) $ \px -> 78 | let idx = px + py * w 79 | fpx = fromIntegral px :: Float 80 | fpy = fromIntegral py :: Float 81 | y = (fpy / fh) * 2.9 - 1.45 -- Y axis is [-1.45, +1.45] 82 | x = (fpx / fw) * 2.9 * ratio - xshift -- Keep aspect and center 83 | c = x :+ y 84 | (iCnt, escZ) = go (0 :: Int) c 85 | go iter z | (iter == maxIter) || -- Iteration limit? 86 | magnitudeSq z > 4 * 4 = (iter, z) -- Hit escape radius? 87 | | otherwise = let newZ = z * z + (juliaR :+ juliaI) 88 | in if newZ == z -- Simple 1-cycle detection 89 | then (maxIter, z) 90 | else go (iter + 1) newZ 91 | icCont | iCnt == maxIter = fromIntegral maxIter -- Interior in case of limit 92 | | otherwise = fractionalIterCnt iCnt escZ 93 | toGreen v = v `unsafeShiftL` 8 94 | in VSM.unsafeWrite fb idx . toGreen . truncate $ 95 | if smooth 96 | then icCont / fromIntegral maxIter * 255 :: Float 97 | else fromIntegral iCnt / fromIntegral maxIter * 255 :: Float 98 | in void $ forSegmentsConcurrently Nothing 0 h doSeg 99 | 100 | -------------------------------------------------------------------------------- /FrameBuffer.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE RecordWildCards, FlexibleContexts, LambdaCase, ScopedTypeVariables #-} 3 | 4 | module FrameBuffer ( withFrameBuffer 5 | , fillFrameBuffer 6 | , drawFrameBuffer 7 | , saveFrameBufferToPNG 8 | , resizeFrameBuffer 9 | , getFrameBufferDim 10 | , drawIntoFrameBuffer 11 | , FrameBuffer 12 | , Downscaling(..) 13 | ) where 14 | 15 | import Control.Monad 16 | import Control.Exception 17 | import Control.Monad.Trans 18 | import Control.Monad.Trans.Control 19 | import qualified Graphics.Rendering.OpenGL as GL 20 | import qualified Graphics.GL as GLR 21 | import Data.Word 22 | import Data.IORef 23 | import qualified Data.Vector.Storable.Mutable as VSM 24 | import qualified Data.Vector.Storable as VS 25 | import Text.Printf 26 | import Foreign.Storable 27 | import Foreign.Ptr 28 | import Foreign.ForeignPtr 29 | import qualified Codec.Picture as JP 30 | 31 | import GLHelpers 32 | import QuadRendering 33 | import Trace 34 | 35 | -- Simple 'frame buffer' interface where we can either directly write into an RGBA8 vector CPU 36 | -- side or render into a texture with the GPU and have it appear on screen, optionally with 37 | -- super sampling 38 | 39 | data FrameBuffer = FrameBuffer { fbTex :: !GL.TextureObject 40 | -- Ping-pong with two PBOs doesn't seem to help upload 41 | -- speed as long as we orphan our buffers anyway 42 | , fbPBO :: !GL.BufferObject 43 | , fbDim :: IORef (Int, Int) 44 | , fbFBO :: !GL.FramebufferObject 45 | , fbDownscaling :: !Downscaling 46 | } 47 | 48 | data Downscaling = HighQualityDownscaling | LowQualityDownscaling 49 | deriving (Show, Eq) 50 | 51 | withFrameBuffer :: Int -> Int -> Downscaling -> (FrameBuffer -> IO a) -> IO a 52 | withFrameBuffer w h fbDownscaling f = do 53 | traceOnGLError $ Just "withFrameBuffer begin" 54 | r <- bracket GL.genObjectName GL.deleteObjectName $ \fbTex -> 55 | bracket GL.genObjectName GL.deleteObjectName $ \fbPBO -> 56 | bracket GL.genObjectName GL.deleteObjectName $ \fbFBO -> do 57 | -- Setup texture 58 | GL.textureBinding GL.Texture2D GL.$= Just fbTex 59 | setTextureFiltering GL.Texture2D $ 60 | if fbDownscaling == HighQualityDownscaling 61 | then TFMinMag -- Need to generate MIP-maps after every change 62 | else TFMagOnly 63 | setTextureClampST GL.Texture2D -- No wrap-around artifacts at the FB borders 64 | -- Setup FBO 65 | GL.bindFramebuffer GL.Framebuffer GL.$= fbFBO 66 | GL.framebufferTexture2D GL.Framebuffer (GL.ColorAttachment 0) GL.Texture2D fbTex 0 67 | GL.drawBuffer GL.$= GL.FBOColorAttachment 0 68 | GL.bindFramebuffer GL.Framebuffer GL.$= GL.defaultFramebufferObject 69 | -- Setup texture, dimensions 70 | fbDim <- newIORef (0, 0) 71 | let fb = FrameBuffer { .. } 72 | resizeFrameBuffer fb w h 73 | -- Inner 74 | traceOnGLError $ Just "withFrameBuffer begin inner" 75 | f fb 76 | traceOnGLError $ Just "withFrameBuffer after cleanup" 77 | return r 78 | 79 | resizeFrameBuffer :: FrameBuffer -> Int -> Int -> IO () 80 | resizeFrameBuffer fb w h = do 81 | -- Limit requested size by maximum available and store. This can lead to some 82 | -- blurriness when drawing with high quality downscaling. For instance, a 640^2 83 | -- window size with a maximum render size of 1024^2 and 2x super sampling will 84 | -- not get the requested 1280^2, and there won't be a clean 1:4 pixel ratio, 85 | -- leading to some blurriness from the MIP-mapping filter. This is of course 86 | -- preferable to failing to allocate the FB altogether, but is the reason why 87 | -- sometimes higher levels of super sampling will reduce sharpness in the preview 88 | (maxWdh, maxHgt) <- maxRenderSize 89 | let aspect = fromIntegral w / fromIntegral h :: Double 90 | wdiff = max 0 $ w - maxWdh 91 | (clampWW, clampWH) = ( w - wdiff 92 | , truncate $ fromIntegral h - fromIntegral wdiff / aspect 93 | ) 94 | hdiff = max 0 $ clampWH - maxHgt 95 | (clampHW, clampHH) = ( truncate $ fromIntegral clampWW - fromIntegral hdiff * aspect 96 | , clampWH - hdiff 97 | ) 98 | writeIORef (fbDim fb) (clampHW, clampHH) 99 | -- Allocate texture and clear contents to black 100 | GL.textureBinding GL.Texture2D GL.$= Just (fbTex fb) 101 | GL.texImage2D GL.Texture2D 102 | GL.NoProxy 103 | 0 104 | GL.RGBA8 105 | (GL.TextureSize2D (fromIntegral clampHW) (fromIntegral clampHH)) 106 | 0 107 | (GL.PixelData GL.RGBA GL.UnsignedByte nullPtr) 108 | GL.textureBinding GL.Texture2D GL.$= Nothing 109 | void . drawIntoFrameBuffer fb $ \_ _ -> do 110 | GL.clearColor GL.$= (GL.Color4 0 0 0 1 :: GL.Color4 GL.GLclampf) 111 | GL.clear [GL.ColorBuffer] 112 | 113 | getFrameBufferDim :: FrameBuffer -> IO (Int, Int) 114 | getFrameBufferDim fb = readIORef $ fbDim fb 115 | 116 | -- Specify the frame buffer contents by filling a mutable vector 117 | fillFrameBuffer :: forall a m s. (MonadBaseControl IO m, MonadIO m) 118 | => FrameBuffer 119 | -> (Int -> Int -> VSM.MVector s Word32 -> m a) -- Run inner inside the base monad 120 | -> m (Maybe a) -- Return Nothing if mapping fails 121 | fillFrameBuffer fb@(FrameBuffer { .. }) f = do 122 | -- Map. If this function is nested inside another fillFrameBuffer with the same FrameBuffer, 123 | -- the mapping operation will fail as OpenGL does not allow two concurrent mappings. Hence, 124 | -- no need to check for this explicitly 125 | (w, h) <- liftIO $ readIORef fbDim 126 | r <- control $ \run -> liftIO $ do 127 | let bindPBO = GL.bindBuffer GL.PixelUnpackBuffer GL.$= Just fbPBO 128 | -- Prevent stalls by just allocating new PBO storage every time 129 | in bindPBO >> allocPBO fb >> GL.withMappedBuffer 130 | GL.PixelUnpackBuffer 131 | GL.WriteOnly 132 | ( \ptrPBO -> newForeignPtr_ ptrPBO >>= \fpPBO -> 133 | finally 134 | -- Run in outer base monad 135 | ( run $ Just <$> f w h (VSM.unsafeFromForeignPtr0 fpPBO $ fbSizeB w h) ) 136 | bindPBO -- Make sure we rebind our PBO, otherwise 137 | -- unmapping might fail if the inner 138 | -- modified the bound buffer objects 139 | ) 140 | ( \mf -> do traceS TLError $ "fillFrameBuffer - PBO mapping failure: " ++ show mf 141 | -- Looks like since the 1.0.0.0 change in monad-control we need 142 | -- some type annotations for this to work 143 | run $ (return Nothing :: m (Maybe a)) 144 | ) 145 | liftIO $ do 146 | -- Update frame buffer texture from the PBO data 147 | GL.textureBinding GL.Texture2D GL.$= Just fbTex 148 | GL.texSubImage2D GL.Texture2D 149 | 0 150 | (GL.TexturePosition2D 0 0) 151 | (GL.TextureSize2D (fromIntegral w) (fromIntegral h)) 152 | (GL.PixelData GL.RGBA GL.UnsignedByte nullPtr) 153 | when (fbDownscaling == HighQualityDownscaling) $ 154 | GLR.glGenerateMipmap GLR.GL_TEXTURE_2D 155 | -- Done 156 | GL.bindBuffer GL.PixelUnpackBuffer GL.$= Nothing 157 | GL.textureBinding GL.Texture2D GL.$= Nothing 158 | return r 159 | 160 | -- Specify the frame buffer contents by rendering into it 161 | -- http://www.opengl-tutorial.org/intermediate-tutorials/tutorial-14-render-to-texture/ 162 | drawIntoFrameBuffer :: forall a m. (MonadBaseControl IO m, MonadIO m) 163 | => FrameBuffer 164 | -> (Int -> Int -> m a) 165 | -> m (Maybe a) 166 | drawIntoFrameBuffer FrameBuffer { .. } f = do 167 | oldVP <- liftIO $ GL.get GL.viewport 168 | control $ \run -> finally 169 | ( do GL.bindFramebuffer GL.Framebuffer GL.$= fbFBO 170 | (w, h) <- readIORef fbDim 171 | setupViewport w h 172 | -- GL.framebufferStatus is unfortunately broken in OpenGL 2.9.2.0 173 | -- (see https://github.com/haskell-opengl/OpenGL/issues/51), so 174 | -- we're using the raw APIs as a backup 175 | GLR.glCheckFramebufferStatus GLR.GL_FRAMEBUFFER >>= \case 176 | r | r == GLR.GL_FRAMEBUFFER_COMPLETE -> run $ Just <$> f w h 177 | | otherwise -> do 178 | traceS TLError $ printf 179 | "drawIntoFrameBuffer, glCheckFramebufferStatus: 0x%x" 180 | (fromIntegral r :: Int) 181 | -- Looks like since the 1.0.0.0 change in monad-control we need 182 | -- some type annotations for this to work 183 | run $ (return Nothing :: m (Maybe a)) 184 | ) 185 | ( do GL.bindFramebuffer GL.Framebuffer GL.$= GL.defaultFramebufferObject 186 | GL.viewport GL.$= oldVP 187 | when (fbDownscaling == HighQualityDownscaling) $ do 188 | -- TODO: When rendering tiles we're computing the MIP-chain for the 189 | -- full frame buffer texture after rendering each individual tile. 190 | -- We would need to make the frame buffer tiling aware and render 191 | -- into a tile sized texture (later copied into the full frame 192 | -- buffer) to address this 193 | GL.textureBinding GL.Texture2D GL.$= Just fbTex 194 | GLR.glGenerateMipmap GLR.GL_TEXTURE_2D 195 | GL.textureBinding GL.Texture2D GL.$= Nothing 196 | ) 197 | 198 | -- Draw quad with frame buffer texture 199 | drawFrameBuffer :: FrameBuffer -> QuadRenderBuffer -> Float -> Float -> Float -> Float -> IO () 200 | drawFrameBuffer FrameBuffer { .. } qb x1 y1 x2 y2 = 201 | drawQuad qb x1 y1 x2 y2 10 FCWhite TRNone (Just fbTex) QuadUVDefault 202 | 203 | fbSizeB :: Integral a => Int -> Int -> a 204 | fbSizeB w h = fromIntegral $ w * h * sizeOf (0 :: Word32) 205 | 206 | -- Allocate new frame buffer sized backing storage for the bound PBO 207 | allocPBO :: FrameBuffer -> IO () 208 | allocPBO FrameBuffer { .. } = do 209 | (w, h) <- readIORef fbDim 210 | GL.bufferData GL.PixelUnpackBuffer GL.$= ( fbSizeB w h -- In bytes 211 | , nullPtr -- Just allocate 212 | , GL.StreamDraw -- Dynamic 213 | ) 214 | 215 | saveFrameBufferToPNG :: FrameBuffer -> FilePath -> IO () 216 | saveFrameBufferToPNG FrameBuffer { .. } fn = do 217 | GL.textureBinding GL.Texture2D GL.$= Just fbTex 218 | (w, h) <- getCurTex2DSize 219 | img <- VSM.new $ fbSizeB w h :: IO (VSM.IOVector JP.Pixel8) 220 | VSM.unsafeWith img $ GL.getTexImage GL.Texture2D 0 . GL.PixelData GL.RGBA GL.UnsignedByte 221 | GL.textureBinding GL.Texture2D GL.$= Nothing 222 | let flipAndFixA img' = 223 | JP.generateImage 224 | ( \x y -> case JP.pixelAt img' x (h - 1 - y) of 225 | JP.PixelRGBA8 r g b _ -> JP.PixelRGBA8 r g b 0xFF 226 | ) w h 227 | in JP.savePngImage fn . JP.ImageRGBA8 . flipAndFixA . JP.Image w h =<< VS.freeze img 228 | traceS TLInfo $ "Saved screenshot of framebuffer to " ++ fn 229 | 230 | -------------------------------------------------------------------------------- /GLFWHelpers.hs: -------------------------------------------------------------------------------- 1 | 2 | module GLFWHelpers ( withWindow 3 | , GLFWEvent(..) 4 | , highDPIScaleFactor 5 | ) where 6 | 7 | import Control.Exception 8 | import Control.Monad 9 | import Control.Concurrent.STM 10 | import qualified Graphics.UI.GLFW as GLFW 11 | import qualified Graphics.GL as GLR 12 | 13 | -- Various utility functions related to GLFW 14 | 15 | withWindow :: Int -> Int -> Bool -> String -> TQueue GLFWEvent -> (GLFW.Window -> IO ()) -> IO () 16 | withWindow w h srgb title tq = 17 | bracket 18 | ( do GLFW.setErrorCallback . Just $ errorCallback tq 19 | True <- GLFW.init 20 | -- GLFW.windowHint $ GLFW.WindowHint'Samples 4 21 | -- GLFW.windowHint $ GLFW.WindowHint'Decorated False 22 | GLFW.windowHint $ GLFW.WindowHint'Resizable True 23 | when srgb . GLFW.windowHint $ GLFW.WindowHint'sRGBCapable True 24 | modernOpenGL 25 | Just window <- GLFW.createWindow w h title Nothing Nothing 26 | registerCallbacks window tq 27 | GLFW.makeContextCurrent $ Just window 28 | when srgb $ GLR.glEnable GLR.GL_FRAMEBUFFER_SRGB 29 | return window 30 | ) 31 | ( \window -> do GLFW.destroyWindow window 32 | GLFW.terminate 33 | ) 34 | 35 | -- >2.1, no backwards compatibility on OS X 36 | -- http://www.glfw.org/faq.html#how-do-i-create-an-opengl-30-context 37 | modernOpenGL :: IO () 38 | modernOpenGL = do 39 | GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core 40 | GLFW.windowHint $ GLFW.WindowHint'OpenGLForwardCompat True 41 | GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor 3 42 | GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor 3 43 | 44 | highDPIScaleFactor :: GLFW.Window -> IO Double 45 | highDPIScaleFactor win = do 46 | (scWdh, _) <- GLFW.getWindowSize win 47 | (pxWdh, _) <- GLFW.getFramebufferSize win 48 | return $ fromIntegral pxWdh / fromIntegral scWdh 49 | 50 | -- Convert GLFW callbacks into events delivered to a queue 51 | 52 | data GLFWEvent = GLFWEventError 53 | !GLFW.Error 54 | !String 55 | | GLFWEventKey 56 | !GLFW.Window 57 | !GLFW.Key 58 | !Int 59 | !GLFW.KeyState 60 | !GLFW.ModifierKeys 61 | | GLFWEventWindowSize 62 | !GLFW.Window 63 | !Int 64 | !Int 65 | | GLFWEventFramebufferSize 66 | !GLFW.Window 67 | !Int 68 | !Int 69 | | GLFWEventMouseButton 70 | !GLFW.Window 71 | !GLFW.MouseButton 72 | !GLFW.MouseButtonState 73 | !GLFW.ModifierKeys 74 | | GLFWEventCursorPos 75 | !GLFW.Window 76 | !Double 77 | !Double 78 | | GLFWEventScroll 79 | !GLFW.Window 80 | !Double 81 | !Double 82 | 83 | errorCallback :: TQueue GLFWEvent -> GLFW.Error -> String -> IO () 84 | errorCallback tq e s = atomically . writeTQueue tq $ GLFWEventError e s 85 | 86 | keyCallback :: TQueue GLFWEvent 87 | -> GLFW.Window 88 | -> GLFW.Key 89 | -> Int 90 | -> GLFW.KeyState 91 | -> GLFW.ModifierKeys -> IO () 92 | keyCallback tq win k sc ka mk = atomically . writeTQueue tq $ GLFWEventKey win k sc ka mk 93 | 94 | windowSizeCallback :: TQueue GLFWEvent -> GLFW.Window -> Int -> Int -> IO () 95 | windowSizeCallback tq win w h = atomically . writeTQueue tq $ GLFWEventWindowSize win w h 96 | 97 | framebufferSizeCallback :: TQueue GLFWEvent -> GLFW.Window -> Int -> Int -> IO () 98 | framebufferSizeCallback tq win w h = 99 | atomically . writeTQueue tq $ GLFWEventFramebufferSize win w h 100 | 101 | mouseButtonCallback :: TQueue GLFWEvent 102 | -> GLFW.Window 103 | -> GLFW.MouseButton 104 | -> GLFW.MouseButtonState 105 | -> GLFW.ModifierKeys 106 | -> IO () 107 | mouseButtonCallback tq win bttn st mk = 108 | atomically . writeTQueue tq $ GLFWEventMouseButton win bttn st mk 109 | 110 | cursorPosCallback :: TQueue GLFWEvent -> GLFW.Window -> Double -> Double -> IO () 111 | cursorPosCallback tq win x y = atomically . writeTQueue tq $ GLFWEventCursorPos win x y 112 | 113 | scrollCallback :: TQueue GLFWEvent -> GLFW.Window -> Double -> Double -> IO () 114 | scrollCallback tq win x y = atomically . writeTQueue tq $ GLFWEventScroll win x y 115 | 116 | registerCallbacks :: GLFW.Window -> TQueue GLFWEvent -> IO () 117 | registerCallbacks window tq = do 118 | GLFW.setKeyCallback window . Just $ keyCallback tq 119 | GLFW.setWindowSizeCallback window . Just $ windowSizeCallback tq 120 | GLFW.setFramebufferSizeCallback window . Just $ framebufferSizeCallback tq 121 | GLFW.setMouseButtonCallback window . Just $ mouseButtonCallback tq 122 | GLFW.setCursorPosCallback window . Just $ cursorPosCallback tq 123 | GLFW.setScrollCallback window . Just $ scrollCallback tq 124 | 125 | -------------------------------------------------------------------------------- /GLHelpers.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE LambdaCase, ScopedTypeVariables #-} 3 | 4 | module GLHelpers ( getGLStrings 5 | , getGLExtensionList 6 | , traceOnGLError 7 | , throwOnGLError 8 | , getCurTex2DSize 9 | , disableVAOAndShaders 10 | , Transparency(..) 11 | , setTransparency 12 | , setTextureFiltering 13 | , setTextureClampST 14 | , TextureFiltering(..) 15 | , setupViewport 16 | , maxRenderSize 17 | , genObjectNameResource 18 | ) where 19 | 20 | import qualified Graphics.Rendering.OpenGL as GL 21 | import qualified Graphics.GL as GLR 22 | import qualified Graphics.UI.GLFW as GLFW 23 | import Control.Monad 24 | import Control.Exception 25 | import Control.Monad.Trans.Resource 26 | import Text.Printf 27 | import Data.Maybe 28 | import Foreign.Marshal.Alloc 29 | import Foreign.Marshal.Array 30 | import Foreign.Storable 31 | import Foreign.Ptr 32 | import Foreign.C.String 33 | 34 | import Trace 35 | 36 | -- Various utility functions related to OpenGL 37 | 38 | getErrors :: Maybe String -> IO (Maybe String) 39 | getErrors context = 40 | GL.get GL.errors >>= \case 41 | [] -> return Nothing 42 | err -> return . Just $ 43 | "OpenGL Error" ++ maybe ": " (\c -> " (" ++ c ++ "): ") context ++ show err 44 | 45 | traceOnGLError :: Maybe String -> IO () 46 | traceOnGLError context = getErrors context >>= maybe (return ()) (traceS TLError) 47 | 48 | throwOnGLError :: Maybe String -> IO () 49 | throwOnGLError context = getErrors context >>= maybe (return ()) (throwIO . ErrorCall) 50 | 51 | -- No wrapper around the OpenGL 3 extension APIs yet, have to use the raw ones 52 | getNumExtensions :: IO Int 53 | getNumExtensions = 54 | alloca $ \(ptr :: Ptr GLR.GLint) -> 55 | GLR.glGetIntegerv GLR.GL_NUM_EXTENSIONS ptr >> fromIntegral <$> peek ptr 56 | getExtensionStr :: Int -> IO String 57 | getExtensionStr i = 58 | peekCString =<< castPtr <$> GLR.glGetStringi GLR.GL_EXTENSIONS (fromIntegral i) 59 | 60 | getGLExtensionList :: IO [String] 61 | getGLExtensionList = 62 | getNumExtensions >>= \numExt -> forM [0..numExt - 1] $ \i -> getExtensionStr i 63 | 64 | -- Take the minimum of the maximum viewport and texture size to figure out 65 | -- how large of a frame buffer we can allocate and render into 66 | maxRenderSize :: IO (Int, Int) 67 | maxRenderSize = 68 | withArray [0, 0] $ \ptr -> do 69 | GLR.glGetIntegerv GLR.GL_MAX_VIEWPORT_DIMS ptr 70 | [vpWdh, vpHgt] <- peekArray 2 ptr 71 | GLR.glGetIntegerv GLR.GL_MAX_TEXTURE_SIZE ptr 72 | texDim <- peek ptr 73 | return (fromIntegral $ min vpWdh texDim, fromIntegral $ max vpHgt texDim) 74 | 75 | getGLStrings :: IO String 76 | getGLStrings = do 77 | numExt <- getNumExtensions 78 | (w, h) <- maxRenderSize 79 | printf 80 | ( "OpenGL - Vendor: %s · Renderer: %s · Version: %s · GLSL: %s · Num Extensions: %i" ++ 81 | " · Max FB Res: %ix%i\nGLFW - Version: %s" 82 | ) 83 | <$> GL.get GL.vendor 84 | <*> GL.get GL.renderer 85 | <*> GL.get GL.glVersion 86 | <*> GL.get GL.shadingLanguageVersion 87 | <*> pure numExt 88 | <*> pure w 89 | <*> pure h 90 | <*> (fromJust <$> GLFW.getVersionString) 91 | 92 | getCurTex2DSize :: IO (Int, Int) 93 | getCurTex2DSize = (\(GL.TextureSize2D w h) -> (fromIntegral w, fromIntegral h)) 94 | <$> (GL.get $ GL.textureSize2D GL.Texture2D 0) 95 | 96 | data TextureFiltering = TFNone | TFMinMag | TFMinOnly | TFMagOnly 97 | 98 | setTextureFiltering :: GL.ParameterizedTextureTarget t => t -> TextureFiltering -> IO () 99 | setTextureFiltering target TFNone = 100 | GL.textureFilter target GL.$= ((GL.Nearest, Nothing ), GL.Nearest) 101 | setTextureFiltering target TFMinMag = 102 | GL.textureFilter target GL.$= ((GL.Linear', Just GL.Linear'), GL.Linear') 103 | setTextureFiltering target TFMinOnly = 104 | GL.textureFilter target GL.$= ((GL.Linear', Just GL.Linear'), GL.Nearest) 105 | setTextureFiltering target TFMagOnly = 106 | GL.textureFilter target GL.$= ((GL.Nearest, Nothing ), GL.Linear') 107 | 108 | setTextureClampST :: GL.ParameterizedTextureTarget t => t -> IO () 109 | setTextureClampST target = 110 | forM_ [GL.S, GL.T] $ 111 | \x -> GL.textureWrapMode target x GL.$= (GL.Repeated, GL.ClampToEdge) 112 | 113 | data Transparency = TRNone 114 | | TRBlend !Float 115 | | TRSrcAlpha 116 | deriving (Eq, Ord, Show) 117 | 118 | setTransparency :: Transparency -> IO () 119 | setTransparency trans = 120 | case trans of TRNone -> GL.blend GL.$= GL.Disabled 121 | TRBlend weight -> do 122 | GL.blend GL.$= GL.Enabled 123 | GL.blendFunc GL.$= (GL.ConstantAlpha, GL.OneMinusConstantAlpha) 124 | GL.blendColor GL.$= GL.Color4 0 0 0 (realToFrac weight :: GL.GLfloat) 125 | TRSrcAlpha -> do 126 | GL.blend GL.$= GL.Enabled 127 | GL.blendFunc GL.$= (GL.SrcAlpha, GL.OneMinusSrcAlpha) 128 | 129 | -- Disable vertex attribute arrays and shaders 130 | disableVAOAndShaders :: IO () 131 | disableVAOAndShaders = do 132 | GL.bindVertexArrayObject GL.$= Nothing 133 | GL.currentProgram GL.$= Nothing 134 | 135 | setupViewport :: Int -> Int -> IO () 136 | setupViewport w h = GL.viewport GL.$= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h)) 137 | 138 | -- Allocate OpenGL object name in ResourceT 139 | genObjectNameResource :: (GL.GeneratableObjectName a, MonadResource m) => m a 140 | genObjectNameResource = snd <$> allocate GL.genObjectName GL.deleteObjectName 141 | 142 | -------------------------------------------------------------------------------- /GLSLHelpers.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE FlexibleContexts, LambdaCase #-} 3 | 4 | module GLSLHelpers ( mkShaderProgram 5 | , compileShaderProgram 6 | , tryMkShaderResource 7 | , setTextureShader 8 | , setOrtho2DProjMatrix 9 | ) where 10 | 11 | import qualified Graphics.Rendering.OpenGL as GL 12 | import qualified Graphics.GL as GLR 13 | import qualified Data.ByteString as B 14 | import Data.Either 15 | import Control.Exception 16 | import Control.Monad 17 | import Control.Monad.Except 18 | import Control.Monad.Trans.Resource 19 | import Foreign.Marshal.Array 20 | 21 | import GLHelpers 22 | 23 | -- GLSL shaders and support functions 24 | 25 | mkShaderProgram :: B.ByteString 26 | -> B.ByteString 27 | -> [(String, GL.AttribLocation)] 28 | -> IO (Either String GL.Program) 29 | mkShaderProgram vsSrc fsSrc attribLocations = 30 | -- Only delete the program on error 31 | bracketOnError GL.createProgram GL.deleteObjectName $ \shdProg -> do 32 | compileShaderProgram vsSrc fsSrc attribLocations shdProg >>= 33 | \case Left err -> do -- The bracket only deletes in case of an exception, 34 | -- still need to delete manually in case of a monadic error 35 | GL.deleteObjectName shdProg 36 | return $ Left err 37 | Right () -> return $ Right shdProg 38 | 39 | compileShaderProgram :: B.ByteString 40 | -> B.ByteString 41 | -> [(String, GL.AttribLocation)] 42 | -> GL.Program 43 | -> IO (Either String ()) 44 | compileShaderProgram vsSrc fsSrc attribLocations shdProg = 45 | -- Delete the shaders (don't need them after linking) 46 | bracket (GL.createShader GL.VertexShader ) (GL.deleteObjectName) $ \shdVtx -> 47 | bracket (GL.createShader GL.FragmentShader) (GL.deleteObjectName) $ \shdFrag -> 48 | runExceptT $ do 49 | compile shdVtx vsSrc 50 | compile shdFrag fsSrc 51 | liftIO $ GL.attachShader shdProg shdVtx >> GL.attachShader shdProg shdFrag 52 | -- Need to specify attribute locations before we link 53 | liftIO . forM_ attribLocations $ 54 | \(name, loc) -> GL.attribLocation shdProg name GL.$= loc 55 | link shdProg 56 | liftIO $ GL.detachShader shdProg shdVtx >> GL.detachShader shdProg shdFrag 57 | liftIO . traceOnGLError $ Just "compileShaderProgram end" 58 | -- Compile and link helpers 59 | where compile shd src = do 60 | liftIO $ do GL.shaderSourceBS shd GL.$= src 61 | GL.compileShader shd 62 | success <- liftIO $ GL.get $ GL.compileStatus shd 63 | unless success $ do 64 | errLog <- liftIO . GL.get $ GL.shaderInfoLog shd 65 | throwError errLog 66 | link prog = do 67 | liftIO $ GL.linkProgram prog 68 | success <- liftIO . GL.get $ GL.linkStatus prog 69 | unless success $ do 70 | errLog <- liftIO $ GL.get $ GL.programInfoLog prog 71 | throwError errLog 72 | 73 | -- Helper for mkShaderProgam, guaranteeing deallocation through ResourceT and 74 | -- reports errors through MonadError 75 | tryMkShaderResource :: (MonadError String m, MonadIO m, MonadResource m) 76 | => IO (Either String GL.Program) 77 | -> m GL.Program 78 | tryMkShaderResource f = 79 | allocate f (GL.deleteObjectNames . rights . (: [])) >>= (either throwError return . snd) 80 | 81 | setTextureShader :: GL.BindableTextureTarget t 82 | => GL.TextureObject 83 | -> t 84 | -> Int 85 | -> GL.Program 86 | -> String 87 | -> IO () 88 | setTextureShader tex target tu prog uname = do 89 | (GL.get $ GL.uniformLocation prog uname) >>= \loc -> 90 | GL.uniform loc GL.$= GL.Index1 (fromIntegral tu :: GL.GLint) 91 | GL.activeTexture GL.$= GL.TextureUnit (fromIntegral tu) 92 | GL.textureBinding target GL.$= Just tex 93 | 94 | setOrtho2DProjMatrix :: GL.Program -> String -> Int -> Int -> IO () 95 | setOrtho2DProjMatrix prog uniform w h = do 96 | GL.UniformLocation loc <- GL.get $ GL.uniformLocation prog uniform 97 | let ortho2D = [ 2 / fromIntegral w, 0, 0, -1, 98 | 0, 2 / fromIntegral h, 0, -1, 99 | 0, 0, (-2) / 1000, -1, 100 | 0, 0, 0, 1 101 | ] :: [GL.GLfloat] 102 | withArray ortho2D $ \ptr -> GLR.glUniformMatrix4fv loc 1 1 {- transpose -} ptr 103 | 104 | -------------------------------------------------------------------------------- /HDREnvMap.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE LambdaCase, BangPatterns #-} 3 | 4 | module HDREnvMap ( loadHDRImage 5 | , buildTestLatLongEnvMap 6 | , cubeMapPixelToDir 7 | , latLongHDREnvMapToCubeMap 8 | , resizeHDRImage 9 | , cosineConvolveHDREnvMap 10 | ) where 11 | 12 | import Control.Monad 13 | import Control.Exception 14 | import Control.Lens 15 | import Control.Loop 16 | import Data.List 17 | import Text.Printf 18 | import qualified Data.Vector.Unboxed as VU 19 | import qualified Data.Vector.Storable.Mutable as VSM 20 | import qualified Graphics.Rendering.OpenGL as GL 21 | import qualified Graphics.GL as GLR 22 | import qualified Codec.Picture as JP 23 | import qualified Codec.Picture.Types as JPT 24 | import Linear 25 | 26 | import GLHelpers 27 | import CoordTransf 28 | import Trace 29 | import ConcurrentSegments 30 | 31 | loadHDRImage :: FilePath -> IO (Either String (JP.Image JP.PixelRGBF)) 32 | loadHDRImage fn = do 33 | JP.readImage fn >>= \case 34 | Right (JP.ImageRGBF img) -> do 35 | -- Trace intensity bounds of the image 36 | when (False) $ 37 | let (minIntensity, maxIntensity, avgIntensity) = JPT.pixelFold 38 | (\(!minI, !maxI, !avgI) _ _ (JP.PixelRGBF r g b) -> 39 | let int = (r + g + b) / 3 40 | in (min minI int, max maxI int, avgI + int) 41 | ) 42 | (10000000, 0, 0) 43 | img 44 | in traceS TLInfo $ printf 45 | "Loaded HDR image '%s', min int: %f, max int: %f, avg int: %f" 46 | fn 47 | minIntensity 48 | maxIntensity 49 | (avgIntensity / (fromIntegral $ JP.imageWidth img * JP.imageHeight img)) 50 | return $ Right img 51 | Left err -> return $ Left err 52 | _ -> return . Left $ "Not an HDR RGBF image: " ++ fn 53 | 54 | -- Create an environment map representing a distant cube with colored faces 55 | buildTestLatLongEnvMap :: JP.Image JP.PixelRGBF 56 | buildTestLatLongEnvMap = JP.generateImage f w h 57 | where w = 512 58 | h = 256 59 | colRight = JP.PixelRGBF 1 0 0 -- Red 60 | colLeft = JP.PixelRGBF 0 1 0 -- Green 61 | colUp = JP.PixelRGBF 0 0 1 -- Blue 62 | colDown = JP.PixelRGBF 1 0 1 -- Pink 63 | colFront = JP.PixelRGBF 1 1 0 -- Yellow 64 | colBack = JP.PixelRGBF 0 1 1 -- Cyan 65 | f x y = let (theta, phi) = environmentPxToSpherical x y w 66 | dir = localToWorld $ sphericalToCartesian theta phi 67 | in case () of 68 | _ | abs (dir^._x) >= abs (dir^._y) && abs (dir^._x) >= abs (dir^._z) -> 69 | if dir^._x > 0 then colRight else colLeft 70 | | abs (dir^._y) >= abs (dir^._x) && abs (dir^._y) >= abs (dir^._z) -> 71 | if dir^._y > 0 then colUp else colDown 72 | | otherwise -> 73 | if dir^._z < 0 then colFront else colBack 74 | 75 | -- Get directional vector for a pixel on a cube map face 76 | cubeMapPixelToDir :: GL.TextureTargetCubeMapFace -> GL.TextureSize2D -> Int -> Int -> V3 Float 77 | cubeMapPixelToDir face (GL.TextureSize2D w h) x y = 78 | -- Centering like this ensures clean filtering across cube map seams 79 | let vw = (fromIntegral x + 0.5) / fromIntegral w * 2 - 1 80 | vh = (fromIntegral y + 0.5) / fromIntegral h * 2 - 1 81 | in normalize $ case face of 82 | GL.TextureCubeMapPositiveX -> V3 1 (-vh) (-vw) 83 | GL.TextureCubeMapNegativeX -> V3 (-1) (-vh) vw 84 | GL.TextureCubeMapPositiveY -> V3 vw 1 vh 85 | GL.TextureCubeMapNegativeY -> V3 vw (-1) (-vh) 86 | GL.TextureCubeMapPositiveZ -> V3 vw (-vh) 1 87 | GL.TextureCubeMapNegativeZ -> V3 (-vw) (-vh) (-1) 88 | 89 | -- Bilinear lookup into an HDR environment map 90 | -- http://en.wikipedia.org/wiki/Bilinear_filtering#Sample_code 91 | pixelAtBilinear :: JP.Image JP.PixelRGBF -> Float -> Float -> V3 Float 92 | pixelAtBilinear img u v = 93 | let w = JP.imageWidth img 94 | h = JP.imageHeight img 95 | -- Texel center at (0, 0) 96 | upx = u * (fromIntegral w - 1) 97 | upy = v * (fromIntegral h - 1) 98 | x = floor upx 99 | y = floor upy 100 | xp1 = (x + 1) `mod` (w - 1) 101 | -- TODO: Fix this properly. We can wrap around on the X axis, but for Y we can't wrap 102 | -- from top to bottom, but would instead need to reflect X around the center 103 | -- of the axis to get the correct texel 104 | yp1 = min (h - 1) (y + 1) 105 | uRatio = upx - fromIntegral x 106 | vRatio = upy - fromIntegral y 107 | uOpposite = 1 - uRatio 108 | vOpposite = 1 - vRatio 109 | tex xc yc = case JP.unsafePixelAt (JP.imageData img) (xc * 3 + yc * w * 3) of 110 | (JP.PixelRGBF r g b) -> V3 r g b 111 | -- tex xc yc = case JP.pixelAt img xc yc of (JP.PixelRGBF r g b) -> V3 r g b 112 | in (tex x y ^* uOpposite + tex xp1 y ^* uRatio) ^* vOpposite + 113 | (tex x yp1 ^* uOpposite + tex xp1 yp1 ^* uRatio) ^* vRatio 114 | 115 | -- Transform a latitude / longitude format environment map into a cube map texture. This 116 | -- creates some distortion and we only use basic bilinear lookups (no full texel coverage) 117 | -- for the resampling, introducing artifacts in the process. Results look fairly good, though 118 | latLongHDREnvMapToCubeMap :: JP.Image JP.PixelRGBF -> Bool -> IO GL.TextureObject 119 | latLongHDREnvMapToCubeMap latlong debugFaceColorize = 120 | bracketOnError GL.genObjectName GL.deleteObjectName $ \tex -> do 121 | -- Setup cube map 122 | GL.textureBinding GL.TextureCubeMap GL.$= Just tex 123 | setTextureFiltering GL.TextureCubeMap TFMagOnly 124 | -- Apparently some older GPUs / drivers have issues with this, a simple 125 | -- 'setTextureClampST GL.TextureCubeMap' might also be sufficient 126 | GLR.glEnable GLR.GL_TEXTURE_CUBE_MAP_SEAMLESS 127 | -- Fill all six cube map faces 128 | let w = JP.imageWidth latlong `div` 3 -- Three is a slight increase in texels, 129 | -- four is a slight reduction 130 | size = GL.TextureSize2D (fromIntegral w) (fromIntegral w) 131 | forM_ [ GL.TextureCubeMapPositiveX 132 | , GL.TextureCubeMapNegativeX 133 | , GL.TextureCubeMapPositiveY 134 | , GL.TextureCubeMapNegativeY 135 | , GL.TextureCubeMapPositiveZ 136 | , GL.TextureCubeMapNegativeZ 137 | ] $ \face -> do 138 | faceImg <- VSM.new $ w * w :: IO (VSM.IOVector (V3 Float)) 139 | void $ forSegmentsConcurrently Nothing 0 w $ \start end -> -- In parallel 140 | forM_ [start..end - 1] $ \y -> forM_ [0..w - 1] $ \x -> 141 | let idx = x + y * w 142 | -- Convert from a cube map texel to a lat./long. environment map texel 143 | dir = cubeMapPixelToDir face size x y 144 | (theta, phi) = cartesianToSpherical $ worldToLocal dir 145 | (u, v) = sphericalToEnvironmentUV theta phi 146 | -- Lookup source texel 147 | col = pixelAtBilinear latlong u v 148 | -- We can colorize the faces of the cube for debugging purposes 149 | colFace = case face of 150 | GL.TextureCubeMapPositiveX -> V3 1 0 0 -- Red 151 | GL.TextureCubeMapNegativeX -> V3 0 1 0 -- Green 152 | GL.TextureCubeMapPositiveY -> V3 0 0 1 -- Blue 153 | GL.TextureCubeMapNegativeY -> V3 1 0 1 -- Pink 154 | GL.TextureCubeMapPositiveZ -> V3 1 1 0 -- Yellow 155 | GL.TextureCubeMapNegativeZ -> V3 0 1 1 -- Cyan 156 | in VSM.write faceImg idx $ col * if debugFaceColorize then colFace else 1 157 | -- Debug output normal 158 | -- VSM.write faceImg idx $ V3 (dir ^. _x) (dir ^. _y) (dir ^. _z) 159 | -- Upload and let OpenGL convert to half floats 160 | VSM.unsafeWith faceImg $ 161 | GL.texImage2D face GL.NoProxy 0 GL.RGB16F size 0 . GL.PixelData GL.RGB GL.Float 162 | traceOnGLError $ Just "latLongHDREnvMapToCubeMap" 163 | return tex 164 | 165 | -- Scale an HDR image to a given target width (keep aspect for height). This is certainly 166 | -- not the most sophisticated way to do image scaling and will produce poor results for 167 | -- small changes in size and upscaling in general. For our actual use case (downscaling an 168 | -- HDR environment map prior to convolution) its quality is absolutely adequate 169 | resizeHDRImage :: JP.Image JP.PixelRGBF -> Int -> JP.Image JP.PixelRGBF 170 | resizeHDRImage src dstw = 171 | let srcw = JP.imageWidth src 172 | srch = JP.imageHeight src 173 | dsth = round $ (fromIntegral srch / fromIntegral srcw * fromIntegral dstw :: Float) 174 | scale = fromIntegral srcw / fromIntegral dstw :: Float 175 | taps = ceiling $ scale :: Int 176 | ntaps = fromIntegral $ taps * taps 177 | step = scale / fromIntegral taps 178 | resized dstx dsty = 179 | let srcx1 = fromIntegral dstx * scale 180 | srcy1 = fromIntegral dsty * scale 181 | in (\(JP.PixelRGBF r g b) -> JP.PixelRGBF (r / ntaps) (g / ntaps) (b / ntaps)) $ foldl' 182 | (\(JP.PixelRGBF ar ag ab) (srcx, srcy) -> 183 | let u = srcx / (fromIntegral srcw - 1) 184 | v = srcy / (fromIntegral srch - 1) 185 | V3 r g b = pixelAtBilinear src u v 186 | in JP.PixelRGBF (ar + r) (ag + g) (ab + b) 187 | ) 188 | (JP.PixelRGBF 0 0 0) 189 | [ ( srcx1 + fromIntegral x * step 190 | , srcy1 + fromIntegral y * step 191 | ) 192 | | y <- [0..taps - 1] 193 | , x <- [0..taps - 1] 194 | ] 195 | in JP.generateImage resized dstw dsth 196 | 197 | -- TODO: There's plenty of room for improvement regarding our handling of pre-convolved 198 | -- environment maps. We could do the convolution in frequency space with SH, 199 | -- possibly even at runtime to save memory and allow for multiple exponents, see here: 200 | -- 201 | -- http://www.cs.columbia.edu/~cs4162/slides/spherical-harmonic-lighting.pdf 202 | -- http://www.ppsloan.org/publications/StupidSH36.pdf 203 | -- 204 | -- We could also adopt improvements from AMD's cubemapgen tool, as described here: 205 | -- 206 | -- http://seblagarde.wordpress.com/2012/06/10/amd-cubemapgen-for-physically-based-rendering/ 207 | -- https://code.google.com/p/cubemapgen/ 208 | 209 | -- Convolve an environment map with a cosine lobe. This is a rather slow O(n^4) 210 | -- operation. A resolution of 256x128 is both sufficient and probably the most 211 | -- that is computationally feasible 212 | -- 213 | -- TODO: We add a lot of values together that might be either very small or very large. 214 | -- Analyze if the 32 bit intermediate floats, the 32 bit RGBE values in the HDR 215 | -- file and the RGB16F on the GPU are always sufficient 216 | -- 217 | cosineConvolveHDREnvMap :: JP.Image JP.PixelRGBF -> Float -> JP.Image JP.PixelRGBF 218 | cosineConvolveHDREnvMap src power = 219 | let srcw = JP.imageWidth src 220 | srch = JP.imageHeight src 221 | -- We don't care about the actual correct angles as stored in the environment map, 222 | -- only their difference matters 223 | pxToTheta p = fromIntegral p / fromIntegral (srch - 1) * pi 224 | pxToPhi p = fromIntegral p / fromIntegral (srcw - 1) * 2 * pi 225 | convolve dstx dsty = 226 | let thetaLobe = pxToTheta dsty 227 | thetaLobeCos = cos thetaLobe 228 | thetaLobeSin = sin thetaLobe 229 | phiLobe = pxToPhi dstx 230 | absPhiDiffCosLookup = VU.generate srcw (\x -> cos . abs $ phiLobe - pxToPhi x) 231 | -- Divide sum by number of hemisphere samples 232 | in (\(r, g, b, n) -> JP.PixelRGBF (r / n) (g / n) (b / n)) $ 233 | forLoopFold 0 (< srch) (+ 1) (0, 0, 0, 0) $ \accY y -> 234 | let thetaPx = pxToTheta y 235 | thetaPxCos = cos thetaPx 236 | thetaPxSin = sin thetaPx 237 | in forLoopFold 0 (< srcw) (+ 1) accY $ \(!ar, !ag, !ab, !n) x -> 238 | let JP.PixelRGBF r g b = JP.unsafePixelAt (JP.imageData src) 239 | (x * 3 + y * srcw * 3) 240 | -- Basically a dot product in spherical coordinates 241 | -- http://en.wikipedia.org/wiki/Great-circle_distance#Formulas 242 | cosAngle = thetaLobeCos * thetaPxCos + 243 | thetaLobeSin * thetaPxSin * 244 | VU.unsafeIndex absPhiDiffCosLookup x 245 | -- TODO: That power takes a good chunk of the overall runtime, 246 | -- consider using a lookup table 247 | cosAnglePow = cosAngle ** power 248 | -- Sin theta factor to account for area distortion in the lat/long 249 | -- parameterization of the sphere 250 | fac = thetaPxSin * cosAnglePow 251 | in if cosAngle > 0 252 | then (ar + (r * fac), ag + (g * fac), ab + (b * fac), n + 1) 253 | else (ar, ag, ab, n) 254 | in JP.generateImage convolve srcw srch 255 | 256 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Tim C. Schroeder 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | module Main (main) where 5 | 6 | import GHC.Conc (getNumProcessors) 7 | import Control.Concurrent (setNumCapabilities) 8 | import Control.Concurrent.STM.TQueue 9 | import Data.List 10 | import qualified System.Info as SI 11 | 12 | import App 13 | import Trace 14 | import GLFWHelpers 15 | import GLHelpers 16 | import Timing 17 | import Font 18 | import FrameBuffer 19 | import QuadRendering 20 | import ShaderRendering 21 | import FileModChecker 22 | import qualified BoundedSequence as BS 23 | 24 | runOnAllCores :: IO () 25 | runOnAllCores = GHC.Conc.getNumProcessors >>= setNumCapabilities 26 | 27 | traceSystemInfo :: IO () 28 | traceSystemInfo = do 29 | cpus <- GHC.Conc.getNumProcessors 30 | traceS TLInfo =<< 31 | ( (++) . concat . intersperse " · " $ 32 | [ "System - OS: " ++ SI.os 33 | , "Arch: " ++ SI.arch 34 | , "CPUs: " ++ show cpus 35 | , concat [ "Compiler: " 36 | , SI.compilerName 37 | , " / " 38 | , show SI.compilerVersion 39 | ] 40 | ] 41 | ) 42 | <$> (("\n" ++) <$> getGLStrings) 43 | -- mapM_ (traceS TLInfo) =<< getGLExtensionList 44 | 45 | main :: IO () 46 | main = do 47 | runOnAllCores 48 | withTrace Nothing True False True TLInfo $ do 49 | _aeGLFWEventsQueue <- newTQueueIO :: IO (TQueue GLFWEvent) 50 | let w = 512 51 | h = 512 52 | shdFn = "./fragment.shd" 53 | reflMapFn = "./latlong_envmaps/uffizi_512.hdr" 54 | in withWindow w h False "Viewer" _aeGLFWEventsQueue $ \_aeWindow -> 55 | withFontTexture $ \_aeFontTexture -> 56 | withFrameBuffer w h HighQualityDownscaling $ \_aeFB -> 57 | withQuadRenderer 16384 $ \_aeQR -> 58 | withShaderRenderer shdFn reflMapFn $ \_aeSR -> do 59 | traceSystemInfo 60 | _asCurTick <- getTick 61 | _aeShaderModChecker <- checkModifedAsync shdFn 0.5 62 | let as = AppState { _asLastEscPress = -1 63 | , _asFrameTimes = BS.empty 60 -- Average over last N FPS 64 | , _asMode = ModeDETestShader 65 | , _asFBScale = 1 66 | , _asLastShdErr = "" 67 | , _asTiling = False 68 | , _asFrameIdx = 0 69 | , _asTakeScreenShot = False 70 | , .. 71 | } 72 | ae = AppEnv { .. } 73 | in runAppT as ae run 74 | 75 | -------------------------------------------------------------------------------- /QQPlainText.hs: -------------------------------------------------------------------------------- 1 | 2 | module QQPlainText ( plaintext 3 | ) where 4 | 5 | import Language.Haskell.TH 6 | import Language.Haskell.TH.Quote 7 | 8 | -- Simple Quasi Quoter inserting its contents as a String where it is called 9 | 10 | plaintext :: QuasiQuoter 11 | plaintext = QuasiQuoter { quoteExp = quotePlainTextExp 12 | , quotePat = undefined 13 | , quoteDec = undefined 14 | , quoteType = undefined 15 | } 16 | 17 | quotePlainTextExp :: String -> Q Exp 18 | quotePlainTextExp = dataToExpQ (const Nothing) 19 | 20 | -------------------------------------------------------------------------------- /QuadRendering.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE RecordWildCards 3 | , OverloadedStrings 4 | , LambdaCase 5 | , FlexibleContexts 6 | , BangPatterns 7 | , ScopedTypeVariables #-} 8 | 9 | module QuadRendering ( withQuadRenderer 10 | , QuadRenderer 11 | , withQuadRenderBuffer 12 | , QuadRenderBuffer 13 | , drawQuad 14 | , gatherRenderStats 15 | -- Re-exports from GLHelpers 16 | , Transparency(..) 17 | -- Re-exports from QuadTypes 18 | , RGBA(..) 19 | , FillColor(..) 20 | , QuadUV(..) 21 | ) where 22 | 23 | import qualified Graphics.Rendering.OpenGL as GL 24 | import qualified Data.Vector as V 25 | import qualified Data.Vector.Storable.Mutable as VSM 26 | import qualified Data.Vector.Mutable as VM 27 | import Data.List 28 | import Control.Monad 29 | import Control.Exception 30 | import Control.Monad.IO.Class 31 | import Control.Monad.Trans.Control 32 | import Control.Monad.Trans.Resource 33 | import Control.Monad.Except 34 | import Control.DeepSeq 35 | import Data.IORef 36 | import Foreign.Ptr 37 | import Foreign.ForeignPtr 38 | import Foreign.Storable 39 | import Text.Printf 40 | 41 | import Trace 42 | import GLHelpers 43 | import GLSLHelpers 44 | import QuadShaderSource 45 | import QuadTypes 46 | 47 | -- Module for efficient rendering of 2D quad primitives, used for UI elements and texture 48 | -- mapped font rendering 49 | -- 50 | -- TODO: We could speed this up quite a bit by using a geometry shader, significantly 51 | -- reducing the amount of vertex and index data we have to generate and write 52 | 53 | data QuadRenderer = QuadRenderer 54 | { -- Vertex / Element Array Buffer Objects and layout 55 | qrVAO :: !GL.VertexArrayObject 56 | , qrVBO :: !GL.BufferObject 57 | , qrEBO :: !GL.BufferObject 58 | , qrVtxStride :: !Int 59 | , qrColStride :: !Int 60 | , qrUVStride :: !Int 61 | , qrTotalStride :: !Int 62 | , qrMaxQuad :: !Int 63 | , qrMaxVtx :: !Int 64 | , qrMaxTri :: !Int 65 | , qrVtxOffset :: !Int 66 | , qrColOffset :: !Int 67 | , qrUVOffset :: !Int 68 | -- Shaders 69 | , qrShdProgTex :: !GL.Program 70 | , qrShdProgColOnly :: !GL.Program 71 | -- Rendering statistics 72 | , qrRenderStats :: !(IORef String) 73 | } 74 | 75 | -- Bind and allocate Vertex / Element Array Buffer Object (VBO / EBO) 76 | bindAllocateDynamicBO :: GL.BufferObject -> GL.BufferTarget -> Int -> IO () 77 | bindAllocateDynamicBO bo target size = do 78 | GL.bindBuffer target GL.$= Just bo 79 | GL.bufferData target GL.$= ( fromIntegral size -- In bytes 80 | , nullPtr 81 | , GL.StreamDraw -- Dynamic 82 | ) 83 | 84 | setAttribArray :: GL.GLuint 85 | -> Int 86 | -> Int 87 | -> Int 88 | -> IO GL.AttribLocation 89 | setAttribArray idx attribStride vertexStride offset = do 90 | -- Specify and enable vertex attribute array 91 | let attrib = GL.AttribLocation idx 92 | szf = sizeOf (0 :: Float) 93 | GL.vertexAttribPointer attrib GL.$= 94 | ( GL.ToFloat 95 | , GL.VertexArrayDescriptor 96 | (fromIntegral attribStride) 97 | GL.Float 98 | (fromIntegral $ vertexStride * szf) 99 | (nullPtr `plusPtr` (offset * szf)) 100 | ) 101 | GL.vertexAttribArray attrib GL.$= GL.Enabled 102 | return attrib 103 | 104 | -- Initialize / clean up all OpenGL resources for our renderer 105 | withQuadRenderer :: Int -> (QuadRenderer -> IO a) -> IO a 106 | withQuadRenderer qrMaxQuad f = 107 | traceOnGLError (Just "withQuadRenderer begin") >> 108 | -- Allocate OpenGL objects 109 | let glBracket bo = bracket GL.genObjectName GL.deleteObjectName bo 110 | in glBracket $ \qrVAO -> 111 | glBracket $ \qrVBO -> 112 | glBracket $ \qrEBO -> do 113 | qrRenderStats <- newIORef "" 114 | -- VAO 115 | GL.bindVertexArrayObject GL.$= Just qrVAO 116 | -- VBO 117 | let szf = sizeOf (0 :: Float) 118 | qrVtxStride = 3 119 | qrColStride = 4 120 | qrUVStride = 2 121 | qrTotalStride = qrVtxStride + qrColStride + qrUVStride 122 | qrMaxTri = qrMaxQuad * 2 123 | qrMaxVtx = qrMaxTri * 4 124 | numfloat = qrTotalStride * qrMaxVtx 125 | qrVtxOffset = 0 126 | qrColOffset = qrVtxOffset + qrVtxStride 127 | qrUVOffset = qrColOffset + qrColStride 128 | bindAllocateDynamicBO qrVBO GL.ArrayBuffer $ numfloat * szf 129 | -- Specify and enable vertex attribute arrays 130 | vtxAttrib <- setAttribArray 0 qrVtxStride qrTotalStride qrVtxOffset 131 | colAttrib <- setAttribArray 1 qrColStride qrTotalStride qrColOffset 132 | uvAttrib <- setAttribArray 2 qrUVStride qrTotalStride qrUVOffset 133 | let attribLocations = [ ("in_pos", vtxAttrib) 134 | , ("in_col", colAttrib) 135 | , ("in_uv" , uvAttrib ) 136 | ] 137 | -- EBO 138 | let numIdx = qrMaxTri * 3 139 | szi = sizeOf(0 :: GL.GLuint) 140 | bindAllocateDynamicBO qrEBO GL.ElementArrayBuffer $ numIdx * szi 141 | -- Create, compile and link shaders 142 | r <- runExceptT . runResourceT $ do 143 | qrShdProgTex <- tryMkShaderResource $ 144 | mkShaderProgram vsSrcBasic fsSrcBasic attribLocations 145 | qrShdProgColOnly <- tryMkShaderResource $ 146 | mkShaderProgram vsSrcBasic fsColOnlySrcBasic attribLocations 147 | -- Initialization done, run inner 148 | liftIO $ do 149 | disableVAOAndShaders 150 | traceOnGLError $ Just "withQuadRenderer begin inner" 151 | finally 152 | ( f $ QuadRenderer { .. } ) 153 | ( traceOnGLError $ Just "withQuadRenderer after inner" ) 154 | either (traceAndThrow . printf "withQuadRenderer - Shader init failed:\n%s") return r 155 | 156 | -- TODO: Write an Unbox instance for this and switch to an unboxed mutable vector 157 | data QuadRenderAttrib = QuadRenderAttrib 158 | { qaFillTransparency :: !Transparency 159 | , qaMaybeTexture :: !(Maybe GL.TextureObject) 160 | , qaIndex :: !Int -- Index into the VBO so we know what indices to generate 161 | -- after sorting by attributes 162 | , qaDepth :: !Float -- We store the depth / layer information already in the 163 | -- VBO, but replicate them here so we can sort for transparency 164 | } deriving (Eq) 165 | 166 | -- Back-to-front ordering (transparency) and then sorting to reduce OpenGL state changes 167 | instance Ord QuadRenderAttrib where 168 | compare a b = let cmpDepth = compare (qaDepth b) (qaDepth a) 169 | cmpTex = compare (qaMaybeTexture a) (qaMaybeTexture b) 170 | cmpTrans = compare (qaFillTransparency a) (qaFillTransparency b) 171 | in case () of 172 | _ | cmpDepth /= EQ -> cmpDepth -- Sort by depth first 173 | | cmpTex /= EQ -> cmpTex -- Sort by texture at the same depth 174 | | otherwise -> cmpTrans -- Finally by transparency 175 | 176 | data QuadRenderBuffer = QuadRenderBuffer 177 | { qbQR :: !QuadRenderer 178 | , qbNumQuad :: !(IORef Int) 179 | , qbAttribs :: !(VM.IOVector QuadRenderAttrib) 180 | , qbVBOMap :: !(VSM.IOVector GL.GLfloat ) 181 | } 182 | 183 | -- Prepare data structures and render when inner exits. This is meant to be called once or 184 | -- more per-frame. Runs its inner inside the base monad. Takes width and height so it 185 | -- knows how to setup the orthographic projection for the shader 186 | withQuadRenderBuffer :: forall a m. (MonadBaseControl IO m, MonadIO m) 187 | => QuadRenderer 188 | -> Int 189 | -> Int 190 | -> (QuadRenderBuffer -> m a) 191 | -> m (Maybe a) -- We return Nothing if mapping fails 192 | withQuadRenderBuffer qbQR@(QuadRenderer { .. }) w h f = do 193 | -- Map. If this function is nested inside a withQuadRenderBuffer with the same QuadRenderer, 194 | -- the mapping operation will fail as OpenGL does not allow two concurrent mappings. Hence, 195 | -- no need to check for this explicitly 196 | liftIO $ traceOnGLError (Just "1") 197 | r <- control $ \run -> liftIO $ do 198 | -- Reallocate VBO to prevent stall 199 | let szf = sizeOf (0 :: Float) 200 | numfloat = qrTotalStride * qrMaxVtx 201 | bindAllocateDynamicBO qrVBO GL.ArrayBuffer (numfloat * szf) 202 | let bindVBO = GL.bindBuffer GL.ArrayBuffer GL.$= Just qrVBO 203 | in GL.withMappedBuffer 204 | GL.ArrayBuffer 205 | GL.WriteOnly 206 | ( \ptrVBO -> newForeignPtr_ ptrVBO >>= \fpVBO -> 207 | let qbVBOMap = VSM.unsafeFromForeignPtr0 fpVBO numfloat 208 | in do qbNumQuad <- newIORef 0 209 | qbAttribs <- VM.new qrMaxQuad 210 | finally 211 | ( run $ do -- Run in outer base monad 212 | let qb = QuadRenderBuffer { .. } 213 | r <- f qb 214 | return $ Just (r, qb) 215 | ) 216 | bindVBO -- Make sure we rebind our VBO, otherwise 217 | -- unmapping might fail if the inner 218 | -- modified the bound buffer objects 219 | ) 220 | ( \mf -> do traceS TLError $ 221 | "withQuadRenderBuffer - VBO mapping failure: " ++ show mf 222 | -- Looks like since the 1.0.0.0 change in monad-control we need 223 | -- some type annotations for this to work 224 | run $ (return Nothing :: m (Maybe (a, QuadRenderBuffer))) 225 | ) 226 | case r of 227 | Nothing -> return Nothing 228 | Just (ra, qb) -> liftIO $ do 229 | -- VBO has been successfully mapped, filled and unmapped, attributes have been 230 | -- collected as well, proceed to render 231 | dr <- drawRenderBuffer qb w h 232 | return $ if dr then Just ra else Nothing 233 | 234 | -- Internal function to draw the contents of a render buffer once we're done filling it 235 | drawRenderBuffer :: QuadRenderBuffer -> Int -> Int -> IO Bool 236 | drawRenderBuffer (QuadRenderBuffer { .. }) w h = do 237 | let QuadRenderer { .. } = qbQR 238 | GL.bindVertexArrayObject GL.$= Just qrVAO 239 | numQuad <- readIORef qbNumQuad 240 | attribs <- sortAttributes qbAttribs numQuad 241 | eboSucc <- fillEBO qrMaxTri qrEBO attribs 242 | if not eboSucc 243 | then return False 244 | else do 245 | -- Setup 246 | forM_ [qrShdProgTex, qrShdProgColOnly] $ \shdProg -> do 247 | GL.currentProgram GL.$= Just shdProg 248 | setOrtho2DProjMatrix shdProg "in_mvp" w h 249 | -- Texture, use first TU 250 | GL.currentProgram GL.$= Just qrShdProgTex 251 | (GL.get $ GL.uniformLocation qrShdProgTex "tex") >>= \loc -> 252 | GL.uniform loc GL.$= GL.Index1 (0 :: GL.GLint) 253 | GL.activeTexture GL.$= GL.TextureUnit 0 254 | -- Setup some initial state and build corresponding attribute record 255 | GL.currentProgram GL.$= Just qrShdProgColOnly 256 | GL.textureBinding GL.Texture2D GL.$= Nothing 257 | setTransparency TRNone 258 | let initialState = QuadRenderAttrib TRNone Nothing 0 0.0 259 | -- Draw all quads 260 | foldM_ 261 | ( \(oldA, i) a -> do 262 | let newA = head a 263 | numIdx = length a * 6 -- TODO: Slow, just output this during the first pass 264 | -- Modify OpenGL state which changed between old / new rendering attributes 265 | case (qaMaybeTexture oldA, qaMaybeTexture newA) of 266 | (Just oldTex, Just newTex) -> 267 | when (oldTex /= newTex) $ 268 | GL.textureBinding GL.Texture2D GL.$= Just newTex 269 | (Nothing, Just newTex) -> do 270 | GL.currentProgram GL.$= Just qrShdProgTex 271 | GL.textureBinding GL.Texture2D GL.$= Just newTex 272 | (Just _, Nothing) -> 273 | GL.currentProgram GL.$= Just qrShdProgColOnly 274 | (Nothing, Nothing) -> 275 | return () 276 | when (qaFillTransparency oldA /= qaFillTransparency newA) . 277 | setTransparency $ qaFillTransparency newA 278 | -- Draw all quads in the current attribute group as two triangles 279 | let szi = sizeOf(0 :: GL.GLuint) 280 | in GL.drawElements GL.Triangles 281 | (fromIntegral numIdx) 282 | GL.UnsignedInt 283 | $ nullPtr `plusPtr` (i * szi) 284 | return (newA, i + numIdx) 285 | ) 286 | (initialState, 0) 287 | attribs 288 | -- Store statistics inside QuadRenderer record. Need to make sure the string has 289 | -- been fully generated, no dependency on the rendering data should be kept 290 | let statString = printf "Last drawRenderBuffer drawElementCalls: %i · numQuad: %i" 291 | (length attribs) 292 | numQuad 293 | in statString `deepseq` writeIORef qrRenderStats statString 294 | -- Done 295 | disableVAOAndShaders 296 | return True 297 | 298 | gatherRenderStats :: QuadRenderer -> IO String 299 | gatherRenderStats = readIORef . qrRenderStats 300 | 301 | -- Sort and group attributes (for transparency and reduced state changes) 302 | sortAttributes :: VM.IOVector QuadRenderAttrib -> Int -> IO [[QuadRenderAttrib]] 303 | sortAttributes attribs numQuad = 304 | groupBy (\a b -> compare a b == EQ) . -- Group by state into single draw calls. We 305 | -- use the compare instance used for state 306 | -- sorting so we only break groups on 307 | -- relevant changes 308 | sort . V.toList -- TODO: Sort mutable vector in-place with 309 | -- vector-algorithms? 310 | <$> ( V.unsafeFreeze -- Can only convert immutable vector to a list 311 | . VM.unsafeTake numQuad -- Drop undefined elements 312 | $ attribs 313 | ) 314 | 315 | -- Build EBO from state sorted attributes. This benchmarked slightly faster than doing 316 | -- drawing in a single pass with ad-hoc index buffer building 317 | fillEBO :: Int -> GL.BufferObject -> [[QuadRenderAttrib]] -> IO Bool 318 | fillEBO maxTri ebo attribs = do 319 | -- Reallocate EBO to prevent stalls 320 | let numIdx = maxTri * 3 321 | szi = sizeOf(0 :: GL.GLuint) 322 | bindAllocateDynamicBO ebo GL.ElementArrayBuffer $ numIdx * szi 323 | GL.withMappedBuffer 324 | GL.ElementArrayBuffer 325 | GL.WriteOnly 326 | ( \ptrEBO -> newForeignPtr_ ptrEBO >>= \fpEBO -> 327 | let !eboMap = VSM.unsafeFromForeignPtr0 fpEBO numIdx :: VSM.IOVector GL.GLuint 328 | in do foldM_ -- Fold over draw call groups 329 | ( \r a -> do 330 | n <- foldM 331 | ( \gr ga -> do -- Fold over quads in group 332 | -- Write index data to the mapped element array buffer 333 | let !eboOffs = gr * 6 334 | !vboOffs = qaIndex ga 335 | uw = VSM.unsafeWrite eboMap 336 | in -- Unrolled version of 337 | -- forM_ (zip [eboOffs..] [0, 1, 2, 0, 2, 3]) $ \(i, e) -> 338 | -- VSM.write eboMap i (fromIntegral $ e + vboOffs) 339 | do uw (eboOffs + 0) . fromIntegral $ vboOffs + 0 340 | uw (eboOffs + 1) . fromIntegral $ vboOffs + 1 341 | uw (eboOffs + 2) . fromIntegral $ vboOffs + 2 342 | uw (eboOffs + 3) . fromIntegral $ vboOffs + 0 343 | uw (eboOffs + 4) . fromIntegral $ vboOffs + 2 344 | uw (eboOffs + 5) . fromIntegral $ vboOffs + 3 345 | return $! gr + 1 -- Next six EBO entries 346 | ) r a 347 | return n 348 | ) 0 attribs 349 | return True 350 | ) 351 | ( \mf -> do traceS TLError $ "drawRenderBuffer - EBO mapping failure: " ++ show mf 352 | -- Return false on mapping failure 353 | return False 354 | ) 355 | 356 | -- Record all data to render the specified quad into the passed render buffer 357 | drawQuad :: QuadRenderBuffer 358 | -> Float -> Float -> Float -> Float 359 | -> Float 360 | -> FillColor 361 | -> Transparency 362 | -> Maybe GL.TextureObject 363 | -> QuadUV 364 | -> IO () 365 | drawQuad (QuadRenderBuffer { .. }) 366 | !x1 !y1 !x2 !y2 367 | !qaDepth 368 | col 369 | qaFillTransparency 370 | qaMaybeTexture 371 | uv = do 372 | let QuadRenderer { .. } = qbQR -- Bring buffer layout information into scope 373 | -- Are we at capacity? 374 | numQuad <- readIORef qbNumQuad 375 | if numQuad == qrMaxQuad 376 | then traceT TLError "drawQuad - QuadRenderBuffer overflow, dropping quad" 377 | else do 378 | -- Write vertex data to our mapped attribute buffers 379 | -- 380 | -- TODO: Could use a hashmap to reuse vertices between adjacent quads 381 | -- 382 | -- TODO: The code we're using is an unrolled version of this: 383 | -- 384 | -- let (pos', cols, texs) = paramToPosColUV x1 y1 x2 y2 col 385 | -- vboOffs = numQuad * 4 386 | -- forM_ (zip4 [vboOffs..] pos' cols texs) $ 387 | -- \(i, (x, y), RGBA r g b a, (u, v)) -> 388 | -- forM_ (zip [0..] [x, y, (-qaDepth), r, g, b, a, u, v]) $ 389 | -- \(offs, f) -> VSM.write qbVBOMap (i * qrTotalStride + offs) $ realToFrac f 390 | -- 391 | -- Would be nice to find a more elegant yet still fast version 392 | -- 393 | let !vtxBase = numQuad * 4 * qrTotalStride 394 | !vtx0 = vtxBase + (qrTotalStride * 0) 395 | !vtx1 = vtxBase + (qrTotalStride * 1) 396 | !vtx2 = vtxBase + (qrTotalStride * 2) 397 | !vtx3 = vtxBase + (qrTotalStride * 3) 398 | !( RGBA !r0 !g0 !b0 !a0 399 | , RGBA !r1 !g1 !b1 !a1 400 | , RGBA !r2 !g2 !b2 !a2 401 | , RGBA !r3 !g3 !b3 !a3 402 | ) = case col of FCWhite -> let c = RGBA 1 1 1 1 in (c, c, c, c) 403 | FCBlack -> let c = RGBA 0 0 0 1 in (c, c, c, c) 404 | FCSolid c -> (c, c, c, c) 405 | FCBottomTopGradient b t -> (b, b, t, t) 406 | FCLeftRightGradient l r -> (l, r, r, l) 407 | !(!u0, !v0, !u1, !v1) = 408 | case uv of QuadUVDefault -> (0, 0, 1, 1) 409 | QuadUV u0' v0' u1' v1' -> (u0', v0', u1', v1') 410 | uw = VSM.unsafeWrite qbVBOMap 411 | in do -- Vertex 0 412 | uw (vtx0 + 0) $ realToFrac x1 -- X 413 | uw (vtx0 + 1) $ realToFrac y1 -- Y 414 | uw (vtx0 + 2) $ realToFrac (-qaDepth) -- Z 415 | uw (vtx0 + 3) $ realToFrac r0 -- R 416 | uw (vtx0 + 4) $ realToFrac g0 -- G 417 | uw (vtx0 + 5) $ realToFrac b0 -- B 418 | uw (vtx0 + 6) $ realToFrac a0 -- A 419 | uw (vtx0 + 7) $ realToFrac u0 -- U 420 | uw (vtx0 + 8) $ realToFrac v0 -- V 421 | -- Vertex 1 422 | uw (vtx1 + 0) $ realToFrac x2 -- X 423 | uw (vtx1 + 1) $ realToFrac y1 -- Y 424 | uw (vtx1 + 2) $ realToFrac (-qaDepth) -- Z 425 | uw (vtx1 + 3) $ realToFrac r1 -- R 426 | uw (vtx1 + 4) $ realToFrac g1 -- G 427 | uw (vtx1 + 5) $ realToFrac b1 -- B 428 | uw (vtx1 + 6) $ realToFrac a1 -- A 429 | uw (vtx1 + 7) $ realToFrac u1 -- U 430 | uw (vtx1 + 8) $ realToFrac v0 -- V 431 | -- Vertex 2 432 | uw (vtx2 + 0) $ realToFrac x2 -- X 433 | uw (vtx2 + 1) $ realToFrac y2 -- Y 434 | uw (vtx2 + 2) $ realToFrac (-qaDepth) -- Z 435 | uw (vtx2 + 3) $ realToFrac r2 -- R 436 | uw (vtx2 + 4) $ realToFrac g2 -- G 437 | uw (vtx2 + 5) $ realToFrac b2 -- B 438 | uw (vtx2 + 6) $ realToFrac a2 -- A 439 | uw (vtx2 + 7) $ realToFrac u1 -- U 440 | uw (vtx2 + 8) $ realToFrac v1 -- V 441 | -- Vertex 3 442 | uw (vtx3 + 0) $ realToFrac x1 -- X 443 | uw (vtx3 + 1) $ realToFrac y2 -- Y 444 | uw (vtx3 + 2) $ realToFrac (-qaDepth) -- Z 445 | uw (vtx3 + 3) $ realToFrac r3 -- R 446 | uw (vtx3 + 4) $ realToFrac g3 -- G 447 | uw (vtx3 + 5) $ realToFrac b3 -- B 448 | uw (vtx3 + 6) $ realToFrac a3 -- A 449 | uw (vtx3 + 7) $ realToFrac u0 -- U 450 | uw (vtx3 + 8) $ realToFrac v1 -- V 451 | -- Write rendering attributes (need to be strict since it's not an unboxed vector) 452 | VM.unsafeWrite qbAttribs numQuad $! QuadRenderAttrib { qaIndex = numQuad * 4, .. } 453 | -- One more quad 454 | modifyIORef' qbNumQuad (+ 1) 455 | 456 | -------------------------------------------------------------------------------- /QuadShaderSource.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE QuasiQuotes #-} 3 | 4 | module QuadShaderSource ( vsSrcBasic 5 | , fsSrcBasic 6 | , fsColOnlySrcBasic 7 | ) where 8 | 9 | import qualified Data.Text as T 10 | import qualified Data.Text.Encoding as TE 11 | import qualified Data.ByteString as B 12 | 13 | import QQPlainText 14 | 15 | -- Shader source for basic vertex and fragment shaders 16 | vsSrcBasic, fsSrcBasic, fsColOnlySrcBasic :: B.ByteString 17 | 18 | vsSrcBasic = TE.encodeUtf8 . T.pack $ 19 | [plaintext| #version 330 core 20 | uniform mat4 in_mvp; 21 | in vec3 in_pos; 22 | in vec4 in_col; 23 | in vec2 in_uv; 24 | out vec4 fs_col; 25 | out vec2 fs_uv; 26 | void main() 27 | { 28 | gl_Position = in_mvp * vec4(in_pos, 1.0); 29 | fs_col = in_col; 30 | fs_uv = in_uv; 31 | } 32 | |] 33 | 34 | fsSrcBasic = TE.encodeUtf8 . T.pack $ 35 | [plaintext| #version 330 core 36 | in vec4 fs_col; 37 | in vec2 fs_uv; 38 | uniform sampler2D tex; 39 | out vec4 frag_color; 40 | void main() 41 | { 42 | frag_color = fs_col * texture(tex, fs_uv); 43 | } 44 | |] 45 | 46 | fsColOnlySrcBasic = TE.encodeUtf8 . T.pack $ 47 | [plaintext| #version 330 core 48 | in vec4 fs_col; 49 | out vec4 frag_color; 50 | void main() 51 | { 52 | frag_color = fs_col; 53 | } 54 | |] 55 | 56 | -------------------------------------------------------------------------------- /QuadTypes.hs: -------------------------------------------------------------------------------- 1 | 2 | module QuadTypes ( RGBA(..) 3 | , FillColor(..) 4 | , QuadUV(..) 5 | ) where 6 | 7 | -- Types shared between different modules generating / processing / storing quads for 8 | -- OpenGL rendering. Put in their own module to reduce logical and compile time dependency 9 | -- between them 10 | 11 | data RGBA = RGBA {-# UNPACK #-} !Float 12 | {-# UNPACK #-} !Float 13 | {-# UNPACK #-} !Float 14 | {-# UNPACK #-} !Float 15 | deriving (Eq, Show) 16 | 17 | data FillColor = FCWhite 18 | | FCBlack 19 | | FCSolid !RGBA 20 | | FCBottomTopGradient !RGBA !RGBA 21 | | FCLeftRightGradient !RGBA !RGBA 22 | deriving (Eq, Show) 23 | 24 | data QuadUV = QuadUVDefault 25 | | QuadUV {-# UNPACK #-} !Float -- UV Bottom Left 26 | {-# UNPACK #-} !Float 27 | {-# UNPACK #-} !Float -- UV Top Right 28 | {-# UNPACK #-} !Float 29 | deriving (Eq, Show) 30 | 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | # Ray Marching Distance Fields 3 | 4 | This project is a Haskell and GLSL program containing my distance field / ray marching related experiments. The Haskell viewing application is doing the pre-processing, functioning as a development and debugging aid, allowing different shaders to be explored. It automatically reloads and recompiles shaders when they change, showing an overlay displaying any errors. There's a flexible frame buffer system, supporting under and super sampling and saving of screenshots. Tiled rendering avoids shader timeouts and unresponsive UI. It also features offline convolution of environment maps with a filter kernel to enable fast lighting of diffuse and glossy surfaces. Finally, there's an implementation of the Mandelbulb fractal as well as several simpler ones like Mandelbrot and Julia sets. There's some more functionality in the program, try it out and / or visit my website. 5 | 6 | **If you want to read actual algorithm descriptions and references of this project and see more, higher quality images visit the following links to my website** 7 | 8 | - [Ray Marching Distance Fields](http://www.blitzcode.net/haskell.shtml#ray_marching_distance_fields) 9 | - [Mandelbulb](http://www.blitzcode.net/haskell.shtml#mandelbulb) 10 | - [Prefiltered Environment Maps](http://www.blitzcode.net/haskell.shtml#prefiltered_environment_maps) 11 | - [Julia Set](http://www.blitzcode.net/haskell.shtml#julia_set) 12 | 13 | # Images 14 | 15 | A few low-resolution previews of pictures generated, visit the links above for more, higher quality images. 16 | 17 | ![rmdf](https://raw.github.com/blitzcode/ray-marching-distance-fields/master/img/rmdf.png) 18 | ![mandelbulb](https://raw.github.com/blitzcode/ray-marching-distance-fields/master/img/mandelbulb.png) 19 | ![prefiltered](https://raw.github.com/blitzcode/ray-marching-distance-fields/master/img/prefiltered.png) 20 | ![julia set](https://raw.github.com/blitzcode/ray-marching-distance-fields/master/img/julia_set.png) 21 | 22 | # Legal 23 | 24 | This program is published under the [MIT License](http://en.wikipedia.org/wiki/MIT_License). 25 | 26 | # Author 27 | 28 | Developed by Tim C. Schroeder, visit my [website](http://www.blitzcode.net) to learn more. 29 | 30 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ShaderRendering.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE RecordWildCards, ScopedTypeVariables, OverloadedStrings #-} 3 | 4 | module ShaderRendering ( withShaderRenderer 5 | , loadAndCompileShaders 6 | , ShaderRenderer 7 | , drawShaderTile 8 | , FragmentShader(..) 9 | , isTileIdxFirstTile 10 | , isTileIdxLastTile 11 | ) where 12 | 13 | import Control.Exception 14 | import Control.DeepSeq 15 | import Control.Monad.Trans 16 | import Control.Monad.Except 17 | import Control.Monad.Trans.Resource 18 | import Control.Concurrent.Async 19 | import System.Directory 20 | import System.FilePath 21 | import Data.Monoid 22 | import Text.Printf 23 | import qualified Data.ByteString as B 24 | import qualified Graphics.Rendering.OpenGL as GL 25 | import qualified Graphics.GL as GLR 26 | import qualified Codec.Picture as JP 27 | 28 | import Trace 29 | import Timing 30 | import GLHelpers 31 | import GLSLHelpers 32 | import ShaderRenderingVertexShaderSrc 33 | import HDREnvMap 34 | import CornellBox 35 | 36 | data ShaderRenderer = ShaderRenderer { srVAO :: !GL.VertexArrayObject 37 | , srShdFn :: !FilePath 38 | , srDECornellBoxShd :: !GL.Program 39 | , srDETestShd :: !GL.Program 40 | , srMBPower8Shd :: !GL.Program 41 | , srMBGeneralShd :: !GL.Program 42 | , srEnvCubeMaps :: [(String, GL.TextureObject)] 43 | , srCornellBoxGeomTex :: !GL.TextureObject 44 | } 45 | 46 | data FragmentShader = FSDECornellBoxShader | FSDETestShader | FSMBPower8Shader | FSMBGeneralShader 47 | deriving (Show, Eq, Enum) 48 | 49 | tilesX, tilesY, nTiles :: Int 50 | tilesX = 8 51 | tilesY = 8 52 | nTiles = tilesX * tilesY 53 | 54 | isTileIdxLastTile :: Int -> Bool 55 | isTileIdxLastTile idx = idx `mod` nTiles == nTiles - 1 56 | 57 | isTileIdxFirstTile :: Int -> Bool 58 | isTileIdxFirstTile idx = idx `mod` nTiles == 0 59 | 60 | withShaderRenderer :: FilePath -> FilePath -> (ShaderRenderer -> IO a) -> IO a 61 | withShaderRenderer srShdFn reflMapFn f = do 62 | -- Create, compile and link shaders, load resources 63 | r <- runExceptT . runResourceT $ do 64 | srVAO <- genObjectNameResource 65 | -- Load reflection environment map 66 | envStart <- liftIO getTick 67 | reflMap <- either throwError return =<< liftIO (loadHDRImage reflMapFn) 68 | -- Build debug environment map 69 | -- return buildTestLatLongEnvMap 70 | -- Build / verify cache of pre-convolved environment maps 71 | let powers = [1, 8, 64, 512] 72 | mkCacheFn pow | pow == 0 = reflMapFn 73 | | otherwise = dropExtension reflMapFn ++ 74 | "_cache_pow_" ++ show pow ++ ".hdr" 75 | powfn = map (\pow -> (pow, mkCacheFn pow)) powers -- Power / cache file nm. pairs 76 | liftIO $ buildPreConvolvedHDREnvMapCache reflMap powfn 77 | -- Load pre-convolved environment maps, convert to cube maps and upload to GPU 78 | -- 79 | -- TODO: Speed up load time by loading and converting environment map texture in a 80 | -- background thread, display white or a cached scale version in the meantime 81 | let convertAndAllocCM envMap = 82 | snd <$> allocate (latLongHDREnvMapToCubeMap envMap False) GL.deleteObjectName 83 | envCubeMaps <- forM powfn $ \(pow, fn) -> do 84 | envMap <- either throwError return =<< liftIO (loadHDRImage fn) 85 | tex <- convertAndAllocCM envMap 86 | return ( "env_cos_" ++ show (round pow :: Int) -- Shader uniform name 87 | , tex -- Cube map texture 88 | ) 89 | -- Add regular reflection environment map and store in record 90 | reflCubeMap <- convertAndAllocCM reflMap 91 | let srEnvCubeMaps = ("env_reflection", reflCubeMap) : envCubeMaps 92 | envEnd <- liftIO getTick 93 | -- Create fragment shaders 94 | [srDECornellBoxShd, srDETestShd, srMBPower8Shd, srMBGeneralShd] <- 95 | forM ([0..3] :: [Int]) $ \_ -> 96 | snd <$> allocate GL.createProgram GL.deleteObjectName 97 | -- Cornell box geometry texture 98 | srCornellBoxGeomTex <- 99 | snd <$> allocate mkCornellBoxVerticesTex GL.deleteObjectName 100 | -- Record 101 | let sr = ShaderRenderer { .. } 102 | -- Shaders 103 | shaderTime <- either throwError return 104 | =<< liftIO (loadAndCompileShaders sr) 105 | -- Statistics 106 | liftIO . traceS TLInfo $ printf 107 | "withShaderRenderer - Shader time: %.2fs, EnvMap time: %.2fs" 108 | shaderTime (envEnd - envStart) 109 | liftIO $ f sr 110 | either (traceAndThrow . printf "withShaderRenderer - Init failed:\n%s") return r 111 | 112 | loadAndCompileShaders :: ShaderRenderer -> IO (Either String Double) 113 | loadAndCompileShaders ShaderRenderer { .. } = runExceptT $ do 114 | -- Fragment shader is loaded from a file 115 | shaderStart <- liftIO getTick 116 | fsSrc <- either (\(e :: IOException) -> throwError $ show e) return 117 | =<< (liftIO . try . B.readFile $ srShdFn) 118 | -- Generate several shader variations through GLSL's pre-processor 119 | forM_ [ (srDECornellBoxShd, "#define CORNELL_BOX_SCENE" ) 120 | , (srDETestShd , "" ) 121 | , (srMBPower8Shd , "#define MANDELBULB_SCENE\n#define POWER8\n") 122 | , (srMBGeneralShd , "#define MANDELBULB_SCENE\n" ) 123 | ] 124 | $ \(shd, defines) -> 125 | let src = "#version 330 core\n" <> defines <> fsSrc 126 | in either throwError return =<< 127 | liftIO (compileShaderProgram vsSrcFSQuad src [] shd) 128 | shaderEnd <- liftIO getTick 129 | return $ shaderEnd - shaderStart -- Return shader load, compile and link time 130 | 131 | buildPreConvolvedHDREnvMapCache :: JP.Image JP.PixelRGBF -> [(Float, FilePath)] -> IO () 132 | buildPreConvolvedHDREnvMapCache reflMap powfn = do 133 | -- Check if we have any pre-convolved files missing 134 | missing <- filterM (fmap not . doesFileExist . snd) powfn 135 | unless (null missing) $ do 136 | traceS TLInfo $ printf "Missing %i pre-convolved environment map(s), computing..." 137 | (length missing) 138 | -- We compute the pre-convolved versions from a small, downsampled reflection map 139 | (timeResized, resized) <- timeIt . evaluate . force $ resizeHDRImage reflMap 256 140 | traceS TLInfo $ printf "Downsampled reflection environment in %.2fs" timeResized 141 | -- Compute missing convolutions in parallel 142 | void $ flip mapConcurrently missing $ \(pow, fn) -> do 143 | (timeConvolved, convolved) <- timeIt . evaluate . force $ 144 | cosineConvolveHDREnvMap resized pow 145 | traceS TLInfo $ printf "Computed power %.1f in %.2fs wallclock" pow timeConvolved 146 | (timeWritten, _) <- timeIt $ onException 147 | (JP.saveRadianceImage fn . JP.ImageRGBF $ convolved) 148 | (removeFile fn) -- Delete cache image file on error / cancellation 149 | traceS TLInfo $ printf "Written '%s' in %.2fs" (takeFileName fn) timeWritten 150 | 151 | drawShaderTile :: ShaderRenderer -> FragmentShader -> Maybe Int -> Int -> Int -> Double -> IO () 152 | drawShaderTile ShaderRenderer { .. } shdEnum tileIdx w h time = do 153 | -- We need a dummy VAO active with all vertex attributes disabled 154 | GL.bindVertexArrayObject GL.$= Just srVAO 155 | -- Bind shader 156 | let shd = case shdEnum of 157 | FSDECornellBoxShader -> srDECornellBoxShd 158 | FSDETestShader -> srDETestShd 159 | FSMBPower8Shader -> srMBPower8Shd 160 | FSMBGeneralShader -> srMBGeneralShd 161 | GL.currentProgram GL.$= Just shd 162 | -- Only set shader parameters on the first tile, don't want them to change 163 | -- over the course of a single frame 164 | when (case tileIdx of Nothing -> True; Just idx -> isTileIdxFirstTile idx) $ do 165 | -- Setup uniforms 166 | let uniformFloat nm val = 167 | GL.get (GL.uniformLocation shd nm) >>= \(GL.UniformLocation loc) -> 168 | GLR.glUniform1f loc val 169 | in do uniformFloat "in_screen_wdh" $ fromIntegral w 170 | uniformFloat "in_screen_hgt" $ fromIntegral h 171 | uniformFloat "in_time" $ realToFrac time 172 | -- Setup environment cube maps 173 | forM_ (zip srEnvCubeMaps ([0..] :: [Int])) $ \((uniformName, tex), tuIdx) -> do 174 | setTextureShader tex GL.TextureCubeMap tuIdx shd uniformName 175 | -- Cornell box geometry texture 176 | setTextureShader srCornellBoxGeomTex GL.Texture1D (length srEnvCubeMaps) shd "cornell_geom" 177 | -- Don't need any VBO etc, the vertex shader will make this a proper quad. 178 | -- Specify one dummy attribute, as some drivers apparently have an issue 179 | -- with this otherwise (http://stackoverflow.com/a/8041472/1898360) 180 | GLR.glVertexAttrib1f 0 0 181 | -- Optionally draw the full screen quad in tiles to prevent shader timeouts and increase UI 182 | -- responsibility when we're rendering very complex images or at very high resolution 183 | let (x0, y0, x1, y1) = 184 | case tileIdx of 185 | Nothing -> (-1, -1, 1, 1) 186 | Just idx -> let midx = idx `mod` nTiles 187 | tx = midx `mod` tilesX 188 | ty = midx `div` tilesX 189 | in ( (-1 + fromIntegral tx / fromIntegral tilesX * 2) 190 | , (-1 + fromIntegral ty / fromIntegral tilesY * 2) 191 | , (-1 + fromIntegral (tx + 1) / fromIntegral tilesX * 2) 192 | , (-1 + fromIntegral (ty + 1) / fromIntegral tilesY * 2) 193 | ) 194 | in GL.get (GL.uniformLocation shd "quad") >>= \(GL.UniformLocation loc) -> 195 | GLR.glUniform4f loc x0 y0 x1 y1 196 | GL.drawArrays GL.TriangleStrip 0 4 197 | 198 | -------------------------------------------------------------------------------- /ShaderRenderingVertexShaderSrc.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE QuasiQuotes #-} 3 | 4 | module ShaderRenderingVertexShaderSrc ( vsSrcFSQuad 5 | ) where 6 | 7 | import qualified Data.Text as T 8 | import qualified Data.Text.Encoding as TE 9 | import qualified Data.ByteString as B 10 | 11 | import QQPlainText 12 | 13 | vsSrcFSQuad :: B.ByteString 14 | vsSrcFSQuad = TE.encodeUtf8 . T.pack $ [plaintext| 15 | 16 | #version 330 core 17 | 18 | uniform vec4 quad = vec4(-1.0, -1.0, 1.0, 1.0); 19 | 20 | vec2 quad_vtx[4] = vec2[4] ( vec2(quad.x, quad.y) 21 | , vec2(quad.z, quad.y) 22 | , vec2(quad.x, quad.w) 23 | , vec2(quad.z, quad.w) 24 | ); 25 | void main() 26 | { 27 | gl_Position = vec4(quad_vtx[gl_VertexID], 0.0, 1.0); 28 | } 29 | 30 | |] 31 | 32 | -------------------------------------------------------------------------------- /Timing.hs: -------------------------------------------------------------------------------- 1 | 2 | module Timing ( getTick 3 | , timeIt 4 | ) where 5 | 6 | import Control.Exception 7 | import Data.Time.Clock 8 | import Control.Monad.IO.Class 9 | import System.IO.Unsafe 10 | 11 | -- Timing functions 12 | 13 | -- TODO: Consider just using the criterion package for all performance measurements 14 | -- http://hackage.haskell.org/package/criterion 15 | 16 | {-# NOINLINE startTime #-} 17 | startTime :: UTCTime 18 | startTime = unsafePerformIO getCurrentTime 19 | 20 | -- In seconds 21 | getTick :: IO Double 22 | getTick = do 23 | -- Make sure startTime has been evaluated, otherwise the getCurrentTime in the 24 | -- unsafePerformIO might be evaluated after the getCurrentTime here, returning a 25 | -- negative tick on the first call to getTick 26 | st <- evaluate startTime 27 | (realToFrac . flip diffUTCTime st) <$> getCurrentTime 28 | 29 | timeIt :: MonadIO m => m a -> m (Double, a) 30 | timeIt f = do 31 | start <- liftIO getCurrentTime 32 | r <- f 33 | end <- liftIO getCurrentTime 34 | return (realToFrac $ diffUTCTime end start, r) 35 | 36 | -------------------------------------------------------------------------------- /Trace.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Trace ( withTrace 5 | , TraceLevel(..) 6 | , traceT 7 | , traceS 8 | , traceB 9 | , traceAndThrow 10 | ) where 11 | 12 | -- Execution tracing for multiple threads into file / stdout 13 | 14 | import System.IO 15 | import System.IO.Unsafe (unsafePerformIO) 16 | import qualified System.Console.ANSI as A 17 | import Control.Concurrent.MVar 18 | import Control.Exception 19 | import Control.Monad 20 | import Control.Concurrent 21 | import qualified Data.Text as T 22 | import qualified Data.Text.IO as TI 23 | import qualified Data.Text.Encoding as E 24 | import qualified Data.ByteString as B 25 | import Data.Time 26 | import Data.List 27 | import Data.Monoid 28 | import Text.Printf 29 | 30 | data TraceLevel = TLNone | TLError | TLWarn | TLInfo 31 | deriving (Eq, Enum) 32 | 33 | data TraceSettings = TraceSettings { tsFile :: Maybe Handle 34 | , tsEchoOn :: Bool 35 | , tsColorOn :: Bool 36 | , tsLevel :: TraceLevel 37 | } 38 | 39 | -- The well-known unsafePerformIO hack. It would be a bit cumbersome to always pass the trace 40 | -- record around or always be in a reader or special trace monad 41 | {-# NOINLINE traceSettings #-} 42 | traceSettings :: MVar TraceSettings 43 | traceSettings = unsafePerformIO newEmptyMVar 44 | 45 | withTrace :: Maybe FilePath -> Bool -> Bool -> Bool -> TraceLevel -> IO () -> IO () 46 | withTrace traceFn echoOn appendOn colorOn level f = 47 | bracket 48 | ( do h <- case traceFn of Just fn -> if level /= TLNone 49 | then Just <$> openFile fn (if appendOn 50 | then AppendMode 51 | else WriteMode) 52 | else return Nothing 53 | _ -> return Nothing 54 | let ts = TraceSettings { tsFile = h 55 | , tsEchoOn = echoOn 56 | , tsColorOn = colorOn 57 | , tsLevel = level 58 | } 59 | r <- tryPutMVar traceSettings ts 60 | unless r $ error "Double initialization of Trace module" 61 | return ts 62 | ) 63 | ( \ts -> do traceT TLInfo "Shutting down trace system" 64 | void . takeMVar $ traceSettings 65 | case tsFile ts of Just h -> hClose h 66 | _ -> return () 67 | when (tsEchoOn ts) $ hFlush stdout 68 | ) 69 | $ \_ -> f 70 | 71 | trace :: TraceLevel -> T.Text -> IO () 72 | trace lvl msg = void $ withMVar traceSettings $ \ts -> -- TODO: Have to take an MVar even if 73 | -- tracing is off, speed this up 74 | when (lvl /= TLNone && fromEnum lvl <= fromEnum (tsLevel ts)) $ do 75 | tid <- printf "%-12s" . show <$> myThreadId 76 | time <- printf "%-26s" . show . zonedTimeToLocalTime <$> getZonedTime 77 | let lvlDesc color = (if color then concat else (!! 1)) $ case lvl of 78 | TLError -> [ mkANSICol A.Red , "ERROR", reset ] 79 | TLWarn -> [ mkANSICol A.Yellow, "WARN ", reset ] 80 | TLInfo -> [ mkANSICol A.White , "INFO ", reset ] 81 | _ -> replicate 3 "" 82 | reset = A.setSGRCode [] 83 | mkANSICol c = A.setSGRCode [ A.SetColor A.Foreground A.Vivid c ] 84 | header color = intercalate " | " [ lvlDesc color, tid, time ] 85 | handles = case tsFile ts of Just h -> [h]; _ -> []; ++ [stdout | tsEchoOn ts] 86 | oneLine = not (T.any (== '\n') msg) && T.length msg < 80 87 | forM_ handles $ \h -> do 88 | closed <- hIsClosed h 89 | hs <- hShow h 90 | -- Use ANSI colors when outputting to the terminal 91 | color <- (&&) (tsColorOn ts) <$> hIsTerminalDevice h 92 | if closed 93 | then TI.putStrLn $ "ERROR: Trace message lost, called trace after shutdown: " <> msg 94 | <> "\n" <> T.pack hs <> "\n" <> T.pack (show h) 95 | else -- Display short, unbroken messages in a single line without padding newline 96 | if oneLine 97 | then TI.hPutStrLn h $ T.pack (header color) <> " - " <> msg 98 | else do hPutStrLn h $ header color 99 | TI.hPutStrLn h msg 100 | hPutStrLn h "" 101 | 102 | traceT :: TraceLevel -> T.Text -> IO () 103 | traceT = trace 104 | 105 | traceS :: TraceLevel -> String -> IO () 106 | traceS lvl msg = trace lvl (T.pack msg) 107 | 108 | traceB :: TraceLevel -> B.ByteString -> IO () 109 | traceB lvl msg = trace lvl (E.decodeUtf8 msg) 110 | 111 | traceAndThrow :: String -> IO a 112 | traceAndThrow err = traceS TLError err >> (throwIO $ ErrorCall err) 113 | 114 | -------------------------------------------------------------------------------- /fragment.shd: -------------------------------------------------------------------------------- 1 | 2 | // --------------------------------------------------------- 3 | // Ray marching distance fields plus shading with IBL and AO 4 | // --------------------------------------------------------- 5 | 6 | uniform float in_time; 7 | uniform float in_screen_wdh; 8 | uniform float in_screen_hgt; 9 | 10 | uniform samplerCube env_reflection; 11 | uniform samplerCube env_cos_1; 12 | uniform samplerCube env_cos_8; 13 | uniform samplerCube env_cos_64; 14 | uniform samplerCube env_cos_512; 15 | 16 | uniform sampler1D cornell_geom; 17 | 18 | out vec4 frag_color; 19 | 20 | // http://iquilezles.org/www/articles/distfunctions/distfunctions.htm 21 | float de_sphere(vec3 pos, float r) 22 | { 23 | return length(pos) - r; 24 | } 25 | float de_torus(vec3 pos, float torus_size, float torus_r) 26 | { 27 | vec2 q = vec2(length(pos.xy) - torus_size, pos.z); 28 | return length(q) - torus_r; 29 | } 30 | float de_rounded_box(vec3 pos, vec3 box, float r) 31 | { 32 | return length(max(abs(pos) - box, 0.0)) - r; 33 | } 34 | float de_cone(vec3 pos, vec2 c) 35 | { 36 | // c must be normalized 37 | float q = length(pos.xz); 38 | return dot(c, vec2(q, pos.y)); 39 | } 40 | 41 | // http://en.wikipedia.org/wiki/Spherical_coordinate_system 42 | void cartesian_to_spherical(vec3 p, out float r, out float theta, out float phi) 43 | { 44 | r = length(p); 45 | theta = acos(p.z / r); 46 | phi = atan(p.y, p.x); 47 | } 48 | vec3 spherical_to_cartesian(float r, float theta, float phi) 49 | { 50 | return r * vec3(sin(theta) * cos(phi), sin(theta) * sin(phi), cos(theta)); 51 | } 52 | 53 | vec3 triplex_pow(vec3 w, float power) 54 | { 55 | // General pow() for our triplex numbers 56 | // 57 | // http://blog.hvidtfeldts.net/index.php/2011/09/ 58 | // distance-estimated-3d-fractals-iv-the-holy-grail/ 59 | // 60 | // http://blog.hvidtfeldts.net/index.php/2011/09/ 61 | // distance-estimated-3d-fractals-v-the-mandelbulb-different-de-approximations/ 62 | 63 | float r, theta, phi; 64 | cartesian_to_spherical(w, r, theta, phi); 65 | 66 | // Scale and rotate the point 67 | float zr = pow(r, power); 68 | theta = theta * power; 69 | phi = phi * power; 70 | 71 | return spherical_to_cartesian(zr, theta, phi); 72 | } 73 | 74 | vec3 triplex_pow8(vec3 w) 75 | { 76 | // Optimized pow(x, 8) for our triplex numbers (special case without transcendentals) 77 | // 78 | // http://www.iquilezles.org/www/articles/mandelbulb/mandelbulb.htm 79 | // 80 | // (modified so the Mandelbulb has the same orientation as the general triplex_pow() one) 81 | // 82 | // TODO: Have specialized versions of all the integer powers, i.e. 83 | // http://www.fractalforums.com/index.php?action=dlattach;topic=742.0;attach=429;image 84 | // http://en.wikipedia.org/wiki/Mandelbulb 85 | 86 | float x = w.x; float x2 = x*x; float x4 = x2*x2; 87 | float y = w.y; float y2 = y*y; float y4 = y2*y2; 88 | float z = w.z; float z2 = z*z; float z4 = z2*z2; 89 | 90 | float k3 = y2 + x2; 91 | float k2 = inversesqrt( k3*k3*k3*k3*k3*k3*k3 ); 92 | float k1 = y4 + z4 + x4 - 6.0*z2*x2 - 6.0*y2*z2 + 2.0*x2*y2; 93 | float k4 = y2 - z2 + x2; 94 | 95 | return vec3( -8.0*z*k4*(y4*y4 - 28.0*y4*y2*x2 + 70.0*y4*x4 - 28.0*y2*x2*x4 + x4*x4)*k1*k2 96 | , 64.0*y*z*x*(y2-x2)*k4*(y4-6.0*y2*x2+x4)*k1*k2 97 | , -16.0*z2*k3*k4*k4 + k1*k1 98 | ); 99 | } 100 | 101 | float de_mandelbulb(vec3 pos) 102 | { 103 | // References 104 | // 105 | // http://www.skytopia.com/project/fractal/mandelbulb.html 106 | // http://www.bugman123.com/Hypercomplex/index.html 107 | // http://blog.hvidtfeldts.net/index.php/2011/09/ 108 | // distance-estimated-3d-fractals-v-the-mandelbulb-different-de-approximations/ 109 | // 110 | // TODO: Understand and try out some of the other DE methods from the link above 111 | 112 | #ifdef POWER8 113 | float power = 8; 114 | #else 115 | // Animate power 116 | float pow_offs = mod(in_time / 2, 9); 117 | if (pow_offs > 4.5) 118 | pow_offs = 9 - pow_offs; 119 | float power = pow_offs + 2; 120 | #endif 121 | const float bailout = 4; 122 | const int iterations = 25; 123 | 124 | // Swap some axis so our Mandelbulb is upright instead of lying on the side 125 | pos = pos.zxy; 126 | 127 | // Iterate. This is pretty much what we'd do for a Mandelbrot set, except that instead of 128 | // complex numbers we have triplex numbers with a special power operation that rotates 129 | // and scales in spherical coordinates 130 | vec3 w = pos; 131 | float dr = 1.0; 132 | float r = 0.0; 133 | // vec3 trap = abs(w); 134 | for (int i=0; i bailout) 139 | break; 140 | #ifdef POWER8 141 | w = triplex_pow8(w); 142 | #else 143 | w = triplex_pow(w, power); 144 | #endif 145 | w += pos; 146 | 147 | // Running scalar derivative 148 | dr = pow(r, power - 1.0) * power * dr + 1.0; 149 | 150 | // Use the three coordinate system axis-aligned planes as orbit traps 151 | // trap = min(trap, abs(w)); 152 | } 153 | 154 | // surf_col = trap; 155 | 156 | // Distance estimate from running derivative and escape radius 157 | return 0.5 * log(r) * r / dr; 158 | } 159 | 160 | // Generalized Distance Functions 161 | // 162 | // http://www.pouet.net/topic.php?which=7931&page=1#c365231 163 | // http://www.viz.tamu.edu/faculty/ergun/research/implicitmodeling/papers/sm99.pdf 164 | // 165 | const vec3 gd_n1 = vec3( 1.000, 0.000, 0.000); 166 | const vec3 gd_n2 = vec3( 0.000, 1.000, 0.000); 167 | const vec3 gd_n3 = vec3( 0.000, 0.000, 1.000); 168 | const vec3 gd_n4 = vec3( 0.577, 0.577, 0.577); 169 | const vec3 gd_n5 = vec3(-0.577, 0.577, 0.577); 170 | const vec3 gd_n6 = vec3( 0.577, -0.577, 0.577); 171 | const vec3 gd_n7 = vec3( 0.577, 0.577, -0.577); 172 | const vec3 gd_n8 = vec3( 0.000, 0.357, 0.934); 173 | const vec3 gd_n9 = vec3( 0.000, -0.357, 0.934); 174 | const vec3 gd_n10 = vec3( 0.934, 0.000, 0.357); 175 | const vec3 gd_n11 = vec3(-0.934, 0.000, 0.357); 176 | const vec3 gd_n12 = vec3( 0.357, 0.934, 0.000); 177 | const vec3 gd_n13 = vec3(-0.357, 0.934, 0.000); 178 | const vec3 gd_n14 = vec3( 0.000, 0.851, 0.526); 179 | const vec3 gd_n15 = vec3( 0.000, -0.851, 0.526); 180 | const vec3 gd_n16 = vec3( 0.526, 0.000, 0.851); 181 | const vec3 gd_n17 = vec3(-0.526, 0.000, 0.851); 182 | const vec3 gd_n18 = vec3( 0.851, 0.526, 0.000); 183 | const vec3 gd_n19 = vec3(-0.851, 0.526, 0.000); 184 | float de_octahedral(vec3 p, float e, float r) 185 | { 186 | float s = pow(abs(dot(p, gd_n4)), e); 187 | s += pow(abs(dot(p, gd_n5)), e); 188 | s += pow(abs(dot(p, gd_n6)), e); 189 | s += pow(abs(dot(p, gd_n7)), e); 190 | s = pow(s, 1.0 / e); 191 | return s - r; 192 | } 193 | float de_dodecahedral(vec3 p, float e, float r) 194 | { 195 | float s = pow(abs(dot(p, gd_n14)), e); 196 | s += pow(abs(dot(p, gd_n15)), e); 197 | s += pow(abs(dot(p, gd_n16)), e); 198 | s += pow(abs(dot(p, gd_n17)), e); 199 | s += pow(abs(dot(p, gd_n18)), e); 200 | s += pow(abs(dot(p, gd_n19)), e); 201 | s = pow(s, 1.0 / e); 202 | return s - r; 203 | } 204 | float de_icosahedral(vec3 p, float e, float r) 205 | { 206 | float s = pow(abs(dot(p, gd_n4)), e); 207 | s += pow(abs(dot(p, gd_n5 )), e); 208 | s += pow(abs(dot(p, gd_n6 )), e); 209 | s += pow(abs(dot(p, gd_n7 )), e); 210 | s += pow(abs(dot(p, gd_n8 )), e); 211 | s += pow(abs(dot(p, gd_n9 )), e); 212 | s += pow(abs(dot(p, gd_n10)), e); 213 | s += pow(abs(dot(p, gd_n11)), e); 214 | s += pow(abs(dot(p, gd_n12)), e); 215 | s += pow(abs(dot(p, gd_n13)), e); 216 | s = pow(s, 1.0 / e); 217 | return s - r; 218 | } 219 | float de_toctahedral(vec3 p, float e, float r) 220 | { 221 | float s = pow(abs(dot(p, gd_n1)), e); 222 | s += pow(abs(dot(p, gd_n2)), e); 223 | s += pow(abs(dot(p, gd_n3)), e); 224 | s += pow(abs(dot(p, gd_n4)), e); 225 | s += pow(abs(dot(p, gd_n5)), e); 226 | s += pow(abs(dot(p, gd_n6)), e); 227 | s += pow(abs(dot(p, gd_n7)), e); 228 | s = pow(s, 1.0 / e); 229 | return s - r; 230 | } 231 | float de_ticosahedral(vec3 p, float e, float r) 232 | { 233 | float s = pow(abs(dot(p, gd_n4)), e); 234 | s += pow(abs(dot(p, gd_n5 )), e); 235 | s += pow(abs(dot(p, gd_n6 )), e); 236 | s += pow(abs(dot(p, gd_n7 )), e); 237 | s += pow(abs(dot(p, gd_n8 )), e); 238 | s += pow(abs(dot(p, gd_n9 )), e); 239 | s += pow(abs(dot(p, gd_n10)), e); 240 | s += pow(abs(dot(p, gd_n11)), e); 241 | s += pow(abs(dot(p, gd_n12)), e); 242 | s += pow(abs(dot(p, gd_n13)), e); 243 | s += pow(abs(dot(p, gd_n14)), e); 244 | s += pow(abs(dot(p, gd_n15)), e); 245 | s += pow(abs(dot(p, gd_n16)), e); 246 | s += pow(abs(dot(p, gd_n17)), e); 247 | s += pow(abs(dot(p, gd_n18)), e); 248 | s += pow(abs(dot(p, gd_n19)), e); 249 | s = pow(s, 1.0 / e); 250 | return s - r; 251 | } 252 | 253 | bool intersect_triangle( vec3 orig 254 | , vec3 dir 255 | , vec3 vert0 256 | , vec3 vert1 257 | , vec3 vert2 258 | , out float t 259 | , out float u 260 | , out float v 261 | ) 262 | { 263 | // Fast, Minimum Storage Ray-Triangle Intersection 264 | // 265 | // Tomas Möller and Ben Trumbore. Fast, minimum storage ray-triangle intersection. 266 | // Journal of graphics tools, 2(1):21-28, 1997 267 | // 268 | // http://www.jcenligne.fr/download/little3d/ 269 | // jgt%20Fast,%20Minumum%20Storage%20Ray-Triangle%20Intersection.htm 270 | 271 | const float JGT_RAYTRI_EPSILON = 0.000001; 272 | 273 | vec3 edge1, edge2, tvec, pvec, qvec; 274 | float det, inv_det; 275 | 276 | // Find vectors for two edges sharing vert0 277 | edge1 = vert1 - vert0; 278 | edge2 = vert2 - vert0; 279 | 280 | // Begin calculating determinant - also used to calculate U parameter 281 | pvec = cross(dir, edge2); 282 | 283 | // If determinant is near zero, ray lies in plane of triangle 284 | det = dot(edge1, pvec); 285 | 286 | if (det > -JGT_RAYTRI_EPSILON && det < JGT_RAYTRI_EPSILON) 287 | return false; 288 | inv_det = 1.0 / det; 289 | 290 | // Calculate distance from vert0 to ray origin 291 | tvec = orig - vert0; 292 | 293 | // Calculate U parameter and test bounds 294 | u = dot(tvec, pvec) * inv_det; 295 | if (u < 0.0 || u > 1.0) 296 | return false; 297 | 298 | // Prepare to test V parameter 299 | qvec = cross(tvec, edge1); 300 | 301 | // Calculate V parameter and test bounds 302 | v = dot(dir, qvec) * inv_det; 303 | if (v < 0.0 || u + v > 1.0) 304 | return false; 305 | 306 | // Calculate t, ray intersects triangle 307 | t = dot(edge2, qvec) * inv_det; 308 | 309 | return true; 310 | } 311 | 312 | float line_seg_min_dist_sq(vec3 a, vec3 b, vec3 p) 313 | { 314 | // Squared distance to the closest point from p on the line segment a b 315 | vec3 ab = b - a; 316 | float len_sq = dot(ab, ab); 317 | float t = dot(p - a, ab) / len_sq; 318 | t = clamp(t, 0, 1); 319 | vec3 proj = a + t * ab; 320 | return dot(p-proj, p-proj); 321 | } 322 | 323 | bool compute_barycentric(vec3 pos, vec3 v0, vec3 v1, vec3 v2, out float u, out float v) 324 | { 325 | // Compute the barycentric coordinates of a point, return if the point is inside 326 | // the triangle, or more accurate, inside its triangular prism 327 | // 328 | // Source: http://www.blackpawn.com/texts/pointinpoly/ 329 | 330 | vec3 e0 = v2 - v0; 331 | vec3 e1 = v1 - v0; 332 | vec3 e2 = pos - v0; 333 | 334 | float dot00 = dot(e0, e0); 335 | float dot01 = dot(e0, e1); 336 | float dot02 = dot(e0, e2); 337 | float dot11 = dot(e1, e1); 338 | float dot12 = dot(e1, e2); 339 | 340 | float inv_denom = 1 / (dot00 * dot11 - dot01 * dot01); 341 | u = (dot11 * dot02 - dot01 * dot12) * inv_denom; 342 | v = (dot00 * dot12 - dot01 * dot02) * inv_denom; 343 | 344 | // Check if point is in triangle 345 | return (u >= 0) && (v >= 0) && (u + v < 1); 346 | } 347 | 348 | float de_triangle(vec3 pos, vec3 v0, vec3 v1, vec3 v2) 349 | { 350 | // Compute the distance between a point and a triangle. This is either the closest 351 | // point on the plane (if it is inside the triangle), or the closest point on any of 352 | // the three edges. Note that if we remove the 'inside triangle' case we get a DE for 353 | // the edges only, allowing us to produce a wireframe rendering 354 | // 355 | // TODO: Explore some other, potentially faster methods of computing this 356 | // http://www-compsci.swan.ac.uk/~csmark/PDFS/dist.pdf 357 | // http://www.ann.jussieu.fr/~frey/papers/divers/ 358 | // Jones%20M.W.,%203d%20distance%20fields,%20a%20survey.pdf 359 | 360 | float u, v; 361 | if (compute_barycentric(pos, v0, v1, v2, u, v)) 362 | { 363 | vec3 point_on_plane = v2 * u + v1 * v + v0 * (1 - (u + v)); 364 | return distance(pos, point_on_plane); 365 | } 366 | else 367 | { 368 | return sqrt(min(line_seg_min_dist_sq(v0, v1, pos), 369 | min(line_seg_min_dist_sq(v0, v2, pos), 370 | line_seg_min_dist_sq(v1, v2, pos)))); 371 | } 372 | } 373 | 374 | float de_cornell_box(vec3 pos) 375 | { 376 | // Trying to store the array with the Cornell Box geometry as literal data caused issues. 377 | // The compiler tries to unroll the entire loop, inlining the de_triangle() function 32 378 | // times. This will stall glUseProgram(), where the actual code generation / optimization 379 | // happens, for a very long time (see 380 | // http://lists.apple.com/archives/mac-opengl/2008/Nov/msg00003.html). Also, in general 381 | // indexing into a large constant array seems to be something that doesn't map well to 382 | // shader hardware, so here we store the vertices in a floating-point texture instead 383 | // 384 | // TODO: It would be useful to explore acceleration structures for triangle meshes. 385 | // 386 | // Here's a survey with a section on that subject: 387 | // 388 | // http://www.ann.jussieu.fr/~frey/papers/divers/ 389 | // Jones%20M.W.,%203d%20distance%20fields,%20a%20survey.pdf 390 | // 391 | // This approach seems promising: 392 | // 393 | // https://graphics.stanford.edu/courses/cs468-03-fall/Papers/ 394 | // completeDistanceFieldRep.pdf 395 | // 396 | // Rather memory and pre-computation intensive, but the final representation is 397 | // very GPU traversal friendly and there is no loss of precision as with 398 | // the voxelization approaches 399 | // 400 | float dist = 999; 401 | for (int i=0; i<32; i++) 402 | { 403 | // TODO: We could just compare squared distance and take the sqrt() at the end 404 | dist = min(dist, de_triangle(pos, texelFetch(cornell_geom, i * 3 + 0, 0).xyz, 405 | texelFetch(cornell_geom, i * 3 + 1, 0).xyz, 406 | texelFetch(cornell_geom, i * 3 + 2, 0).xyz)); 407 | } 408 | // dist = min(dist, de_toctahedral(pos + vec3(-0.17, -0.28, -0.06), 40, 0.175)); 409 | // dist = min(dist, de_ticosahedral(pos + vec3(0.2, 0.05, 0.2), 40, 0.175)); 410 | return dist; 411 | } 412 | 413 | float smin(float a, float b, float k) 414 | { 415 | // http://iquilezles.org/www/articles/smin/smin.htm 416 | float res = exp(-k * a) + exp(-k * b); 417 | return -log(res) / k; 418 | } 419 | 420 | float distance_estimator(vec3 pos) 421 | { 422 | #if defined(MANDELBULB_SCENE) 423 | return de_mandelbulb(pos); 424 | #elif defined(CORNELL_BOX_SCENE) 425 | return de_cornell_box(pos); 426 | #else 427 | // float offset = 428 | // 0.03*sin(20.0*pos.x+in_time)*sin(20.0*pos.y+in_time)*sin(20.0*pos.z+in_time); 429 | // return de_triangle(pos, vec3(-0.25, -0.25, 0), vec3(0.25, -0.25, 0), vec3(0, 0.25, 0)); 430 | /* 431 | return smin(de_rounded_box(pos, vec3(0.05, 0.85, 0.05), 0.05), 432 | smin(de_rounded_box(pos, vec3(0.1, 0.1, 0.85), 0.05), 433 | smin(de_sphere(pos, 0.3), 434 | de_torus(pos, 0.8, 0.2), 435 | 32), 32), 64); 436 | */ 437 | // return de_cone(pos + vec3(0, -1, 0), normalize(vec2(0.2, 0.1))); 438 | /* 439 | float min_dist = 999; 440 | min_dist = min(min_dist, de_octahedral(pos + vec3(-0.5, -0.5, 0), 30, 0.20)); 441 | min_dist = min(min_dist, de_dodecahedral(pos + vec3(-0.5, 0.5, 0), 50, 0.25)); 442 | min_dist = min(min_dist, de_icosahedral(pos + vec3(0.5, 0.5, 0), 50, 0.25)); 443 | min_dist = min(min_dist, de_toctahedral(pos + vec3(0.5, -0.5, 0), 50, 0.25)); 444 | min_dist = min(min_dist, de_ticosahedral(pos + vec3(0, 0, 0), 50, 0.25)); 445 | return min_dist; 446 | */ 447 | float d_sphere = de_sphere(pos, 0.4); 448 | float d_torus = smin(smin( 449 | de_torus(pos, 0.85, 0.1), 450 | de_torus(pos.zxy, 0.85, 0.1), 64), 451 | de_torus(pos.yzx, 0.85, 0.1), 64); 452 | float d_box = smin(smin( 453 | de_rounded_box(pos, vec3(0.8, 0.06, 0.06), 0.03), 454 | de_rounded_box(pos, vec3(0.06, 0.8, 0.06), 0.03), 64), 455 | de_rounded_box(pos, vec3(0.06, 0.06, 0.8), 0.03), 64); 456 | return smin(d_box, min(d_sphere, d_torus), 64); 457 | #endif 458 | } 459 | 460 | // http://en.wikipedia.org/wiki/Finite_difference#Forward.2C_backward.2C_and_central_differences 461 | // http://blog.hvidtfeldts.net/index.php/2011/08/ 462 | // distance-estimated-3d-fractals-ii-lighting-and-coloring/ 463 | vec3 normal_backward_difference(vec3 pos) 464 | { 465 | float c = distance_estimator(pos); 466 | const float eps = 0.00001; 467 | return normalize(vec3(c - distance_estimator(pos - vec3(eps, 0.0, 0.0)), 468 | c - distance_estimator(pos - vec3(0.0, eps, 0.0)), 469 | c - distance_estimator(pos - vec3(0.0, 0.0, eps)))); 470 | } 471 | vec3 normal_central_difference(vec3 pos) 472 | { 473 | const float eps = 0.00001; 474 | const vec3 epsX = vec3(eps, 0.0, 0.0); 475 | const vec3 epsY = vec3(0.0, eps, 0.0); 476 | const vec3 epsZ = vec3(0.0, 0.0, eps); 477 | return normalize(vec3(distance_estimator(pos + epsX) - distance_estimator(pos - epsX), 478 | distance_estimator(pos + epsY) - distance_estimator(pos - epsY), 479 | distance_estimator(pos + epsZ) - distance_estimator(pos - epsZ))); 480 | } 481 | 482 | // Compute the world-space surface normal from the screen-space partial derivatives 483 | // of the intersection distance (depth) and the camera transform 484 | vec3 normal_screen_space_depth(float dx, float dy, mat4x4 camera) 485 | { 486 | // TODO: This is wrong, use normal_screen_space_isec() 487 | return (camera * vec4(normalize(vec3(dx, dy, sqrt(dx*dx + dy*dy))), 0)).xyz; 488 | } 489 | 490 | // Normal from position through screen-space partial derivatives 491 | vec3 normal_screen_space_isec(vec3 p) 492 | { 493 | return cross(normalize(dFdx(p)), normalize(dFdy(p))); 494 | } 495 | 496 | // Distance AO based on the following references: 497 | // 498 | // http://www.iquilezles.org/www/material/nvscene2008/rwwtt.pdf 499 | // http://www.mazapan.se/news/2010/07/15/gpu-ray-marching-with-distance-fields/ 500 | // 501 | // 5 1 502 | // ao = 1 - k * E --- (i * d - distfield(p + n * i * d)) 503 | // i=1 2^i 504 | // 505 | // The above never really seemed to work properly, though. At the very least it 506 | // seems to be required to divide the 'd - distfield' term by d to have it normalized. 507 | // 508 | // Then, there are still errors due to the distance at p not being zero, which makes 509 | // sense as the ray marcher will stop at a min. distance. A cheap fix is to simply clamp 510 | // the term. There's also some kind of surface acne problem that can be mitigated by back 511 | // stepping on the ray like for the normal computation. The deltas are also poorly setup, 512 | // with some spheres contributing little more than artifacts or a constant occlusion 513 | // 514 | float distance_ao_old(vec3 p, vec3 n) 515 | { 516 | float weight = 0.5; 517 | float occl_sum = 0.0; 518 | 519 | for (int i=0; i<5; i++) 520 | { 521 | // Test progressively larger spheres further away along the surface normal 522 | float delta = pow(i + 1.0, 4.0) * 0.001; // i = 0..4, delta = 0.001..0.625 523 | 524 | // Check sphere occlusion. The back stepping epsilon seems fairly large, but 525 | // anything smaller causes issues. The change in position in combination with 526 | // the min. distance at which the ray marcher stops will cause the occlusion 527 | // term to leave its range, for now we fix this by simply clamping it instead 528 | // of trying to account for these errors 529 | occl_sum += weight * clamp( 530 | 1.0 - distance_estimator((p + n * 0.001) + n * delta) / delta, 0.0, 1.0); 531 | 532 | // More distant, outer spheres contribute exponentially less to the occlusion sum 533 | weight *= 0.5; 534 | } 535 | 536 | // Magic fudge factor to make dark parts darker and bright parts brighter 537 | occl_sum = (clamp((occl_sum * 2 - 1) * 1.65, -1, 1) + 1) * 0.5; 538 | return pow(1.0 - occl_sum, 8.0); 539 | } 540 | 541 | // Faster, simpler, more stable, less artifacts version of distance_ao_old() 542 | float distance_ao(vec3 p, vec3 n) 543 | { 544 | #ifndef CORNELL_BOX_SCENE 545 | float occl_sum = 0.0; 546 | float weight, delta; 547 | 548 | weight = 0.5; 549 | delta = 0.016; 550 | occl_sum += weight * clamp(1.0 - distance_estimator(p + n * delta) / delta, 0.0, 1.0); 551 | 552 | weight = 0.25; 553 | delta = 0.081; 554 | occl_sum += weight * clamp(1.0 - distance_estimator(p + n * delta) / delta, 0.0, 1.0); 555 | 556 | // Magic fudge factor to make dark parts darker and bright parts brighter 557 | occl_sum = 1 - occl_sum; 558 | occl_sum -= 0.29; 559 | occl_sum *= 3.5; 560 | occl_sum *= occl_sum; 561 | occl_sum = clamp(occl_sum, 0, 1); 562 | return occl_sum; 563 | 564 | //occl_sum = (clamp((occl_sum * 2 - 1) * 2.0, -1, 1) + 1) * 0.5; 565 | //occl_sum = 1 - occl_sum; 566 | //return occl_sum * occl_sum; 567 | #else 568 | float occl_sum = 0.0; 569 | float weight, delta; 570 | 571 | weight = 0.1; 572 | delta = 0.1; 573 | occl_sum += weight * clamp(1.0 - distance_estimator(p + n * delta) / delta, 0.0, 1.0); 574 | 575 | weight = 0.2; 576 | delta = 0.2; 577 | occl_sum += weight * clamp(1.0 - distance_estimator(p + n * delta) / delta, 0.0, 1.0); 578 | 579 | weight = 0.125; 580 | delta = 0.4; 581 | occl_sum += weight * clamp(1.0 - distance_estimator(p + n * delta) / delta, 0.0, 1.0); 582 | 583 | weight = 0.0625; 584 | delta = 0.5; 585 | occl_sum += weight * clamp(1.0 - distance_estimator(p + n * delta) / delta, 0.0, 1.0); 586 | 587 | // Magic fudge factor to make dark parts darker and bright parts brighter 588 | occl_sum = 1 - occl_sum; 589 | return occl_sum; 590 | #endif 591 | } 592 | 593 | // TODO: Could try implementing SSS based on the distance_ao() function 594 | 595 | bool ray_sphere( vec3 origin 596 | , vec3 dir 597 | , vec3 spherePos 598 | , float sphereR 599 | , out float tmin 600 | , out float tmax 601 | ) 602 | { 603 | vec3 rs = spherePos - origin; 604 | float t = dot(dir, rs); 605 | float a = dot(rs, rs) - t * t; 606 | float r2 = sphereR * sphereR; 607 | 608 | if (a > r2) 609 | return false; 610 | 611 | float h = sqrt(r2 - a); 612 | tmin = t - h; 613 | tmax = t + h; 614 | 615 | return true; 616 | } 617 | 618 | bool ray_march( vec3 origin 619 | , vec3 dir 620 | , out float t // Intersection T along the ray 621 | , out float step_gradient // Step count based gradient (for cheap fake AO) 622 | ) 623 | { 624 | // Ray march till we come close enough to a surface or exceed the iteration count 625 | // 626 | // References: 627 | // 628 | // http://blog.hvidtfeldts.net/index.php/2011/06/distance-estimated-3d-fractals-part-i/ 629 | // http://www.iquilezles.org/www/material/nvscene2008/rwwtt.pdf 630 | 631 | // TODO: Adjust ray marching MIN_DIST, FD normal epsilon and ray step back 632 | // based screen projection, like in https://www.shadertoy.com/view/MdfGRr 633 | 634 | const int MAX_STEPS = 128; 635 | const float MIN_DIST = 0.001; 636 | 637 | // First intersect with a bounding sphere. Helps quickly reject rays which can't 638 | // possibly intersect with the scene and brings our starting point closer 639 | // to the surface (DEs get very imprecise when we're starting to far away) 640 | const float b_sphere_r = 641 | #ifdef MANDELBULB_SCENE 642 | #ifdef POWER8 643 | 1.15; 644 | #else 645 | 1.5; 646 | #endif 647 | #else 648 | 1.0; 649 | #endif 650 | float tspheremin, tspheremax; 651 | if (!ray_sphere(origin, dir, vec3(0,0,0), b_sphere_r, tspheremin, tspheremax)) 652 | return false; 653 | t = tspheremin; 654 | 655 | // Ignore intersections behind the origin, might otherwise render scene with flipped 656 | // ray direction if we're looking away from it 657 | t = max(0, t); 658 | 659 | for (int steps=0; steps tspheremax) // Left bounding sphere? 666 | return false; 667 | 668 | if (dist < MIN_DIST) // Close enough to surface? 669 | { 670 | step_gradient = 1.0 - float(steps) / float(MAX_STEPS); 671 | return true; 672 | } 673 | } 674 | 675 | return false; 676 | } 677 | 678 | vec3 soft_lam(vec3 n, vec3 light, vec3 surface_col) 679 | { 680 | vec3 warm_col = vec3(0.9 , 0.9 , 0.7); 681 | vec3 cool_col = vec3(0.07, 0.07, 0.1); 682 | float diff_warm = 0.35; 683 | float diff_cool = 0.25; 684 | 685 | float ndotl = (dot(light, n) + 1.0) * 0.5; 686 | 687 | vec3 kcool = min((cool_col + diff_cool) * surface_col, 1.0); 688 | vec3 kwarm = min((warm_col + diff_warm) * surface_col, 1.0); 689 | vec3 kfinal = mix(kcool, kwarm, ndotl); 690 | 691 | return min(kfinal, 1.0); 692 | } 693 | 694 | float fresnel_conductor( float cosi // Cosine between normal and incident ray 695 | , float eta // Index of refraction 696 | , float k // Absorption coefficient 697 | ) 698 | { 699 | // Compute Fresnel term for a conductor, PBRT 1st edition p422 700 | 701 | // Material | Eta | K 702 | // ------------------------ 703 | // Gold | 0.370 | 2.820 704 | // Silver | 0.177 | 3.638 705 | // Copper | 0.617 | 2.63 706 | // Steel | 2.485 | 3.433 707 | 708 | // TODO: Fresnel for dielectrics 709 | 710 | float tmp = (eta * eta + k * k) * cosi * cosi; 711 | float r_parallel_2 = 712 | (tmp - (2.0 * eta * cosi) + 1.0) / 713 | (tmp + (2.0 * eta * cosi) + 1.0); 714 | float tmp_f = eta * eta + k * k; 715 | float r_perpend_2 = 716 | (tmp_f - (2.0 * eta * cosi) + cosi * cosi) / 717 | (tmp_f + (2.0 * eta * cosi) + cosi * cosi); 718 | return (r_parallel_2 + r_perpend_2) / 2.0; 719 | } 720 | 721 | float normalize_phong_lobe(float power) 722 | { 723 | return (power + 2) / 2; 724 | } 725 | 726 | vec3 render_ray(vec3 origin, vec3 dir, mat4x4 camera) 727 | { 728 | // Ray march 729 | float t, step_gradient; 730 | bool hit = ray_march(origin, dir, t, step_gradient); 731 | 732 | // Can use the iteration count to add a snowy/foggy/glow type effect 733 | // 734 | // http://www.fractalforums.com/mandelbulb-implementation/faked-ambient-occlusion/ 735 | // msg10526/#msg10526 736 | // 737 | // vec3 glow = (1.0 - pow((clamp((step_gradient * 2 - 1) * 1.5, -1, 1) + 1) * 0.5, 8.0)) 738 | // * vec3(0.2, 0.3, 0.3); 739 | 740 | if (hit) 741 | { 742 | // Compute intersection 743 | vec3 isec_pos = origin + dir * t; 744 | 745 | // Step back from the surface a bit before computing the normal 746 | // 747 | // Experiments with trying to step back along the surface normal (cheaply computed 748 | // in screen-space) did not improve results. Not having the step back also works 749 | // reasonably well, except in a few corner cases like infinitely thin surfaces 750 | // 751 | vec3 isec_n = normal_backward_difference(isec_pos - dir * 0.00001); 752 | // vec3 isec_n = normal_screen_space_isec(isec_pos); 753 | 754 | // TODO: We can fix some numerical problems when computing normals by switching to 755 | // screen-space normals when very thin, fin-like surfaces causes errors. This is 756 | // most noticeable for some of the lower powers of the mandelbulb, but 757 | // unfortunately those surfaces are so disjoint that they also causes issues for 758 | // our distanced based AO computations 759 | // 760 | // vec3 isec_n_ss = normal_screen_space_isec(isec_pos); 761 | // if (dot(-dir, isec_n) < 0.0) // Clearly wrong normal? 762 | // isec_n = isec_n_ss; // Switch to screen space normal 763 | 764 | // TODO: Better IBL + AO by doing occlusion for a number of cosine lobes to get 765 | // directional visibility information 766 | #define DISTANCE_AO 767 | #ifdef DISTANCE_AO 768 | float ao = distance_ao(isec_pos, isec_n); 769 | #else 770 | float ao = pow((clamp((step_gradient * 2 - 1) * 1.25, -1, 1) + 1) * 0.5, 8.0); 771 | #endif 772 | 773 | // Shading 774 | vec3 color; 775 | 776 | //if (gl_FragCoord.x < in_screen_wdh / 2) 777 | 778 | //color = vec3(((isec_n + 1) * 0.5) * ao); 779 | //color = soft_lam(isec_n, normalize(vec3(1, 1, 1)), vec3(ao)); 780 | //color = ((dot(isec_n, (camera * vec4(0, 0, 1, 0)).xyz) +1) * 0.5 + 0.5) * vec3(ao); 781 | /*color = clamp(dot(isec_n, vec3(0,0,1)), 0, 1) * vec3(1,0,0) + 782 | clamp(dot(isec_n, vec3(0,0,-1)), 0, 1) * vec3(0,1,0);*/ 783 | //color = (isec_n + 1) * 0.5; 784 | //color = vec3(ao); 785 | /* 786 | color = ( vec3(max(0, 0.2+dot(isec_n, normalize(vec3(1, 1, 1))))) * vec3(1,0.75,0.75) + 787 | vec3(max(0, 0.2+dot(isec_n, normalize(vec3(-1, -1, -1))))) * vec3(0.75,1.0,1.0) 788 | ) * ao; 789 | */ 790 | /* 791 | color = 792 | ( 793 | max(0.2+dot(isec_n, (camera * vec4(0, 0, 1, 0)).xyz),0)*vec3(0.2)+ 794 | vec3(max(0, pow(dot(reflect(dir,isec_n), normalize(vec3(1,0,1))),5))) * vec3(1,0.4,0)*2 + 795 | vec3(max(0, pow(dot(reflect(dir,isec_n), normalize(vec3(1,-1,0))),5))) * vec3(0,.51,.51)*2 796 | ) * ao; 797 | */ 798 | 799 | float fresnel = fresnel_conductor(dot(-dir, isec_n), 0.4, 0.8); 800 | //fresnel = 1; 801 | float diff_weight = 0.5; 802 | vec3 diff_col = vec3(1, 0.8, 0.8); 803 | vec3 spec_col = vec3(0.8, 0.8, 1); 804 | float spec_weight = 1.0 - diff_weight; 805 | color = 806 | ( 807 | texture(env_cos_1, isec_n).xyz * diff_col * diff_weight 808 | + texture(env_cos_8, reflect(dir, isec_n)).xyz * spec_col * normalize_phong_lobe(8) * fresnel * spec_weight 809 | + texture(env_reflection, reflect(dir, isec_n)).xyz * spec_weight * fresnel * 0.1 810 | ) * 3.0 * ao; 811 | //color = vec3(fresnel); 812 | //color = vec3(ao); 813 | //color = vec3(1,0,1); 814 | //color = (isec_n + 1) * 0.5; 815 | 816 | return color; 817 | } 818 | else 819 | #define BG_GRADIENT 820 | #ifdef BG_GRADIENT 821 | //return mix(vec3(1, 0.4, 0), vec3(0, 0.51, 0.51), gl_FragCoord.y / in_screen_hgt); 822 | //return mix(vec3(1), vec3(0), gl_FragCoord.y / in_screen_hgt); 823 | return texture(env_reflection, dir).xyz; 824 | #else 825 | return vec3(0); 826 | #endif 827 | } 828 | 829 | mat4x4 lookat(vec3 eye, vec3 focus, vec3 up) 830 | { 831 | vec3 zaxis = normalize(eye - focus); 832 | vec3 xaxis = normalize(cross(up, zaxis)); 833 | vec3 yaxis = cross(zaxis, xaxis); 834 | return mat4x4(xaxis.x, xaxis.y, xaxis.z, 0.0, 835 | yaxis.x, yaxis.y, yaxis.z, 0.0, 836 | zaxis.x, zaxis.y, zaxis.z, 0.0, 837 | eye.x , eye.y , eye.z , 1.0); 838 | } 839 | 840 | void generate_ray( mat4x4 camera // Camera transform 841 | , vec2 sample_offs // Sample offset [-.5, +.5] 842 | , bool ortho // Orthographic or perspective camera? 843 | , float width_or_hfov // Width of ortho viewing volume or horizontal FOV degrees 844 | , out vec3 origin 845 | , out vec3 dir 846 | ) 847 | { 848 | // Convert fragment coordinates and sample offset to NDC [-1, 1] 849 | vec2 ndc = (gl_FragCoord.xy + sample_offs) / vec2(in_screen_wdh, in_screen_hgt) * 2.0 - 1.0; 850 | 851 | // Generate ray from NDC and camera transform 852 | float aspect = in_screen_wdh / in_screen_hgt; 853 | if (ortho) 854 | { 855 | // Orthographic projection. Frame [-w/2, w/2] on X, 856 | // center interval on Y while keeping aspect 857 | float width = width_or_hfov; 858 | float height = width / aspect; 859 | origin = (camera * vec4(ndc * vec2(width / 2.0, height / 2.0), 0, 1)).xyz; 860 | dir = mat3(camera) * vec3(0, 0, -1); 861 | } 862 | else 863 | { 864 | // Perspective projection. Unlike the usual vertical FOV we deal with a horizontal 865 | // one, just like the orthographic camera defined by its width 866 | float hfov = radians(width_or_hfov); 867 | float fov_xs = tan(hfov / 2); 868 | origin = (camera * vec4(0, 0, 0, 1)).xyz; 869 | dir = mat3(camera) * normalize(vec3(ndc.x*fov_xs, ndc.y*fov_xs / aspect, -1.0)); 870 | } 871 | } 872 | 873 | void main() 874 | { 875 | // TODO: Move transformations into vertex shader, like here: 876 | // http://blog.hvidtfeldts.net/index.php/2014/01/combining-ray-tracing-and-polygons/ 877 | 878 | // TODO: Consider a hierarchical Z like setup where we first ray march 4x4 pixel blocks 879 | // till we get close to the surface and then start off there at pixel resolution 880 | // Also see 881 | // http://www.fractalforums.com/mandelbulb-implementation/major-raymarching-optimization/ 882 | 883 | // Orbit camera 884 | vec3 cam_pos = vec3(0,0,2); 885 | #define AUTO_ROTATION 886 | #ifdef AUTO_ROTATION 887 | #ifdef CORNELL_BOX_SCENE 888 | cam_pos.x = sin(in_time / 2) * 0.4; 889 | cam_pos.z = -2; 890 | cam_pos.y = cos(in_time / 2) * 0.4; 891 | #else 892 | cam_pos.x = sin(in_time / 3.0); 893 | cam_pos.z = cos(in_time / 3.0); 894 | cam_pos.y = cos(in_time / 4.0); 895 | // Keep a constant distance. Distance is so that a width = 2 orthographic projection 896 | // matches up with a HFOV = 45 perspective projection as close as possible 897 | cam_pos = normalize(cam_pos) * 2.414213562373095; 898 | #endif 899 | #endif 900 | 901 | // Camera transform. Look at center, orbit around it 902 | mat4x4 camera = lookat(cam_pos, vec3(0,0,0), vec3(0,1,0)); 903 | 904 | // Generate camera ray 905 | vec3 origin, dir; 906 | //#define CAM_ORTHO 907 | #ifdef CAM_ORTHO 908 | generate_ray(camera, vec2(0, 0), true, 2.0, origin, dir); 909 | #else 910 | generate_ray(camera, vec2(0, 0), false, 45.0 * 1.5, origin, dir); 911 | #endif 912 | 913 | // Trace and shade 914 | vec3 color; 915 | //#define RAY_TRACING_TEST 916 | #ifdef RAY_TRACING_TEST 917 | // Ray trace Cornell Box 918 | float mint = 999; 919 | vec3 n; 920 | 921 | for (int i=0; i<32; i++) 922 | { 923 | vec3 v0 = texelFetch(cornell_geom, i * 3 + 0, 0).xyz; 924 | vec3 v1 = texelFetch(cornell_geom, i * 3 + 1, 0).xyz; 925 | vec3 v2 = texelFetch(cornell_geom, i * 3 + 2, 0).xyz; 926 | 927 | float t, u, v; 928 | if (intersect_triangle(origin, dir, v0, v1, v2, t, u, v)) 929 | if (t < mint) 930 | { 931 | n = normalize(cross(v1 - v0, v2 - v0)); 932 | mint = t; 933 | } 934 | } 935 | 936 | color = (mint == 999) ? texture(env_reflection, dir).xyz : (n + 1) * 0.5; 937 | #else 938 | color = render_ray(origin, dir, camera); 939 | #endif 940 | 941 | // Use screen-space derivatives to check the contrast between neighbouring pixels, 942 | // keep shooting more rays till it passes below a threshold. Works OK from an image 943 | // quality standpoint, but performance is fairly poor due to the heavy cost of 944 | // divergence, probably not worth it in practice compared to the naive super sampling 945 | // we have on the frame buffer level 946 | #ifdef ADAPTIVE_SAMPLING 947 | float weight = 1.0; 948 | while (fwidth(pow(color.r / weight, 1.0 / 2.2) /* gamma */) > 0.3 /* threshold*/ && weight < 32) 949 | { 950 | // 951 | // weight += 1; 952 | } 953 | color /= weight; 954 | #endif 955 | 956 | #define GAMMA_CORRECT 957 | #ifdef GAMMA_CORRECT 958 | // Gamma correct and output 959 | vec3 gamma = pow(color, vec3(1.0 / 2.2)); 960 | frag_color = vec4(gamma, 1); 961 | #else 962 | frag_color = vec4(color, 1); 963 | #endif 964 | 965 | // TODO: Add some form of tone mapping to the output, exposure controls 966 | } 967 | 968 | -------------------------------------------------------------------------------- /img/julia_set.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/blitzcode/ray-marching-distance-fields/0578d01e75f819b1242fa1378e3963bd48842acc/img/julia_set.png -------------------------------------------------------------------------------- /img/mandelbulb.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/blitzcode/ray-marching-distance-fields/0578d01e75f819b1242fa1378e3963bd48842acc/img/mandelbulb.png -------------------------------------------------------------------------------- /img/prefiltered.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/blitzcode/ray-marching-distance-fields/0578d01e75f819b1242fa1378e3963bd48842acc/img/prefiltered.png -------------------------------------------------------------------------------- /img/rmdf.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/blitzcode/ray-marching-distance-fields/0578d01e75f819b1242fa1378e3963bd48842acc/img/rmdf.png -------------------------------------------------------------------------------- /latlong_envmaps/download_hdr_environments.txt: -------------------------------------------------------------------------------- 1 | 2 | There are plenty of free HDR environment maps in the supported lat/long format available here: 3 | 4 | http://gl.ict.usc.edu/Data/HighResProbes/ 5 | http://www.hdrlabs.com/sibl/archive.html 6 | http://www.hdri-hub.com/free-hdri-environments-for-download 7 | 8 | -------------------------------------------------------------------------------- /latlong_envmaps/uffizi_512.hdr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/blitzcode/ray-marching-distance-fields/0578d01e75f819b1242fa1378e3963bd48842acc/latlong_envmaps/uffizi_512.hdr -------------------------------------------------------------------------------- /rmdf.cabal: -------------------------------------------------------------------------------- 1 | -- Initial mandelbulb.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: rmdf 5 | version: 0.1.0.0 6 | synopsis: Ray Marching Distance Fields 7 | -- description: 8 | license: MIT 9 | license-file: LICENSE 10 | author: Tim C. Schroeder 11 | maintainer: www.blitzcode.net 12 | -- copyright: 13 | category: Graphics 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | executable rmdf 19 | main-is: Main.hs 20 | -- other-modules: 21 | -- other-extensions: 22 | build-depends: base >=4.7 && <5, 23 | -- Want ExceptT and modify' 24 | mtl >= 2.2.1, 25 | transformers, 26 | monad-control, 27 | linear >= 1.10.1.1, 28 | GLFW-b, 29 | OpenGL >= 2.9.2.0, 30 | -- After the namespace change 31 | OpenGLRaw >= 3.0.0.0, 32 | loop, 33 | stm, 34 | vector >= 0.10.11.0, 35 | lens >= 4.3, 36 | time, 37 | ansi-terminal, 38 | text, 39 | bytestring, 40 | containers, 41 | async, 42 | -- Version with the HDR writer bug fix (issue #74) 43 | JuicyPixels >= 3.1.7, 44 | template-haskell, 45 | resourcet >= 1.1.2.3, 46 | directory, 47 | filepath, 48 | deepseq, 49 | async 50 | -- hs-source-dirs: 51 | default-language: Haskell2010 52 | -- -ddump-simpl -ddump-to-file 53 | ghc-options: -Wall -rtsopts -O2 -threaded -dynamic 54 | ghc-prof-options: -fprof-auto -caf-all 55 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-4.0 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Extra package databases containing global packages 17 | extra-package-dbs: [] 18 | 19 | # Control whether we use the GHC we find on the path 20 | # system-ghc: true 21 | 22 | # Require a specific version of stack, using version ranges 23 | # require-stack-version: -any # Default 24 | # require-stack-version: >= 1.0.0 25 | 26 | # Override the architecture used by stack, especially useful on Windows 27 | # arch: i386 28 | # arch: x86_64 29 | 30 | # Extra directories used by stack for building 31 | # extra-include-dirs: [/path/to/dir] 32 | # extra-lib-dirs: [/path/to/dir] 33 | --------------------------------------------------------------------------------