diff --git a/Bindings.hs b/Bindings.hs deleted file mode 100644 --- a/Bindings.hs +++ /dev/null @@ -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 diff --git a/FracColour.hs b/FracColour.hs deleted file mode 100644 --- a/FracColour.hs +++ /dev/null @@ -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) - diff --git a/FracComp.hs b/FracComp.hs deleted file mode 100644 --- a/FracComp.hs +++ /dev/null @@ -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 diff --git a/FracImg.hs b/FracImg.hs deleted file mode 100644 --- a/FracImg.hs +++ /dev/null @@ -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 --} diff --git a/FracState.hs b/FracState.hs deleted file mode 100644 --- a/FracState.hs +++ /dev/null @@ -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 ) diff --git a/Hfractal.hs b/Hfractal.hs deleted file mode 100644 --- a/Hfractal.hs +++ /dev/null @@ -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 diff --git a/README b/README --- a/README +++ b/README @@ -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] diff --git a/hfractal.cabal b/hfractal.cabal --- a/hfractal.cabal +++ b/hfractal.cabal @@ -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 maintainer: Chris Holdsworth +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 diff --git a/src/Bindings.hs b/src/Bindings.hs new file mode 100644 --- /dev/null +++ b/src/Bindings.hs @@ -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 diff --git a/src/FracColour.hs b/src/FracColour.hs new file mode 100644 --- /dev/null +++ b/src/FracColour.hs @@ -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) + diff --git a/src/FracComp.hs b/src/FracComp.hs new file mode 100644 --- /dev/null +++ b/src/FracComp.hs @@ -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 diff --git a/src/FracImg.hs b/src/FracImg.hs new file mode 100644 --- /dev/null +++ b/src/FracImg.hs @@ -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 +-} diff --git a/src/FracState.hs b/src/FracState.hs new file mode 100644 --- /dev/null +++ b/src/FracState.hs @@ -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 ) diff --git a/src/Hfractal.hs b/src/Hfractal.hs new file mode 100644 --- /dev/null +++ b/src/Hfractal.hs @@ -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