phraskell 0.1.2.1 → 0.1.3
raw patch · 11 files changed
+19/−413 lines, 11 files
Files
- phraskell.cabal +5/−5
- src/Application.hs +0/−31
- src/Default.hs +0/−4
- src/Fractal.hs +0/−10
- src/FractalModel.hs +0/−46
- src/GUI.hs +0/−38
- src/Phraskell.hs +14/−103
- src/Render.hs +0/−69
- src/UI.hs +0/−48
- src/UI/Impl.hs +0/−29
- src/Viewer.hs +0/−30
phraskell.cabal view
@@ -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
− src/Application.hs
@@ -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 ()
− src/Default.hs
@@ -1,4 +0,0 @@-module Default where--class Default a where- def :: a
− src/Fractal.hs
@@ -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
− src/FractalModel.hs
@@ -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
− src/GUI.hs
@@ -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 }
src/Phraskell.hs view
@@ -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
− src/Render.hs
@@ -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 = (<cr)- isYellow = (<2*cr)- isGreen = (<3*cr)- isAzure = (<4*cr)- isBlue = (<5*cr)
− src/UI.hs
@@ -1,48 +0,0 @@-module UI where--import Application-import Control.Monad-import Graphics.UI.SDL-import GUI-import UI.Impl-import Viewer--treatEvents :: App -> 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
− src/UI/Impl.hs
@@ -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 }
− src/Viewer.hs
@@ -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