diff --git a/phraskell.cabal b/phraskell.cabal --- a/phraskell.cabal +++ b/phraskell.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: phraskell -version: 0.1.2.1 +version: 0.1.3 synopsis: A fractal viewer. description: A fractal viewer with some cool features like changing colorscheme, screenshot, buddhabrot, and so on. homepage: https://github.com/skypers/phraskell @@ -21,12 +21,12 @@ source-repository this type: git location: git://github.com/skypers/phraskell.git - tag: 0.1.2.1 + tag: 0.1.3 executable phraskell main-is: Phraskell.hs - other-modules: Application Default Fractal FractalModel GUI Render UI UI.Impl Viewer + --other-modules: build-depends: base ==4.6.*, SDL ==0.6.*, mtl ==2.1.*, transformers ==0.3.* hs-source-dirs: src - ghc-options: -O2 -Wall -funbox-strict-fields - ghc-prof-options: -O2 -Wall -prof -auto-all -caf-all -rtsopts + ghc-options: -O2 -funbox-strict-fields + ghc-prof-options: -O2 -Wall -funbox-strict-fields -prof -auto-all -caf-all -rtsopts diff --git a/src/Application.hs b/src/Application.hs deleted file mode 100644 --- a/src/Application.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Application where - -import FractalModel -import Viewer -import Graphics.UI.SDL -import GUI - --- TODO: add fullscreen support -data App = App { - appViewer :: Viewer -- application viewer - , appIterFrame :: FractalModel -- iteration frame - , appScreen :: Surface -- screen surface - , appFractalFrame :: Surface -- fractal surface - , appVisibleGUI :: Bool -- is GUI visiable? - , appGUI :: GUI -- GUI data - } - -instance Show App where - show = show . appViewer - -renderGUI :: App -> Int -> Int -> IO () -renderGUI app x y = do - let v = appViewer app - rw = floor $ viewerWidth v / zf - rh = floor $ viewerHeight v / zf - rx = x - rw `div` 2 - ry = y - rh `div` 2 - zf = viewerZoomf v - g = appGUI app - blitSurface (guiZoomArea g) Nothing (appScreen app) (Just $ Rect rx ry rw rh) - return () diff --git a/src/Default.hs b/src/Default.hs deleted file mode 100644 --- a/src/Default.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Default where - -class Default a where - def :: a diff --git a/src/Fractal.hs b/src/Fractal.hs deleted file mode 100644 --- a/src/Fractal.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Fractal where - -import Data.Complex - -type FComplex = Complex Double -type FractalProgression = (FComplex -> FComplex -> FComplex) - --- mandelbrot progression -mandelbrot :: FractalProgression -mandelbrot z c = z^2 + c diff --git a/src/FractalModel.hs b/src/FractalModel.hs deleted file mode 100644 --- a/src/FractalModel.hs +++ /dev/null @@ -1,46 +0,0 @@ -module FractalModel where - -import Data.Complex -import Fractal -import Viewer - -type FractalRef = [[FComplex]] - -screen :: Double -> Double -> (FComplex -> FComplex) -> FractalRef -screen w h f = map (\x -> [ f $ toCart w h (x :+ y) | y <- [0..h-1] ]) [0..w-1] - -toCart :: Double -> Double -> FComplex -> FComplex -toCart w h (x :+ y) = r*(2 * x / w - 1) :+ (1 - 2 * y / h) - where r = w / h - -oZoom :: Double -> FComplex -> FComplex -oZoom z (x :+ y) = (x/z) :+ (y/z) - -offsets :: Double -> Double -> FComplex -> FComplex -offsets rx ry (x :+ y) = (x+rx) :+ (y+ry) - -data FractalModel - = IterFrame [[Integer]] - - -- for x and y, evaluate the fractal equation -evalFrac :: FractalProgression -> FComplex -> FComplex -> Integer -> Integer -evalFrac e z1 xy1 m = go z1 xy1 0 - where go z@(rp :+ ip) xy i - | i > m = -1 - | rp^2 + ip^2 > 4.0 = i - | otherwise = go (e z xy) xy (i+1) - --- make the iterations frame --- TODO: add maxiter considerations -mkIterFrame :: Viewer -> FractalModel -mkIterFrame v = - let w = viewerWidth v - h = viewerHeight v - rx = viewerX v - ry = viewerY v - z = viewerZoom v - p = viewerProgression v - maxi = viewerMaxIter v - ref = screen w h $ offsets rx ry . oZoom z - eval = map $ map (\(x :+ y) -> evalFrac p (0 :+ 0) (x :+ y) maxi) - in IterFrame $ eval ref diff --git a/src/GUI.hs b/src/GUI.hs deleted file mode 100644 --- a/src/GUI.hs +++ /dev/null @@ -1,38 +0,0 @@ -module GUI where - -import Control.Monad.Trans -import Control.Monad.Trans.Maybe -import Graphics.UI.SDL -import Viewer - -data GUI = GUI { - guiZoomArea :: Surface -} - -createGUI :: Viewer -> MaybeT IO GUI -createGUI v = do - zoomArea <- tryCreateZoomArea v - return $ GUI zoomArea - --- This function creates a Surface according to the mouse position. -tryCreateZoomArea :: Viewer -> MaybeT IO Surface -tryCreateZoomArea v = do - let rw = floor $ viewerWidth v / zf - rh = floor $ viewerHeight v / zf - zf = viewerZoomf v - zoomArea <- MaybeT $ tryCreateRGBSurface [HWSurface] rw rh 32 0 0 0 0 - lift $ setAlpha zoomArea [SrcAlpha] 127 -- TODO: Bool, what for? - pixel <- lift $ mapRGB (surfaceGetPixelFormat zoomArea) 60 60 60 - lift $ fillRect zoomArea Nothing pixel - return zoomArea - --- This function updates the zoom area according to the mouse position --- and the zoom factor. -updateGUIZoomArea :: GUI -> Viewer -> IO GUI -updateGUIZoomArea gui v = do - maybeZoomArea <- runMaybeT $ tryCreateZoomArea v - case maybeZoomArea of - Nothing -> return gui - Just zoomArea -> do - --freeSurface $ guiZoomArea gui - return gui { guiZoomArea = zoomArea } diff --git a/src/Phraskell.hs b/src/Phraskell.hs --- a/src/Phraskell.hs +++ b/src/Phraskell.hs @@ -1,109 +1,20 @@ -import Application -import Control.Monad -import Control.Monad.State +import Data.Maybe (maybe) import Control.Monad.Trans.Maybe -import Default -import Fractal -import FractalModel -import Graphics.UI.SDL as SDL -import GUI -import Render -import System.Environment -import System.Console.GetOpt +import Controller.App +import Controller.Bootstrap +import Controller.CLI +import Controller.Init as C import System.IO -import UI -import UI.Impl -import Viewer - --- application defaults -depth :: Double -depth = 32 - -title :: String -title = "Phraskell" - --- CLI flag used to customize the applications behavior -data CLIFlag - = CLIVersion -- version of the program - | CLIFullscreen -- should the app in fullscreen mode? - | CLIWidth String -- width of the screen - | CLIHeight String -- heigth of the sceen - | CLIX String -- x value - | CLIY String -- y value - | CLIZoom String -- zoom value - | CLIMaxIter Integer -- max iteration value - --- Display some usage informantion on standard output -usage :: IO () -usage = putStrLn $ usageInfo "usage: phraskell [OPTIONS]" options - --- All possible CLI options -options :: [OptDescr CLIFlag] -options = - [ Option ['v','?'] ["version", "about"] (NoArg CLIVersion) "show version" - , Option ['w'] ["width"] (ReqArg CLIWidth "WIDTH") "width of window" - , Option ['h'] ["heigth"] (ReqArg CLIHeight "HEIGHT") "height of the window" - , Option ['x'] ["rx","relx"] (ReqArg CLIX "X") "x displacement" - , Option ['y'] ["ry","rely"] (ReqArg CLIY "Y") "y displacement" - , Option ['z'] ["zoom"] (ReqArg CLIZoom "ZOOM") "zoom factor" - , Option ['f'] ["fullscreen"] (NoArg CLIFullscreen) "launch in fullscreen" - ] - --- Parse options and maybe return a tuple of filled flags and non-options -parseOpts :: [String] -> MaybeT IO [CLIFlag] -parseOpts args = - case getOpt Permute options args of - (o,n,[]) -> return o - _ -> mzero - --- Create a viewer with CLI flags -mkViewer :: [CLIFlag] -> Viewer -mkViewer = foldl alterViewerWithFlag def - --- alter a viewer regarding an option flag -alterViewerWithFlag :: Viewer -> CLIFlag -> Viewer -alterViewerWithFlag v f = case f of - CLIWidth s -> v { viewerWidth = read s } - CLIHeight s -> v { viewerHeight = read s } - CLIX s -> v { viewerX = read s } - CLIY s -> v { viewerX = read s } - CLIZoom s -> v { viewerZoom = read s } - CLIMaxIter i -> v { viewerMaxIter = i } - CLIFullscreen -> v { viewerFullscreen = True } - _ -> v +import System.Environment --- Entry point main = do hSetBuffering stdout NoBuffering - args <- getArgs - params <- runMaybeT $ do - cliOpts <- (parseOpts args) - viewer <- return $ mkViewer cliOpts - maybeScreen <- MaybeT $ trySetVideoMode (floor $ viewerWidth viewer) (floor $ viewerHeight viewer) (floor depth) ([HWSurface,DoubleBuf] ++ if viewerFullscreen viewer then [Fullscreen] else []) - scr <- MaybeT $ trySetVideoMode (floor $ viewerWidth viewer) (floor $ viewerHeight viewer) (floor depth) [HWSurface,DoubleBuf] - fractalSurface <- MaybeT $ tryCreateRGBSurface [HWSurface] (floor $ viewerWidth viewer) (floor $ viewerHeight viewer) (floor depth) 0 0 0 0 - gui <- createGUI viewer - return (viewer,scr,fractalSurface,gui) - case params of - Nothing -> putStrLn "something just went wrong! :(" - Just (viewer,scr,fractalSurface,gui) -> do - let app = App viewer (IterFrame []) scr fractalSurface True gui - launch app - - print "Bye!" - where launch app = do - showCursor False - enableKeyRepeat 200 10 - onFractalFrameUpdate app >>= loop - loop app = do - (goon,newApp) <- treatEvents app - case goon of - False -> return () - True -> do - blitSurface (appFractalFrame app) Nothing (appScreen app) Nothing - (mx,my,_) <- getMouseState - when (appVisibleGUI app) $ renderGUI app mx my - SDL.flip $ appScreen app - delay 10 - loop newApp + args <- getArgs + cliflags <- parseOpts args + maybe (putStrLn usage) entrypoint cliflags + +entrypoint :: [CLIFlag] -> IO () +entrypoint f = do + app <- C.init (bootstrap f) + maybe (putStrLn "failed to init") run app diff --git a/src/Render.hs b/src/Render.hs deleted file mode 100644 --- a/src/Render.hs +++ /dev/null @@ -1,69 +0,0 @@ -module Render where - -import Data.Bits -import Control.Monad -import Foreign -import FractalModel -import Graphics.UI.SDL as SDL - -tryGetScreen :: Int -> Int -> Int -> String -> IO (Maybe Surface) -tryGetScreen w h d t = do - SDL.init [InitVideo] - screen <- SDL.trySetVideoMode w h d [HWSurface, DoubleBuf] - SDL.setCaption t [] -- we don’t give a fuck about the title icon - return screen - --- destroy the render -destroyRender :: IO () -destroyRender = SDL.quit - -type UV = (Int,Int) -type UVs = [[UV]] - --- put a single pixel in a surface -putPixel :: SDL.Pixel -> Surface -> UV -> IO () -putPixel p s (u,v) = do - pixels <- castPtr `liftM` surfaceGetPixels s - pokeElemOff pixels (u + v*surfaceGetWidth s) p - --- pixelize an iteration value -pixelize :: Integer -> SDL.Pixel -pixelize (-1) = Pixel (0 :: Word32) -pixelize i = Pixel $ (shift r 16) + (shift g 8) + b -{- - where (r,g,b) = toWord32 $ (0,0,imod256) - imod256 = i `mod` 256 - toWord32 (r,g,b) = (fromIntegral r, fromIntegral g, fromIntegral b) --} - where (r,g,b) = toWord32 $ decodeColor (6*i) - toWord32 (r,g,b) = (fromIntegral r, fromIntegral g, fromIntegral b) - --- pixelize an entire SDL Surface -pixelizeSurface :: FractalModel -> Surface -> IO () -pixelizeSurface (IterFrame iterf) surface = do - foldM_ (\row line -> foldM_ (\col x -> f (row,col) x >> return (col+1)) 0 line >> return (row+1)) 0 iterf - where width = surfaceGetWidth surface - height = surfaceGetHeight surface - f uv x = putPixel (pixelize x) surface uv - --- to move in some utils module -type RGBColor = (Word8,Word8,Word8) - --- decode a rainbow color -decodeColor :: Integer -> RGBColor -decodeColor i - | isRed c = (255,contrib,0) - | isYellow c = (ncontrib,255,0) - | isGreen c = (0,255,contrib) - | isAzure c = (0,ncontrib,255) - | isBlue c = (contrib,0,255) - | otherwise = (255,0,ncontrib) - where cr = 255 -- color range - 1 - contrib = fromIntegral $ (c `mod` cr) - ncontrib = fromIntegral $ 255 - contrib - c = i `mod` (6*cr) - isRed = ( IO (Bool,App) -treatEvents app = do - event <- pollEvent - case event of - NoEvent -> nochange - Quit -> quit - KeyUp k -> case symKey k of - SDLK_ESCAPE -> quit - SDLK_SPACE -> alter $ \a -> let vg = appVisibleGUI a in return a { appVisibleGUI = not vg } - SDLK_RETURN -> alter onFractalFrameUpdate - SDLK_MINUS -> alter $ (\a -> let v = appViewer a - maxi = viewerMaxIter v - in return a { appViewer = v { viewerMaxIter = max 0 $ maxi-50 } }) - SDLK_PLUS -> alter $ (\a -> let v = appViewer a - maxi = viewerMaxIter v - in return a { appViewer = v { viewerMaxIter = maxi+50 } }) - _ -> loopback app - KeyDown k -> case symKey k of - SDLK_LEFTPAREN -> do - let v = appViewer app - zf = viewerZoomf v - na = app { appViewer = v { viewerZoomf = max 0.1 $ zf-0.1 } } - newGUI <- updateGUIZoomArea (appGUI na) (appViewer na) - loopback $ na { appGUI = newGUI } - SDLK_RIGHTPAREN -> do - let v = appViewer app - zf = viewerZoomf v - na = app { appViewer = v { viewerZoomf = zf+0.1 } } - newGUI <- updateGUIZoomArea (appGUI na) (appViewer na) - loopback $ na { appGUI = newGUI } - _ -> loopback app - MouseButtonUp x y b -> case b of - ButtonLeft -> alter $ onIterFrameUpdate (fromIntegral x) (fromIntegral y) - _ -> loopback app - _ -> loopback app - where quit = return (False,app) - nochange = return (True,app) - alter f = f app >>= loopback - loopback = treatEvents diff --git a/src/UI/Impl.hs b/src/UI/Impl.hs deleted file mode 100644 --- a/src/UI/Impl.hs +++ /dev/null @@ -1,29 +0,0 @@ -module UI.Impl where - -import Application -import Data.Complex -import FractalModel -import Graphics.UI.SDL as SDL -import Render -import Viewer - --- Take the position of the mouse, the zoom factor, the application, and regenerate --- the fractal frame (also update the app’s viewer). -onIterFrameUpdate :: Double -> Double -> App -> IO App -onIterFrameUpdate x y app = do - let cviewer = appViewer app - cz = viewerZoom cviewer - zf = viewerZoomf cviewer - (rx :+ ry) = toCart (viewerWidth cviewer) (viewerHeight cviewer) (x :+ y) - (nx,ny) = (viewerX cviewer + rx/cz,viewerY cviewer + ry/cz) - newViewer = cviewer { viewerX = nx, viewerY = ny, viewerZoom = cz*zf } - onFractalFrameUpdate $ app { appViewer = newViewer } - -onFractalFrameUpdate :: App -> IO App -onFractalFrameUpdate app = do - let viewer = appViewer app - iterf = mkIterFrame viewer - putStr $ "updating fractal " ++ show app ++ "... " - pixelizeSurface iterf (appFractalFrame app) - putStrLn "done!" - return app { appViewer = viewer, appIterFrame = iterf } diff --git a/src/Viewer.hs b/src/Viewer.hs deleted file mode 100644 --- a/src/Viewer.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Viewer where - -import Default -import Fractal (FractalProgression, mandelbrot) - -data Viewer = Viewer { - viewerWidth :: Double -- current width value - , viewerHeight :: Double -- current height value - , viewerZoom :: Double -- current zoom value - , viewerZoomf :: Double -- current zoof factor value - , viewerX :: Double -- current x displacement value - , viewerY :: Double -- current y displacement value - , viewerMaxIter :: Integer -- current max iteration value - , viewerColorSeed :: Int -- current color seed value - , viewerProgression :: FractalProgression -- current fractal equation - , viewerFullscreen :: Bool -- running in fullscreen? -} - -instance Show Viewer where - show viewer = "[" - ++ "w:" ++ show (viewerWidth viewer) ++ " " - ++ "h:" ++ show (viewerHeight viewer) ++ " " - ++ "x:" ++ show (viewerX viewer) ++ " " - ++ "y:" ++ show (viewerY viewer) ++ " " - ++ "z:" ++ show (viewerZoom viewer) ++ " " - ++ "i:" ++ show (viewerMaxIter viewer) ++ " " - ++ "]" - -instance Default Viewer where - def = Viewer 800 600 0.8 2 (-0.5) 0 500 0 mandelbrot False