diff --git a/gloss-examples.cabal b/gloss-examples.cabal --- a/gloss-examples.cabal +++ b/gloss-examples.cabal @@ -1,5 +1,5 @@ Name: gloss-examples -Version: 1.7.4.1 +Version: 1.7.4.2 License: MIT License-file: LICENSE Author: Ben Lippmeier @@ -193,7 +193,7 @@ Main-is: Main.hs hs-source-dirs: raster/Crystal ghc-options: - -Wall -threaded -eventlog + -Wall -threaded -rtsopts -eventlog -Odph -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 @@ -209,7 +209,7 @@ other-modules: Light Object Trace Vec3 World hs-source-dirs: raster/Ray ghc-options: - -Wall -threaded -eventlog + -Wall -threaded -rtsopts -eventlog -Odph -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 @@ -224,7 +224,7 @@ Main-is: Main.hs hs-source-dirs: raster/Pulse ghc-options: - -Wall -threaded -eventlog + -Wall -threaded -rtsopts -eventlog -Odph -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 @@ -241,7 +241,7 @@ Main-is: Main.hs hs-source-dirs: raster/Wave ghc-options: - -Wall -threaded -eventlog + -Wall -threaded -rtsopts -eventlog -Odph -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 @@ -265,7 +265,7 @@ Stage.Linear Stage.Project Stage.Sources hs-source-dirs: raster/Fluid ghc-options: - -Wall -threaded -eventlog -rtsopts + -Wall -threaded -rtsopts -eventlog -Odph -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 @@ -282,10 +282,28 @@ Main-is: Main.hs hs-source-dirs: raster/Snow ghc-options: - -Wall -threaded -eventlog -rtsopts + -Wall -threaded -rtsopts -eventlog -Odph -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 -fllvm -optlo-O3 + + +Executable gloss-mandel + Build-depends + base == 4.*, + gloss == 1.7.*, + repa >= 3.1.4.2 && < 3.2 + Main-is: Main.hs + other-modules: Solver + hs-source-dirs: raster/Mandel + ghc-options: + -Wall -threaded -rtsopts -eventlog + -Odph -fno-liberate-case + -funfolding-use-threshold1000 + -funfolding-keeness-factor1000 + -fllvm -optlo-O3 + extensions: + PatternGuards diff --git a/raster/Mandel/Main.hs b/raster/Mandel/Main.hs new file mode 100644 --- /dev/null +++ b/raster/Mandel/Main.hs @@ -0,0 +1,322 @@ +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} + +import Graphics.Gloss.Interface.IO.Game +import Solver +import Data.Array.Repa.IO.BMP +import System.Exit +import System.Environment +import Data.Maybe +import Data.Char + + +main :: IO () +main + = do args <- getArgs + config <- parseArgs args defaultConfig + let world = configPreset config + $ (initWorld (configSizeX config) + (configSizeY config)) + { worldPixelsDynamic = configPixelsDynamic config} + + case configFileName config of + -- Run interactively. + Nothing + -> playIO (configDisplay config) + black + 100 + (updateWorld world) + draw handle advance + + -- Render image and write to .bmp file. + Just filePath + -> do arr <- mandelArray + (worldSizeX world) (worldSizeY world) + (worldPosX world) (worldPosY world) + (worldZoom world) (worldRadius world) + (truncate $ worldIterations world) + + writeImageToBMP filePath arr + + +-- Config --------------------------------------------------------------------- +data Config + = Config + { configDisplay :: Display + , configFileName :: Maybe FilePath + , configPreset :: World -> World + , configPixelsDynamic :: Int + , configSizeX :: Int + , configSizeY :: Int } + + +defaultConfig :: Config +defaultConfig + = Config + { configDisplay = InWindow "Mandelbrot" (800, 600) (10, 10) + , configFileName = Nothing + , configPreset = id + , configPixelsDynamic = 4 + , configSizeX = 800 + , configSizeY = 600 } + + +parseArgs :: [String] -> Config -> IO Config +parseArgs args config + | [] <- args + = return config + + | "-fullscreen" : sizeX : sizeY : rest <- args + , all isDigit sizeX + , all isDigit sizeY + = parseArgs rest + $ config { configDisplay = FullScreen (read sizeX, read sizeY) + , configSizeX = read sizeX + , configSizeY = read sizeY } + + | "-window" : sizeX : sizeY : rest <- args + , all isDigit sizeX + , all isDigit sizeY + = parseArgs rest + $ config { configDisplay = InWindow "MandelBrot" (read sizeX, read sizeY) (0, 0) + , configSizeX = read sizeX + , configSizeY = read sizeY } + + | "-bmp" : sizeX : sizeY : fileName : rest <- args + , all isDigit sizeX + , all isDigit sizeY + = parseArgs rest + $ config { configFileName = Just fileName + , configSizeX = read sizeX + , configSizeY = read sizeY } + + | "-dynamic" : num : rest <- args + , all isDigit num + = parseArgs rest + $ config { configPixelsDynamic = read num } + + | "-preset" : num : rest <- args + , length num == 1 + , all isDigit num + = parseArgs rest + $ config { configPreset = presets !! read num } + + | otherwise + = do printUsage + exitWith $ ExitFailure 1 + +printUsage :: IO () +printUsage + = putStrLn + $ unlines + [ "Usage: gloss-mandel [flags]" + , " -fullscreen " + , " -window " + , " -bmp " + , " -dynamic Level of detail reduction when zooming and panning. (4) " + , "" + , " Controls:" + , " ESC Quit" + , " mouse drag Centerpoint" + , " w/s Zoom" + , " a/d Maximum interations" + , " q/e Pixels per point" + , " z/c Escape radius for iteration" + , " 0 .. 9 Select presets" + , " r Reset" + , " . Print current location to stdout" ] + + + +-- World ---------------------------------------------------------------------- +data World + = World + { worldPicture :: Picture + , worldSizeX :: Int + , worldSizeY :: Int + , worldPixels :: Int + , worldPixelsDynamic :: Int + + , worldPosX :: Double + , worldPosY :: Double + , worldZoom :: Double + + , worldIterations :: Double + , worldRadius :: Double + + , worldDragging :: Maybe (Float, Float) + , worldZooming :: Maybe Double } + + +initWorld :: Int -> Int -> World +initWorld sizeX sizeY + = World + { worldPicture = Blank + + , worldSizeX = sizeX + , worldSizeY = sizeY + , worldPixels = 1 + , worldPixelsDynamic = 4 + + , worldPosX = -0.5 + , worldPosY = 0 + , worldZoom = 2 + + , worldIterations = 100 + , worldRadius = 2 + , worldDragging = Nothing + , worldZooming = Nothing } + + +draw :: World -> IO Picture +draw world + = return $ worldPicture world + + +handle :: Event -> World -> IO World +handle event world + + -- Pan + | EventKey (MouseButton LeftButton) Down _ (x, y) <- event + = return $ updateWorld $ world { worldDragging = Just (x, y)} + + | EventKey (MouseButton LeftButton) Up _ _ <- event + = return $ updateWorld $ world { worldDragging = Nothing } + + | EventMotion (x, y) <- event + , Just (x0, y0) <- worldDragging world + = let x' = 2 * (f2d (x0 - x)) * worldZoom world / (fromIntegral $ worldSizeX world) + y' = 2 * (f2d (y0 - y)) * worldZoom world / (fromIntegral $ worldSizeX world) + in return $ moveWorld x' y' + $ world { worldDragging = Just (x, y) } + + -- Zoom + | EventKey (Char 's') Down _ _ <- event + = return $ world { worldZooming = Just 1.01 } + + | EventKey (Char 'w') Down _ _ <- event + = return $ world { worldZooming = Just 0.99 } + + -- Iterations + | EventKey (Char 'a') Down _ _ <- event + , iters <- worldIterations world * 0.8 + , iters' <- if iters < 1 then 1 else iters + = return $ world { worldIterations = iters' } + + | EventKey (Char 'd') Down _ _ <- event + = return $ world { worldIterations = worldIterations world * 1.2 } + + -- Radius + | EventKey (Char 'z') Down _ _ <- event + = return $ world { worldRadius = worldRadius world * 0.5 } + + | EventKey (Char 'c') Down _ _ <- event + = return $ world { worldRadius = worldRadius world * 2 } + + -- Pixels + | EventKey (Char 'q') Down _ _ <- event + , worldPixels world > 1 + = return $ world { worldPixels = worldPixels world - 1 } + + | EventKey (Char 'e') Down _ _ <- event + = return $ world { worldPixels = worldPixels world + 1 } + + -- Reset + | EventKey (Char 'r') Down _ _ <- event + = return $ initWorld (worldSizeX world) (worldSizeY world) + + -- Dump preset + | EventKey (Char 'p') Down _ _ <- event + = do putStrLn $ showWorld world + return world + + -- Load preset + | EventKey (Char d) Down _ _ <- event + , isDigit d + = return $ updateWorld ((presets !! read [d]) world) + + -- Cancel zoom + | EventKey _ Up _ _ <- event + = return $ updateWorld $ world { worldZooming = Nothing } + + | otherwise + = return world + + +advance :: Float -> World -> IO World +advance _ world + | Just factor <- worldZooming world + = return $ zoomWorld factor world + + | otherwise + = return world + + +moveWorld :: Double -> Double -> World -> World +moveWorld bumpX bumpY world + = updateWorld + $ world { worldPosX = worldPosX world + bumpX + , worldPosY = worldPosY world + bumpY } + + +zoomWorld :: Double -> World -> World +zoomWorld zoom world + = updateWorld + $ world { worldZoom = worldZoom world * zoom } + + +updateWorld :: World -> World +updateWorld world + = let dynamic = isJust (worldDragging world) + || isJust (worldZooming world) + + pixels + | dynamic = worldPixels world + worldPixelsDynamic world + | otherwise = worldPixels world + + in world { worldPicture + = mandelPicture + (worldSizeX world) (worldSizeY world) + pixels pixels + (worldPosX world) (worldPosY world) + (worldZoom world) + (worldRadius world) + (truncate $ worldIterations world) + } + + +-- Presets -------------------------------------------------------------------- +-- | Show the current state of the world, in preset form. +showWorld :: World -> String +showWorld world + = show ( worldPosX world + , worldPosY world + , worldZoom world + , worldIterations world + , worldRadius world) + + +-- | Load a preset into the world. +loadWorld :: (Double, Double, Double, Double, Double) -> World -> World +loadWorld (posX, posY, zoom, iters, radius) world + = world + { worldPosX = posX + , worldPosY = posY + , worldZoom = zoom + , worldIterations = iters + , worldRadius = radius } + + +presets :: [World -> World] +presets + = map loadWorld + $ [ (-0.5, 0, 2, 100, 2) + , (0.20508818500545423, 0.9014915666351141 * 900/1440,6.375321937544527e-6, 629.3354966759534, 16.0) + , (0.4510757067879078, 0.6144133202705898 * 900/1440,7.632248223018773e-5, 253.61352386150395, 2.0) + , (0.3469337523117071, 0.6866350870407725 * 900/1440,3.508380713647269e-5, 168.61054759193718, 1024.0) + , (-0.7902001921590814, 0.24910667566731381 * 900/1440,5.071115028132377e-4, 1176.757810813391, 3.4359738368e10) + , (2.3127178455019423e-2,-1.301205470975472 * 900/1440,3.6349313304610088e-9, 343.0390372557315, 2.0) + , (2.3127176148480418e-2,-1.3012054707668765 * 900/1440,2.71444790387451e-10, 604.1620768089155, 2.0) + , (2.3127176156746785e-2,-1.301205470242045 * 900/1440,4.49615119202067e-12, 1731.8575629678642, 2.0) + , (0.2550376327692795, 8.962363618058007e-4 * 900/1440,7.351698819132829e-5, 1412.1093729760698, 16.0) + , (0.25498593633806477, 8.726424280526077e-4 * 900/1440,1.6858526052251987e-10,10492.090844482025, 2.0) ] + diff --git a/raster/Mandel/Solver.hs b/raster/Mandel/Solver.hs new file mode 100644 --- /dev/null +++ b/raster/Mandel/Solver.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} +module Solver + ( mandelPicture + , mandelArray + , f2d + , d2f) +where +import Graphics.Gloss.Data.Color +import Graphics.Gloss.Data.Picture +import Data.Word +import System.IO.Unsafe +import Unsafe.Coerce +import Data.Bits +import GHC.Float +import Data.Array.Repa as R +import Data.Array.Repa.Repr.ForeignPtr as R +import Data.Array.Repa.Repr.HintInterleave as R +import Data.Array.Repa.Algorithms.ColorRamp as R +import Prelude as P + + +mandelPicture + :: Int -- Window Size X + -> Int -- Window Size Y + -> Int -- Pixels X + -> Int -- Pixels Y + -> Double -- Offset X + -> Double -- Offset Y + -> Double -- zoom + -> Double -- radius + -> Int -- iterations + -> Picture +mandelPicture winX winY pixelsX pixelsY offX offY zoom radius iters + = let scaleX :: Double = 1 + scaleY :: Double = fromIntegral winY / fromIntegral winX + in makePicture + winX winY + pixelsX pixelsY + (mandelPixel scaleX scaleY offX offY zoom iters radius) +{-# NOINLINE mandelPicture #-} + + + +mandelArray + :: Int -- Window Size X + -> Int -- Window Size Y + -> Double -- Offset X + -> Double -- Offset Y + -> Double -- zoom + -> Double -- radius + -> Int -- iterations + -> IO (Array U DIM2 (Word8, Word8, Word8)) + +mandelArray winX winY offX offY zoom radius iters + = let scaleX :: Double = 1 + scaleY :: Double = fromIntegral winY / fromIntegral winX + + arr = makeFrame winX winY 1 1 + $ mandelPixel scaleX scaleY offX offY zoom iters radius + + in R.computeP arr +{-# NOINLINE mandelArray #-} + + +-- Picture -------------------------------------------------------------------- +makePicture + :: Int -- Window Size X + -> Int -- Window Size Y + -> Int -- Pixels X + -> Int -- Pixels Y + -> (Double -> Double -> Color) + -> Picture +makePicture !winSizeX !winSizeY !zoomX !zoomY !makePixel + = let -- Size of the raw image to render. + sizeX = winSizeX `div` zoomX + sizeY = winSizeY `div` zoomY + + {-# INLINE conv #-} + conv (r, g, b) + = let r' = fromIntegral r + g' = fromIntegral g + b' = fromIntegral b + a = 255 + + !w = unsafeShiftL r' 24 + .|. unsafeShiftL g' 16 + .|. unsafeShiftL b' 8 + .|. a + in w + + in unsafePerformIO $ do + + -- Define the image, and extract out just the RGB color components. + -- We don't need the alpha because we're only drawing one image. + (arrRGB :: Array F DIM2 Word32) + <- R.computeP + $ R.map conv + $ makeFrame winSizeX winSizeY zoomX zoomY makePixel + + -- Wrap the ForeignPtr from the Array as a gloss picture. + let picture + = Scale (fromIntegral zoomX) (fromIntegral zoomY) + $ bitmapOfForeignPtr + sizeX sizeY -- raw image size + (R.toForeignPtr $ unsafeCoerce arrRGB) + -- the image data. + False -- don't cache this in texture memory. + + return picture +{-# INLINE makePicture #-} + + +-- Frame ---------------------------------------------------------------------- +makeFrame + :: Int -- Window Size X + -> Int -- Window Size Y + -> Int -- Pixels X + -> Int -- Pixels Y + -> (Double -> Double -> Color) + -> Array (I D) DIM2 (Word8, Word8, Word8) + +makeFrame !winSizeX !winSizeY !zoomX !zoomY !makePixel + = let -- Size of the raw image to render. + sizeX = winSizeX `div` zoomX + sizeY = winSizeY `div` zoomY + + fsizeX, fsizeY :: Double + !fsizeX = fromIntegral sizeX + !fsizeY = fromIntegral sizeY + + fsizeX2, fsizeY2 :: Double + !fsizeX2 = fsizeX / 2 + !fsizeY2 = fsizeY / 2 + + -- Midpoint of image. + midX, midY :: Int + !midX = sizeX `div` 2 + !midY = sizeY `div` 2 + + {-# INLINE pixelOfIndex #-} + pixelOfIndex (Z :. y :. x) + = let x' = fromIntegral (x - midX) / fsizeX2 + y' = fromIntegral (y - midY) / fsizeY2 + in makePixel x' y' + + in R.hintInterleave + $ R.map unpackColor + $ R.fromFunction (Z :. sizeY :. sizeX) + $ pixelOfIndex +{-# INLINE makeFrame #-} + + +-- Mandel --------------------------------------------------------------------- +mandelPixel + :: Double -- Scale X + -> Double -- Scale Y + -> Double -- Offset X + -> Double -- Offset Y + -> Double -- Zoom + -> Int -- iterations + -> Double -- max radius + -> Double -- X (Real) + -> Double -- Y (Imaginary) + -> Color +mandelPixel scaleX scaleY x0 y0 zoom cMax rMax x y + = let + !x' = x0 + x * zoom * scaleX + !y' = y0 + y * zoom * scaleY + + !count = mandelRun (fromIntegral cMax) rMax x' y' + !v = fromIntegral count / fromIntegral cMax + + color' + | v > 0.99 = rgb 0 0 0 + | (r, g, b) <- rampColorHotToCold 0 1 v + = rgb r g b + in color' +{-# INLINE mandelPixel #-} + + +mandelRun :: Int -> Double -> Double -> Double -> Int +mandelRun countMax rMax cr ci + = go cr ci 0 + where + go :: Double -> Double -> Int -> Int + go !zr !zi !count + | count >= countMax = count + | sqrt (zr * zr + zi * zi) > rMax = count + + | otherwise + = let !z2r = zr*zr - zi*zi + !z2i = 2 * zr * zi + !yr = z2r + cr + !yi = z2i + ci + in go yr yi (count + 1) +{-# INLINE mandelRun #-} + + +-- Conversion ----------------------------------------------------------------- +f2d :: Float -> Double +f2d = float2Double +{-# INLINE f2d #-} + + +d2f :: Double -> Float +d2f = double2Float +{-# INLINE d2f #-} + + +-- | Construct a color from red, green, blue components. +rgb :: Float -> Float -> Float -> Color +rgb r g b = makeColor' r g b 1.0 +{-# INLINE rgb #-} + + +-- | Float to Word8 conversion because the one in the GHC libraries +-- doesn't have enout specialisations and goes via Integer. +word8OfFloat :: Float -> Word8 +word8OfFloat f + = fromIntegral (truncate f :: Int) +{-# INLINE word8OfFloat #-} + + +unpackColor :: Color -> (Word8, Word8, Word8) +unpackColor c + | (r, g, b, _) <- rgbaOfColor c + = ( word8OfFloat (r * 255) + , word8OfFloat (g * 255) + , word8OfFloat (b * 255)) +{-# INLINE unpackColor #-} + diff --git a/raster/Ray/Main.hs b/raster/Ray/Main.hs --- a/raster/Ray/Main.hs +++ b/raster/Ray/Main.hs @@ -8,26 +8,105 @@ import qualified Graphics.Gloss as G import qualified Graphics.Gloss.Interface.Pure.Game as G import qualified Graphics.Gloss.Raster.Field as G +import qualified Data.Array.Repa as R +import qualified Data.Array.Repa.IO.BMP as R +import Data.Char +import System.Exit + main :: IO () main = do args <- getArgs - case args of - [] -> run 800 600 4 100 4 + config <- parseArgs args defaultConfig - [sizeX, sizeY, zoom, fov, bounces] - -> run (read sizeX) (read sizeY) (read zoom) (read fov) (read bounces) + case configFileName config of + Nothing + -> runInteractive + (configSizeX config) (configSizeY config) + (configZoom config) + (configFieldOfView config) (configBounces config) - _ -> putStr $ unlines - [ "trace (fov::Int) (bounces::Int)" - , " sizeX, sizeY - visualisation size (default 800, 600)" - , " zoom - pixel replication factor (default 4)" - , " fov - field of view (default 100)" - , " bounces - ray bounce limit (default 4)" + Just file + -> runBmp + file + (configSizeX config) (configSizeY config) + (configFieldOfView config) (configBounces config) + + +-- Config --------------------------------------------------------------------- +data Config + = Config + { configSizeX :: Int + , configSizeY :: Int + , configFieldOfView :: Int + , configBounces :: Int + , configZoom :: Int + , configFileName :: Maybe FilePath } + deriving Show + + +defaultConfig :: Config +defaultConfig + = Config + { configSizeX = 800 + , configSizeY = 600 + , configFieldOfView = 100 + , configBounces = 4 + , configZoom = 4 + , configFileName = Nothing } + + +parseArgs :: [String] -> Config -> IO Config +parseArgs args config + | [] <- args + = return config + + | "-window" : sizeX : sizeY : zoom : rest <- args + , all isDigit sizeX + , all isDigit sizeY + , all isDigit zoom + = parseArgs rest + $ config { configSizeX = read sizeX + , configSizeY = read sizeY + , configZoom = read zoom + , configFileName = Nothing } + + | "-bmp" : sizeX : sizeY : file : rest <- args + , all isDigit sizeX + , all isDigit sizeY + = parseArgs rest + $ config { configSizeX = read sizeX + , configSizeY = read sizeY + , configZoom = 1 + , configFileName = Just file } + + | "-fov" : fov : rest <- args + , all isDigit fov + = parseArgs rest + $ config { configFieldOfView = read fov } + + | "-bounces" : bounces : rest <- args + , all isDigit bounces + = parseArgs rest + $ config { configBounces = read bounces } + + | otherwise + = do printUsage + exitWith $ ExitFailure 1 + +printUsage :: IO () +printUsage + = putStrLn $ unlines + [ "gloss-ray [flags]" + , " -window (800, 400, 4)" + , " -bmp " + , " -fov Field of view (100)" + , " -bounces Ray bounce limit (4)" , "" , " You'll want to run this with +RTS -N to enable threads" ] - + +-- World ---------------------------------------------------------------------- -- | World and interface state. data State = State @@ -53,10 +132,10 @@ -- | Initial world and interface state. -initState :: State -initState +initState :: Float -> State +initState time = State - { stateTime = 0 + { stateTime = time , stateEyePos = Vec3 50 (-100) (-700) , stateEyeLoc = Vec3 (-50) 200 1296 @@ -68,27 +147,43 @@ , stateMovingLeft = False , stateMovingRight = False - , stateObjects = makeObjects 0 - , stateObjectsView = makeObjects 0 + , stateObjects = makeObjects time + , stateObjectsView = makeObjects time - , stateLights = makeLights 0 - , stateLightsView = makeLights 0 } + , stateLights = makeLights time + , stateLightsView = makeLights time } --- | Run the game. -run :: Int -> Int -> Int -> Int -> Int -> IO () -run sizeX sizeY zoom fov bounces +-- Run ------------------------------------------------------------------------ +-- | Run the simulation interactively. +runInteractive :: Int -> Int -> Int -> Int -> Int -> IO () +runInteractive sizeX sizeY zoom fov bounces = G.playField (G.InWindow "Ray" (sizeX, sizeY) (10, 10)) (zoom, zoom) 100 - initState + (advanceState 1 $ initState 0) (tracePixel sizeX sizeY fov bounces) handleEvent advanceState -{-# NOINLINE run #-} +{-# NOINLINE runInteractive #-} +-- BMP ------------------------------------------------------------------------ +-- | Write the first frame to a .bmp file +runBmp :: FilePath -> Int -> Int -> Int -> Int -> IO () +runBmp file sizeX sizeY fov bounces + = do img <- R.computeUnboxedP + $ G.makeFrame sizeX sizeY + $ tracePixel sizeX sizeY fov bounces + $ advanceState 1 + $ initState 0 + + R.writeImageToBMP file img +{-# NOINLINE runBmp #-} + + +-- Trace ---------------------------------------------------------------------- -- | Render a single pixel of the image. tracePixel :: Int -> Int -> Int -> Int -> State -> G.Point -> G.Color tracePixel !sizeX !sizeY !fov !bounces !state (x, y)