packages feed

phraskell 0.1.0 → 0.1.1

raw patch · 10 files changed

+307/−3 lines, 10 files

Files

phraskell.cabal view
@@ -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
+ src/Application.hs view
@@ -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 ()
+ src/Default.hs view
@@ -0,0 +1,4 @@+module Default where++class Default a where+  def :: a
+ src/Fractal.hs view
@@ -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
+ src/FractalModel.hs view
@@ -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
+ src/GUI.hs view
@@ -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 }
+ src/Render.hs view
@@ -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     = (<cr)+          isYellow  = (<2*cr)+          isGreen   = (<3*cr)+          isAzure   = (<4*cr)+          isBlue    = (<5*cr)
+ src/UI.hs view
@@ -0,0 +1,47 @@+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_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
+ src/UI/Impl.hs view
@@ -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 }
+ src/Viewer.hs view
@@ -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