hfractal 0.1.0.1 → 0.1.1.0
raw patch · 7 files changed
+81/−56 lines, 7 filesdep +data-accessordep +data-accessor-templatedep ~gd
Dependencies added: data-accessor, data-accessor-template
Dependency ranges changed: gd
Files
- Bindings.hs +18/−10
- FracComp.hs +9/−8
- FracImg.hs +6/−5
- FracState.hs +20/−14
- Hfractal.hs +21/−16
- README +5/−1
- hfractal.cabal +2/−2
Bindings.hs view
@@ -4,31 +4,39 @@ import Graphics.UI.GLUT import Data.IORef import System.Exit+import Data.Accessor import FracState import FracImg ---TODO. Clean up by using Data.Accessor keyboardAct :: IORef Mandstate -> Key -> KeyState -> IO () keyboardAct ms (SpecialKey KeyLeft) Down = do- modifyIORef ms (\m@Mandstate{xmid=x,range=r} -> m{xmid=x - 0.1*r})+ ms' <- readIORef ms+ modifyIORef ms (xmid ^: ((+) ( -0.05 * ms'^.range))) keyboardAct ms (SpecialKey KeyRight) Down = do- modifyIORef ms (\m@Mandstate{xmid=x,range=r} -> m{xmid=x + 0.1*r})+ ms' <- readIORef ms+ modifyIORef ms (xmid ^: ((+) ( 0.05 * ms'^.range))) keyboardAct ms (SpecialKey KeyUp) Down = do- modifyIORef ms (\m@Mandstate{ymid=y,range=r} -> m{ymid=y + 0.1*r})+ ms' <- readIORef ms+ modifyIORef ms (ymid ^: ((+) ( 0.05 * ms'^.range))) keyboardAct ms (SpecialKey KeyDown) Down = do- modifyIORef ms (\m@Mandstate{ymid=y,range=r} -> m{ymid=y - 0.1*r})+ ms' <- readIORef ms+ modifyIORef ms (ymid ^: ((+) ( -0.05 * ms'^.range))) keyboardAct ms (Char '+') Down = do- modifyIORef ms (\m@Mandstate{range=r} -> m{range=r/rangemul})+ modifyIORef ms (range ^: (/rangemul)) keyboardAct ms (Char '-') Down = do- modifyIORef ms (\m@Mandstate{range=r} -> m{range=r*rangemul})+ modifyIORef ms (range ^: (*rangemul)) keyboardAct ms (Char 'a') Down = do- modifyIORef ms (\m@Mandstate{colourmul=cm} -> m{colourmul=cm*cmul})+ modifyIORef ms (colourmul ^: (*cmul)) keyboardAct ms (Char 's') Down = do- modifyIORef ms (\m@Mandstate{colourmul=cm} -> m{colourmul=cm/cmul})+ modifyIORef ms (colourmul ^: (/cmul)) +keyboardAct ms (Char '<') Down = do+ modifyIORef ms (maxiter ^: ((-) iteradd))+keyboardAct ms (Char '>') Down = do+ modifyIORef ms (maxiter ^: (+ iteradd)) keyboardAct ms (Char 'p') Down = do ms' <- readIORef ms- imagAt "frac.png" ms'+ imagAt "frac.png" ms' --TODO: Allow user-namable output images keyboardAct ms (Char 'o') Down = do ms' <- readIORef ms print ms'
FracComp.hs view
@@ -8,20 +8,21 @@ import FracState type Pix = IOUArray Int Double+ -- Number of iterations to escape-mandPoint :: Int -> Double -> Double -> Double -> Double -> Double-mandPoint !n !x !y cx cy | n > maxIter = 0.0- | (x2 + y2) > 4.0 = 1.0 - logBase 2 (0.5 * logBase 2 (x2 + y2)) + fromIntegral n- | otherwise = mandPoint (n+1) (x2 - y2 + cx) (2.0*x*y + cy) cx cy where+mandPoint :: Int -> Double -> Double -> Double -> Double -> Int -> Double+mandPoint !n !x !y cx cy mi | n > mi = 0.0+ | (x2 + y2) > 4.0 = 1.0 - logBase 2 (0.5 * logBase 2 (x2 + y2)) + fromIntegral n+ | otherwise = mandPoint (n+1) (x2 - y2 + cx) (2.0*x*y + cy) cx cy mi where x2 = x*x --This CSE saves a few cycles y2 = y*y -compPoints :: Double -> Double -> Double -> Sz -> Pix -> IO ()-compPoints xm ym rng sz@(Sz width height) arr = go 0 0 where+compPoints :: Double -> Double -> Double -> Int -> Sz -> Pix -> IO ()+compPoints xm ym rng mi sz@(Sz width height) arr = go 0 0 where go !x !y | y == height = return () | x == width = go 0 (y+1) | otherwise = do - writeArray arr k (mandPoint 0 0.0 0.0 cx cy)+ writeArray arr k (mandPoint 0 0.0 0.0 cx cy mi) go (x+1) y where k = x + y*width fi = fromIntegral@@ -43,4 +44,4 @@ --TODO: Conjure up some more properties prop_reflection :: Double -> Double -> Bool-prop_reflection x y = mandPoint 0 0.0 0.0 x y == mandPoint 0 0.0 0.0 x (-y)+prop_reflection x y = mandPoint 0 0.0 0.0 x y 500 == mandPoint 0 0.0 0.0 x (-y) 500
FracImg.hs view
@@ -10,15 +10,16 @@ import System.IO import Graphics.Rendering.OpenGL -w = 1600-h = 1600+imgMaxIter = 5000 --High iteration for the output image+w = 2000 --High resolution for the output image+h = 2000 filepath = "." :: FilePath +--Convert a GL Colour datatype to a GD Colour datatype convColour :: Color3 GLdouble -> Graphics.GD.Color convColour (Color3 r g b) = rgb (f r) (f g) (f b) where f = (floor . (* 256)) ---pixel :: Image -> Double -> (Int, Double) -> IO () pixelWrite im (Sz w h) cm pixarr = go 0 0 where go !x !y | y == h = return () | x == w = go 0 (y+1)@@ -28,10 +29,10 @@ go (x+1) y imagAt :: FilePath -> Mandstate -> IO ()-imagAt fp Mandstate{xmid=xm, ymid=ym, range=rng, colourmul=cm} = do+imagAt fp (Mandstate xm ym rng cm mi) = do pixarr <- newArray (0, w*h-1) 0.0 :: IO Pix im <- newImage (w, h)- compPoints xm ym rng (Sz w h) pixarr+ compPoints xm ym rng (max imgMaxIter mi) (Sz w h) pixarr pixelWrite im (Sz w h) cm pixarr savePngFile fp im
FracState.hs view
@@ -1,27 +1,33 @@+{-# LANGUAGE TemplateHaskell #-} module FracState where -maxIter, maxWidth, maxHeight :: Int-maxIter = 500-(maxWidth, maxHeight) = (1200,1200)----Keep the indicies as a global list so they aren't recopmuted every rendering-indicies :: [Int]-indicies = [0 .. (maxWidth-1)*(maxHeight-1)]+import Data.Accessor+import Data.Accessor.Basic (T)+import Data.Accessor.Template +--These values alter the state in various ways+iteradd :: Int rangemul, cmul :: Double rangemul = 1.02 cmul = 1.3+iteradd = 100 data Mandstate = Mandstate {- xmid :: Double,- ymid :: Double,- range :: Double,- colourmul :: Double } deriving (Eq, Show)+ xmid_ :: Double,+ ymid_ :: Double,+ range_ :: Double,+ colourmul_ :: Double,+ maxiter_ :: Int} deriving (Eq, Show) +$( deriveAccessors ''Mandstate ) -data Sz = Sz Int Int deriving (Eq, Show)+data Sz = Sz {+ wi_ :: Int,+ hi_ :: Int} deriving (Eq, Show)+$( deriveAccessors ''Sz ) data Options = Options- { size :: Sz,- ms :: Mandstate + { size_:: Sz,+ ms_ :: Mandstate } deriving (Eq, Show)+$( deriveAccessors ''Options )
Hfractal.hs view
@@ -4,24 +4,24 @@ import Data.Array.IO hiding (range) import System.Console.GetOpt import System.Environment (getArgs)+import Data.Accessor import Bindings import FracState import FracComp -inializeScreen opts@Options{size=Sz w h} = do+inializeScreen opts@(Options (Sz w h) _) = do (progname,_) <- getArgsAndInitialize initialDisplayMode $= [DoubleBuffered] lineSmooth $= Enabled blendFunc $= (SrcAlpha, OneMinusSrcAlpha) createWindow "HFractal" windowSize $= Size (fromIntegral (w-2)) (fromIntegral (h-1))- --clearColor $= Color4 0 0 0 0 matrixMode $= Projection ortho2D 0.0 (fromIntegral (w-1)) 0.0 (fromIntegral (h-1)) matrixMode $= Modelview 0 -setCallBacks opts@Options{size=s@(Sz w h), ms=state} = do+setCallBacks opts@(Options s@(Sz w h) state) = do --Create the state and pixel array ms <- newIORef state pixarr <- newArray (0, w*h-1) 0.0 :: IO Pix@@ -38,12 +38,14 @@ display ms sz@(Sz w h) pixarr = do clear [ColorBuffer] loadIdentity- Mandstate{xmid=x, ymid=y, range=r, colourmul=cm} <- get ms- compPoints x y r sz pixarr+ (Mandstate x y r cm mi) <- get ms --Get state+ compPoints x y r mi sz pixarr --Compute escape iterations for this state preservingMatrix $ do- renderPrimitive Points $ displayPix sz cm pixarr+ renderPrimitive Points $ displayPix sz cm pixarr swapBuffers +--Takes the array with escape iterations (+ smoothing) and displays using+--the colour function defined in FracComp displayPix :: Sz -> Double -> IOUArray Int Double -> IO () displayPix sz@(Sz width height) cm pixarr = go 0 0 where go !x !y | y == height = return ()@@ -58,6 +60,8 @@ --Other Callbacks ----------------------------------------- +--TODO: This is necessary currently+--want to only postRedisplay if something changes idle :: IO () idle = do postRedisplay Nothing@@ -74,22 +78,23 @@ --Option Parsing and Main loop ---------------------------------------- +--Some defualt starting positions zeroState, state1 :: Mandstate-zeroState = Mandstate {xmid = 0.0, ymid = 0.0, range = 2.0, colourmul = 0.05}-state1 = Mandstate {xmid = 0.001643721971153, ymid = 0.822467633298876, range = 0.05, colourmul = 0.0625}-state = state1+zeroState = Mandstate 0.0 0.0 2.0 0.05 500+state1 = Mandstate 0.001643721971153 0.822467633298876 0.05 0.0625 500+state = state1 -defOpts = Options {size=Sz 400 400, ms=state}+defOpts = Options (Sz 400 400) state --TODO: Tidy up the option parser with Data.Accessor(.Template) options :: [OptDescr (Options -> Options)] options = [ - Option ['w'] ["width"] (ReqArg (\x opt -> opt {size = sx (size opt) (r x)} ) "WIDTH") "Set width of rendering window", - Option ['h'] ["height"] (ReqArg (\y opt -> opt {size = sy (size opt) (r y)} ) "HEIGHT") "Set height of rendering window"] where - --Options ['x'] ["x-mid"] (NoArg (\x opt -> opt { ms {xmid = read x} }))- sx (Sz x y) x' = (Sz x' y)- sy (Sz x y) y' = (Sz x y')- r = read+ Option ['w'] ["width"] (ReqArg (\w -> size^:wi^=(read w)) "Window width") "Set width of rendering window", + Option ['h'] ["height"] (ReqArg (\h -> size^:hi^=(read h)) "Window height") "Set height of rendering window",+ Option ['x'] ["x-mid"] (ReqArg (\x -> ms^:xmid^=(read x)) "Real(z)") "Set the real part of the initial z (double)",+ Option ['y'] ["y-mid"] (ReqArg (\y -> ms^:ymid^=(read y)) "Imag(z)") "Set the imaginary part of the inital z (double)",+ Option ['i'] ["maxiter"] (ReqArg (\i -> ms^:maxiter^=(read i)) "Max iterations") "Maximum iterations until escape (int)",+ Option ['z'] ["zoom"] (ReqArg (\z -> ms^:range^=(read z)) "Zoom") "Level of zoom (double)"] getOpts :: [String] -> IO Options getOpts argv = case getOpt Permute options argv of
README view
@@ -4,4 +4,8 @@ Arrow keys - Movement +/- - Zoom in/out a/s - Alter colouring gradient-p - Print a hi-res image of the current location in the working direction+</> - Decrease/increase number of iterations + in escape algorithm.+p - Print a hi-res image of the current location+ in the working direction+o - Print current location to console
hfractal.cabal view
@@ -1,5 +1,5 @@ name: hfractal-version: 0.1.0.1+version: 0.1.1.0 cabal-version: >= 1.2 synopsis: OpenGL fractal renderer category: Graphics@@ -11,6 +11,6 @@ Executable hfractal main-is: Hfractal.hs- build-depends: base >=3 && <5, array, gd, OpenGL >= 2.3 && < 2.4, GLUT+ build-depends: base >=3 && <5, array, gd < 3000.3.0 && >= 3000.2.0, data-accessor >=0.2 && <=0.3, data-accessor-template >=0.2 && <=0.3, OpenGL >= 2.3 && < 2.4, GLUT other-Modules: FracComp, FracState, FracImg, Bindings ghc-options: -O2