diff --git a/Bindings.hs b/Bindings.hs --- a/Bindings.hs +++ b/Bindings.hs @@ -63,6 +63,5 @@ 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/FracComp.hs b/FracComp.hs --- a/FracComp.hs +++ b/FracComp.hs @@ -50,6 +50,33 @@ 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 @@ -62,8 +89,8 @@ goRow (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 + 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) ----------------------------------------- diff --git a/FracImg.hs b/FracImg.hs --- a/FracImg.hs +++ b/FracImg.hs @@ -10,6 +10,7 @@ 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 @@ -25,14 +26,14 @@ | x == w = go 0 (y+1) | otherwise = do p <- readArray pixarr (x + y*w) - setPixel (x,y) (convColour $ colourMand p cm) im + (antiAliased $ setPixel (x,y)) (convColour $ colourMand 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) - compPoints xm ym rng (max imgMaxIter mi) (Sz w h) pixarr + compPointsSampled xm ym rng (max imgMaxIter mi) (Sz w h) pixarr supSamp pixelWrite im (Sz w h) cm pixarr savePngFile fp im diff --git a/Hfractal.hs b/Hfractal.hs --- a/Hfractal.hs +++ b/Hfractal.hs @@ -17,16 +17,17 @@ blendFunc $= (SrcAlpha, OneMinusSrcAlpha) createWindow "HFractal" windowSize $= Size (fromIntegral (w-2)) (fromIntegral (h-1)) - matrixMode $= Projection - ortho2D 0.0 (fromIntegral (w-1)) 0.0 (fromIntegral (h-1)) - matrixMode $= Modelview 0 +-- reshapeCallback $= Just (reshape opts) setCallBacks opts@(Options s@(Sz w h) state) = do --Create the state and pixel array - ms <- newIORef state + 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 - reshapeCallback $= Just (reshape opts) keyboardMouseCallback $= Just (keyboardMouse ms s) displayCallback $= display ms s pixarr @@ -34,6 +35,7 @@ --Display Callback and related functions ---------------------------------------- +display :: (HasGetter g) => g Mandstate -> Sz -> Pix -> IO () display ms sz@(Sz w h) pixarr = do clear [ColorBuffer] loadIdentity @@ -59,10 +61,14 @@ --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 + --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 @@ -72,15 +78,16 @@ --Option Parsing and Main loop ---------------------------------------- ---Some defualt starting positions -zeroState, state1 :: Mandstate +--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 -state = state1 +state2 = Mandstate 0.35473015182773904 9.541013313560959e-2 0.0002 0.0625 500 +state = state0 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 (\w -> size^:wi^=(read w)) "Window width") "Set width of rendering window", diff --git a/hfractal.cabal b/hfractal.cabal --- a/hfractal.cabal +++ b/hfractal.cabal @@ -1,9 +1,12 @@ name: hfractal -version: 0.3.0 +version: 0.3.1 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. +stability: Experimental category: Graphics license: BSD3 +copyright: 2009-2009 Chris Holdsworth author: Chris Holdsworth maintainer: Chris Holdsworth build-type: Simple