hfractal (empty) → 0.1.0

raw patch · 8 files changed

+282/−0 lines, 8 filesdep +GLUTdep +OpenGLdep +arraysetup-changed

Dependencies added: GLUT, OpenGL, array, base, data-accessor, data-accessor-template, gd

Files

• Bindings.hs +36/−0
• FracComp.hs +46/−0
• FracImg.hs +43/−0
• FracState.hs +27/−0
• Hfractal.hs +105/−0
• README +7/−0
• Setup.hs +2/−0
• hfractal.cabal +16/−0

@@ -0,0 +1,36 @@+module Bindings+  where++import Graphics.UI.GLUT+import Data.IORef+import System.Exit++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})+keyboardAct ms (SpecialKey KeyRight) Down = do+  modifyIORef ms (\m@Mandstate{xmid=x,range=r} -> m{xmid=x + 0.1*r})+keyboardAct ms (SpecialKey KeyUp) Down = do+  modifyIORef ms (\m@Mandstate{ymid=y,range=r} -> m{ymid=y + 0.1*r})+keyboardAct ms (SpecialKey KeyDown) Down = do+  modifyIORef ms (\m@Mandstate{ymid=y,range=r} -> m{ymid=y - 0.1*r})+keyboardAct ms (Char '+') Down = do+  modifyIORef ms (\m@Mandstate{range=r} -> m{range=r/rangemul})+keyboardAct ms (Char '-') Down = do+  modifyIORef ms (\m@Mandstate{range=r} -> m{range=r*rangemul})+keyboardAct ms (Char 'a') Down = do+  modifyIORef ms (\m@Mandstate{colourmul=cm} -> m{colourmul=cm*cmul})+keyboardAct ms (Char 's') Down = do+  modifyIORef ms (\m@Mandstate{colourmul=cm} -> m{colourmul=cm/cmul})+keyboardAct ms (Char 'p') Down = do+  ms' <- readIORef ms+  imagAt "frac.png" ms'+keyboardAct ms (Char 'o') Down = do+  ms' <- readIORef ms+  print ms'+keyboardAct _ (Char '\27') _ = exitWith ExitSuccess+keyboardAct _ _ _ = return ()

@@ -0,0 +1,46 @@+{-# LANGUAGE BangPatterns #-}+module FracComp+  where++import Graphics.UI.GLUT+import Data.Array.IO++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+	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+	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)+		go (x+1) y where+			k = x + y*width+			fi = fromIntegral+			cx = rng * (fi x - fi w2) / fi w2 + xm :: Double+			cy = rng * (fi y - fi h2) / fi h2 + ym :: Double+			(w2, h2) = (width `div` 2, height `div` 2)++-- Colour a vertex+colourMand :: Double -> Double -> Color3 GLdouble+colourMand 0.0 _ = fmap realToFrac $ Color3 0.0 0.0 0.0+colourMand m cm = fmap realToFrac $ Color3 r g b where+	r = 0.5 + 0.5 * cos (m * cm) +	g = 0.5 + 0.5 * cos ((m + 16.0) * cm)+	b = 0.5 + 0.5 * cos ((m + 32.0) * cm)++-----------------------------------------+--QuickCheck Properties+-----------------------------------------+--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)

@@ -0,0 +1,43 @@+{-# LANGUAGE BangPatterns #-}+module FracImg+	where++import FracComp+import FracState++import Graphics.GD+import Data.Array.IO hiding (range)+import System.IO+import Graphics.Rendering.OpenGL++w = 1600+h = 1600+filepath = "." :: FilePath++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)+			 | otherwise = do+		p <- readArray pixarr (x + y*w)+		setPixel (x,y) (convColour $ colourMand p cm) im+		go (x+1) y++imagAt ::  FilePath -> Mandstate -> IO ()+imagAt fp Mandstate{xmid=xm, ymid=ym, range=rng, colourmul=cm} = do+	pixarr <- newArray (0, w*h-1) 0.0 :: IO Pix+	im <- newImage (w, h)+	compPoints xm ym rng (Sz w h) pixarr+	pixelWrite im (Sz w h) cm pixarr +	savePngFile fp im++{-+imgrange :: Double-> Double-> Double-> Double-> Double-> Int-> [Char]-> IO ()+imgrange xm ym cm initrange scale num rootfp = mapM_ (\(fn, r) -> imagAt fn xm ym cm r) $ zip fns ranges where+	fns = map (\s -> rootfp ++ show (100000 + s) ++ ".png") [1..num]+	ranges = take num $ iterate (/scale) initrange+-}

@@ -0,0 +1,27 @@+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)]++rangemul, cmul :: Double+rangemul = 1.02+cmul     = 1.3++data Mandstate = Mandstate {+  xmid :: Double,+  ymid :: Double,+  range :: Double,+  colourmul :: Double } deriving (Eq, Show)++data Sz = Sz Int Int deriving (Eq, Show)++data Options = Options+	{ size :: Sz,+	  ms   :: Mandstate   +	} deriving (Eq, Show)

@@ -0,0 +1,105 @@+{-# LANGUAGE BangPatterns #-}+import Graphics.UI.GLUT+import Data.IORef+import Data.Array.IO hiding (range)+import System.Console.GetOpt+import System.Environment (getArgs)++import Bindings+import FracState+import FracComp++inializeScreen opts@Options{size=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+	--Create the state and pixel array+	ms <- newIORef state+	pixarr <- newArray (0, w*h-1) 0.0 :: IO Pix+	--Set the callbacks+	reshapeCallback $= Just (reshape opts)+	idleCallback $= Just idle+	keyboardMouseCallback $= Just (keyboardMouse ms)+	displayCallback $= display ms s pixarr++----------------------------------------+--Display Callback and related functions+----------------------------------------++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+	preservingMatrix $ do+		renderPrimitive Points $ displayPix sz cm pixarr+	swapBuffers++displayPix :: Sz -> Double -> IOUArray Int Double -> IO ()+displayPix sz@(Sz width height) cm pixarr = go 0 0 where+	go !x !y | y == height = return ()+	         | x == width  = go 0 (y+1)	+			 | otherwise   = do+		dk <- readArray pixarr (x + y*width)+		color (colourMand dk cm)+		vertex $ Vertex2 (fromIntegral x) (fromIntegral y :: GLfloat)+		go (x+1) y++-----------------------------------------+--Other Callbacks+-----------------------------------------++idle ::  IO ()+idle = do+	postRedisplay Nothing++reshape opts s'@(Size w h) = do+	viewport $= (Position 0 0, s')+	--setCallBacks opts{size=Sz (fromIntegral w) (fromIntegral h)} --Reset the callbacks so that the pixarr is recreated+	postRedisplay Nothing++keyboardMouse ms key state _ _ = do+	keyboardAct ms key state++-----------------------------------------+--Option Parsing and Main loop+----------------------------------------++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++defOpts = Options {size=Sz 400 400, ms=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++getOpts :: [String] -> IO Options+getOpts argv = case getOpt Permute options argv of+	(o, [], []) -> return $ foldl (flip ($)) defOpts o+	(_, _, errs) -> ioError (userError (concat errs ++ usageInfo header options))+	where header = "Usage: hfractal [OPTION...]"++main :: IO()+main = do+	opts <- getOpts =<< getArgs+	inializeScreen opts +	setCallBacks opts+	mainLoop

@@ -0,0 +1,7 @@+OpenGL Fractal renderer. Currently only renders the Mandelbrot set, but can (and will) be easily extened to other fractals.++Controls:+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

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,16 @@+name:                hfractal+version:             0.1.0+cabal-version:		 >= 1.2+synopsis:            OpenGL fractal renderer+category:            Graphics+license:             BSD3+author:              Chris Holdsworth+maintainer:          chrisholdsworth@gmail.com+build-type:          Simple+extra-source-files:  README++Executable hfractal+    main-is:            Hfractal.hs+    build-depends:      base >=4 && <= 4.1, array, data-accessor, data-accessor-template, gd, OpenGL, GLUT+    other-Modules:      FracComp, FracState, FracImg, Bindings+    ghc-options:        -O2