{-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} import Graphics.Gloss.Interface.IO.Game import Graphics.Gloss.Interface.Environment 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 (width,height) <- if configDisplay config == FullScreen then getScreenSize else return (configSizeX config, configSizeY config) let world = configPreset config $ (initWorld width height) { 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" : rest <- args = parseArgs rest $ config { configDisplay = FullScreen } | "-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) ]