hfractal 0.3.2.1 → 0.3.3.2
raw patch · 14 files changed
+430/−431 lines, 14 files
Files
- Bindings.hs +0/−68
- FracColour.hs +0/−51
- FracComp.hs +0/−104
- FracImg.hs +0/−46
- FracState.hs +0/−33
- Hfractal.hs +0/−112
- README +17/−14
- hfractal.cabal +5/−3
- src/Bindings.hs +68/−0
- src/FracColour.hs +51/−0
- src/FracComp.hs +102/−0
- src/FracImg.hs +46/−0
- src/FracState.hs +33/−0
- src/Hfractal.hs +108/−0
− Bindings.hs
@@ -1,68 +0,0 @@-module Bindings- where--import Graphics.UI.GLUT-import Data.IORef-import System.Exit-import Data.Accessor-import Data.Accessor.Basic (T)-import Control.Concurrent--import FracState-import FracImg--keyboardMouseAct :: IORef Mandstate -> Sz -> Key -> KeyState -> Position -> IO ()---Keyboard actions as described in README-keyboardMouseAct ms _ (SpecialKey KeyLeft) Down _ = do- ms' <- readIORef ms- modifyIORef ms (xmid ^: ((+) ( -0.05 * ms'^.range)))-keyboardMouseAct ms _ (SpecialKey KeyRight) Down _ = do- ms' <- readIORef ms- modifyIORef ms (xmid ^: ((+) ( 0.05 * ms'^.range)))-keyboardMouseAct ms _ (SpecialKey KeyUp) Down _ = do- ms' <- readIORef ms- modifyIORef ms (ymid ^: ((+) ( 0.05 * ms'^.range)))-keyboardMouseAct ms _ (SpecialKey KeyDown) Down _ = do- ms' <- readIORef ms- modifyIORef ms (ymid ^: ((+) ( -0.05 * ms'^.range)))-keyboardMouseAct ms _ (Char '+') Down _ = do- modifyIORef ms (range ^: (/rangemul))-keyboardMouseAct ms _ (Char '-') Down _ = do- modifyIORef ms (range ^: (*rangemul))-keyboardMouseAct ms _ (Char 'a') Down _ = do- modifyIORef ms (colourmul ^: (*cmul)) -keyboardMouseAct ms _ (Char 's') Down _ = do- modifyIORef ms (colourmul ^: (/cmul)) -keyboardMouseAct ms _ (Char '<') Down _ = do- modifyIORef ms (maxiter ^: ((-) iteradd))-keyboardMouseAct ms _ (Char '>') Down _ = do- modifyIORef ms (maxiter ^: (+ iteradd))-keyboardMouseAct ms _ (Char 'p') Down _ = do- ms' <- readIORef ms- putStrLn "Creating frac.png"- forkIO (imagAt "frac.png" ms' >> putStrLn "Finished Image") >> return ()- --TODO: Allow user-namable output images, make this concurrent-keyboardMouseAct ms _ (Char 'o') Down _ = do- ms' <- readIORef ms- print ms'---Mouse actions-keyboardMouseAct ms _ (MouseButton WheelUp) Down _ = do- modifyIORef ms (range ^: (/ (rangemul*1.05)))-keyboardMouseAct ms _ (MouseButton WheelDown) Down _ = do- modifyIORef ms (range ^: (* (rangemul*1.05)))-keyboardMouseAct ms (Sz w h) (MouseButton RightButton) Down (Position x y) = do- ms' <- readIORef ms- modifyIORef ms ((xmid ^: ((+) ((x `mp` w) * ms'^.range ))) .- (ymid ^: ((+) (-(y `mp` h) * ms'^.range ))) .- (range ^: (/rangemul)))-keyboardMouseAct ms (Sz w h) (MouseButton LeftButton) Down (Position x y) = do- ms' <- readIORef ms- modifyIORef ms ((xmid ^: ((+) ((x `mp` w) * ms'^.range ))) .- (ymid ^: ((+) (-(y `mp` h) * ms'^.range ))))---Exit and default-keyboardMouseAct _ _ (Char '\27') _ _ = exitWith ExitSuccess-keyboardMouseAct _ _ _ _ _ = return ()----TODO, have a separate mouse and keyboard functions and then a wrapper with cases on the type of Key-mp :: GLint -> Int -> Double-mp x w = (fromIntegral x - fromIntegral (w `div` 2)) / fromIntegral w
− FracColour.hs
@@ -1,51 +0,0 @@-module FracColour - where--import Graphics.UI.GLUT hiding (blend)--(Color3, GLdouble)-import Data.Colour as C-import Data.Colour.SRGB-import Data.List as L-import Data.IntMap as IM-import Data.Maybe-import Data.Colour.Names-import Graphics.GD---- Create a pallette of colours with which is a map from escape iterations to colours-createPallete :: Int -> [(Int, Colour Double)] -> IntMap (Colour Double)-createPallete maxIter points | length points < 2 || maximum (L.map fst points) > maxIter - || minimum (L.map fst points) < 0 = error "Invalid pallete reference points"- | otherwise = fromList (interpolate $ sortBy (\x y -> fst x `compare` fst y) points)--interpolate :: [(Int, Colour Double)] -> [(Int, Colour Double)]-interpolate [(_,_)] = []-interpolate ((n1,c1):(n2,c2):xs) = [(n1 + i, C.blend (fromIntegral i / delta) c1 c2) | i <- [0 .. (n2 - n1 - 1)]] ++ (interpolate ((n2,c2):xs)) where- delta = fromIntegral (n2 - n1)--colourPoint' :: IntMap (Colour Double) -> Double -> Colour Double-colourPoint' colpal n = {-# SCC "blend" #-} C.blend (n-fromIntegral n1) (fromJust c1) (fromJust c2) where --Will it blend?- n1 = {-# SCC "floor" #-} truncate n- n2 = n1 + 1- (c1, c2) = {-# SCC "lookups" #-} (IM.lookup n1 colpal, IM.lookup n2 colpal)--pallete = createPallete 5002 [(0,red), (1200, white), (1600, yellow), (2000, blend 0.3 white orange), (2500,darken 0.2 orange), (3200, blend 0.7 orange black), (4400, white), (5002, red)]--{--colourPoint :: Double -> Double -> Color3 GLdouble-colourPoint 0.0 _ = fmap realToFrac $ Color3 0.0 0.0 0.0-colourPoint n _ = let c = toSRGB $ colourPoint' pallete n in- {-# SCC "conversions" #-} fmap realToFrac $ Color3 (channelRed c) (channelGreen c) (channelBlue c)--}--colourGD :: Double -> Double -> Graphics.GD.Color-colourGD 0.0 _ = rgb 0 0 0-colourGD n _ = let c = toSRGB24 $ colourPoint' pallete n in- rgb (fromIntegral $ channelRed c) (fromIntegral $ channelGreen c) (fromIntegral $ channelBlue c)---- Colour a vertex based on the number of iterations it took to escape-colourPoint :: Double -> Double -> Color3 GLdouble-colourPoint 0.0 _ = fmap realToFrac $ Color3 0.0 0.0 0.0-colourPoint 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)-
− FracComp.hs
@@ -1,104 +0,0 @@-{-# LANGUAGE BangPatterns #-}-module FracComp- where--import Graphics.UI.GLUT-import Data.Array.IO-import Control.Concurrent-import Control.Exception-import System.IO.Unsafe--import FracState--type Pix = IOUArray Int Double---- Number of iterations to escape the mandelbrot set-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--{---- Number of iterations to escape the burning ship fractal-burnPoint :: Int -> Double -> Double -> Double -> Double -> Int -> Double-burnPoint !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 = burnPoint (n+1) (x2 - y2 + cx) (-2.0 * abs (x*y) + cy) cx cy mi where- !x2 = x*x - !y2 = y*y--}--children :: MVar [MVar ()]-children = unsafePerformIO (newMVar [])--waitForChildren :: IO ()-waitForChildren = do- cs <- takeMVar children- case cs of- [] -> do- putMVar children []- return ()- m:ms -> do- putMVar children ms- takeMVar m- waitForChildren--forkChild :: IO () -> IO ThreadId-forkChild io = do- mvar <- newEmptyMVar- childs <- takeMVar children- putMVar children (mvar:childs)- forkIO (io `finally` putMVar mvar ())---mandPointSampled !x !y !xrng !yrng !mi ss = average points where- points = [ mandPoint 0 0.0 0.0 (x + dx) (y + dy) mi | - dx <- ((take ss) . iterate (+xrng)) 0.0, - dy <- ((take ss) . iterate (+yrng)) 0.0]- average xs = sum xs / (fromIntegral . length) xs-----This gives an image in a sligtly different position than the unsampled function---But the code is easier this way-compPointsSampled :: Double -> Double -> Double -> Int -> Sz -> Pix -> Int -> IO ()-compPointsSampled xm ym rng mi sz@(Sz width height) arr ss = do- go 0- waitForChildren where- go !y | y == height = return () - | otherwise = forkChild (goRow 0 y) >> go (y+1)- goRow !x y | x == width = return () :: IO ()- | otherwise = do - writeArray arr k (mandPointSampled cx cy xrng yrng mi ss)- goRow (x+1) y where- (xrng, yrng) = (rng / fi (ss * width), rng / fi (ss * height))- k = x + y*width- fi = fromIntegral- cx = rng * (fi x - fi w2) / fi width + xm :: Double- cy = rng * (fi y - fi h2) / fi height + ym :: Double- (w2, h2) = (width `div` 2, height `div` 2) --compPoints :: Double -> Double -> Double -> Int -> Sz -> Pix -> IO ()-compPoints xm ym rng mi sz@(Sz width height) arr = do- go 0- waitForChildren where- go !y | y == height = return () - | otherwise = forkChild (goRow 0 y) >> go (y+1)- goRow !x y | x == width = return () :: IO ()- | otherwise = do - writeArray arr k (mandPoint 0 0.0 0.0 cx cy mi)- goRow (x+1) y where- k = x + y*width- fi = fromIntegral- cx = rng * (fi x - fi w2) / fi width + xm :: Double- cy = rng * (fi y - fi h2) / fi height + ym :: Double- (w2, h2) = (width `div` 2, height `div` 2) ----------------------------------------------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 500 == mandPoint 0 0.0 0.0 x (-y) 500
− FracImg.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE BangPatterns #-}-module FracImg- where--import FracComp-import FracState-import FracColour--import Graphics.GD-import Data.Array.IO hiding (range)-import System.IO-import Graphics.Rendering.OpenGL--supSamp = 5 --Use subpixel sampling-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))--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)- (antiAliased $ setPixel (x,y)) (convColour $ colourPoint p cm) im- go (x+1) y--imagAt :: FilePath -> Mandstate -> IO ()-imagAt fp (Mandstate xm ym rng cm mi) = do- pixarr <- newArray (0, w*h-1) 0.0 :: IO Pix- im <- newImage (w, h)- compPointsSampled xm ym rng (max imgMaxIter mi) (Sz w h) pixarr supSamp- 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--}
− FracState.hs
@@ -1,33 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module FracState- where--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.019-cmul = 1.2-iteradd = 100--data Mandstate = Mandstate {- xmid_ :: Double,- ymid_ :: Double,- range_ :: Double,- colourmul_ :: Double,- maxiter_ :: Int} deriving (Eq, Show) -$( deriveAccessors ''Mandstate )--data Sz = Sz {- wi_ :: Int,- hi_ :: Int} deriving (Eq, Show)-$( deriveAccessors ''Sz )--data Options = Options- { size_:: Sz,- ms_ :: Mandstate - } deriving (Eq, Show)-$( deriveAccessors ''Options )
− Hfractal.hs
@@ -1,112 +0,0 @@-{-# LANGUAGE BangPatterns #-}-import Graphics.UI.GLUT-import Data.IORef-import Data.Array.IO hiding (range)-import System.Console.GetOpt-import System.Environment (getArgs)-import Data.Accessor--import Bindings-import FracState-import FracColour-import FracComp--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))--- reshapeCallback $= Just (reshape opts)--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- --Deal with the window size- matrixMode $= Projection- ortho2D 0.0 (fromIntegral (w-1)) 0.0 (fromIntegral (h-1)) - matrixMode $= Modelview 0- --Set the callbacks- keyboardMouseCallback $= Just (keyboardMouse ms s)- displayCallback $= display ms s pixarr---------------------------------------------Display Callback and related functions-------------------------------------------display :: (HasGetter g) => g Mandstate -> Sz -> Pix -> IO ()-display ms sz@(Sz w h) pixarr = do- clear [ColorBuffer]- loadIdentity- (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 - 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 ()- | x == width = go 0 (y+1) - | otherwise = do- dk <- readArray pixarr (x + y*width)- color (colourPoint dk cm)- vertex $ Vertex2 (fromIntegral x) (fromIntegral y :: GLfloat)- go (x+1) y----------------------------------------------Other Callbacks----------------------------------------------Don't allow resizing-{--reshape :: Options -> Size -> IO ()-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 s key state _ pos = do- keyboardMouseAct ms s key state pos- postRedisplay Nothing----------------------------------------------Option Parsing and Main loop---------------------------------------------Some interesting starting positions-zeroState, state0, state1, state2 :: Mandstate-zeroState = Mandstate 0.0 0.0 2.0 0.05 500-state0 = Mandstate (-0.14076572210832694) 0.8510989379408804 1.0 0.05 500-state1 = Mandstate 0.001643721971153 0.822467633298876 0.05 0.0625 500-state2 = Mandstate 0.35473015182773904 9.541013313560959e-2 0.0002 0.0625 500-state = state1--defOpts = Options (Sz 400 400) state--options :: [OptDescr (Options -> Options)]-options = [ - 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- (o, [], []) -> return $ foldl (flip ($)) defOpts o- (_, _, errs) -> ioError (userError (concat errs ++ usageInfo header options))- where header = "Usage: hfractal [OPTIONS...] [+RTS -N{cores}]"--main :: IO()-main = do- opts <- getOpts =<< getArgs- inializeScreen opts - setCallBacks opts- mainLoop
README view
@@ -1,19 +1,22 @@-OpenGL Fractal renderer. Currently only renders the Mandelbrot set, but can (and will) be easily extened to other fractals.+OpenGL Fractal renderer. Currently only renders the Mandelbrot set, but can extened to other fractals. Doesn't play well with xmonad - use on the floating layer.+ Controls:- Keyboard- Arrow keys - Movement- +/- - Zoom in/out- a/s - Alter colouring gradient- </> - 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+ Keyboard+ Arrow keys - Movement+ +/- - Zoom in/out+ a/s - Alter colouring gradient+ </> - 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 - Mouse- Left Mouse - Centre- Right Mouse - Centre and zoom- Mouse Wheel - Zoom+ Mouse+ Left Mouse - Centre+ Right Mouse - Centre and zoom+ Mouse Wheel - Zoom Can exploit multiple cores - Use hfractal [opts] +RTS -N{cores} to enable this.++On linux the following libraries may be required: [libjpeg8, libpng, libgd2-xpm-dev]
hfractal.cabal view
@@ -1,14 +1,15 @@ name: hfractal-version: 0.3.2.1-cabal-version: >= 1.2+version: 0.3.3.2+cabal-version: >= 1.2 synopsis: OpenGL fractal renderer-description: An OpenGL fractal browser with multicore support and the capability to output high quality png images.+description: An OpenGL fractal browser with multicore support and the capability to output high quality png images. stability: Experimental category: Graphics license: BSD3 copyright: 2009-2009 Chris Holdsworth author: Chris Holdsworth <chrisholdsworth@gmail.com> maintainer: Chris Holdsworth <chrisholdsworth@gmail.com>+homepage: http://github.com/cmh/Hfractal build-type: Simple extra-source-files: README @@ -17,3 +18,4 @@ 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.0.0, OpenGLRaw < 1.1.0.0, GLUT >= 2.2.1.0 && < 2.2.2.0, colour >=2.3.1, containers >= 0.2 other-Modules: FracComp, FracColour, FracImg, FracState, Bindings ghc-options: -O2 -threaded -fvia-C -optc-O3 -optc-ffast-math+ Hs-Source-Dirs: src
+ src/Bindings.hs view
@@ -0,0 +1,68 @@+module Bindings+ where++import Graphics.UI.GLUT+import Data.IORef+import System.Exit+import Data.Accessor+import Data.Accessor.Basic (T)+import Control.Concurrent++import FracState+import FracImg++keyboardMouseAct :: IORef Mandstate -> Sz -> Key -> KeyState -> Position -> IO ()+--Keyboard actions as described in README+keyboardMouseAct ms _ (SpecialKey KeyLeft) Down _ = do+ ms' <- readIORef ms+ modifyIORef ms (xmid ^: ((+) ( -0.05 * ms'^.range)))+keyboardMouseAct ms _ (SpecialKey KeyRight) Down _ = do+ ms' <- readIORef ms+ modifyIORef ms (xmid ^: ((+) ( 0.05 * ms'^.range)))+keyboardMouseAct ms _ (SpecialKey KeyUp) Down _ = do+ ms' <- readIORef ms+ modifyIORef ms (ymid ^: ((+) ( 0.05 * ms'^.range)))+keyboardMouseAct ms _ (SpecialKey KeyDown) Down _ = do+ ms' <- readIORef ms+ modifyIORef ms (ymid ^: ((+) ( -0.05 * ms'^.range)))+keyboardMouseAct ms _ (Char '+') Down _ = do+ modifyIORef ms (range ^: (/rangemul))+keyboardMouseAct ms _ (Char '-') Down _ = do+ modifyIORef ms (range ^: (*rangemul))+keyboardMouseAct ms _ (Char 'a') Down _ = do+ modifyIORef ms (colourmul ^: (*cmul)) +keyboardMouseAct ms _ (Char 's') Down _ = do+ modifyIORef ms (colourmul ^: (/cmul)) +keyboardMouseAct ms _ (Char '<') Down _ = do+ modifyIORef ms (maxiter ^: ((-) iteradd))+keyboardMouseAct ms _ (Char '>') Down _ = do+ modifyIORef ms (maxiter ^: (+ iteradd))+keyboardMouseAct ms _ (Char 'p') Down _ = do+ ms' <- readIORef ms+ putStrLn "Creating frac.png"+ forkIO (imagAt "frac.png" ms' >> putStrLn "Finished Image") >> return ()+ --TODO: Allow user-namable output images, make this concurrent+keyboardMouseAct ms _ (Char 'o') Down _ = do+ ms' <- readIORef ms+ print ms'+--Mouse actions+keyboardMouseAct ms _ (MouseButton WheelUp) Down _ = do+ modifyIORef ms (range ^: (/ (rangemul*1.05)))+keyboardMouseAct ms _ (MouseButton WheelDown) Down _ = do+ modifyIORef ms (range ^: (* (rangemul*1.05)))+keyboardMouseAct ms (Sz w h) (MouseButton RightButton) Down (Position x y) = do+ ms' <- readIORef ms+ modifyIORef ms ((xmid ^: ((+) ((x `mp` w) * ms'^.range ))) .+ (ymid ^: ((+) (-(y `mp` h) * ms'^.range ))) .+ (range ^: (/rangemul)))+keyboardMouseAct ms (Sz w h) (MouseButton LeftButton) Down (Position x y) = do+ ms' <- readIORef ms+ modifyIORef ms ((xmid ^: ((+) ((x `mp` w) * ms'^.range ))) .+ (ymid ^: ((+) (-(y `mp` h) * ms'^.range ))))+--Exit and default+keyboardMouseAct _ _ (Char '\27') _ _ = exitWith ExitSuccess+keyboardMouseAct _ _ _ _ _ = return ()++--TODO, have a separate mouse and keyboard functions and then a wrapper with cases on the type of Key+mp :: GLint -> Int -> Double+mp x w = (fromIntegral x - fromIntegral (w `div` 2)) / fromIntegral w
+ src/FracColour.hs view
@@ -0,0 +1,51 @@+module FracColour + where++import Graphics.UI.GLUT hiding (blend)--(Color3, GLdouble)+import Data.Colour as C+import Data.Colour.SRGB+import Data.List as L+import Data.IntMap as IM+import Data.Maybe+import Data.Colour.Names+import Graphics.GD++-- Create a pallette of colours with which is a map from escape iterations to colours+createPallete :: Int -> [(Int, Colour Double)] -> IntMap (Colour Double)+createPallete maxIter points | length points < 2 || maximum (L.map fst points) > maxIter + || minimum (L.map fst points) < 0 = error "Invalid pallete reference points"+ | otherwise = fromList (interpolate $ sortBy (\x y -> fst x `compare` fst y) points)++interpolate :: [(Int, Colour Double)] -> [(Int, Colour Double)]+interpolate [(_,_)] = []+interpolate ((n1,c1):(n2,c2):xs) = [(n1 + i, C.blend (fromIntegral i / delta) c1 c2) | i <- [0 .. (n2 - n1 - 1)]] ++ (interpolate ((n2,c2):xs)) where+ delta = fromIntegral (n2 - n1)++colourPoint' :: IntMap (Colour Double) -> Double -> Colour Double+colourPoint' colpal n = {-# SCC "blend" #-} C.blend (n-fromIntegral n1) (fromJust c1) (fromJust c2) where --Will it blend?+ n1 = {-# SCC "floor" #-} truncate n+ n2 = n1 + 1+ (c1, c2) = {-# SCC "lookups" #-} (IM.lookup n1 colpal, IM.lookup n2 colpal)++pallete = createPallete 5002 [(0,red), (1200, white), (1600, yellow), (2000, blend 0.3 white orange), (2500,darken 0.2 orange), (3200, blend 0.7 orange black), (4400, white), (5002, red)]++{-+colourPoint :: Double -> Double -> Color3 GLdouble+colourPoint 0.0 _ = fmap realToFrac $ Color3 0.0 0.0 0.0+colourPoint n _ = let c = toSRGB $ colourPoint' pallete n in+ {-# SCC "conversions" #-} fmap realToFrac $ Color3 (channelRed c) (channelGreen c) (channelBlue c)+-}++colourGD :: Double -> Double -> Graphics.GD.Color+colourGD 0.0 _ = rgb 0 0 0+colourGD n _ = let c = toSRGB24 $ colourPoint' pallete n in+ rgb (fromIntegral $ channelRed c) (fromIntegral $ channelGreen c) (fromIntegral $ channelBlue c)++-- Colour a vertex based on the number of iterations it took to escape+colourPoint :: Double -> Double -> Color3 GLdouble+colourPoint 0.0 _ = fmap realToFrac $ Color3 0.0 0.0 0.0+colourPoint 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)+
+ src/FracComp.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE BangPatterns #-}+module FracComp+ where++import Graphics.UI.GLUT+import Data.Array.IO+import Control.Concurrent+import Control.Exception+import System.IO.Unsafe++import FracState++type Pix = IOUArray Int Double++-- Number of iterations to escape+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++-- 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)++children :: MVar [MVar ()]+children = unsafePerformIO (newMVar [])++waitForChildren :: IO ()+waitForChildren = do+ cs <- takeMVar children+ case cs of+ [] -> do+ putMVar children []+ return ()+ m:ms -> do+ putMVar children ms+ takeMVar m+ waitForChildren++forkChild :: IO () -> IO ThreadId+forkChild io = do+ mvar <- newEmptyMVar+ childs <- takeMVar children+ putMVar children (mvar:childs)+ forkIO (io `finally` putMVar mvar ())+++mandPointSampled !x !y !xrng !yrng !mi ss = if (any (== 0.0) points) then 0.0 else average points where+ points = [ mandPoint 0 0.0 0.0 (x + dx) (y + dy) mi | + dx <- ((take ss) . iterate (+xrng)) 0.0, + dy <- ((take ss) . iterate (+yrng)) 0.0]+ average xs = sum xs / (fromIntegral . length) xs+++--This gives an image in a sligtly different position than the unsampled function+--But the code is easier this way+compPointsSampled :: Double -> Double -> Double -> Int -> Sz -> Pix -> Int -> IO ()+compPointsSampled xm ym rng mi sz@(Sz width height) arr ss = do+ go 0+ waitForChildren where+ go !y | y == height = return () + | otherwise = forkChild (goRow 0 y) >> go (y+1)+ goRow !x y | x == width = return () :: IO ()+ | otherwise = do + writeArray arr k (mandPointSampled cx cy xrng yrng mi ss)+ goRow (x+1) y where+ (xrng, yrng) = (rng / fi (ss * width), rng / fi (ss * height))+ k = x + y*width+ fi = fromIntegral+ cx = rng * (fi x - fi w2) / fi width + xm :: Double+ cy = rng * (fi y - fi h2) / fi height + ym :: Double+ (w2, h2) = (width `div` 2, height `div` 2) ++compPoints :: Double -> Double -> Double -> Int -> Sz -> Pix -> IO ()+compPoints xm ym rng mi sz@(Sz width height) arr = do+ go 0+ waitForChildren where+ go !y | y == height = return () + | otherwise = forkChild (goRow 0 y) >> go (y+1)+ goRow !x y | x == width = return () :: IO ()+ | otherwise = do + writeArray arr k (mandPoint 0 0.0 0.0 cx cy mi)+ goRow (x+1) y where+ k = x + y*width+ fi = fromIntegral+ cx = rng * (fi x - fi w2) / fi width + xm :: Double+ cy = rng * (fi y - fi h2) / fi height + ym :: Double+ (w2, h2) = (width `div` 2, height `div` 2) ++-----------------------------------------+--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 500 == mandPoint 0 0.0 0.0 x (-y) 500
+ src/FracImg.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE BangPatterns #-}+module FracImg+ where++import FracComp+import FracState+import FracColour++import Graphics.GD+import Data.Array.IO hiding (range)+import System.IO+import Graphics.Rendering.OpenGL++supSamp = 5 --Use subpixel sampling+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))++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)+ (antiAliased $ setPixel (x,y)) (convColour $ colourPoint p cm) im+ go (x+1) y++imagAt :: FilePath -> Mandstate -> IO ()+imagAt fp (Mandstate xm ym rng cm mi) = do+ pixarr <- newArray (0, w*h-1) 0.0 :: IO Pix+ im <- newImage (w, h)+ compPointsSampled xm ym rng (max imgMaxIter mi) (Sz w h) pixarr supSamp+ 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+-}
+ src/FracState.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE TemplateHaskell #-}+module FracState+ where++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.019+cmul = 1.2+iteradd = 100++data Mandstate = Mandstate {+ xmid_ :: Double,+ ymid_ :: Double,+ range_ :: Double,+ colourmul_ :: Double,+ maxiter_ :: Int} deriving (Eq, Show) +$( deriveAccessors ''Mandstate )++data Sz = Sz {+ wi_ :: Int,+ hi_ :: Int} deriving (Eq, Show)+$( deriveAccessors ''Sz )++data Options = Options+ { size_:: Sz,+ ms_ :: Mandstate + } deriving (Eq, Show)+$( deriveAccessors ''Options )
+ src/Hfractal.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE BangPatterns #-}+import Graphics.UI.GLUT+import Data.IORef+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 (Sz w h) _) = do+ (progname,_) <- getArgsAndInitialize+ initialDisplayMode $= [DoubleBuffered]+ lineSmooth $= Enabled+ blendFunc $= (SrcAlpha, OneMinusSrcAlpha)+ createWindow "HFractal"+ windowSize $= Size (fromIntegral (w-2)) (fromIntegral (h-1))+ reshapeCallback $= Just (reshape opts)++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+ --Deal with the window size+ matrixMode $= Projection+ ortho2D 0.0 (fromIntegral (w-1)) 0.0 (fromIntegral (h-1)) + matrixMode $= Modelview 0+ --Set the callbacks+ keyboardMouseCallback $= Just (keyboardMouse ms s)+ displayCallback $= display ms s pixarr++----------------------------------------+--Display Callback and related functions+----------------------------------------++display :: (HasGetter g) => g Mandstate -> Sz -> Pix -> IO ()+display ms sz@(Sz w h) pixarr = do+ clear [ColorBuffer]+ loadIdentity+ (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 + 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 ()+ | 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+-----------------------------------------++reshape :: Options -> Size -> IO ()+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 s key state _ pos = do+ keyboardMouseAct ms s key state pos+ postRedisplay Nothing++-----------------------------------------+--Option Parsing and Main loop+----------------------------------------++--Some interesting starting positions+zeroState, state0, state1, state2 :: Mandstate+zeroState = Mandstate 0.0 0.0 2.0 0.05 500+state0 = Mandstate (-0.14076572210832694) 0.8510989379408804 1.0 0.05 5000+state1 = Mandstate 0.001643721971153 0.822467633298876 0.05 0.0625 500+state2 = Mandstate 0.35473015182773904 9.541013313560959e-2 0.0002 0.0625 5000+state = state1++defOpts = Options (Sz 500 500) state++options :: [OptDescr (Options -> Options)]+options = [ + 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+ (o, [], []) -> return $ foldl (flip ($)) defOpts o+ (_, _, errs) -> ioError (userError (concat errs ++ usageInfo header options))+ where header = "Usage: hfractal [OPTIONS...] [+RTS -N{cores}]"++main :: IO()+main = do+ opts <- getOpts =<< getArgs+ inializeScreen opts + setCallBacks opts+ mainLoop