packages feed

hfractal 0.3.3.2 → 0.4.1

raw patch · 8 files changed

+188/−66 lines, 8 files

Files

README view
@@ -6,6 +6,7 @@         Arrow keys   -    Movement         +/-          -    Zoom in/out         a/s          -    Alter colouring gradient+        f            -    Toggle colouring method         </>          -    Decrease/increase number of iterations                            in escape algorithm.         p            -    Print a hi-res image of the current location
hfractal.cabal view
@@ -1,12 +1,12 @@ name:                hfractal-version:             0.3.3.2+version:             0.4.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+copyright:           2009-2010 Chris Holdsworth author:              Chris Holdsworth <chrisholdsworth@gmail.com> maintainer:          Chris Holdsworth <chrisholdsworth@gmail.com> homepage:            http://github.com/cmh/Hfractal
src/Bindings.hs view
@@ -11,20 +11,20 @@ import FracState import FracImg -keyboardMouseAct :: IORef Mandstate -> Sz -> Key -> KeyState -> Position -> IO () --Keyboard actions as described in README+keyboardMouseAct :: IORef Mandstate -> Sz -> Key -> KeyState -> Position -> IO () keyboardMouseAct ms _ (SpecialKey KeyLeft) Down _ = do   ms' <- readIORef ms-  modifyIORef ms (xmid ^: ((+) ( -0.05 * ms'^.range)))+  modifyIORef ms (xmid ^: ((+) ( -0.01 * ms'^.range))) keyboardMouseAct ms _ (SpecialKey KeyRight) Down _ = do   ms' <- readIORef ms-  modifyIORef ms (xmid ^: ((+) ( 0.05 * ms'^.range)))+  modifyIORef ms (xmid ^: ((+) ( 0.01 * ms'^.range))) keyboardMouseAct ms _ (SpecialKey KeyUp) Down _ = do   ms' <- readIORef ms-  modifyIORef ms (ymid ^: ((+) ( 0.05 * ms'^.range)))+  modifyIORef ms (ymid ^: ((+) ( 0.01 * ms'^.range))) keyboardMouseAct ms _ (SpecialKey KeyDown) Down _ = do   ms' <- readIORef ms-  modifyIORef ms (ymid ^: ((+) ( -0.05 * ms'^.range)))+  modifyIORef ms (ymid ^: ((+) ( -0.01 * ms'^.range))) keyboardMouseAct ms _ (Char '+') Down _ = do   modifyIORef ms (range ^: (/rangemul)) keyboardMouseAct ms _ (Char '-') Down _ = do@@ -37,19 +37,23 @@   modifyIORef ms (maxiter ^: ((-) iteradd)) keyboardMouseAct ms _ (Char '>') Down _ = do   modifyIORef ms (maxiter ^: (+ iteradd))+--colourfun is an INT which when read modularly chooses the +--colour rendering function+keyboardMouseAct ms _ (Char 'f') Down _ = do+  modifyIORef ms (colourfun ^: (+ 1)) 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+--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)))+  modifyIORef ms (range ^: (/ (rangemul*1.03))) keyboardMouseAct ms _ (MouseButton WheelDown) Down _ = do-  modifyIORef ms (range ^: (* (rangemul*1.05)))+  modifyIORef ms (range ^: (* (rangemul*1.03))) keyboardMouseAct ms (Sz w h) (MouseButton RightButton) Down (Position x y) = do   ms' <- readIORef ms   modifyIORef ms ((xmid ^: ((+) ((x `mp` w) * ms'^.range ))) .
src/FracColour.hs view
@@ -27,25 +27,40 @@ 	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)]+pallete = createPallete 5002 [(0,red), (200, 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+colourPointPal :: Double -> Double -> Color3 GLdouble+colourPointPal 0.0 _ = fmap realToFrac $ Color3 0.0 0.0 0.0+colourPointPal n _ = let c = toSRGB $ colourPoint' pallete n in 	{-# SCC "conversions" #-} fmap realToFrac $ Color3 (channelRed c) (channelGreen c) (channelBlue c)++-- Colour a vertex based on the number of iterations it took to escape+colourPointFun :: Double -> Double -> Color3 GLdouble+colourPointFun 0.0 _ = fmap realToFrac $ Color3 0.0 0.0 0.0+colourPointFun m cm = {-# SCC "conversions" #-} fmap realToFrac $ Color3 r g b where+	r = {-# SCC "red" #-} 0.5 + 0.5 * cos (m * cm) +	g = {-# SCC "green" #-} 0.5 + 0.5 * cos ((m + 16.0) * cm)+	b = {-# SCC "blue" #-} 0.5 + 0.5 * cos ((m + 32.0) * cm)++{-+-- Range based colouring, need access to the maxiter here (after refactor)+colourPointFun2 :: Double -> Double -> Color3 GLdouble+colourPointFun2 0.0 _ = fmap realToFrac $ Color3 0.0 0.0 0.0+colourPointFun2 m cm = fmap realToFrac $ Color3 r g b where+	frac = fromIntegral m / fromIntegral maxIter -} +-- The function used to render. can be selected at runtime by the parameter cf+-- FIXME: this computes a mod for each point - not good.+{- colourPoint cf | cf `mod` 2 == 1 = colourPointFun+                  | cf `mod` 2 == 0 = colourPointPal+-}++colourPoint cf = colourPointFun++-- Colour a point outputting a GD compatiable value for png files 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
@@ -9,25 +9,49 @@ import System.IO.Unsafe  import FracState+import PointComp  type Pix = IOUArray Int Double+type RowVals = IOUArray Int Double+type ColVals = 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+--Could keep maximum escape value in here for colouring purposes+data PixArray = PixArray {+	pixels :: Pix,+	rows :: RowVals,+	cols :: ColVals,+	pixelsTemp :: Pix,+	rowsTemp :: RowVals,+	colsTemp :: ColVals,+	siz :: Sz} --- 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)+initPixArray :: Int -> Int -> IO PixArray +initPixArray width height = do+	pixels <- newArray (0, width * height - 1) 0.0 :: IO Pix+	rows <- newArray (0, width) 0.0 :: IO RowVals+	cols <- newArray (0, height) 0.0 :: IO ColVals+	pixelsTemp <- newArray (0, width * height - 1) 0.0 :: IO Pix+	rowsTemp <- newArray (0, width) 0.0 :: IO RowVals+	colsTemp <- newArray (0, height) 0.0 :: IO ColVals+	return (PixArray pixels rows cols pixelsTemp rowsTemp colsTemp (Sz width height)) +copyArr :: Int -> IOUArray Int Double -> IOUArray Int Double -> IO ()+copyArr end orig dest = go 0 where+	go !x | x == end = return ()+	      | otherwise = do+		t <- readArray orig x+		writeArray dest x t+		go (x + 1)++copyPix :: Sz -> Pix -> Pix -> IO () +copyPix sz@(Sz width height) = copyArr (width * height)++copyRow :: Sz -> RowVals -> RowVals -> IO ()+copyRow sz@(Sz width height) = copyArr width++copyCol :: Sz -> RowVals -> RowVals -> IO ()+copyCol sz@(Sz width height) = copyArr height+ children :: MVar [MVar ()] children = unsafePerformIO (newMVar []) @@ -52,12 +76,11 @@   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 | +	points = [ mandPoint (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 ()@@ -77,15 +100,18 @@ 				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+--Fill a Pix array with an initial computation centered at xm ym at zoom range+compPoints :: Double -> Double -> Double -> Int -> PixArray -> IO ()+compPoints xm ym rng mi pa@(PixArray arr rows cols _ _ _ sz@(Sz width height)) = 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)+			writeArray arr k (mandPoint cx cy mi)+			writeArray rows x cx  --This is horribly inefficient, but quick fix+			writeArray cols y cy 			goRow (x+1) y where 				k = x + y*width 				fi = fromIntegral@@ -93,10 +119,86 @@ 				cy = rng * (fi y - fi h2) / fi height + ym :: Double 				(w2, h2) = (width `div` 2, height `div` 2)  +--Moving from a previously computed pixel array to a new one. Hopefull reusing any applicable+--previous values.+mp :: Double -> Double -> Double -> Int -> PixArray -> IO ()+mp xm ym rng mi pa@(PixArray pix rows cols pixt rowst colst sz@(Sz width height)) = do+	go 0 0+	waitForChildren where+		(w2, h2) = (width `div` 2, height `div` 2) +		fi = fromIntegral+		step = rng / fi (height * 2) :: Double+		go !rowIndex !y = do+			if (y >= height) +				then do return () :: IO ()+				else do rc <- (readArray rows rowIndex)+					let cy = {-# SCC "cy" #-} rng * (fi y - fi h2) / fi height + ym :: Double+					if (rowIndex == height) +						then do writeArray rowst y cy+							forkChild (goRow 0 y) >> go rowIndex (y+1)+						else if (rc < (cy - step)) +							then do go (rowIndex + 1) y +							else if (rc > (cy - step) && rc < (cy + step)) +								then do writeArray rowst y rc+									--putStrLn "Cache"+									forkChild (goRowCache rowIndex rc cy 0 0 y) >> go rowIndex (y+1)+								else do writeArray rowst y cy+									--putStrLn "NoCache"+									forkChild (goRow 0 y) >> go rowIndex (y+1)+		goRowCache ri rc cy !colIndex !x y = do+			if (x == width) +				then do return () :: IO ()+				else do cc <- (readArray cols colIndex)+					let cx = rng * (fi x - fi w2) / fi width + xm :: Double+					let k = x + y*width	+					if (colIndex == width) +						then do writeArray colst x cx+							writeArray pixt k (mandPoint cx cy mi)+							goRowCache ri rc cy colIndex (x+1) y +						else if (cc < (cx - step)) +							then do goRowCache ri rc cy (colIndex + 1) x y +							else do+								if (cc > (cx - step) && cc < (cx + step)) +									then do writeArray colst x cc    --This is a bit of a fuck up+										oldVal <- readArray pix (colIndex + ri * width)+										writeArray pixt k oldVal+										goRowCache ri rc cy colIndex (x+1) y +									else do writeArray colst x cx+										writeArray pixt k (mandPoint cx cy mi)+										goRowCache ri rc cy colIndex (x+1) y +		goRow !x y  | x == width = return () :: IO ()+					| otherwise = do	+			writeArray pixt k (mandPoint cx cy mi)+			writeArray colst y cx+			goRow (x+1) y where+				k = x + y*width+				cx = rng * (fi x - fi w2) / fi width + xm :: Double+				cy = rng * (fi y - fi h2) / fi height + ym :: Double++{-+chunkSize = 20++mp' beg xm ym rng mi pa@(PixArray pix rows cols pixt rowst colst sz@(Sz width height)) = do +	putStrLn (show beg)+	let end = beg + chunkSize+	if (end >= height)+		then do mp beg height xm ym rng mi pa+			waitForChildren+		else do +			forkChild (mp beg end xm ym rng mi pa) >> mp' end xm ym rng mi pa+			waitForChildren+-}++movePoints :: Double -> Double -> Double -> Int -> PixArray -> IO ()+movePoints xm ym rng mi pa@(PixArray pix rows cols pixt rowst colst sz@(Sz width height)) = do+	mp xm ym rng mi pa+	copyPix sz pixt pix   --Flip the arrays+	copyRow sz rowst rows+	copyCol sz colst cols+ ----------------------------------------- --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+prop_reflection x y = mandPoint x y 500 == mandPoint x (-y) 500
src/FracImg.hs view
@@ -22,20 +22,20 @@ 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+pixelWrite im (Sz w h) cf 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+		(antiAliased $ setPixel (x,y)) (convColour $ colourPoint cf p cm) im 		go (x+1) y  imagAt ::  FilePath -> Mandstate -> IO ()-imagAt fp (Mandstate xm ym rng cm mi) = do+imagAt fp (Mandstate xm ym rng cm cf 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 +	pixelWrite im (Sz w h) cf cm pixarr  	savePngFile fp im  {-
src/FracState.hs view
@@ -9,7 +9,7 @@ --These values alter the state in various ways iteradd :: Int rangemul, cmul :: Double-rangemul = 1.019+rangemul = 1.02 cmul     = 1.2 iteradd  = 100 @@ -18,6 +18,7 @@   ymid_ :: Double,   range_ :: Double,   colourmul_ :: Double,+  colourfun_ :: Int,   maxiter_ :: Int} deriving (Eq, Show)  $( deriveAccessors ''Mandstate )
src/Hfractal.hs view
@@ -9,6 +9,7 @@ import Bindings import FracState import FracComp+import FracColour  inializeScreen opts@(Options (Sz w h) _) = do 	(progname,_) <- getArgsAndInitialize@@ -22,38 +23,36 @@ 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+	pix <- initPixArray w h 	--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------------------------------------------+	displayCallback $= display ms s pix ---------------------------------------- --Display Callback and related functions ---------------------------------------- -display ::  (HasGetter g) => g Mandstate -> Sz -> Pix -> IO ()-display ms sz@(Sz w h) pixarr = do+display :: (HasGetter g) => g Mandstate -> Sz -> PixArray -> IO ()+display ms sz@(Sz w h) pix@(PixArray 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+	(Mandstate x y r cm cf mi) <- get ms --Get state+	movePoints x y r mi pix --Compute escape iterations for this state 	preservingMatrix $ do-		renderPrimitive Points $ displayPix sz cm pixarr +		renderPrimitive Points $ displayPix sz cf 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+displayPix :: Sz -> Int -> Double -> IOUArray Int Double -> IO ()+displayPix sz@(Sz width height) cf 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)+		color (colourPointFun dk cm) 		vertex $ Vertex2 (fromIntegral x) (fromIntegral y :: GLfloat) 		go (x+1) y @@ -77,10 +76,10 @@  --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+zeroState = Mandstate 0.0 0.0 2.0 0.05 1 500+state0	  = Mandstate (-0.14076572210832694) 0.8510989379408804 1.0 0.05 2 5000+state1    = Mandstate 0.001643721971153 0.822467633298876 0.05 0.0625 1 400+state2    = Mandstate 0.35473015182773904 9.541013313560959e-2 0.0002 0.0625 1 600 state     = state1  defOpts = Options (Sz 500 500) state