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.0 +version: 0.1.1 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,11 +21,11 @@ source-repository this type: git location: git://github.com/skypers/phraskell.git - tag: 0.1.0 + tag: 0.1.1 executable phraskell main-is: Phraskell.hs - -- other-modules: + other-modules: Application Default Fractal FractalModel GUI Render UI UI.Impl Viewer build-depends: base ==4.6.*, SDL ==0.6.*, mtl ==2.1.*, transformers ==0.3.* hs-source-dirs: src ghc-prof-options: -O2 -Wall -prof -auto-all -caf-all -rtsopts diff --git a/src/Application.hs b/src/Application.hs new file mode 100644 --- /dev/null +++ b/src/Application.hs @@ -0,0 +1,31 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Default.hs @@ -0,0 +1,4 @@ +module Default where + +class Default a where + def :: a diff --git a/src/Fractal.hs b/src/Fractal.hs new file mode 100644 --- /dev/null +++ b/src/Fractal.hs @@ -0,0 +1,10 @@ +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 new file mode 100644 --- /dev/null +++ b/src/FractalModel.hs @@ -0,0 +1,46 @@ +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 new file mode 100644 --- /dev/null +++ b/src/GUI.hs @@ -0,0 +1,38 @@ +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/Render.hs b/src/Render.hs new file mode 100644 --- /dev/null +++ b/src/Render.hs @@ -0,0 +1,69 @@ +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_MINUS -> alter $ (\a -> let v = appViewer a + maxi = viewerMaxIter v + in return a { appViewer = v { viewerMaxIter = 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 = 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 new file mode 100644 --- /dev/null +++ b/src/UI/Impl.hs @@ -0,0 +1,29 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Viewer.hs @@ -0,0 +1,30 @@ +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