gruff 0.1.1 → 0.2
raw patch · 39 files changed
+2627/−2280 lines, 39 filesdep +hmpfrdep +qd-vecdep −addep −floatshowdep −wl-pprint-textdep ~ruffbinary-added
Dependencies added: hmpfr, qd-vec
Dependencies removed: ad, floatshow, wl-pprint-text
Dependency ranges changed: ruff
Files
- Address.hs +0/−47
- Browser.hs +0/−404
- CacheView.hs +0/−351
- GLUTGtk.hs +0/−71
- Logger.hs +0/−40
- Nucleus.hs +0/−67
- PeriodScan.hs +0/−55
- QuadTree.hs +0/−95
- Shader.hs +0/−26
- StatusDialog.hs +0/−31
- TODO +57/−0
- Tile.hs +0/−175
- Utils.hs +0/−43
- cache.frag +0/−66
- colourize.frag +0/−81
- compute.cc +0/−173
- data/icon.png binary
- data/merge.frag +8/−0
- data/minimal.frag +19/−0
- gruff.cabal +71/−20
- gruff.hs +0/−534
- icon.png binary
- rts.c +0/−1
- src/Browser.hs +606/−0
- src/GLUTGtk.hs +71/−0
- src/Logger.hs +44/−0
- src/MuAtom.hs +171/−0
- src/Number.hs +77/−0
- src/QuadTree.hs +110/−0
- src/Shader.hs +29/−0
- src/Snapshot.hs +35/−0
- src/StatusDialog.hs +31/−0
- src/Tile.hs +189/−0
- src/Utils.hs +34/−0
- src/View.hs +214/−0
- src/compute.cc +186/−0
- src/gruff.hs +558/−0
- src/mp_real.h +116/−0
- src/rts.c +1/−0
− Address.hs
@@ -1,47 +0,0 @@-module Address where--import Control.Monad (guard)-import Data.Ratio ((%), denominator)-import Fractal.RUFF.Mandelbrot.Address (AngledInternalAddress(Unangled, Angled), Angle, angledFromList, angledToList)--import Utils (safeRead)--parseAngles :: String -> Maybe [Angle]-parseAngles = mapM parseAngle . words--parseAngle :: String -> Maybe Angle-parseAngle s = do- let (n, d) = break ('/'==) s- n' <- safeRead (filter (' '/=) n)- d' <- safeRead (filter (' '/=) (drop 1 d))- guard (0 < n' && n' < d')- return $ n' % d'--splitAddress :: AngledInternalAddress -> Maybe (AngledInternalAddress, [Angle])-splitAddress a =- let (ps0, rs0) = unzip $ angledToList a- ps1 = reverse ps0- rs1 = reverse (Nothing : init rs0)- prs1 = zip ps1 rs1- f ((p, Just r):qrs@((q, _):_)) acc- | p == denominator r * q = f qrs (r : acc)- f prs acc = g prs acc- g prs acc =- let (ps2, rs2) = unzip prs- ps3 = reverse ps2- rs3 = reverse (Nothing : init rs2)- prs3 = zip ps3 rs3- aa = angledFromList prs3- in case aa of- Nothing -> Nothing- Just aa' -> Just (aa', acc)- in f prs1 []--joinAddress :: AngledInternalAddress -> [Angle] -> AngledInternalAddress-joinAddress (Unangled p) [] = Unangled p-joinAddress (Unangled p) (r:rs) = Angled p r (joinAddress (Unangled $ p * denominator r) rs)-joinAddress (Angled p r a) rs = Angled p r (joinAddress a rs)--addressPeriod :: AngledInternalAddress -> Integer-addressPeriod (Unangled p) = p-addressPeriod (Angled _ _ a) = addressPeriod a
− Browser.hs
@@ -1,404 +0,0 @@-module Browser (iInitialize) where--import Prelude hiding (log)-import Control.Concurrent- ( forkIO, MVar, newMVar, takeMVar, putMVar, tryTakeMVar, threadDelay )-import Control.Monad (forever, forM_, liftM2, replicateM, when)-import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef)-import Data.List (sortBy)-import qualified Data.Map as M-import Data.Map (Map)-import Data.Maybe (isJust, mapMaybe)-import Data.Ord (comparing)-import qualified Data.Set as S-import Data.Set (Set, (\\))-import Foreign (Ptr, malloc, poke)-import Foreign.C (CFloat, CInt)-import GHC.Conc (numCapabilities)-import Graphics.Rendering.OpenGL hiding (Angle, Point, Position, Size)-import qualified Graphics.Rendering.OpenGL as GL-import Graphics.Rendering.OpenGL.Raw- ( glTexImage2D, gl_TEXTURE_2D, gl_R32F, gl_LUMINANCE, gl_FLOAT- , gl_FALSE, glClampColor, gl_CLAMP_VERTEX_COLOR, gl_CLAMP_READ_COLOR- , gl_CLAMP_FRAGMENT_COLOR- )-import Graphics.UI.Gtk hiding (get, Region, Size)-import Numeric.QD (QuadDouble)--import GLUTGtk-import Shader (shader)-import QuadTree-import Tile (Tile(Tile), getTile, freeTile, rootSquare)-import Logger (Logger, LogLevel(Debug))-import qualified Logger as Log-import Paths_gruff (getDataFileName)--type TextureObject3 = (TextureObject, TextureObject, TextureObject)-data GruffImage = GruffImage- { center :: (Rational, Rational)- , level :: Int- , size :: Size- , prog :: Program- , tiles :: Map Quad TextureObject3- , queue :: MVar [Tile]- , progress :: Set Quad- , jobs :: MVar [Quad]- , viewQuads :: [(Square, TextureObject3)]- , workers :: [Ptr CInt]- , gl :: GLUTGtk- , cacheDir :: FilePath- , log :: LogLevel -> String -> IO ()- , hshift :: Double- , hscale :: Double- }--iDisplay :: IORef GruffImage -> IO ()-iDisplay iR = do- s0 <- readIORef iR- mtls <- tryTakeMVar (queue s0)- case mtls of- Just tls -> do- putMVar (queue s0) []- forM_ tls $ \tile@(Tile q ns ds ts) -> do- tde <- upload ds- tit <- upload ns- ttt <- upload ts--- GL.finish- freeTile tile- atomicModifyIORef iR $ \s' ->- ( s'{ tiles = M.insert q (tde, tit, ttt) (tiles s')- , progress = S.delete q (progress s') }- , ())- update iR False- Nothing -> return ()- s <- readIORef iR- let Size w h = size s- log s Debug $ "displayCallback " ++ show (center s, level s)- viewport $=- (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))- loadIdentity- ortho2D 0 (fromIntegral w) (fromIntegral h) 0- clearColor $= Color4 0.5 0.5 0.5 1- clear [ColorBuffer]- currentProgram $= Just (prog s)- lde <- get $ uniformLocation (prog s) "de"- lit <- get $ uniformLocation (prog s) "it"- ltt <- get $ uniformLocation (prog s) "tt"- lhshift <- get $ uniformLocation (prog s) "hshift"- lhscale <- get $ uniformLocation (prog s) "hscale"- uniform lde $= TexCoord1 (0 :: GLint)- uniform lit $= TexCoord1 (1 :: GLint)- uniform ltt $= TexCoord1 (2 :: GLint)- uniform lhshift $= TexCoord1 (realToFrac (hshift s) :: GLfloat)- uniform lhscale $= TexCoord1 (realToFrac (hscale s) :: GLfloat)- mapM_ (drawQuad s) (viewQuads s)- currentProgram $= Nothing--- writeSnapshot (show (level s) ++ ".ppm") (Position 0 0) (size s)--drawQuad :: GruffImage -> (Square, TextureObject3) -> IO ()-drawQuad s (sq, (tde, tit, ttt)) = do- let t x y = texCoord $ TexCoord2 (x :: GLdouble) (y :: GLdouble)- v x y = let (x', y') = toPixel s x y- in vertex $ Vertex2- (fromRational x' :: GLdouble)- (fromRational y' :: GLdouble)- x0 = squareWest sq- x1 = squareWest sq + squareSize sq- y0 = squareNorth sq- y1 = squareNorth sq + squareSize sq- activeTexture $= TextureUnit 0- textureBinding Texture2D $= Just tde- activeTexture $= TextureUnit 1- textureBinding Texture2D $= Just tit- activeTexture $= TextureUnit 2- textureBinding Texture2D $= Just ttt- renderPrimitive Quads $ do- color $ Color3 1 1 (1::GLdouble)- t 0 1 >> v x0 y1- t 0 0 >> v x0 y0- t 1 0 >> v x1 y0- t 1 1 >> v x1 y1- textureBinding Texture2D $= Nothing- activeTexture $= TextureUnit 1- textureBinding Texture2D $= Nothing- activeTexture $= TextureUnit 0- textureBinding Texture2D $= Nothing--iReshape :: IORef GruffImage -> Size -> IO ()-iReshape iR size' = do- s' <- readIORef iR- log s' Debug $ "reshapeCallback " ++ show size'- atomicModifyIORef iR $ \s -> (s{ size = size' }, ())- update iR True--iMouse :: IORef GruffImage -> IO () -> Key -> KeyState -> [Modifier] -> Position -> IO ()-iMouse sR updateGUI (MouseButton LeftButton ) Down _ p@(Position x y) = do- s' <- readIORef sR- log s' Debug $ "leftMouse " ++ show p- atomicModifyIORef sR $ \s -> let level' = (level s + 1) `min` maxLevel in- ( s{ center = fromPixel s (round x) (round y), level = level' }- , ())- update sR True >> updateGUI-iMouse sR updateGUI (MouseButton MiddleButton) Down _ p@(Position x y) = do- s' <- readIORef sR- log s' Debug $ "middleMouse " ++ show p- atomicModifyIORef sR $ \s ->- ( s{ center = fromPixel s (round x) (round y) }- , ())- update sR True >> updateGUI-iMouse sR updateGUI (MouseButton RightButton ) Down _ p@(Position x y) = do- s' <- readIORef sR- log s' Debug $ "rightMouse " ++ show p- atomicModifyIORef sR $ \s -> let level' = (level s - 1) `max` 0 in- ( s{ center = fromPixel s (round x) (round y), level = level' }- , ())- update sR True >> updateGUI-iMouse _ _ _ _ _ _ = return ()--fromPixel :: GruffImage -> Int -> Int -> (Rational, Rational)-fromPixel s x y = (x', y')- where- Size w h = size s- a = fromIntegral w / fromIntegral h- (cx, cy) = center s- r = 8 / 2 ^ level s * fromIntegral h / (2 * fromIntegral tileSize)- x' = cx + r * (fromIntegral x / fromIntegral w - 0.5) * a- y' = cy + r * (fromIntegral y / fromIntegral h - 0.5)--toPixel :: GruffImage -> Rational -> Rational -> (Rational, Rational)-toPixel s x y = (x', y')- where- Size w h = size s- a = fromIntegral w / fromIntegral h- (cx, cy) = center s- r = 8 / 2 ^ level s * fromIntegral h / (2 * fromIntegral tileSize)- x' = ((x - cx) / a / r + 0.5) * fromIntegral w- y' = ((y - cy) / r + 0.5) * fromIntegral h--tileSize :: Int-tileSize = 256--cacheSizeMin, cacheSizeMax :: Int-cacheSizeMin = 160-cacheSizeMax = 250--prune :: IORef GruffImage -> IO ()-prune sR = do- s0 <- readIORef sR- let cacheSize = M.size (tiles s0)- when (cacheSize > cacheSizeMax) $ do- log s0 Debug . concat $- [ "pruning texture cache "- , show cacheSize, " > ", show cacheSizeMax- , " --> ", show cacheSizeMin- ]- bad <- atomicModifyIORef sR $ \s -> - let (cx, cy) = center s- f = contains (Point cx cy) . square rootSquare- refine = filter f . liftM2 child [minBound .. maxBound]- Quad{ quadLevel = l0, quadWest = r0, quadNorth = i0 } =- head $ iterate refine [root] !! (level s + 1)- score Quad{ quadLevel = l, quadWest = r, quadNorth = i}- = dl + d r r0 + d i i0 :: Double- where- dl = abs (fromIntegral l - fromIntegral l0)- d x x0- | l > l0 = abs (xfi - x0fi / 2 ^ (l - l0))- | l == l0 = abs (xfi - x0fi)- | l < l0 = abs (x0fi - xfi / 2 ^ (l0 - l))- where xfi = fromIntegral x ; x0fi = fromIntegral x0- d _ _ = error "score"- o = comparing (score . fst)- (good, bad)- = splitAt cacheSizeMin . sortBy o . M.toList . tiles $ s- in (s{ tiles = M.fromList good }, bad)- let t (_, (t1, t2, t3)) = [t1, t2, t3]- deleteObjectNames $ concatMap t bad--update :: IORef GruffImage -> Bool -> IO ()-update sR newView = do- prune sR- s' <- readIORef sR- log s' Debug $ "updateCallback " ++ show newView- todo' <- atomicModifyIORef sR $ \s ->- let Size w h = size s- ((bw,bn),(be,bs)) =- ( fromPixel s 0 0- , fromPixel s (fromIntegral w) (fromIntegral h) )- view = Region- { regionWest = bw, regionNorth = bn- , regionEast = be, regionSouth = bs }- qs = S.fromList $ quads rootSquare view (level s + 1)- todo = S.filter (`M.notMember` tiles s) qs \\ progress s- getQuad q = (,) (square rootSquare q) `fmap` M.lookup q (tiles s)- drp = level s - 4- tke = 6 + (drp `min` 0)- quads' = mapMaybe getQuad . concat . take tke . drop drp $- quadss rootSquare view- in (s{ viewQuads = quads' }, todo)- when newView $ do- -- cancel in-progress jobs- putJobs sR []- mapM_ (`poke` 1) (workers s')- atomicModifyIORef sR $ \s -> (s{ progress = S.empty }, ())- -- set new jobs- putJobs sR (S.toList todo')- postRedisplay (gl s')--putTile :: IORef GruffImage -> Tile -> IO ()-putTile sR t = do- s <- readIORef sR- ts <- takeMVar (queue s)- putMVar (queue s) (t:ts)--putJobs :: IORef GruffImage -> [Quad] -> IO ()-putJobs sR qs = do- s <- readIORef sR- _ <- takeMVar (jobs s)- putMVar (jobs s) qs--takeJob :: IORef GruffImage -> IO Quad-takeJob sR = do- s <- readIORef sR- qs <- takeMVar (jobs s)- case qs of- [] -> do- putMVar (jobs s) []- threadDelay 10000- takeJob sR- (q:qs') -> do- atomicModifyIORef sR $ \s' ->- ( s'{ progress = S.insert q (progress s') }- , ())- putMVar (jobs s) qs'- return q--worker :: IORef GruffImage -> Ptr CInt -> IO ()-worker sR p = forever $ do- s <- readIORef sR- q <- takeJob sR- mt <- getTile (log s Debug) (cacheDir s) p q- case mt of- Nothing -> return ()- Just t -> putTile sR t--timer :: IORef GruffImage -> IO ()-timer sR = do- s <- readIORef sR- mtls <- tryTakeMVar (queue s)- case mtls of- Just tls@(_:_) -> do- putMVar (queue s) tls- postRedisplay (gl s)- Just [] -> do- putMVar (queue s) []- _ -> return ()--upload :: Ptr CFloat -> IO TextureObject-upload p = do- [tex] <- genObjectNames 1- texture Texture2D $= Enabled- textureBinding Texture2D $= Just tex- glTexImage2D gl_TEXTURE_2D 0 (fromIntegral gl_R32F)- (fromIntegral tileSize) (fromIntegral tileSize) 0- gl_LUMINANCE gl_FLOAT p- textureFilter Texture2D $= ((Nearest, Nothing), Nearest)- textureWrapMode Texture2D S $= (Repeated, ClampToEdge)- textureWrapMode Texture2D T $= (Repeated, ClampToEdge)- textureBinding Texture2D $= Nothing- texture Texture2D $= Disabled- return tex--defSize :: Size-defSize = Size 320 200--maxLevel :: Int-maxLevel = 191--msPerFrame :: Int-msPerFrame = 40--iInitialize :: GLUTGtk -> Pixbuf -> Logger -> FilePath- -> IO ( Window- , Maybe QuadDouble -> Maybe QuadDouble -> Maybe QuadDouble -> Maybe Double -> Maybe Double -> IO ()- , (QuadDouble -> QuadDouble -> QuadDouble -> IO ()) -> IO () -> IO ()- )-iInitialize gl' icon lg cacheDir' = do- -- image window- iw <- windowNew- let Size defW defH = defSize- windowSetDefaultSize iw defW defH- set iw- [ containerBorderWidth := 0- , containerChild := widget gl'- , windowIcon := Just icon- , windowTitle := "gruff browser"- ]- queue' <- newMVar []- jobs' <- newMVar []- iR <- newIORef GruffImage- { center = (0, 0)- , level = 0- , size = defSize- , tiles = M.empty- , queue = queue'- , jobs = jobs'- , progress = S.empty- , viewQuads = []- , gl = gl'- , cacheDir = cacheDir'- , log = Log.log lg- , workers = []- , prog = undefined- , hshift = 0- , hscale = 1- }- realizeCallback gl' $= iRealize iR- reshapeCallback gl' $= iReshape iR- displayCallback gl' $= iDisplay iR- let iUpdate mre mim mz mhshift mhscale = do- case liftM2 (,) mre mim of- Just (r, i) -> atomicModifyIORef iR $ \s ->- ( s { center = (toRational r, negate $ toRational i) }, () )- Nothing -> return ()- case mz of- Just z | z > 0 -> atomicModifyIORef iR $ \s ->- ( s { level = max 0 . min maxLevel . floor . negate . logBase 2 $ z }, () )- _ -> return ()- case mhshift of- Just x -> atomicModifyIORef iR $ \s ->- ( s { hshift = x }, () )- _ -> return ()- case mhscale of- Just x -> atomicModifyIORef iR $ \s ->- ( s { hscale = x }, () )- _ -> return ()- update iR (any isJust [mre, mim, mz])- postRedisplay gl'- iInitializeLate aUpdate aExit = do- let updateCoordinates = do- i <- readIORef iR- let re = fromRational . fst . center $ i- im = fromRational . negate . snd . center $ i- z = 2 ^^ negate (level i)- aUpdate re im z- _ <- iw `onDestroy` aExit- _ <- timeoutAdd (timer iR >> return True) msPerFrame- keyboardMouseCallback gl' $= iMouse iR updateCoordinates- return (iw, iUpdate, iInitializeLate)--iRealize :: IORef GruffImage -> IO ()-iRealize iR = do- s <- readIORef iR- log s Debug "realizeCallback"- drawBuffer $= BackBuffers- glClampColor gl_CLAMP_VERTEX_COLOR gl_FALSE- glClampColor gl_CLAMP_READ_COLOR gl_FALSE- glClampColor gl_CLAMP_FRAGMENT_COLOR gl_FALSE- f <- getDataFileName "colourize.frag"- prog' <- shader Nothing (Just f)- ps <- replicateM numCapabilities $ do- p <- malloc- _ <- forkIO (worker iR p)- return p- atomicModifyIORef iR $ \i -> (i{ prog = prog', workers = ps }, ())
− CacheView.hs
@@ -1,351 +0,0 @@-module CacheView (cInitialize) where--import Control.Concurrent (forkIO)-import Control.Monad (forM_, liftM2, when)-import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef)-import qualified Data.Map as M-import Data.Map (Map)-import Data.Maybe (catMaybes, mapMaybe)-import System.FilePath ((</>), dropExtension)--import Foreign (alloca, peek, nullPtr)-import Graphics.Rendering.OpenGL hiding (Position, Size)-import qualified Graphics.Rendering.OpenGL as GL-import Graphics.Rendering.OpenGL.Raw- ( glGenFramebuffers, glBindFramebuffer, glFramebufferTexture2D- , gl_FRAMEBUFFER, gl_COLOR_ATTACHMENT0, gl_TEXTURE_2D- , glTexImage2D, gl_R32F, gl_LUMINANCE, gl_FLOAT- , gl_FALSE, glClampColor, gl_CLAMP_VERTEX_COLOR, gl_CLAMP_READ_COLOR- , gl_CLAMP_FRAGMENT_COLOR )-import Graphics.UI.Gtk hiding (Region, Size)--import Numeric.QD (QuadDouble)--import GLUTGtk-import Shader (shader)-import QuadTree (Child(..), unsafeName, Quad, Square(..), square, child, root, outside, Region(..))---import Tile (rootSquare)-import Utils (getFilesRecursive)--import Paths_gruff (getDataFileName)--rootSquare :: Square-rootSquare = Square{ squareSize = 8, squareWest = -4, squareNorth = -4 }--names :: Map Char [Child]-names = M.fromList names1 `M.union` M.fromList names2- where- names1 = [ (unsafeName [i], [i]) | i <- [minBound..maxBound] ]- names2 = [ (unsafeName [i,j], [i,j]) | i <- [minBound..maxBound], j <- [minBound..maxBound] ]--fromPath :: ([FilePath], FilePath) -> Maybe [Child]-fromPath (ps, f) =- let s = concat ps ++ dropExtension f- p = concat $ mapMaybe (`M.lookup` names) s- in if all (`M.member` names) s then Just p else Nothing--cDisplay :: IORef GruffCache -> IO ()-cDisplay cR = do- c <- readIORef cR- let Size w h = cSize c- TextureObject tex = cTex c- when (cRecalc c) $ do- viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))- loadIdentity- ortho2D 0 (fromIntegral w) (fromIntegral h) 0- withFBO (cFBO c) tex $ do- clearColor $= Color4 0 0 0 1- clear [ColorBuffer]- let toPixel' = toPixel c- qs = cQuads c- zm = fromIntegral . snd . head $ qs- withBlend (One, One) $ renderPrimitive Quads $ forM_ qs $ \(q, z) -> do- let sq = square rootSquare q- s = squareSize sq `max` cSquareSize c- (x0, y0) = toPixel' (squareWest sq) (squareNorth sq)- (x1, y1) = toPixel' (squareWest sq + s) (squareNorth sq + s)- v x y = vertex $ Vertex2 (fromRational x :: GLdouble) (fromRational y :: GLdouble)- k = fromIntegral z / zm :: GLdouble- color $ Color3 k k k- v x0 y1 >> v x0 y0 >> v x1 y0 >> v x1 y1- atomicModifyIORef cR $ \c' -> (c'{ cRecalc = False }, ())- -- draw texture- loadIdentity- ortho2D 0 1 1 0- textureBinding Texture2D $= Just (cTex c)- currentProgram $= Just (cProg c)- lt <- GL.get $ uniformLocation (cProg c) "tex"- uniform lt $= TexCoord1 (0 :: GLint)- renderPrimitive Quads $ do- let Size tw th = cTexSize c- let tx = fromIntegral w / fromIntegral tw- ty = fromIntegral h / fromIntegral th- v :: GLdouble -> GLdouble -> IO ()- v x y = do- texCoord $ TexCoord2 (tx * x) (ty * (1-y))- vertex $ Vertex2 x y- v 0 1 >> v 0 0 >> v 1 0 >> v 1 1- currentProgram $= Nothing- textureBinding Texture2D $= Nothing--withFBO :: GLuint -> GLuint -> IO () -> IO ()-withFBO fbo tex act = do- glBindFramebuffer gl_FRAMEBUFFER fbo- glFramebufferTexture2D gl_FRAMEBUFFER gl_COLOR_ATTACHMENT0 gl_TEXTURE_2D tex 0- act- glFramebufferTexture2D gl_FRAMEBUFFER gl_COLOR_ATTACHMENT0 gl_TEXTURE_2D 0 0- glBindFramebuffer gl_FRAMEBUFFER 0--withBlend :: (BlendingFactor, BlendingFactor) -> IO a -> IO a-withBlend bf act = do- ob <- GL.get blend- obf <- GL.get blendFunc- blend $= Enabled- blendFunc $= bf- r <- act- blendFunc $= obf- blend $= ob- return r--data GruffCache = GruffCache- { cSize :: Size- , cCenter :: (Rational, Rational)- , cLevel :: Int- , cCacheDir :: FilePath- , cGL :: GLUTGtk- , cProg :: Program- , cTex :: TextureObject- , cTexSize :: Size- , cFBO :: GLuint- , cRecalc :: Bool- , cQTree :: QTree Integer- }--fromPixel :: GruffCache -> Int -> Int -> (Rational, Rational)-fromPixel c x y = (x', y')- where- Size w h = cSize c- a = fromIntegral w / fromIntegral h- (cx, cy) = cCenter c- r = 8 / 2 ^ cLevel c * fromIntegral h / (2 * fromIntegral tileSize)- x' = cx + r * (fromIntegral x / fromIntegral w - 0.5) * a- y' = cy + r * (fromIntegral y / fromIntegral h - 0.5)--toPixel :: GruffCache -> Rational -> Rational -> (Rational, Rational)-toPixel c = f- where- f x y = {-# SCC "toPixel'" #-} (x', y')- where- x' = ((x - cx) / r' + 0.5) * w'- y' = ((y - cy) / r + 0.5) * h'- Size w h = cSize c- w' = fromIntegral w- h' = fromIntegral h- a = w' / h'- (cx, cy) = cCenter c- r = 8 / 2 ^ cLevel c * h' / (2 * fromIntegral tileSize)- r' = a * r--tileSize :: Int-tileSize = 256--cRealize :: IORef GruffCache -> IO ()-cRealize cR = do- f <- getDataFileName "cache.frag"- prog <- shader Nothing (Just f)- drawBuffer $= BackBuffers- glClampColor gl_CLAMP_VERTEX_COLOR gl_FALSE- glClampColor gl_CLAMP_READ_COLOR gl_FALSE- glClampColor gl_CLAMP_FRAGMENT_COLOR gl_FALSE- [tex] <- genObjectNames 1- texture Texture2D $= Enabled- textureBinding Texture2D $= Just tex- textureFilter Texture2D $= ((Nearest, Nothing), Nearest)- textureWrapMode Texture2D S $= (Repeated, ClampToEdge)- textureWrapMode Texture2D T $= (Repeated, ClampToEdge)- textureBinding Texture2D $= Nothing- texture Texture2D $= Disabled- fbo <- alloca $ \p -> glGenFramebuffers 1 p >> peek p- atomicModifyIORef cR $ \c -> (c{ cProg = prog, cFBO = fbo, cTex = tex }, ())- c <- readIORef cR- cReshape cR (cSize c)--cSquareSize :: GruffCache -> Rational-cSquareSize c = squareSize rootSquare / 2 ^ cLevel c / (2 * fromIntegral tileSize)--cInitialize :: GLUTGtk -> Pixbuf -> FilePath- -> IO ( Window- , Maybe QuadDouble -> Maybe QuadDouble -> Maybe QuadDouble -> IO ()- , IO () -> IO ()- )-cInitialize gl' icon cacheDir' = do- -- image window- cw <- windowNew- let Size defW defH = defSize- windowSetDefaultSize cw defW defH- set cw- [ containerBorderWidth := 0- , containerChild := widget gl'- , windowIcon := Just icon- , windowTitle := "gruff cache"- ]- cR <- newIORef GruffCache- { cCenter = (0, 0)- , cLevel = 0- , cSize = defSize- , cQTree = QTree 0 Nothing Nothing Nothing Nothing- , cCacheDir = cacheDir'- , cGL = gl'- , cProg = undefined- , cFBO = 0- , cTex = TextureObject 0- , cTexSize = roundUpSize defSize- , cRecalc = False- }- realizeCallback gl' $= cRealize cR- reshapeCallback gl' $= cReshape cR- displayCallback gl' $= cDisplay cR- keyboardMouseCallback gl' $= cMouse cR- let cUpdateCoords mre mim mz = do- case liftM2 (,) mre mim of- Just (r, i) -> atomicModifyIORef cR $ \s ->- ( s { cCenter = (toRational r, negate $ toRational i) }, () )- Nothing -> return ()- case mz of- Just z | z > 0 -> atomicModifyIORef cR $ \s ->- ( s { cLevel = max 0 . min maxLevel . floor . negate . logBase 2 $ z }, () )- _ -> return ()- cUpdate cR True- cInitializeLate aExit = do- _ <- cw `onDestroy` aExit- _ <- forkIO $ cRescan cR- return ()- return (cw, cUpdateCoords, cInitializeLate)--cRescan :: IORef GruffCache -> IO ()-cRescan cR = do- c' <- readIORef cR- fs <- getFilesRecursive (cCacheDir c' </> ".")- let q = depthQ . treeQ . mapMaybe fromPath $ fs- atomicModifyIORef cR $ \c -> (c{ cQTree = q }, ())- postGUISync (cUpdate cR True)--maxLevel :: Int-maxLevel = 200-defSize :: Size-defSize = Size 320 200--cUpdate :: IORef GruffCache -> Bool -> IO ()-cUpdate cR rec = do- c' <- readIORef cR- atomicModifyIORef cR $ \c -> (c{ cRecalc = cRecalc c || rec }, ())- postRedisplay (cGL c')--cReshape :: IORef GruffCache -> Size -> IO ()-cReshape iR size' = do- c <- readIORef iR- let tsize@(Size tw th) = roundUpSize size'- textureBinding Texture2D $= Just (cTex c)- glTexImage2D gl_TEXTURE_2D 0 (fromIntegral gl_R32F)- (fromIntegral tw) (fromIntegral th) 0 gl_LUMINANCE gl_FLOAT nullPtr- textureBinding Texture2D $= Nothing- atomicModifyIORef iR $ \s -> (s{ cSize = size', cTexSize = tsize }, ())- cUpdate iR True--cMouse :: IORef GruffCache -> Key -> KeyState -> [Modifier] -> Position -> IO ()-cMouse sR (MouseButton LeftButton ) Down _ (Position x y) = do- atomicModifyIORef sR $ \s -> let level' = (cLevel s + 1) `min` maxLevel in- ( s{ cCenter = fromPixel s (round x) (round y), cLevel = level' }- , ())- cUpdate sR True-cMouse sR (MouseButton MiddleButton) Down _ (Position x y) = do- atomicModifyIORef sR $ \s ->- ( s{ cCenter = fromPixel s (round x) (round y) }- , ())- cUpdate sR True-cMouse sR (MouseButton RightButton ) Down _ (Position x y) = do- atomicModifyIORef sR $ \s -> let level' = (cLevel s - 1) `max` 0 in- ( s{ cCenter = fromPixel s (round x) (round y), cLevel = level' }- , ())- cUpdate sR True-cMouse _ _ _ _ _ = return ()--roundUpSize :: Size -> Size-roundUpSize (Size w h) = Size (roundUp w) (roundUp h)--roundUp :: Int -> Int-roundUp x = head . filter (>= x) . iterate (2*) $ 1--data QTree a = QTree a (Maybe (QTree a)) (Maybe (QTree a)) (Maybe (QTree a)) (Maybe (QTree a))--payloadQ :: QTree a -> a-payloadQ (QTree w _ _ _ _) = w--childQ :: Child -> QTree a -> Maybe (QTree a)-childQ NorthWest (QTree _ a _ _ _) = a-childQ NorthEast (QTree _ _ b _ _) = b-childQ SouthWest (QTree _ _ _ c _) = c-childQ SouthEast (QTree _ _ _ _ d) = d--emptyQ :: QTree Bool-emptyQ = QTree False Nothing Nothing Nothing Nothing--insertQ :: [Child] -> QTree Bool -> QTree Bool-insertQ [] (QTree _ a b c d) = QTree True a b c d-insertQ (x:xs) (QTree w a b c d) = case x of- NorthWest -> case a of- Nothing -> QTree w (Just $ insertQ xs emptyQ) b c d- Just a' -> QTree w (Just $ insertQ xs a' ) b c d- NorthEast -> case b of- Nothing -> QTree w a (Just $ insertQ xs emptyQ) c d- Just b' -> QTree w a (Just $ insertQ xs b' ) c d- SouthWest -> case c of- Nothing -> QTree w a b (Just $ insertQ xs emptyQ) d- Just c' -> QTree w a b (Just $ insertQ xs c' ) d- SouthEast -> case d of- Nothing -> QTree w a b c (Just $ insertQ xs emptyQ)- Just d' -> QTree w a b c (Just $ insertQ xs d' )--treeQ :: [[Child]] -> QTree Bool-treeQ = foldr insertQ emptyQ--{--sizeQ :: QTree Bool -> QTree Integer-sizeQ (QTree w a b c d) = QTree n a' b' c' d'- where- s@[a', b', c', d'] = fmap sizeQ `map` [a, b, c, d]- n = (if w then 1 else 0) + (sum . map payloadQ . catMaybes) s--}--depthQ :: QTree a -> QTree Integer-depthQ = depthQ' 0- where- depthQ' n (QTree _ Nothing Nothing Nothing Nothing) = QTree n Nothing Nothing Nothing Nothing- depthQ' n (QTree _ a b c d) = QTree m a' b' c' d'- where- s@[a', b', c', d'] = fmap (depthQ' (n + 1)) `map` [a, b, c, d]- m = maximum . map payloadQ . catMaybes $ s--pruneQ :: Int -> QTree a -> QTree a-pruneQ 0 (QTree w _ _ _ _) = QTree w Nothing Nothing Nothing Nothing-pruneQ n (QTree w a b c d) = QTree w a' b' c' d'- where- [a', b', c', d'] = fmap (pruneQ (n - 1)) `map` [a, b, c, d]--cQuads :: GruffCache -> [(Quad, Integer)]-cQuads c = map (fmap payloadQ) . concat . quadsQ view . pruneQ (cLevel c + 12) . cQTree $ c- where- Size w h = cSize c- ((bw,bn),(be,bs)) =- ( fromPixel c 0 0- , fromPixel c (fromIntegral w) (fromIntegral h) )- view = Region- { regionWest = bw, regionNorth = bn- , regionEast = be, regionSouth = bs }--quadsQ :: Region -> QTree a -> [[(Quad, QTree a)]]-quadsQ view q = takeWhile (not . null) . iterate (filter keep . children') $ [(root, q)]- where- keep = not . outside view . square rootSquare . fst- children' = catMaybes . liftM2 child' [minBound .. maxBound]- child' c (quad, qtree) = (,) (child c quad) `fmap` childQ c qtree
− GLUTGtk.hs
@@ -1,71 +0,0 @@-module GLUTGtk where--import Control.Monad (join)-import Control.Monad.Trans (liftIO)-import Data.IORef (IORef, newIORef, readIORef)-import Graphics.UI.Gtk hiding (Size)-import Graphics.UI.Gtk.OpenGL--type RealizeCallback = IO ()-type ReshapeCallback = Size -> IO ()-type DisplayCallback = IO ()-type KeyboardMouseCallback = Key -> KeyState -> [Modifier] -> Position -> IO ()--data Size = Size Int Int- deriving (Eq, Ord, Show)--data Position = Position Double Double- deriving (Eq, Ord, Show)--data KeyState = Down | Up- deriving (Eq, Ord, Show)--data Key = Char Char | MouseButton MouseButton- deriving (Eq, Show)--data GLUTGtk = GLUTGtk- { realizeCallback :: IORef RealizeCallback- , reshapeCallback :: IORef ReshapeCallback- , displayCallback :: IORef DisplayCallback- , keyboardMouseCallback :: IORef KeyboardMouseCallback- , postRedisplay :: IO ()- , widget :: EventBox- }--glut :: Size -> IO GLUTGtk-glut (Size width height) = do- realizeCallback' <- newIORef $ return ()- displayCallback' <- newIORef $ return ()- reshapeCallback' <- newIORef $ \_ -> return ()- keyboardMouseCallback' <- newIORef $ \_ _ _ _ -> return ()- config <- glConfigNew [ GLModeRGBA, GLModeDouble ]- canvas <- glDrawingAreaNew config- widgetSetSizeRequest canvas width height- eventb <- eventBoxNew- set eventb [ containerBorderWidth := 0, containerChild := canvas ]- _ <- onRealize canvas $ withGLDrawingArea canvas $ \_ -> join (readIORef realizeCallback')- _ <- canvas `on` configureEvent $ tryEvent $ do- (w, h) <- eventSize- liftIO $ do- cb <- readIORef reshapeCallback'- cb (Size w h)- _ <- canvas `on` exposeEvent $ tryEvent $ liftIO $ withGLDrawingArea canvas $ \gl -> do- join (readIORef displayCallback')- glDrawableSwapBuffers gl- let handleButton s = do- b <- eventButton- (x, y) <- eventCoordinates- ms <- eventModifier- liftIO $ do- cb <- readIORef keyboardMouseCallback'- cb (MouseButton b) s ms (Position x y)- _ <- eventb `on` buttonPressEvent $ tryEvent $ handleButton Down- _ <- eventb `on` buttonReleaseEvent $ tryEvent $ handleButton Up- return $ GLUTGtk- { realizeCallback = realizeCallback'- , displayCallback = displayCallback'- , reshapeCallback = reshapeCallback'- , keyboardMouseCallback = keyboardMouseCallback'- , postRedisplay = widgetQueueDraw canvas- , widget = eventb- }
− Logger.hs
@@ -1,40 +0,0 @@-module Logger where--import Prelude hiding (log)-import Control.Concurrent (forkIO, newChan, readChan, writeChan)-import Data.Time (formatTime, getCurrentTime, UTCTime)-import System.Locale (defaultTimeLocale)-import System.FilePath ((</>), (<.>))-import System.IO (openFile, IOMode(WriteMode), hPutStrLn, hClose, hFlush)--data LogLevel = Error | Warn | Info | Debug- deriving (Read, Show, Eq, Ord, Enum, Bounded)--data Logger = Logger- { log :: LogLevel -> String -> IO ()- , close :: IO ()- }--logger :: FilePath -> IO Logger-logger logDir = do- date <- getDate- let logFile = logDir </> filter (':'/=) date <.> "log"- h <- openFile logFile WriteMode- c <- newChan- let log' lvl msg = do- d <- getDate- writeChan c (Just $ d ++ "\t" ++ show lvl ++ "\t" ++ show msg)- close' = log' Info "closing log" >> writeChan c Nothing- writer = do- m <- readChan c- case m of- Nothing -> hClose h >> return ()- Just s -> hPutStrLn h s >> hFlush h >> writer- _ <- forkIO writer- log' Info "opening log"- return Logger{ log = log', close = close' }- where- logFormat :: UTCTime -> String- logFormat = formatTime defaultTimeLocale "%FT%T"- getDate :: IO String- getDate = logFormat `fmap` getCurrentTime
− Nucleus.hs
@@ -1,67 +0,0 @@-{-# LANGUAGE Rank2Types #-}-module Nucleus (refineNucleus) where--import Prelude hiding (zipWith)-import Data.Functor ((<$>))-import Data.List (genericIndex, genericSplitAt)-import Data.Vec ((:.)((:.)), toList, solve, fromList, matFromLists, Vec2, NearZero(nearZero), zipWith)-import Text.FShow.Raw (DecimalFormat(nanTest))-import Numeric.AD (jacobian', FF, lift, UU, findZero)-import Fractal.RUFF.Types.Complex (Complex((:+)), cis, magnitude)-import Utils ()--refineNucleus :: (DecimalFormat r, Floating r, Fractional r, Ord r, NearZero r) => Integer -> Complex r -> (r, Complex r)-refineNucleus p g =- let c = converge $ findZero (nucleusIter' p) g- [_, bond0] = root2 (bondIter' p (cis ( pi / 3))) [c, c]- [_, bond1] = root2 (bondIter' p (cis (-pi / 3))) [c, c]- r = magnitude (bond1 - bond0)- in (r, c)--converge :: (DecimalFormat r, NearZero r, Num r) => [Complex r] -> Complex r-converge (x:ys@(y@(yr:+yi):_))- | nanTest yr || nanTest yi = x- | nearZero (x - y) = x- | otherwise = converge ys-converge [x] = x-converge [] = error "gruff.Nucleus.converge: internal error"---- finding nucleus-nucleusIter' :: Fractional r => Integer -> UU r-nucleusIter' n c = (`genericIndex` n) . iterate (\z -> z * z + c) $ 0---- finding bond points-fdf :: (Integral i, Num c) => i -> c -> c -> (c, c)-fdf n z c = let (fzs, fz:_) = genericSplitAt n $ iterate (\w -> w * w + c) z- in (fz, 2 ^ n * product fzs)--bondIter' :: (Fractional c) => Integer -> c -> FF [] [] c-bondIter' n b [z, c] =- let b' = lift b- (fz, dfz) = fdf n z c- p = fz - z- q = dfz - b'- in [p, q]-bondIter' _ _ _ = error "bondIter' internal error"---- Newton's method-root2' :: (Fractional r, Ord r, NearZero r) => FF [] [] r -> Vec2 r -> Vec2 r-root2' f x = go x- where- go x0 = - let (ys, js) = unzip $ jacobian' f (toList x0)- y = fromList (negate <$> ys) `asTypeOf` x- j = matFromLists js `asTypeOf` ((x:.x:.()))- mdx = solve j y- in if all nearZero ys- then x0- else case mdx of- Nothing -> x0- Just dx ->- let x1 = zipWith (+) x0 dx- in if all nearZero (toList dx)- then x0- else go x1--root2 :: (Fractional r, NearZero r, Ord r) => FF [] [] r -> [r] -> [r]-root2 f = toList . root2' f . fromList
− PeriodScan.hs
@@ -1,55 +0,0 @@-module PeriodScan (periodScan, periodNucleus) where--import Control.Parallel.Strategies (parMap, rseq)-import Data.List (genericIndex, nubBy)-import Data.Maybe (listToMaybe)-import Data.Function (on)-import Data.Vec (NearZero, nearZero)-import Text.FShow.Raw (DecimalFormat(nanTest, infTest))--import Fractal.RUFF.Types.Complex (Complex((:+)))--import Utils (safeLast)--periodScan :: (Floating r, Ord r) => r -> Complex r -> Maybe Integer-periodScan r c =- let cs = [ c + (r:+r), c + (r:+(-r)), c + ((-r):+(-r)), c + ((-r):+r) ]- zs = iterate (zipWith (\cc z -> z * z + cc) cs) [0,0,0,0]- in fmap fst . listToMaybe . dropWhile (not . straddlesOrigin . snd) . zip [0 ..] $ zs--periodNucleus1 :: (Floating r, Ord r) => Integer -> r -> Complex r -> [(r, Complex r)]-periodNucleus1 p r0 c0- = map fst . filter (straddlesOrigin . snd)- . parMap rseq (fmap (parMap rseq (\c -> iterate (\z->z * z + c) 0 `genericIndex` p)))- . fmap (\(r, c) -> ((r, c), [c + (r:+r), c + ((-r):+r), c + ((-r):+(-r)), c + (r:+(-r))]))- $( [ (r', c0 + d) | i <- [-1,1], j <- [-1,1 ], let d = ((r'*i) :+ (r'*j)) ]- ++ [ (r', c0 + d) | i <- [ 0 ], j <- [ 0 ], let d = ((r'*i) :+ (r'*j)) ])-{-- of- [] -> []- xs -> fmap fst . minimumBy (comparing $ offsetFromOrigin . snd) $ xs -}- where r' = r0 / 2--periodNucleus :: (NearZero r, DecimalFormat r, Floating r, Ord r) => Integer -> r -> Complex r -> Maybe (Complex r)-periodNucleus p r0 c0 =- let ok (r, (x:+y)) = all ok' [r, x, y]- ok' x = not (nanTest x || infTest x)- in fmap snd . safeLast . takeWhile ok . concat . takeWhile (not . null) . iterate (nubBy (approxEq `on` snd) . (uncurry (periodNucleus1 p) =<<)) $ [(r0, c0)]--straddlesOrigin :: (Ord r, Num r) => [Complex r] -> Bool-straddlesOrigin ps = odd . length . filter id . zipWith positiveReal ps $ (drop 1 ps ++ take 1 ps)--positiveReal :: (Ord r, Num r) => Complex r -> Complex r -> Bool-positiveReal (u:+v) (x:+y)- | v < 0 && y < 0 = False- | v > 0 && y > 0 = False- | (u * (y - v) - v * (x - u)) * (y - v) > 0 = True- | otherwise = False--{--offsetFromOrigin :: (Floating r) => [Complex r] -> r-offsetFromOrigin = magnitude . sum--}--approxEq :: (Num c, NearZero c) => c -> c -> Bool-approxEq w z = nearZero (w - z)
− QuadTree.hs
@@ -1,95 +0,0 @@-module QuadTree- ( Child(..), north, south, west, east- , Quad(..), root, child, children, parent, parents- , filename, unsafeName- , Square(..), square, Point(..), contains, Region(..), outside, quads, quadss- ) where--import Control.Monad (liftM2)-import Data.Bits (bit, shiftL, shiftR, testBit, (.|.))-import Data.List (unfoldr)-import Data.Ratio ((%))--data Child = NorthWest | NorthEast | SouthWest | SouthEast- deriving (Read, Show, Eq, Ord, Enum, Bounded)--north, south, west, east :: Child -> Bool-east c = fromEnum c `testBit` 0-south c = fromEnum c `testBit` 1-north = not . south-west = not . east--data Quad = Quad{ quadLevel :: !Int, quadWest, quadNorth :: !Integer }- deriving (Read, Show, Eq, Ord)--root :: Quad-root = Quad{ quadLevel = 0, quadWest = 0, quadNorth = 0 }--child :: Child -> Quad -> Quad-child c Quad{ quadLevel = l, quadWest = x, quadNorth = y } = Quad- { quadLevel = l + 1- , quadWest = x `shiftL` 1 .|. (fromIntegral . fromEnum . east ) c- , quadNorth = y `shiftL` 1 .|. (fromIntegral . fromEnum . south) c- }--children :: [Child] -> Quad-children = foldr child root--parent :: Quad -> Maybe (Child, Quad)-parent Quad{ quadLevel = l, quadWest = x, quadNorth = y }- | l > 0 = Just- ( toEnum (fromEnum (y `testBit` 0) `shiftL` 1 .|. fromEnum (x `testBit` 0))- , Quad{ quadLevel = l - 1, quadWest = x `shiftR` 1, quadNorth = y `shiftR` 1 }- )- | otherwise = Nothing--parents :: Quad -> [Child]-parents = unfoldr parent--filename :: Quad -> Maybe ([FilePath], FilePath)-filename q- | null cs = Nothing- | otherwise = Just (init cs, last cs)- where- cs = chunk 2 . map unsafeName . chunk 2 . reverse . parents $ q--unsafeName :: [Child] -> Char-unsafeName [c] = ['a'..'d'] !! (fromEnum c)-unsafeName [c,d] = ['e'..'t'] !! (fromEnum c `shiftL` 2 .|. fromEnum d)-unsafeName _ = error "QuadTree.unsafeName"--chunk :: Int -> [a] -> [[a]]-chunk _ [] = []-chunk n xs = let (ys, zs) = splitAt n xs in ys : chunk n zs--data Square = Square{ squareSize, squareWest, squareNorth :: !Rational }- deriving (Read, Show, Eq, Ord)--square :: Square -> Quad -> Square-square Square{ squareSize = s0, squareWest = x0, squareNorth = y0 } Quad{ quadLevel = l, quadWest = x, quadNorth = y } =- Square{ squareSize = s0 / fromInteger r, squareWest = x0 + s0 * (x % r), squareNorth = y0 + s0 * (y % r) } where r = bit l--data Region = Region{ regionNorth, regionSouth, regionWest, regionEast :: !Rational }- deriving (Read, Show, Eq, Ord)--outside :: Region -> Square -> Bool-outside r s- = regionSouth r < squareNorth s- || regionEast r < squareWest s- || regionNorth r > squareNorth s + squareSize s- || regionWest r > squareWest s + squareSize s--data Point = Point{ pointWest, pointNorth :: !Rational }- deriving (Read, Show, Eq, Ord)--contains :: Point -> Square -> Bool-contains p s- = squareNorth s <= pointNorth p && pointNorth p <= squareNorth s + squareSize s- && squareWest s <= pointWest p && pointWest p <= squareWest s + squareSize s--quads :: Square -> Region -> Int -> [Quad]-quads rootSquare region level = quadss rootSquare region !! level--quadss :: Square -> Region -> [[Quad]]-quadss rootSquare region =- iterate (filter (not . outside region . square rootSquare) . liftM2 child [minBound .. maxBound]) [root]
− Shader.hs
@@ -1,26 +0,0 @@-module Shader (shader) where--import Graphics.Rendering.OpenGL--shader :: Maybe FilePath -> Maybe FilePath -> IO Program-shader mV mF = do- [p] <- genObjectNames 1- vs <- case mV of- Nothing -> return []- Just v -> do- [vert] <- genObjectNames 1- source <- readFile v- shaderSource vert $= [ source ]- compileShader vert- return [vert]- fs <- case mF of- Nothing -> return []- Just f -> do- [frag] <- genObjectNames 1- source <- readFile f- shaderSource frag $= [ source ]- compileShader frag- return [frag]- attachedShaders p $= (vs, fs)- linkProgram p- return p
− StatusDialog.hs
@@ -1,31 +0,0 @@-module StatusDialog where--import Control.Concurrent (forkIO, killThread)-import Graphics.UI.Gtk--type Status = (String -> IO ()) -> IO ()-data StatusDialog = StatusDialog{ statusDialog :: String -> Status -> IO () }--statusDialogNew :: IO StatusDialog-statusDialogNew = do- window <- windowNew- windowSetModal window True- windowSetDefaultSize window 320 200- b <- vBoxNew False 2- label <- labelNew (Just "")- cancel <- buttonNewWithLabel "Cancel"- boxPackStartDefaults b label- boxPackStartDefaults b cancel- set window [ containerChild := b ]- return StatusDialog{ statusDialog = \title task -> do- windowSetTitle window title- labelSetText label ""- widgetSetSensitivity cancel True- child <- forkIO $ do- task $ postGUISync . labelSetText label- postGUISync $ widgetHide window- _ <- cancel `onClicked` do- killThread child- widgetHide window- widgetShowAll window- }
+ TODO view
@@ -0,0 +1,57 @@+annoyments+ catch exceptions in worker threads (eg: disk full)+ figure out where rare libpango segfault is coming from - threading?++enhancements+ navigation+ configurable zoom mode: center on click vs expand about click+ continuous zoom mode while button is pressed+ configurable zoom speed+ undo/history tree navigation+ log annotation and search+ log browser view with filtering+ log level settings (Set Loggable ?)+ persistence+ image save as png (or ppm?) when done+ save/load viewing parameters in a common plain text format+ colouring+ multiple colouring modes - minimal / rainbow / hypertile+ gui for each colouring mode with appropriate persistence+ memory cache+ option for maximum memory cache size+ warn when memory cache is not enough for window settings+ memory cache model - LRU or similar?+ disk cache+ option for maximum disk cache size+ option to disable disk cache for casual exploratory browsing+ disk cache management: keep most expensive vs most used?+ tile usage statistics database+ tile renderer+ compute tile cost metrics (iteration stats, boundary size, bit bepth)+ which quadrants are interior/exterior etc+ re-use pixels from parent/child tiles in renderer+ don't compute known-interior tiles+ features+ feature overlay in browser window+ feature overlay save as svg (save image as png and embed it too?)+ scan whole image for atoms, subdivide for more+ draw external rays in feature overlay+ draw internal rays in feature overlay+ feature database - try lookup before calculating, cache results+ algorithms+ child finding algorithm+ parent finding algorithm - need to research+ box counting fractal dimension estimates+ non-slow angled internal address to external angle+ misc+ tiled rendering mode for huge images without seams+ use custom icon for status dialog window+ scripting+ haskell scripting with edsl/library for common tasks+ command line flag to load a script at startup+ interpreter REPL window++internal+ split MuAtom into separate modules+ backport appropriate algorithms to 'ruff'+ source code documentation
− Tile.hs
@@ -1,175 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-module Tile where--import Prelude hiding (log)--import Control.Exception (bracketOnError)-import Control.Monad (when)-import Data.Bits (shiftL, shiftR, (.&.))-import Foreign (Ptr, castPtr, sizeOf, mallocArray, free, Word8, with, poke, allocaBytes, withArray, peekArray)-import Foreign.C (CFloat, CDouble, CInt, CSize, withCStringLen)-import System.Directory (createDirectoryIfMissing)-import System.FilePath ((</>), (<.>))-import System.IO (withBinaryFile, IOMode(ReadMode,WriteMode), hPutBuf, hGetBuf)---import Data.BEncode-import Numeric.QD--import QuadTree-import Utils (catchIO)--width, height, count, bytes :: Int-width = 256-height = 256-count = width * height-bytes = count * sizeOf (0 :: CFloat)--rootSquare :: Square-rootSquare = Square{ squareSize = 8, squareWest = -4, squareNorth = -4 }--data Tile = Tile Quad (Ptr CFloat) (Ptr CFloat) (Ptr CFloat)--mallocTile :: Quad -> IO Tile-mallocTile cs = do- ns <- mallocArray count- ds <- mallocArray count- ts <- mallocArray count- return $ Tile cs ns ds ts--freeTile :: Tile -> IO ()-freeTile (Tile _ ns ds ts) = do- free ns- free ds- free ts--header :: String-header = "RuFfTiLe001\n"--writeTile :: FilePath -> Tile -> IO ()-writeTile cacheDir (Tile q ns ds ts) = do- case filename q of- Nothing -> return ()- Just (dirs, file) -> do- let dir = foldr1 (</>) (cacheDir : dirs)- createDirectoryIfMissing True dir- withBinaryFile (dir </> file <.> "ruff") WriteMode $ \h -> do- withCStringLen header $ \(p, l) -> hPutBuf h p l- withArray (wordBE (bytes * 3)) $ \p -> hPutBuf h p 4- hPutBuf h ns bytes- hPutBuf h ds bytes- hPutBuf h ts bytes--- hPut h . bPack . metaData $ q- where- wordBE :: Int -> [Word8]- wordBE n = map (\b -> fromIntegral $ (n `shiftR` (8 * b)) .&. 0xFF) [3, 2, 1, 0]--{--metaData :: Quad -> BEncode-metaData q@Quad{ quadLevel = l, quadWest = w, quadNorth = n } =- BDict $ fromList [ ("tile", BDict $ fromList- [ ("about", BDict $ fromList- [ ("version", BInt 1)- , ("generator", BString $ pack "gruff-0.1") ]- , ("images", BDict . fromList . map image . zip [0..] $- [ "continuous dwell", "normalized distance", "final angle"]) ]- ]- where- image plane alg = (alg, BDict $ fromList- [ ("width", BInt (fromIntegral width))- , ("height", BInt (fromIntegral height))- , ("real", BInt w)- , ("imag", BInt (negate n))- , ("scale", BInt (fromIntegral l + 2))- , ("format", BString $ pack "float32le")- , ("order", BString $ pack "lr,tb")- , ("data offset", BInt (fromIntegral $ plane * count * sizeOf (0 :: CFloat)))- ])--}--readTile :: FilePath -> Quad -> IO (Maybe Tile)-readTile cacheDir q = flip catchIO (\_ -> return Nothing) $ do- case filename q of- Nothing -> return Nothing- Just (dirs, file) -> do- let dir = foldr1 (</>) (cacheDir : dirs)- bracketOnError (mallocTile q) freeTile $ \t@(Tile _ ns ds ts) -> do- withBinaryFile (dir </> file <.> "ruff") ReadMode $ \h -> do- let headerBytes = 12- allocaBytes headerBytes $ \p -> do- headerBytes' <- hGetBuf h p headerBytes- when (headerBytes /= headerBytes') $ fail "readTile header fail"- header' <- peekArray headerBytes p- when (header' /= (map (fromIntegral . fromEnum) header :: [Word8])) $ fail "readTile header mismatch"- dataBytes <- allocaBytes 4 $ \p -> do- lenBytes' <- hGetBuf h p 4- when (lenBytes' /= 4) $ fail "readTile header length fail"- unwordBE `fmap` peekArray 4 p- when (dataBytes /= bytes * 3) $ fail "readTile header length mismatch"- bytes' <- hGetBuf h ns bytes- when (bytes /= bytes') $ fail ("readTile 0 " ++ show bytes ++ " /= " ++ show bytes')- bytes'' <- hGetBuf h ds bytes- when (bytes /= bytes'') $ fail ("readTile 1 " ++ show bytes ++ " /= " ++ show bytes'')- bytes''' <- hGetBuf h ts bytes- when (bytes /= bytes''') $ fail ("readTile 2 " ++ show bytes ++ " /= " ++ show bytes''')- return $ Just t- where- unwordBE :: [Word8] -> Int- unwordBE = sum . zipWith (\b n -> fromIntegral n `shiftL` (8 * b)) [3, 2, 1, 0]--clearTile :: Tile -> IO ()-clearTile (Tile _ ns ds ts) = do- mapM_ clear [ns, ds, ts]- where- clear p = c_memset (castPtr p) 0 (fromIntegral bytes)--computeTile :: (String -> IO ()) -> Ptr CInt -> Tile -> IO Bool-computeTile log p (Tile q@Quad{ quadLevel = l } ns ds ts) = do- its <- compute'- log $ show ("getTile", q, "computed", its)- return $ its /= 0- where- compute'- | l < 18 = c_compute_f32 p ns ds ts cx cy l' m'- | l < 48 = c_compute_f64 p ns ds ts cx cy l' m'- | l < 96 = with (cx :: DoubleDouble) $ \px -> with (cy :: DoubleDouble) $ \py ->- c_compute_f128 p ns ds ts (castPtr px) (castPtr py) l' m'- | l < 192 = with (cx :: QuadDouble ) $ \px -> with (cy :: QuadDouble ) $ \py ->- c_compute_f256 p ns ds ts (castPtr px) (castPtr py) l' m'- | otherwise = error "Tile.computeTile: too deep"- l' = fromIntegral l- m' = 10000000- s = square rootSquare q- cx, cy :: Fractional a => a- cx = fromRational (squareWest s)- cy = fromRational (squareNorth s)--getTile :: (String -> IO ()) -> FilePath -> Ptr CInt -> Quad -> IO (Maybe Tile)-getTile log cacheDir p q = do- mTile <- readTile cacheDir q- case mTile of- Just t -> do- log $ show ("getTile", q, "read")- return (Just t)- Nothing -> do- log $ show ("getTile", q, "compute")- t <- mallocTile q- clearTile t- poke p 0- ok <- computeTile log p t- if ok- then writeTile cacheDir t >> return (Just t)- else freeTile t >> return Nothing--foreign import ccall unsafe "string.h memset"- c_memset :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8)--foreign import ccall "compute.h compute_f32"- c_compute_f32 :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> CFloat -> CFloat -> CInt -> CInt -> IO CInt--foreign import ccall "compute.h compute_f64"- c_compute_f64 :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> CDouble -> CDouble -> CInt -> CInt -> IO CInt--foreign import ccall "compute.h compute_f128"- c_compute_f128 :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> Ptr CDouble -> Ptr CDouble -> CInt -> CInt -> IO CInt--foreign import ccall "compute.h compute_f256"- c_compute_f256 :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> Ptr CDouble -> Ptr CDouble -> CInt -> CInt -> IO CInt
− Utils.hs
@@ -1,43 +0,0 @@-module Utils where--import Prelude hiding (catch)-import Control.Exception (catch, IOException)-import Control.Monad (forM)-import System.Directory (getDirectoryContents, doesFileExist, doesDirectoryExist)-import System.FilePath ((</>))-import Data.Vec (NearZero(nearZero))-import Numeric.QD (QuadDouble)-import Fractal.RUFF.Types.Complex (Complex((:+)))--safeRead :: Read a => String -> Maybe a-safeRead s = case reads s of- [(a, "")] -> Just a- _ -> Nothing--catchIO :: IO a -> (IOException -> IO a) -> IO a-catchIO = catch--getFilesRecursive :: FilePath -> IO [([FilePath], FilePath)]-getFilesRecursive d = (do- fs0 <- getDirectoryContents d- let fs = filter (`notElem` [".", ".."]) fs0- ffs <- forM fs $ \f -> do- let df = d </> f- fe <- doesFileExist df- fd <- doesDirectoryExist df- case (fe, fd) of- (True, False) -> return [([], f)]- (False, True) -> map (\(ds, f') -> (f:ds, f')) `fmap` getFilesRecursive df- _ -> return []- return (concat ffs)) `catchIO` (\_ -> return [])--safeLast :: [a] -> Maybe a-safeLast [] = Nothing-safeLast [x] = Just x-safeLast (_:xs) = safeLast xs--instance NearZero QuadDouble where- nearZero x = not (abs x > (1e-60))--instance (NearZero a) => NearZero (Complex a) where- nearZero (r :+ i) = nearZero r && nearZero i
− cache.frag
@@ -1,66 +0,0 @@-uniform sampler2D tex;--float lin_interp(float x, float domain_low, float domain_hi, float range_low, float range_hi) {- if ((x >= domain_low) && (x <= domain_hi)) {- x = (x - domain_low) / (domain_hi - domain_low);- x = range_low + x * (range_hi - range_low);- }- return x;-}--float pvp_adjust_3(float x) {- // red- x = lin_interp(x, 0.00, 0.125, -0.050, 0.090);- // orange- x = lin_interp(x, 0.125, 0.25, 0.090, 0.167);- // yellow- x = lin_interp(x, 0.25, 0.375, 0.167, 0.253);- // chartreuse- x = lin_interp(x, 0.375, 0.50, 0.253, 0.383);- // green- x = lin_interp(x, 0.50, 0.625, 0.383, 0.500);- // teal- x = lin_interp(x, 0.625, 0.75, 0.500, 0.667);- // blue- x = lin_interp(x, 0.75, 0.875, 0.667, 0.800);- // purple- x = lin_interp(x, 0.875, 1.00, 0.800, 0.950);- return(x);-}--vec3 hsv2rgb(float h, float s, float v)-{- float i, f, p, q, t, r, g, b;- if (s == 0.0) {- // Ignore hue- r = v;- g = v;- b = v;- } else {- /* Apply physiological mapping: red, yellow, green and blue should- be equidistant. */- h = pvp_adjust_3(h);- h = h - floor(h);- h = h * 6.0;- i = floor(h);- f = h - i;- p = v*(1.0 - s); // The "low-flat" curve- q = v*(1.0 - (s*f)); // The "falling" curve- t = v*(1.0 - (s*(1.0 - f))); // The "rising" curve- if (i < 1.0) { r = v; g = t; b = p; } else- if (i < 2.0) { r = q; g = v; b = p; } else- if (i < 3.0) { r = p; g = v; b = t; } else- if (i < 4.0) { r = p; g = q; b = v; } else- if (i < 5.0) { r = t; g = p; b = v; } else- { r = v; g = p; b = q; }- }- return vec3(r, g, b);-}--void main(void) {- float n = texture2D(tex, gl_TexCoord[0].st).x;- float h = n;- float s = 1.0;- float v = clamp(0.0, 1.0, 0.25 + log(h + 1.0));- gl_FragColor = vec4(hsv2rgb(h, s, v), 1.0);-}
− colourize.frag
@@ -1,81 +0,0 @@-uniform sampler2D de;-uniform sampler2D it;-uniform sampler2D tt;--uniform float hshift;-uniform float hscale;--float lin_interp(float x, float domain_low, float domain_hi, float range_low, float range_hi) {- if ((x >= domain_low) && (x <= domain_hi)) {- x = (x - domain_low) / (domain_hi - domain_low);- x = range_low + x * (range_hi - range_low);- }- return x;-}--float pvp_adjust_3(float x) {- // red- x = lin_interp(x, 0.00, 0.125, -0.050, 0.090);- // orange- x = lin_interp(x, 0.125, 0.25, 0.090, 0.167);- // yellow- x = lin_interp(x, 0.25, 0.375, 0.167, 0.253);- // chartreuse- x = lin_interp(x, 0.375, 0.50, 0.253, 0.383);- // green- x = lin_interp(x, 0.50, 0.625, 0.383, 0.500);- // teal- x = lin_interp(x, 0.625, 0.75, 0.500, 0.667);- // blue- x = lin_interp(x, 0.75, 0.875, 0.667, 0.800);- // purple- x = lin_interp(x, 0.875, 1.00, 0.800, 0.950);- return(x);-}--vec3 hsv2rgb(float h, float s, float v)-{- float i, f, p, q, t, r, g, b;- if (s == 0.0) {- // Ignore hue- r = v;- g = v;- b = v;- } else {- /* Apply physiological mapping: red, yellow, green and blue should- be equidistant. */- h = pvp_adjust_3(h);- h = h - floor(h);- h = h * 6.0;- i = floor(h);- f = h - i;- p = v*(1.0 - s); // The "low-flat" curve- q = v*(1.0 - (s*f)); // The "falling" curve- t = v*(1.0 - (s*(1.0 - f))); // The "rising" curve- if (i < 1.0) { r = v; g = t; b = p; } else- if (i < 2.0) { r = q; g = v; b = p; } else- if (i < 3.0) { r = p; g = v; b = t; } else- if (i < 4.0) { r = p; g = q; b = v; } else- if (i < 5.0) { r = t; g = p; b = v; } else- { r = v; g = p; b = q; }- }- return vec3(r, g, b);-}--void main(void) {- float d = texture2D(de, gl_TexCoord[0].st).x;- float i = texture2D(it, gl_TexCoord[0].st).x;- float t = texture2D(tt, gl_TexCoord[0].st).x;- vec4 c = vec4(vec3(1.0), 1.0);- if (i > 0.0) {- float h = hscale * log(i) + hshift;- float s;- float v;- if (t > 0.0) { s = 0.55; } else { s = 0.45; }- i /= 2.0;- if (i - floor(i) < 0.5) { v = 0.95; } else { v = 1.00; }- c.rgb = hsv2rgb(h, s, v);- c.rgb *= clamp(0.5 + 0.25 * log(d), 0.0, 1.0);- }- gl_FragColor = c;-}
− compute.cc
@@ -1,173 +0,0 @@-#include <cmath>-#include <stdint.h>-#include <stdlib.h>--#include <qd/fpu.h>-#include <qd/dd_real.h>-#include <qd/dd_inline.h>-#include <qd/qd_real.h>-#include <qd/qd_inline.h>--#define likely(x) __builtin_expect((x),1)-#define unlikely(x) __builtin_expect((x),0)--static inline float to_float(float x) { return x; }-static inline float to_float(double x) { return x; }-static inline float to_float(dd_real x) { return to_double(x); }-static inline float to_float(qd_real x) { return to_double(x); }--static inline float sqr(float x) { return x * x; }-static inline double sqr(double x) { return x * x; }--template <typename T>-struct iter {- T zx, zy, dx, dy; int32_t n; int16_t i, j;-};--template <typename T>-static int compute(int *stop, float *out_n, float *out_d, float *out_a, T in_cx, T in_cy, int in_level, int in_iters) {- unsigned int fpu;- fpu_fix_start(&fpu);- struct iter<T> *iters[2];- iters[0] = (struct iter<T> *) malloc(sizeof(struct iter<T>) * 256 * 256);- iters[1] = (struct iter<T> *) malloc(sizeof(struct iter<T>) * 256 * 256);- int active[2];- active[0] = 0;- active[1] = 0;- int from = 0;- int to = 1;- int max_iters = -1;- { /* initialize border */ - struct iter<T> *it = iters[from];- int n = active[from];- { /* corners */- it->zx = it->zy = it->dx = it->dy = it->n = 0; it->i = 0; it->j = 0; out_n[256 * ((int)it->j) + it->i] = -1; it++; n++;- it->zx = it->zy = it->dx = it->dy = it->n = 0; it->i = 255; it->j = 0; out_n[256 * ((int)it->j) + it->i] = -1; it++; n++;- it->zx = it->zy = it->dx = it->dy = it->n = 0; it->i = 0; it->j = 255; out_n[256 * ((int)it->j) + it->i] = -1; it++; n++;- it->zx = it->zy = it->dx = it->dy = it->n = 0; it->i = 255; it->j = 255; out_n[256 * ((int)it->j) + it->i] = -1; it++; n++;- }- for (int i = 1; i < 255; ++i) { /* edges */- it->zx = it->zy = it->dx = it->dy = it->n = 0; it->i = 0; it->j = i; out_n[256 * ((int)it->j) + it->i] = -1; it++; n++;- it->zx = it->zy = it->dx = it->dy = it->n = 0; it->i = 255; it->j = i; out_n[256 * ((int)it->j) + it->i] = -1; it++; n++;- it->zx = it->zy = it->dx = it->dy = it->n = 0; it->i = i; it->j = 0; out_n[256 * ((int)it->j) + it->i] = -1; it++; n++;- it->zx = it->zy = it->dx = it->dy = it->n = 0; it->i = i; it->j = 255; out_n[256 * ((int)it->j) + it->i] = -1; it++; n++;- }- active[from] = n;- }- const T scale = T(1.0) / (T(32.0) * pow(T(2.0), T(in_level)));- int progress = 1;- int progress2 = 1;- int progressed = 0;- int min_iters = 0;- int step_iters = 64;- int retval = 0;- while (active[from] && (progressed ? progress2 : 1) && step_iters < in_iters) {- progress2 = 0;- progress = 1;- while (progress) {- progress = 0;- int o = 0;- for (int i = 0; i < active[from]; ++i) {- if (*stop) { goto cleanup; }- T zx = iters[from][i].zx;- T zy = iters[from][i].zy;- T dx = iters[from][i].dx;- T dy = iters[from][i].dy;- T cx = in_cx + scale * iters[from][i].i;- T cy = in_cy + scale * iters[from][i].j;- int32_t n = iters[from][i].n;- { /* iterate */- const T er2 = 65536;- T zx2 = sqr(zx);- T zy2 = sqr(zy);- T z2 = zx2 + zy2;- T z2xy = 2 * zx * zy;- while (likely(n < step_iters && z2 < er2)) {- T zdzx = zx * dx - zy * dy;- T zdzy = zx * dy + zy * dx;- dx = 2 * zdzx + 1;- dy = 2 * zdzy;- zx = zx2 - zy2 + cx;- zy = z2xy + cy;- zx2 = sqr(zx);- zy2 = sqr(zy);- z2xy = 2 * zx * zy;- z2 = zx2 + zy2;- ++n;- }- if (z2 >= er2) {- int k = ((int) iters[from][i].j) * 256 + iters[from][i].i;- out_n[k] = to_float(1 + n - log(log(z2) / log(er2))/log(2.0));- out_d[k] = to_float((log(z2) * sqrt(z2 / (sqr(dx) + sqr(dy)))) / scale);- out_a[k] = to_float(atan2(zy, zx));- for (int x = iters[from][i].i - 1; x <= iters[from][i].i + 1; ++x) {- if (x < 0 || 255 < x) continue;- for (int y = iters[from][i].j - 1; y <= iters[from][i].j + 1; ++y) {- if (y < 0 || 255 < y) continue;- k = y * 256 + x;- if (out_n[k] == 0) {- iters[to][o].zx = T(0);- iters[to][o].zy = T(0);- iters[to][o].dx = T(0);- iters[to][o].dy = T(0);- iters[to][o].n = 0;- iters[to][o].i = x;- iters[to][o].j = y;- out_n[k] = -1;- ++o;- }- }- }- if (min_iters < n) min_iters = n;- if (max_iters < n) max_iters = n;- ++progress;- } else {- iters[to][o].zx = zx;- iters[to][o].zy = zy;- iters[to][o].dx = dx;- iters[to][o].dy = dy;- iters[to][o].n = n;- iters[to][o].i = iters[from][i].i;- iters[to][o].j = iters[from][i].j;- ++o;- }- }- }- active[to] = o;- int temp = from; from = to; to = temp;- progress2 = progress2 || progress;- }- step_iters *= 2;- progressed = progressed || progress2;- }- { /* deinitialize border */- int k;- for (int i = 0; i < 256; ++i) { /* edges */- k = 256 * i + 0; if (out_n[k] < 0) out_n[k] = 0;- k = 256 * i + 255; if (out_n[k] < 0) out_n[k] = 0;- k = 256 * 0 + i; if (out_n[k] < 0) out_n[k] = 0;- k = 256 * 255 + i; if (out_n[k] < 0) out_n[k] = 0;- }- }- retval = max_iters;-cleanup:- free(iters[0]);- free(iters[1]);- fpu_fix_end(&fpu);- return retval;-}--extern "C" {- int compute_f32(int *stop, float *out_n, float *out_d, float *out_a, float in_cx, float in_cy, int in_level, int in_iters) {- return compute(stop, out_n, out_d, out_a, in_cx, in_cy, in_level, in_iters);- }- int compute_f64(int *stop, float *out_n, float *out_d, float *out_a, double in_cx, double in_cy, int in_level, int in_iters) {- return compute(stop, out_n, out_d, out_a, in_cx, in_cy, in_level, in_iters);- }- int compute_f128(int *stop, float *out_n, float *out_d, float *out_a, double *in_cx, double *in_cy, int in_level, int in_iters) {- return compute(stop, out_n, out_d, out_a, dd_real(in_cx), dd_real(in_cy), in_level, in_iters);- }- int compute_f256(int *stop, float *out_n, float *out_d, float *out_a, double *in_cx, double *in_cy, int in_level, int in_iters) {- return compute(stop, out_n, out_d, out_a, qd_real(in_cx), qd_real(in_cy), in_level, in_iters);- }-}
+ data/icon.png view
binary file changed (absent → 38921 bytes)
+ data/merge.frag view
@@ -0,0 +1,8 @@+uniform sampler2D sheet0;+uniform sampler2D sheet1;+uniform float blend;++void main() {+ vec2 p = gl_TexCoord[0].xy;+ gl_FragColor = mix(texture2D(sheet1, p), texture2D(sheet0, p), blend);+}
+ data/minimal.frag view
@@ -0,0 +1,19 @@+uniform sampler2D de;+uniform sampler2D it;+uniform sampler2D tt;++uniform vec3 interior;+uniform vec3 border;+uniform vec3 exterior;++void main(void) {+ float d = texture2D(de, gl_TexCoord[0].st).x;+ float i = texture2D(it, gl_TexCoord[0].st).x;+ float t = texture2D(tt, gl_TexCoord[0].st).x;+ vec4 c = vec4(interior, 1.0);+ if (i > 0.0) {+ float k = clamp(0.5 + 0.5 * log2(0.5 * d), 0.0, 1.0);+ c.rgb = mix(border, exterior, k);+ }+ gl_FragColor = c;+}
gruff.cabal view
@@ -1,34 +1,47 @@ Name: gruff-Version: 0.1.1+Version: 0.2 Synopsis: fractal explorer GUI using the ruff library Description:- Currently allows exploration only of the Mandelbrot Set fractal.- Requires GTK, OpenGL, and GLSL fragment shader support.+ Mandelbrot Set fractal explorer using the ruff library. .+ Requires GTK, OpenGL, and GLSL fragment shader support; lots of RAM+ and multiple CPU cores recommended. If you want to explore very deep+ zooms, you'll need hmpfr which currently requires GHC to be compiled+ with integer-simple instead of the default integer-gmp. To install+ without MPFR support, use @cabal install gruff -f-mpfr@.+ . Features in this version include: . * Interactive fractal browser display (left click to zoom in, right click to zoom out, middle-click to center). .- * Session persistance (stored in ~/.gruff/state.gruff - states can+ * Session persistance (stored in @~/.gruff/state.gruff@ - states can also be loaded from and saved to other files). .- * Tile cache (by default in ~/.gruff/cache - symlink it somewhere+ * Tile cache (by default in @~/.gruff/cache@ - symlink it somewhere with a few GB of space if you plan on exploring a lot). . * High-level feature finding using angled internal addresses (enter an address, for example @1 2 3 1/3 10@, and hit return,- then click the address to coordinates button).+ then click the adjacent Go button). . * Feature finding using period location (navigate to approximate- location of the desired feature, click the period scan button).+ location of the desired feature, click the Scan button). .- * Cache view (refreshed on program start) to visualize visited- locations.+ * Angled internal address calculation using reverse ray trace+ (navigate to approximate feature location, click the Scan+ button). .- Future features might include image saving, external ray and nucleus- period overlays, more feature finding and identification algorithms,- customizable colour schemes, higher precision for deeper zooms, etc.+ * Uses MPFR where available for higher precision, allowing deeper+ zooms and locating high period nucleii.+ .+ * Limited amount of customizable colouring (colours for interior,+ border, and exterior points).+ .+ * Supersampling for more detailed images (useful range is 1 to 4).+ .+ Future features might include image saving, external ray and feature+ information overlays, more feature finding and identification+ algorithms, scripting support for rendering animations, ... License: GPL-2 License-file: LICENSE@@ -39,13 +52,51 @@ Build-type: Simple Cabal-version: >=1.4 -Data-files: icon.png, colourize.frag, cache.frag+Data-dir: data+Data-files: icon.png, merge.frag, minimal.frag+Extra-source-files: TODO src/mp_real.h +Flag mpfr+ description: use MPFR for higher precision floating point+ default: True+ Executable gruff- Main-is: gruff.hs- Build-depends: base >= 4 && < 5, ad >= 1 && < 2, containers >= 0 && < 1, directory >= 1 && < 2, filepath >= 1 && < 2, floatshow >= 0.2 && < 0.3, gtk >= 0.11 && < 0.13, gtkglext >= 0.11 && < 0.13, old-locale >= 1 && < 2, OpenGL >= 2.4 && < 3, OpenGLRaw >= 1.1 && < 2, parallel >= 3.1 && < 3.2, qd >= 1 && < 2, time >= 1 && < 2, Vec >= 0.9 && < 1, wl-pprint-text >= 1 && < 2, bytestring, mtl, ruff >= 0.1 && < 0.2- Other-modules: GLUTGtk, QuadTree, Tile, Logger, Nucleus, Address, Utils, Browser, Shader, StatusDialog, CacheView, PeriodScan- C-sources: compute.cc, rts.c- CC-options: -O3 -Wall -pedantic -Wextra- GHC-options: -Wall -threaded -rtsopts -O2 -funbox-strict-fields- GHC-Prof-Options: -prof -auto-all -caf-all+ Hs-source-dirs: src+ Main-is: gruff.hs+ Other-modules: Browser+ GLUTGtk+ Logger+ MuAtom+ Number+ QuadTree+ Shader+ Snapshot+ StatusDialog+ Tile+ Utils+ View+ Build-depends: base >= 4 && < 5,+ containers >= 0 && < 1,+ directory >= 1 && < 2,+ filepath >= 1 && < 2,+ gtk >= 0.11 && < 0.13,+ gtkglext >= 0.11 && < 0.13,+ old-locale >= 1 && < 2,+ OpenGL >= 2.4 && < 3,+ OpenGLRaw >= 1.1 && < 2,+ parallel >= 3.1 && < 3.2,+ qd >= 1 && < 2,+ qd-vec >= 1 && < 2,+ time >= 1 && < 2,+ Vec >= 0.9 && < 1,+ ruff >= 0.2 && < 0.3,+ bytestring,+ mtl+ if (flag(mpfr))+ Build-depends: hmpfr >= 0.3.2 && < 0.4+ CPP-options: -DHAVE_MPFR+ CC-options: -DHAVE_MPFR+ C-sources: src/compute.cc, src/rts.c+ CC-options: -O3 -Wall -pedantic -Wextra+ GHC-options: -O2 -Wall -threaded -rtsopts+ GHC-Prof-Options: -prof -auto-all -caf-all
− gruff.hs
@@ -1,534 +0,0 @@-{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}-module Main (main) where--import Prelude hiding (catch, log)-import Control.Monad (forM_, liftM2)-import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef, writeIORef)-import Data.Maybe (isJust, fromMaybe)-import Data.Ratio (numerator, denominator)-import Graphics.UI.Gtk hiding (get, Region, Size)-import Graphics.UI.Gtk.OpenGL (initGL)-import System.Directory- ( getAppUserDataDirectory, createDirectoryIfMissing )-import System.FilePath ((</>))-import Text.PrettyPrint.Leijen.Text (pretty)-import Text.FShow.Raw (DecimalFormat, nanTest, infTest)--import Numeric.QD-import Fractal.RUFF.Mandelbrot.Address (AngledInternalAddress, Angle, parse, angledInternalAddress, externalAngles)-import Fractal.RUFF.Mandelbrot.Ray (externalRay)-import Fractal.RUFF.Types.Complex (Complex((:+)), magnitude)--import GLUTGtk (glut, Size(Size))-import PeriodScan (periodScan, periodNucleus)-import Nucleus (refineNucleus)-import Address (parseAngle, parseAngles, splitAddress, joinAddress, addressPeriod)-import Logger (logger, LogLevel(Debug))-import qualified Logger as Log-import Utils (safeRead, catchIO)-import Paths_gruff (getDataFileName)-import Browser-import StatusDialog-import CacheView (cInitialize)--exit :: (LogLevel -> String -> IO ()) -> FilePath -> Gruff -> IO ()-exit lg stateFile g = do- lg Debug "exitCallback"- aDoSave stateFile g- mainQuit--data GruffGUI = GruffGUI- { dStatus :: StatusDialog- -- buttons- , bHome- , bLoad- , bSave- , bAddressToCoordinates- , bAddressToIslandChild- , bIslandChildToAddress- , bAddressToAngles- , bIslandToAngles- , bLowerAngleToAddress- , bUpperAngleToAddress- , bPeriodScan :: Button- -- entries- , eAddress- , eIsland- , eChild- , eLowerAngle- , eUpperAngle- , eReal- , eImag- , eSize- , eHueShift- , eHueScale :: Entry- -- windows- , wMain- , wImage :: Window- }--main :: IO ()-main = do- -- contexts- _ <- initGUI- _ <- initGL- gl' <- glut minSize- glC <- glut minSize- -- directories- appDir <- getAppUserDataDirectory "gruff"- let cacheDir' = appDir </> "cache"- logDir = appDir </> "log"- stateFile = appDir </> "state.gruff"- createDirectoryIfMissing False appDir- createDirectoryIfMissing False logDir- lg <- logger logDir- icon <- pixbufNewFromFile =<< getDataFileName "icon.png"- -- widget window- (iw, iUpdate, iInitializeLate) <- iInitialize gl' icon lg cacheDir'- (cw, cUpdate, cInitializeLate) <- cInitialize glC icon cacheDir'- -- widget window- sg <- sizeGroupNew SizeGroupHorizontal- let spacing = 2- entryNewWithMnemonic m = do- e <- entryNew- entrySetWidthChars e 80- l <- labelNewWithMnemonic m- labelSetMnemonicWidget l e- sizeGroupAddWidget sg l- h <- hBoxNew False spacing- boxPackStart h l PackNatural 0- boxPackStartDefaults h e- return (e, h)- frameNewWithContents t r ws = do- f <- frameNew- frameSetLabel f t- frameSetLabelAlign f (if r then 1 else 0) 0.5- v <- vBoxNew False spacing- forM_ ws $ boxPackStartDefaults v- set f [ containerChild := v ]- return f- dStatus' <- statusDialogNew- b01@bHome' <- buttonNewWithLabel "Home"- b02@bLoad' <- buttonNewWithLabel "Load"- b03@bSave' <- buttonNewWithLabel "Save"- b7@bAddressToCoordinates' <- buttonNewWithLabel "Address → Coordinates"- b1@bAddressToIslandChild' <- buttonNewWithLabel "Address → Island + Child"- b2@bIslandChildToAddress' <- buttonNewWithLabel "Island + Child → Address"- b3@bAddressToAngles' <- buttonNewWithLabel "Address → Lower + Upper"- b4@bIslandToAngles' <- buttonNewWithLabel "Island → Lower + Upper"- b5@bLowerAngleToAddress' <- buttonNewWithLabel "Lower → Address"- b6@bUpperAngleToAddress' <- buttonNewWithLabel "Upper → Address"- b8@bPeriodScan' <- buttonNewWithLabel "Period Scan"- (eAddress', fa1) <- entryNewWithMnemonic "_Address"- (eIsland', fa2) <- entryNewWithMnemonic "I_sland"- (eChild', fa3) <- entryNewWithMnemonic "_Child"- (eLowerAngle', fe1) <- entryNewWithMnemonic "_Lower"- (eUpperAngle', fe2) <- entryNewWithMnemonic "_Upper"- (eReal', fc1) <- entryNewWithMnemonic "_Real"- (eImag', fc2) <- entryNewWithMnemonic "_Imag"- (eSize', fc3) <- entryNewWithMnemonic "Si_ze"- (eHueShift', fh1) <- entryNewWithMnemonic "Hue Shift"- (eHueScale', fh2) <- entryNewWithMnemonic "Hue Scale"- b0 <- hBoxNew False spacing- mapM_ (boxPackStartDefaults b0) [b01, b02, b03]- fb <- frameNewWithContents "Actions" False $ toWidget b0 : map toWidget [b7, b1, b2, b3, b4, b5, b6, b8]- fa <- frameNewWithContents "Angled Internal Address" True [fa1, fa2, fa3]- fe <- frameNewWithContents "External Angles" True [fe1, fe2]- fh <- frameNewWithContents "Colouring" True [fh1, fh2]- fc <- frameNewWithContents "Coordinates" True [fc1, fc2, fc3]- v <- vBoxNew False spacing- mapM_ (boxPackStartDefaults v) [fc, fa, fe, fh]- h <- hBoxNew False spacing- boxPackStartDefaults h fb- boxPackStartDefaults h v- ww <- windowNew- set ww [ windowIcon := Just icon, windowTitle := "gruff control" ]- containerAdd ww h- mg <- aDoLoad stateFile- gR <- newIORef $ case mg of- Nothing -> initialGruff- Just g -> g- let g0 = GruffGUI- { dStatus = dStatus'- , bHome = bHome'- , bLoad = bLoad'- , bSave = bSave'- , bAddressToCoordinates = bAddressToCoordinates'- , bAddressToIslandChild = bAddressToIslandChild'- , bIslandChildToAddress = bIslandChildToAddress'- , bAddressToAngles = bAddressToAngles'- , bIslandToAngles = bIslandToAngles'- , bLowerAngleToAddress = bLowerAngleToAddress'- , bUpperAngleToAddress = bUpperAngleToAddress'- , bPeriodScan = bPeriodScan'- , eAddress = eAddress'- , eIsland = eIsland'- , eChild = eChild'- , eLowerAngle = eLowerAngle'- , eUpperAngle = eUpperAngle'- , eReal = eReal'- , eImag = eImag'- , eSize = eSize'- , eHueShift = eHueShift'- , eHueScale = eHueScale'- , wMain = ww- , wImage = iw- }- but b a = do- _ <- b g0 `onClicked` wrapA g0 gR a- return ()- butI b a = do- _ <- b g0 `onClicked` (wrapA g0 gR a >> upI)- return ()- butJ b a = do- _ <- b g0 `onClicked` (wrapA' g0 gR a upI)- return ()- ent e a = do- _ <- e g0 `onEntryActivate` (entryGetText (e g0) >>= wrapE g0 gR a)- return ()- entI e a = do- _ <- e g0 `onEntryActivate` (entryGetText (e g0) >>= wrapE g0 gR a >> upI)- return ()- upI = do- g <- readIORef gR- iUpdate (gReal g) (gImag g) (gSize g) (gHueShift g) (gHueScale g)- cUpdate (gReal g) (gImag g) (gSize g)- aUpdate re im z = do- atomicModifyIORef gR $ \g ->- ( g{ gReal = Just re, gImag = Just im, gSize = Just z }, () )- g <- readIORef gR- uReal g0 g- uImag g0 g- uSize g0 g- cUpdate (gReal g) (gImag g) (gSize g)- butI bHome aHome- butI bLoad aLoad- but bSave aSave- butJ bAddressToCoordinates aAddressToCoordinates- but bAddressToIslandChild aAddressToIslandChild- but bIslandChildToAddress aIslandChildToAddress- but bAddressToAngles aAddressToAngles- but bIslandToAngles aIslandToAngles- but bLowerAngleToAddress aLowerAngleToAddress- but bUpperAngleToAddress aUpperAngleToAddress- butJ bPeriodScan aPeriodScan- ent eAddress aAddress- ent eIsland aIsland- ent eChild aChild- ent eLowerAngle aLowerAngle- ent eUpperAngle aUpperAngle- entI eReal aReal- entI eImag aImag- entI eSize aSize- entI eHueShift aHueShift- entI eHueScale aHueScale- let aExit' = (exit (Log.log lg) stateFile =<< readIORef gR)- iInitializeLate aUpdate aExit'- cInitializeLate aExit'- _ <- ww `onDestroy` aExit'- g <- readIORef gR- uEverything g0 g- upI- refreshGUI g0 g- widgetShowAll ww- widgetShowAll cw- widgetShowAll iw- mainGUI--data Gruff = Gruff- { gAddress :: Maybe AngledInternalAddress- , gIsland :: Maybe AngledInternalAddress- , gChild :: Maybe [Angle]- , gLowerAngle :: Maybe Angle- , gUpperAngle :: Maybe Angle- , gReal :: Maybe QuadDouble- , gImag :: Maybe QuadDouble- , gSize :: Maybe QuadDouble- } | Gruff1- { gAddress :: Maybe AngledInternalAddress- , gIsland :: Maybe AngledInternalAddress- , gChild :: Maybe [Angle]- , gLowerAngle :: Maybe Angle- , gUpperAngle :: Maybe Angle- , gReal :: Maybe QuadDouble- , gImag :: Maybe QuadDouble- , gSize :: Maybe QuadDouble- , gHueShift :: Maybe Double- , gHueScale :: Maybe Double- }- deriving (Read, Show)--initialGruff :: Gruff-initialGruff = Gruff1- { gAddress = parse "1"- , gIsland = parse "1"- , gChild = Just []- , gLowerAngle = Just 0- , gUpperAngle = Just 1- , gReal = Just 0- , gImag = Just 0- , gSize = Just 1- , gHueShift = Just 0- , gHueScale = Just 1- }--refreshGUI :: GruffGUI -> Gruff -> IO ()-refreshGUI g0 g = do- can bAddressToCoordinates $ j gAddress- can bAddressToIslandChild $ j gAddress- can bIslandChildToAddress $ j gIsland && j gChild- can bAddressToAngles $ j gAddress- can bIslandToAngles $ j gIsland- can bLowerAngleToAddress $ j gLowerAngle- can bUpperAngleToAddress $ j gUpperAngle- can bPeriodScan $ True- where- can w = widgetSetSensitive (w g0)- j a = isJust (a g)---- button actions--type A = GruffGUI -> Gruff -> IO Gruff-type A' = GruffGUI -> Gruff -> (Gruff -> IO ()) -> IO ()--wrapA :: GruffGUI -> IORef Gruff -> A -> IO ()-wrapA g0 gR a = do- g <- readIORef gR- g' <- a g0 g- writeIORef gR $! g'- refreshGUI g0 g'--wrapA' :: GruffGUI -> IORef Gruff -> A' -> IO () -> IO ()-wrapA' g0 gR a upI = do- g <- readIORef gR- a g0 g $ \g' -> postGUISync $ do- writeIORef gR $! g'- upI- refreshGUI g0 g'--aHome :: A-aHome g0 _ = do- let g = initialGruff- uEverything g0 g- return g--aDoLoad :: FilePath -> IO (Maybe Gruff)-aDoLoad ff = (do- gr <- safeRead `fmap` readFile ff- return $ case gr of- Just (Gruff a b c d e f g h) -> Just (Gruff1 a b c d e f g h (Just 0) (Just 1))- g -> g- ) `catchIO` const (return Nothing)--aLoad :: A-aLoad g0 g = do- fc <- fileChooserDialogNew (Just "gruff load") (Just $ wMain g0) FileChooserActionOpen [("Load", ResponseAccept), ("Cancel", ResponseCancel)]- widgetShow fc- r <- dialogRun fc- g' <- case r of- ResponseAccept -> do- mf <- fileChooserGetFilename fc- case mf of- Nothing -> return g- Just f -> do- mg <- aDoLoad f- case mg of- Nothing -> return g- Just g' -> uEverything g0 g' >> return g'- _ -> return g- widgetDestroy fc- return g'--aDoSave :: FilePath -> Gruff -> IO ()-aDoSave f g = writeFile f (show g) `catchIO` const (return ())--aSave :: A-aSave g0 g = do- fc <- fileChooserDialogNew (Just "gruff save") (Just $ wMain g0) FileChooserActionSave [("Save", ResponseAccept), ("Cancel", ResponseCancel)]- widgetShow fc- r <- dialogRun fc- case r of- ResponseAccept -> do- mf <- fileChooserGetFilename fc- case mf of- Nothing -> return ()- Just f -> aDoSave f g- _ -> return ()- widgetDestroy fc- return g--aPeriodScan :: A'-aPeriodScan g0 g gn = do- statusDialog (dStatus g0) "gruff status" $ \progress -> do- progress "Scanning for period..."- let ps = do- re <- gReal g- im <- gImag g- r <- gSize g- let c = re :+ im- p <- periodScan r c- return (p, r, c)- g' <- case ps of- Just (p, r, c) -> do- progress $ "Scanning for nucleus (" ++ show p ++ ")..."- case periodNucleus p r c of- Just n -> do- progress $ "Computing nucleus (" ++ show p ++ ")..."- case refineNucleus p n of- (z, (re :+ im)) | 10 > z && z > 0 ->- return g{ gReal = Just re, gImag = Just im, gSize = Just (z * 4) }- _ -> return g{ gReal = Nothing, gImag = Nothing, gSize = Nothing }- _ -> return g{ gReal = Nothing, gImag = Nothing, gSize = Nothing }- _ -> return g{ gReal = Nothing, gImag = Nothing, gSize = Nothing }- progress "Done!"- postGUISync $ do- uReal g0 g'- uImag g0 g'- uSize g0 g'- gn g'--aAddressToCoordinates :: A'-aAddressToCoordinates g0 g gn = do- statusDialog (dStatus g0) "gruff status" $ \progress -> do- progress "Splitting address..."- g1 <- aAddressToIslandChild g0 g- progress "Finding external angles..."- g2 <- aIslandToAngles g0 g1- progress "Tracing external rays..."- g' <- aAnglesChildToCoordinates (progress "Computing nucleus...") g0 g2- progress "Done!"- postGUISync $ do- uReal g0 g'- uImag g0 g'- uSize g0 g'- gn g'--aAnglesChildToCoordinates :: IO () -> A-aAnglesChildToCoordinates progress _g0 g = do- case liftM2 (,) (gIsland g) (gLowerAngle g) of- Just (a, lo) ->- let eps = 2 ** negate 48- eps' = 2 ** negate 40- p = addressPeriod a- rlo = externalRay eps 8 (2**24) lo- ok' w = not (nanTest w || infTest w)- ok (w:+x) = ok' w && ok' x- converge [] = Nothing- converge [x] = Just x- converge (x:m@(y:_))- | not $ magnitude (x - y) < eps' = converge m- | otherwise = Just x- rend = converge . takeWhile ok $ rlo- in case rend of- Just c -> progress >> case refineNucleus p c of- (z, (re :+ im)) | z > 0 ->- return g{ gReal = Just re, gImag = Just im, gSize = Just (z * 4) }- _ -> return g{ gReal = Nothing, gImag = Nothing, gSize = Nothing }- Nothing -> return g{ gReal = Nothing, gImag = Nothing, gSize = Nothing }- Nothing -> return g{ gReal = Nothing, gImag = Nothing, gSize = Nothing }--aAddressToIslandChild :: A-aAddressToIslandChild g0 g = do- let g' = fromMaybe g{ gIsland = Nothing, gChild = Nothing } $ do- a <- gAddress g- (i, c) <- splitAddress a- return g{ gIsland = Just i, gChild = Just c }- postGUISync $ uIsland g0 g'- postGUISync $ uChild g0 g'- return g'--aIslandChildToAddress :: A-aIslandChildToAddress g0 g = do- let g' = g{ gAddress = liftM2 joinAddress (gIsland g) (gChild g) }- postGUISync $ uAddress g0 g'- return g'--aAddressToAngles :: A-aAddressToAngles g0 g = do- let (l, u) = case externalAngles =<< gAddress g of- Just (lo, up) -> (Just lo, Just up)- Nothing -> (Nothing, Nothing)- g' = g{ gLowerAngle = l, gUpperAngle = u }- postGUISync $ uLowerAngle g0 g'- postGUISync $ uUpperAngle g0 g'- return g'--aIslandToAngles :: A-aIslandToAngles g0 g = do- let (l, u) = case externalAngles =<< gIsland g of- Just (lo, up) -> (Just lo, Just up)- Nothing -> (Nothing, Nothing)- g' = g{ gLowerAngle = l, gUpperAngle = u }- -- strictness hack to prevent evaluation in gui thread...- case (gLowerAngle g', gUpperAngle g') of- (Just lo, Just up) | lo + up > 0 -> return ()- _ -> return ()- postGUISync $ uLowerAngle g0 g'- postGUISync $ uUpperAngle g0 g'- return g'--aLowerAngleToAddress :: A-aLowerAngleToAddress g0 g = do- let a = angledInternalAddress =<< gLowerAngle g- g' = g{ gAddress = a }- postGUISync $ uAddress g0 g'- return g'--aUpperAngleToAddress :: A-aUpperAngleToAddress g0 g = do- let a = angledInternalAddress =<< gUpperAngle g- g' = g{ gAddress = a }- postGUISync $ uAddress g0 g'- return g'---- entry update--type U = GruffGUI -> Gruff -> IO ()--uEverything, uAddress, uIsland, uChild, uLowerAngle, uUpperAngle, uReal, uImag, uSize :: U-uEverything g0 g = forM_ [uAddress, uIsland, uChild, uLowerAngle, uUpperAngle, uReal, uImag, uSize] $ \u -> u g0 g-uAddress g0 g = do- let s = filter ('"'/=) . show . pretty- entrySetText (eAddress g0) (maybe "" s (gAddress g))-uIsland g0 g = do- let s = filter ('"'/=) . show . pretty- entrySetText (eIsland g0) (maybe "" s (gIsland g))-uChild g0 g = do- let s x = show (numerator x) ++ "/" ++ show (denominator x)- t = unwords . map s- entrySetText (eChild g0) (maybe "" t (gChild g))-uLowerAngle g0 g = do- let s x = show (numerator x) ++ " / " ++ show (denominator x)- entrySetText (eLowerAngle g0) (maybe "" s (gLowerAngle g))-uUpperAngle g0 g = do- let s x = show (numerator x) ++ " / " ++ show (denominator x)- entrySetText (eUpperAngle g0) (maybe "" s (gUpperAngle g))-uReal g0 g = entrySetText (eReal g0) (maybe "" show (gReal g))-uImag g0 g = entrySetText (eImag g0) (maybe "" show (gImag g))-uSize g0 g = entrySetText (eSize g0) (maybe "" show (gSize g))---- entry actions--type E = Gruff -> String -> Gruff--wrapE :: GruffGUI -> IORef Gruff -> E -> String -> IO ()-wrapE g0 gR e s = do- g <- readIORef gR- let g' = e g s- writeIORef gR $! g'- refreshGUI g0 g'--aAddress, aIsland, aChild, aLowerAngle, aUpperAngle, aReal, aImag, aSize, aHueShift, aHueScale :: E-aAddress g s = g{ gAddress = parse s }-aIsland g s = g{ gIsland = parse s }-aChild g s = g{ gChild = parseAngles s }-aLowerAngle g s = g{ gLowerAngle = parseAngle s }-aUpperAngle g s = g{ gUpperAngle = parseAngle s }-aReal g s = g{ gReal = safeRead s }-aImag g s = g{ gImag = safeRead s }-aSize g s = g{ gSize = safeRead s }-aHueShift g s = g{ gHueShift = safeRead s }-aHueScale g s = g{ gHueScale = safeRead s }--minSize :: Size-minSize = Size 160 100
− icon.png
binary file changed (38921 → absent bytes)
− rts.c
@@ -1,1 +0,0 @@-char *ghc_rts_opts = "-N";
+ src/Browser.hs view
@@ -0,0 +1,606 @@+module Browser (Browser(..), browserNew, browserRenders) where++import Prelude hiding (log)+import Control.Concurrent+ ( forkIO, MVar, newMVar, takeMVar, putMVar, tryTakeMVar, threadDelay )+import Control.Monad (foldM, forever, forM_, replicateM, unless, when)+import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef)+import Data.List (sortBy)+import qualified Data.Map as M+import Data.Map (Map)+import Data.Maybe (fromMaybe)+import Data.Ord (comparing)+import qualified Data.Set as S+import Data.Set ((\\))+import Foreign (Ptr, malloc, alloca, peek, poke, nullPtr)+import Foreign.C (CFloat, CInt)+import GHC.Conc (numCapabilities)+import Graphics.Rendering.OpenGL hiding (viewport, Angle, Color, Point, Position, Size)+import qualified Graphics.Rendering.OpenGL as GL+import Graphics.Rendering.OpenGL.Raw+ ( glTexImage2D, gl_TEXTURE_2D, gl_R32F, gl_RGBA, gl_LUMINANCE+ , gl_FLOAT, gl_UNSIGNED_BYTE, gl_FALSE, glClampColor+ , gl_CLAMP_VERTEX_COLOR, gl_CLAMP_READ_COLOR, gl_CLAMP_FRAGMENT_COLOR+ , glGenFramebuffers, glBindFramebuffer, glFramebufferTexture2D+ , gl_FRAMEBUFFER, gl_COLOR_ATTACHMENT0, glGenerateMipmap+ , glGetError+ )+import Graphics.UI.Gtk hiding (get, Window, Viewport, Region, Size, Action, Image)+import qualified Graphics.UI.Gtk as GTK++import Fractal.RUFF.Types.Complex (Complex((:+)))++import Number (R)+import GLUTGtk+ ( GLUTGtk, Size(Size), Key(MouseButton), KeyState(Down), Position(Position)+ , postRedisplay, widget, realizeCallback, reshapeCallback+ , displayCallback, keyboardMouseCallback+ )+import Shader (shader)+import QuadTree (Quad(..))+import Tile (Tile(Tile), getTile, freeTile)+import Logger (Logger, LogLevel(Debug))+import qualified Logger as Log+import Snapshot (writeSnapshot)+import View+ ( Image(..), Location(..), Window(..), Viewport(..)+ , BufferSize(..), bufferSize, tileSize, delta+ , Colours(..), Colour(..), defColours+ , pixelLocation, originQuad, visibleQuads+ , defLocation, defWindow, defViewport+ )+import Paths_gruff (getDataFileName)++type TextureObject3 = (TextureObject, TextureObject, TextureObject)+type QuadList = [(Complex Int, Quad)]+data GruffImage = GruffImage+ { location :: Location+ , window :: Window+ , viewport :: Viewport+ , tiles :: Map Quad TextureObject3+ , queue :: MVar [Tile]+ , jobs :: MVar [Quad]+ , viewQuads :: (QuadList, QuadList)+ , workers :: [Ptr CInt]+ , progress :: Map (Ptr CInt) Quad+ , gl :: GLUTGtk+ , cacheDir :: FilePath+ , log :: LogLevel -> String -> IO ()+ , colours :: Colours+ , prog :: Program+ , combineProg :: Program+ , tsheet0 :: TextureObject+ , tsheet1 :: TextureObject+ , fbo :: GLuint+ , cacheSizeMin :: Int+ , cacheSizeMax :: Int+ -- callbacks+ , exitCallback :: Maybe (IO ())+ , reshapeCallback :: Maybe (Int -> Int -> IO ())+ , mouseCallback :: Maybe (Complex R -> Double -> IO ())+ , doneCallback :: Maybe (IO ())+ , abortCallback :: Maybe (IO ())+ , doClear :: Bool+ }++sheetSize :: GruffImage -> Size+sheetSize g = let s = texels . bufferSize . window $ g in Size s s++zoomPhase :: GruffImage -> Double+zoomPhase = delta . location++rotationA :: GruffImage -> Double+rotationA = orient . viewport++iDisplay :: IORef GruffImage -> IO ()+iDisplay iR = do+ prune iR+ s0 <- readIORef iR+ mtls <- tryTakeMVar (queue s0)+ case mtls of+ Just tls -> do+ putMVar (queue s0) []+ forM_ tls $ \tile@(Tile q ns ds ts) -> do+ tde <- upload ds+ tit <- upload ns+ ttt <- upload ts+ freeTile tile+ atomicModifyIORef iR $ \s' ->+ ( s'{ tiles = M.insert q (tde, tit, ttt) (tiles s')+ , progress = M.filter (/= q) (progress s') }+ , ())+ Nothing -> return ()+ s <- readIORef iR+ log s Debug $ "displayCallback " ++ show (location s)+ c <- atomicModifyIORef iR $ \s' -> (s'{ doClear = False }, doClear s')+ when c $ do+ clearSheet s False+ clearSheet s True+ todo0 <- renderSheet s False+ todo1 <- renderSheet s True+ atomicModifyIORef iR $ \s' -> (s'{ viewQuads = (todo0, todo1) }, ())+ let complete = null todo0 && null todo1+ w = width (window s)+ h = height (window s)+ GL.viewport $=+ (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))+ loadIdentity+ ortho2D 0 (fromIntegral w) 0 (fromIntegral h)+ clearColor $= Color4 0.5 0.5 0.5 1+ clear [ColorBuffer]+ currentProgram $= Just (combineProg s)+ lsheet0 <- get $ uniformLocation (combineProg s) "sheet0"+ lsheet1 <- get $ uniformLocation (combineProg s) "sheet1"+ lblend <- get $ uniformLocation (combineProg s) "blend"+ uniform lsheet0 $= TexCoord1 (0 :: GLint)+ uniform lsheet1 $= TexCoord1 (1 :: GLint)+ uniform lblend $= TexCoord1 (realToFrac (+ let p = negate $ zoomPhase s+ q = 4 -- realToFrac $ supersamples (window s) -- FIXME figure out correct blend+ in 1 - (1 - q**p) / (q**(p + 1) - q**p) ) :: GLfloat)+ activeTexture $= TextureUnit 0+ textureBinding Texture2D $= Just (tsheet0 s)+ activeTexture $= TextureUnit 1+ textureBinding Texture2D $= Just (tsheet1 s)+ let t x0 y0 = texCoord $ TexCoord2 (0.5 + x' :: GLdouble) (0.5 + y' :: GLdouble)+ where+ p = realToFrac . sqrt . aspect . viewport $ s+ x = k * x0 * p+ y = k * y0 / p+ a = - rotationA s+ co = realToFrac $ cos a+ si = realToFrac $ sin a+ x' = co * x + si * y+ y' = -si * x + co * y+ v :: Int -> Int -> IO ()+ v x y = vertex $ Vertex2+ (fromIntegral x :: GLdouble) (fromIntegral y :: GLdouble)+ k = 0.25 * realToFrac (0.5 ** zoomPhase s) :: GLdouble+ renderPrimitive Quads $ do+ t (-1) 1 >> v 0 h+ t (-1) (-1) >> v 0 0+ t 1 (-1) >> v w 0+ t 1 1 >> v w h+ textureBinding Texture2D $= Nothing+ activeTexture $= TextureUnit 0+ textureBinding Texture2D $= Nothing+ currentProgram $= Nothing+ when complete $ case doneCallback s of+ Nothing -> return ()+ Just act -> do+ atomicModifyIORef iR $ \s' -> (s'{ doneCallback = Nothing, abortCallback = Nothing }, ())+ act+ err <- glGetError+ when (err /= 0) $ print ("error: " ++ show err)++clearSheet :: GruffImage -> Bool -> IO ()+clearSheet s b = do+ let Size tw' th' = sheetSize s+ tw = if b then tw' * 2 else tw'+ th = if b then th' * 2 else th'+ tsheet = (if b then tsheet1 else tsheet0) s+ bindFBO (fbo s) tsheet+ GL.viewport $=+ (GL.Position 0 0, GL.Size (fromIntegral tw) (fromIntegral th))+ loadIdentity+ clearColor $= Color4 0 0 1 1+ clear [ColorBuffer]+ unbindFBO+ textureBinding Texture2D $= Just tsheet+ glGenerateMipmap gl_TEXTURE_2D+ textureBinding Texture2D $= Nothing++renderSheet :: GruffImage -> Bool -> IO [(Complex Int, Quad)]+renderSheet s b = do+ let Size tw' th' = sheetSize s+ tw = if b then tw' * 2 else tw'+ th = if b then th' * 2 else th'+ tsheet = (if b then tsheet1 else tsheet0) s+ vquads = (if b then snd else fst) (viewQuads s)+ if null vquads then return [] else do+ bindFBO (fbo s) tsheet+ GL.viewport $=+ (GL.Position 0 0, GL.Size (fromIntegral tw) (fromIntegral th))+ loadIdentity+ ortho2D 0 (fromIntegral tw) 0 (fromIntegral th)+ currentProgram $= Just (prog s)+ lde <- get $ uniformLocation (prog s) "de"+ lit <- get $ uniformLocation (prog s) "it"+ ltt <- get $ uniformLocation (prog s) "tt"+ lint <- get $ uniformLocation (prog s) "interior"+ lbrd <- get $ uniformLocation (prog s) "border"+ lext <- get $ uniformLocation (prog s) "exterior"+ uniform lde $= TexCoord1 (0 :: GLint)+ uniform lit $= TexCoord1 (1 :: GLint)+ uniform ltt $= TexCoord1 (2 :: GLint)+ let (ci, cb, ce) = fromColours $ colours s+ uniform lint $= ci+ uniform lbrd $= cb+ uniform lext $= ce+ todo <- foldM (\a t -> do a' <- drawQuad (tiles s) t ; return (a' ++ a)) [] vquads+ currentProgram $= Nothing+ unbindFBO+ when (length todo < length vquads) $ do+ textureBinding Texture2D $= Just tsheet+ glGenerateMipmap gl_TEXTURE_2D+ textureBinding Texture2D $= Nothing+ return todo++drawQuad :: Map Quad TextureObject3 -> (Complex Int, Quad) -> IO [(Complex Int, Quad)]+drawQuad m ijq@(i :+ j, q) = case q `M.lookup` m of+ Nothing -> return [ijq]+ Just (tde, tit, ttt) -> do+ let t x y = texCoord $ TexCoord2 (x :: GLdouble) (y :: GLdouble)+ v x y = vertex $ Vertex2 (x :: GLdouble) (y :: GLdouble)+ x0 = fromIntegral i+ y0 = fromIntegral j+ x1 = x0 + fromIntegral tileSize+ y1 = y0 + fromIntegral tileSize+ activeTexture $= TextureUnit 0+ textureBinding Texture2D $= Just tde+ activeTexture $= TextureUnit 1+ textureBinding Texture2D $= Just tit+ activeTexture $= TextureUnit 2+ textureBinding Texture2D $= Just ttt+ renderPrimitive Quads $ do+ color $ Color3 1 1 (1::GLdouble)+ t 0 1 >> v x0 y1+ t 0 0 >> v x0 y0+ t 1 0 >> v x1 y0+ t 1 1 >> v x1 y1+ textureBinding Texture2D $= Nothing+ activeTexture $= TextureUnit 1+ textureBinding Texture2D $= Nothing+ activeTexture $= TextureUnit 0+ textureBinding Texture2D $= Nothing+ return []++iReshape :: IORef GruffImage -> Maybe Double -> Size -> IO ()+iReshape iR ms size'@(Size w h) = do+ s' <- readIORef iR+ log s' Debug $ "reshapeCallback " ++ show size'+ let ss = case ms of Nothing -> supersamples (window s') ; Just r -> r+ atomicModifyIORef iR $ \s -> (s{ window = (window s){ width = w, height = h, supersamples = ss }, viewport = (viewport s){ aspect = fromIntegral w / fromIntegral h } }, ())+ s'' <- readIORef iR+ unless (sheetSize s' == sheetSize s'') (reallocateBuffers iR)+ case Browser.reshapeCallback s' of+ Nothing -> return ()+ Just act -> act w h++iMouse :: IORef GruffImage -> Key -> KeyState -> [Modifier] -> Position -> IO ()+iMouse sR (MouseButton LeftButton ) Down _ p@(Position x y) = do+ s <- readIORef sR+ log s Debug $ "leftMouse " ++ show p+ case mouseCallback s of+ Nothing -> return ()+ Just act -> do+ let o = fromPixel s x y+ cx :+ cy = center (location s)+ c = fromRational cx :+ fromRational cy+ r = radius (location s)+ r' = 0.9 * r+ c' = 0.9 * c + 0.1 * o+ act c' r'+iMouse sR (MouseButton MiddleButton) Down _ p@(Position x y) = do+ s <- readIORef sR+ log s Debug $ "middleMouse " ++ show p+ case mouseCallback s of+ Nothing -> return ()+ Just act -> act (fromPixel s x y) (radius (location s))+iMouse sR (MouseButton RightButton ) Down _ p@(Position x y) = do+ s <- readIORef sR+ log s Debug $ "rightMouse " ++ show p+ case mouseCallback s of+ Nothing -> return ()+ Just act -> do+ let o = fromPixel s x y+ cx :+ cy = center (location s)+ c = fromRational cx :+ fromRational cy+ r = radius (location s)+ r' = 1.1 * r+ c' = 1.1 * c - 0.1 * o+ act c' r'+iMouse _ _ _ _ _ = return ()++fromPixel :: GruffImage -> Double -> Double -> Complex R+fromPixel g x y = let r:+i = pixelLocation (window g) (viewport g) (location g) x y in fromRational r :+ fromRational i++quadDistance :: Quad -> Quad -> Double+quadDistance q0 q1 =+ let Quad{ quadLevel = l0, quadWest = r0, quadNorth = i0 } = q0+ Quad{ quadLevel = l, quadWest = r, quadNorth = i} = q1+ dl = sqr (fromIntegral l - fromIntegral l0)+ d x x0+ | l > l0 = fromIntegral $ sqr (x - x0 * 2 ^ (l - l0))+ | l == l0 = fromIntegral $ sqr (x - x0)+ | l < l0 = fromIntegral $ sqr (x0 - x * 2 ^ (l0 - l))+ d _ _ = error "score"+ in dl + d r r0 + d i i0++sqr :: Num a => a -> a+sqr x = x * x++prune :: IORef GruffImage -> IO ()+prune sR = do+ s0 <- readIORef sR+ let cacheSize = M.size (tiles s0)+ when (cacheSize > cacheSizeMax s0) $ do+ log s0 Debug . concat $+ [ "pruning texture cache "+ , show cacheSize, " > ", show (cacheSizeMax s0)+ , " --> ", show (cacheSizeMin s0)+ ]+ bad <- atomicModifyIORef sR $ \s -> + let Just q0 = originQuad (location s) (bufferSize (window s))+ score = quadDistance q0+ o = comparing (score . fst)+ (good, bad)+ = splitAt (cacheSizeMin s) . sortBy o . M.toList . tiles $ s+ in (s{ tiles = M.fromList good }, bad)+ let t (_, (t1, t2, t3)) = [t1, t2, t3]+ deleteObjectNames $ concatMap t bad++update :: IORef GruffImage -> IO ()+update sR = do+ s' <- readIORef sR+ log s' Debug $ "updateCallback "+ todo' <- atomicModifyIORef sR $ \s ->+ let vq@(qs0, qs1) = fromMaybe ([],[]) $ visibleQuads (window s) (viewport s) (location s)+ qs = qs0 ++ qs1+ todo = S.filter (`M.notMember` tiles s) (S.fromList (map snd qs))+ in (s{ viewQuads = vq }, todo)+ -- cancel in-progress jobs that aren't still needed+ _ <- takeMVar (jobs s')+ p <- atomicModifyIORef sR $ \s -> (s{ progress = M.filter (`S.member` todo') (progress s) }, progress s)+ mapM_ (`poke` 1) . filter (\w -> case M.lookup w p of Nothing -> False ; Just q -> q `S.notMember` todo') . workers $ s'+ -- set new jobs+ s <- readIORef sR+ let Just q0 = originQuad (location s) (bufferSize (window s))+ score = quadDistance q0+ putMVar (jobs s') . sortBy (comparing score) . S.toList $ todo' \\ S.fromList (M.elems p)++putTile :: IORef GruffImage -> Ptr CInt -> Tile -> IO ()+putTile sR p t = do+ qu <- atomicModifyIORef sR $ \s ->+ (s{ progress = M.delete p (progress s) }, queue s)+ ts <- takeMVar qu+ putMVar qu (t:ts)++putJobs :: IORef GruffImage -> [Quad] -> IO ()+putJobs sR qs = do+ s <- readIORef sR+ _ <- takeMVar (jobs s)+ putMVar (jobs s) qs++takeJob :: IORef GruffImage -> Ptr CInt -> IO Quad+takeJob sR p = do+ s <- readIORef sR+ qs <- takeMVar (jobs s)+ case qs of+ [] -> do+ putMVar (jobs s) []+ threadDelay 10000+ takeJob sR p+ (q:qs') -> do+ atomicModifyIORef sR $ \s' ->+ ( s'{ progress = M.insert p q (progress s') }, ())+ putMVar (jobs s) qs'+ return q++worker :: IORef GruffImage -> Ptr CInt -> IO ()+worker sR p = forever $ do+ s <- readIORef sR+ q <- takeJob sR p+ mt <- getTile (log s Debug) (cacheDir s) p q+ case mt of+ Nothing -> return ()+ Just t -> putTile sR p t++timer :: IORef GruffImage -> IO ()+timer sR = do+ s <- readIORef sR+ mtls <- tryTakeMVar (queue s)+ case mtls of+ Just tls -> do+ putMVar (queue s) tls+ unless (null tls) $ postRedisplay (gl s)+ _ -> return ()++upload :: Ptr CFloat -> IO TextureObject+upload p = do+ [tex] <- genObjectNames 1+ texture Texture2D $= Enabled+ textureBinding Texture2D $= Just tex+ glTexImage2D gl_TEXTURE_2D 0 (fromIntegral gl_R32F)+ (fromIntegral tileSize) (fromIntegral tileSize) 0+ gl_LUMINANCE gl_FLOAT p+ textureFilter Texture2D $= ((Nearest, Nothing), Nearest)+ textureWrapMode Texture2D S $= (Repeated, ClampToEdge)+ textureWrapMode Texture2D T $= (Repeated, ClampToEdge)+ textureBinding Texture2D $= Nothing+ texture Texture2D $= Disabled+ return tex++msPerFrame :: Int+msPerFrame = 200++data Browser = Browser+ { browserWindow :: GTK.Window+ , browserRender :: Image -> IO () -> IO () -> IO ()+ , browserAbort :: IO ()+ , browserSaveImage :: FilePath -> IO ()+ , browserSetExitCallback :: IO () -> IO ()+ , browserSetReshapeCallback :: (Int -> Int -> IO ()) -> IO ()+ , browserSetMouseCallback :: (Complex R -> Double -> IO ()) -> IO ()+ , browserResize :: Int -> Int -> Double -> IO ()+ }++browserRenders :: Browser -> [(Image, FilePath)] -> IO ()+browserRenders _ [] = print "done"+browserRenders b ((i, f):ifs) = browserRender b i+ (browserSaveImage b f >> browserRenders b ifs)+ (print "aborted")++browserNew :: GLUTGtk -> Pixbuf -> Logger -> FilePath -> IO Browser+browserNew gl' icon lg cacheDir' = do+ -- image window+ iw <- windowNew+ let defW = width defWindow+ defH = height defWindow+ windowSetDefaultSize iw defW defH+ windowSetGeometryHints iw (Nothing `asTypeOf` Just iw) (Just (160, 120)) (Just (2048, 1536)) Nothing Nothing Nothing+ set iw+ [ containerBorderWidth := 0+ , containerChild := widget gl'+ , windowIcon := Just icon+ , windowTitle := "gruff browser"+ ]+ queue' <- newMVar []+ jobs' <- newMVar []+ iR <- newIORef GruffImage+ -- image parameters+ { location = defLocation+ , viewport = defViewport+ , window = defWindow+ , colours = defColours+ -- callbacks+ , exitCallback = Nothing+ , Browser.reshapeCallback = Nothing+ , mouseCallback = Nothing+ , doneCallback = Nothing+ , abortCallback = Nothing+ -- job queue+ , tiles = M.empty+ , queue = queue'+ , jobs = jobs'+ , progress = M.empty+ , viewQuads = ([], [])+ , gl = gl'+ , cacheDir = cacheDir'+ , log = Log.log lg+ , workers = []+ , prog = error "prog"+ , fbo = 0+ , combineProg = error "combineProg"+ , tsheet0 = TextureObject 0+ , tsheet1 = TextureObject 0+ , cacheSizeMin = 1000+ , cacheSizeMax = 1500+ , doClear = False+ }+ realizeCallback gl' $= iRealize iR+ GLUTGtk.reshapeCallback gl' $= iReshape iR Nothing+ displayCallback gl' $= iDisplay iR+ let browserAbort' = do+ i <- readIORef iR+ putJobs iR []+ mapM_ (`poke` 1) . workers $ i+ act <- atomicModifyIORef iR $ \s -> (s{ progress = M.empty, doneCallback = Nothing, abortCallback = Nothing }, abortCallback s)+ fromMaybe (return ()) act+ atExit = do+ i <- readIORef iR+ case exitCallback i of+ Nothing -> return ()+ Just act -> act+ browserRender' img done aborted = do+ atomicModifyIORef iR $ \i -> (i+ { doneCallback = Just done+ , abortCallback = Just aborted+ , location = imageLocation img+ , viewport = imageViewport img+ , window = imageWindow img+ , colours = imageColours img+ , doClear = True+ }, ())+ update iR+ browserSaveImage' fname = do+ s <- readIORef iR+ writeSnapshot fname (GL.Position 0 0) (GL.Size (fromIntegral (width (window s))) (fromIntegral (height (window s))))+ browserSetExitCallback' act = atomicModifyIORef iR $ \i ->+ ( i{ exitCallback = Just act }, () )+ browserSetReshapeCallback' act = atomicModifyIORef iR $ \i ->+ ( i{ Browser.reshapeCallback = Just act }, () )+ browserSetMouseCallback' act = atomicModifyIORef iR $ \i ->+ ( i{ mouseCallback = Just act }, () )+ browserResize' w h s = windowResize iw w h >> iReshape iR (Just s) (Size w h)+ keyboardMouseCallback gl' $= iMouse iR+ _ <- timeoutAdd (timer iR >> return True) msPerFrame+ _ <- iw `onDestroy` atExit+ return Browser+ { browserWindow = iw+ , browserRender = browserRender'+ , browserAbort = browserAbort'+ , browserSaveImage = browserSaveImage'+ , browserSetExitCallback = browserSetExitCallback'+ , browserSetReshapeCallback = browserSetReshapeCallback'+ , browserSetMouseCallback = browserSetMouseCallback'+ , browserResize = browserResize'+ }++fromColours :: Colours -> (Color3 GLfloat, Color3 GLfloat, Color3 GLfloat)+fromColours c =+ ( fromColour (colourInterior c)+ , fromColour (colourBoundary c)+ , fromColour (colourExterior c)+ )++fromColour :: Colour -> Color3 GLfloat+fromColour (Colour r g b) = Color3 (realToFrac r) (realToFrac g) (realToFrac b)++iRealize :: IORef GruffImage -> IO ()+iRealize iR = do+ s <- readIORef iR+ log s Debug "realizeCallback"+ drawBuffer $= BackBuffers+ glClampColor gl_CLAMP_VERTEX_COLOR gl_FALSE+ glClampColor gl_CLAMP_READ_COLOR gl_FALSE+ glClampColor gl_CLAMP_FRAGMENT_COLOR gl_FALSE+ f <- getDataFileName "minimal.frag"+ prog' <- shader Nothing (Just f)+ f' <- getDataFileName "merge.frag"+ combineProg' <- shader Nothing (Just f')+ fbo' <- newFBO+ [tsheet0', tsheet1'] <- genObjectNames 2+ ps <- replicateM numCapabilities $ do+ p <- malloc+ _ <- forkIO (worker iR p)+ return p+ atomicModifyIORef iR $ \i -> (i+ { prog = prog'+ , workers = ps+ , fbo = fbo'+ , combineProg = combineProg'+ , tsheet0 = tsheet0'+ , tsheet1 = tsheet1'+ }, ())+ reallocateBuffers iR++reallocateBuffers :: IORef GruffImage -> IO ()+reallocateBuffers iR = do+ s <- readIORef iR+ let Size tw' th' = sheetSize s+ ts = [tsheet0 s, tsheet1 s]+ forM_ (ts `zip` [(tw', th'), (tw' * 2, th' * 2)]) $ \(t, (tw, th)) -> do+ texture Texture2D $= Enabled+ textureBinding Texture2D $= Just t+ glTexImage2D gl_TEXTURE_2D 0 (fromIntegral gl_RGBA)+ (fromIntegral tw) (fromIntegral th) 0 gl_RGBA gl_UNSIGNED_BYTE+ nullPtr+ textureFilter Texture2D $= ((Linear', Just Linear'), Linear')+ textureWrapMode Texture2D S $= (Repeated, ClampToEdge)+ textureWrapMode Texture2D T $= (Repeated, ClampToEdge)+ textureBinding Texture2D $= Nothing+ texture Texture2D $= Disabled++newFBO :: IO GLuint+newFBO = alloca $ \p -> glGenFramebuffers 1 p >> peek p++bindFBO :: GLuint -> TextureObject -> IO ()+bindFBO f (TextureObject t) = do+ glBindFramebuffer gl_FRAMEBUFFER f+ glFramebufferTexture2D gl_FRAMEBUFFER gl_COLOR_ATTACHMENT0 gl_TEXTURE_2D t 0++unbindFBO :: IO ()+unbindFBO = do+ glFramebufferTexture2D gl_FRAMEBUFFER gl_COLOR_ATTACHMENT0 gl_TEXTURE_2D 0 0+ glBindFramebuffer gl_FRAMEBUFFER 0
+ src/GLUTGtk.hs view
@@ -0,0 +1,71 @@+module GLUTGtk where++import Control.Monad (join)+import Control.Monad.Trans (liftIO)+import Data.IORef (IORef, newIORef, readIORef)+import Graphics.UI.Gtk hiding (Size)+import Graphics.UI.Gtk.OpenGL++type RealizeCallback = IO ()+type ReshapeCallback = Size -> IO ()+type DisplayCallback = IO ()+type KeyboardMouseCallback = Key -> KeyState -> [Modifier] -> Position -> IO ()++data Size = Size Int Int+ deriving (Eq, Ord, Show)++data Position = Position Double Double+ deriving (Eq, Ord, Show)++data KeyState = Down | Up+ deriving (Eq, Ord, Show)++data Key = Char Char | MouseButton MouseButton+ deriving (Eq, Show)++data GLUTGtk = GLUTGtk+ { realizeCallback :: IORef RealizeCallback+ , reshapeCallback :: IORef ReshapeCallback+ , displayCallback :: IORef DisplayCallback+ , keyboardMouseCallback :: IORef KeyboardMouseCallback+ , postRedisplay :: IO ()+ , widget :: EventBox+ }++glut :: Size -> IO GLUTGtk+glut (Size width height) = do+ realizeCallback' <- newIORef $ return ()+ displayCallback' <- newIORef $ return ()+ reshapeCallback' <- newIORef $ \_ -> return ()+ keyboardMouseCallback' <- newIORef $ \_ _ _ _ -> return ()+ config <- glConfigNew [ GLModeRGBA, GLModeDouble ]+ canvas <- glDrawingAreaNew config+ widgetSetSizeRequest canvas width height+ eventb <- eventBoxNew+ set eventb [ containerBorderWidth := 0, containerChild := canvas ]+ _ <- onRealize canvas $ withGLDrawingArea canvas $ \_ -> join (readIORef realizeCallback')+ _ <- canvas `on` configureEvent $ tryEvent $ do+ (w, h) <- eventSize+ liftIO $ do+ cb <- readIORef reshapeCallback'+ cb (Size w h)+ _ <- canvas `on` exposeEvent $ tryEvent $ liftIO $ withGLDrawingArea canvas $ \gl -> do+ join (readIORef displayCallback')+ glDrawableSwapBuffers gl+ let handleButton s = do+ b <- eventButton+ (x, y) <- eventCoordinates+ ms <- eventModifier+ liftIO $ do+ cb <- readIORef keyboardMouseCallback'+ cb (MouseButton b) s ms (Position x y)+ _ <- eventb `on` buttonPressEvent $ tryEvent $ handleButton Down+ _ <- eventb `on` buttonReleaseEvent $ tryEvent $ handleButton Up+ return $ GLUTGtk+ { realizeCallback = realizeCallback'+ , displayCallback = displayCallback'+ , reshapeCallback = reshapeCallback'+ , keyboardMouseCallback = keyboardMouseCallback'+ , postRedisplay = widgetQueueDraw canvas+ , widget = eventb+ }
+ src/Logger.hs view
@@ -0,0 +1,44 @@+module Logger where++import Prelude hiding (log)+import Control.Concurrent (forkIO, newChan, readChan, writeChan)+import Control.Monad (when)+import Data.Time (formatTime, getCurrentTime, UTCTime)+import System.Locale (defaultTimeLocale)+import System.FilePath ((</>), (<.>))+import System.IO (openFile, IOMode(WriteMode), hPutStrLn, hClose, hFlush)++data LogLevel = Error | Warn | Info | Debug+ deriving (Read, Show, Eq, Ord, Enum, Bounded)++defLogLevel :: LogLevel+defLogLevel = Info++data Logger = Logger+ { log :: LogLevel -> String -> IO ()+ , close :: IO ()+ }++logger :: FilePath -> IO Logger+logger logDir = do+ date <- getDate+ let logFile = logDir </> filter (':'/=) date <.> "log"+ h <- openFile logFile WriteMode+ c <- newChan+ let log' lvl msg = when (lvl <= defLogLevel) $ do+ d <- getDate+ writeChan c (Just $ d ++ "\t" ++ show lvl ++ "\t" ++ show msg)+ close' = log' Info "closing log" >> writeChan c Nothing+ writer = do+ m <- readChan c+ case m of+ Nothing -> hClose h >> return ()+ Just s -> hPutStrLn h s >> hFlush h >> writer+ _ <- forkIO writer+ log' Info "opening log"+ return Logger{ log = log', close = close' }+ where+ logFormat :: UTCTime -> String+ logFormat = formatTime defaultTimeLocale "%FT%T"+ getDate :: IO String+ getDate = logFormat `fmap` getCurrentTime
+ src/MuAtom.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE BangPatterns #-}+module MuAtom(MuAtom(..), MuProgress(..), muFromAddress, MuProgress'(..), muToAddress, MuProgress''(..), muLocate) where++import Control.Arrow ((***))+import Data.Ratio ((%))+import Data.Vec (NearZero, nearZero)++import Fractal.RUFF.Mandelbrot.Address (AngledInternalAddress, Angle, splitAddress, addressPeriod, externalAngles, angledInternalAddress)+import Fractal.RUFF.Mandelbrot.Nucleus (findNucleus, findBond, findPeriod)+import Fractal.RUFF.Mandelbrot.Ray (externalRay, externalRayOut)+import Fractal.RUFF.Types.Complex (Complex, magnitude, magnitude2, phase, mkPolar)++import Number (R)++data MuAtom = MuAtom+ { muNucleus :: !(Complex R)+ , muSize :: !Double+ , muOrient :: !Double+ , muPeriod :: !Integer+ }+ deriving (Read, Show, Eq)++data MuProgress+ = MuSplitTodo+ | MuSplitDone AngledInternalAddress [Angle]+ | MuAnglesTodo+ | MuAnglesDone !Rational !Rational+ | MuRayTodo+ | MuRay !Integer+ | MuRayDone !(Complex R)+ | MuNucleusTodo+ | MuNucleus !Integer+ | MuNucleusDone !(Complex R)+ | MuBondTodo+ | MuBond !Integer+ | MuBondDone !(Complex R)+ | MuSuccess !MuAtom+ | MuFailed+ deriving (Read, Show, Eq)++muFromAddress :: AngledInternalAddress -> [MuProgress]+muFromAddress addr = MuSplitTodo :+ let (!iaddr, !caddr) = splitAddress addr+ !p = addressPeriod iaddr+ in MuSplitDone iaddr caddr : MuAnglesTodo : case externalAngles iaddr of+ Nothing -> [MuFailed]+ Just (!lo, !hi) -> MuAnglesDone lo hi : MuRayTodo :+ let sharpness = 8+ er = 65536+ accuracy = 1e-10+ ok w = magnitude2 w < 2 * er ^ (2::Int) -- NaN -> False+ rayl = externalRay accuracy sharpness er lo+ rayh = externalRay accuracy sharpness er hi+ ray' = takeWhile (uncurry (&&) . (ok *** ok) . snd) $ [ 1 .. ] `zip` (rayl `zip` rayh)+ rgo [] _ = [MuFailed]+ rgo [_] _ = [MuFailed]+ rgo ((i, (xl, xh)):m@((_, (yl, yh)):_)) f+ | i < fromIntegral sharpness * (p + 16) = MuRay i : rgo m f+ | dl + dh > dx + dy = MuRay i : rgo m f+ | otherwise = MuRayDone x : f x+ where+ x = 0.5 * (xl + xh)+ dl = magnitude2 (xl - yl)+ dh = magnitude2 (xh - yh)+ dx = magnitude2 (xl - xh)+ dy = magnitude2 (yl - yh)+ in rgo ray' $ \rayend -> MuNucleusTodo :+ let nuc = findNucleus p rayend+ nuc' = takeWhile (ok . snd) $ [ 1 .. ] `zip` nuc+ ngo [] _ = [MuFailed]+ ngo [_] _ = [MuFailed]+ ngo ((i, x):m@((_, y):_)) f+ | not (nearZero (x - y)) = MuNucleus i : ngo m f+ | otherwise = MuNucleusDone x : f x+ in ngo nuc' $ \nucleus -> MuBondTodo :+ let bnd = findBond p nucleus 0.5+ bnd' = takeWhile (ok . snd) $ [ 1.. ] `zip` bnd+ bgo [] _ = [MuFailed]+ bgo [_] _ = [MuFailed]+ bgo ((i, x):m@((_, y):_)) f+ | not (nearZero (x - y)) = MuBond i : bgo m f+ | otherwise = MuBondDone x : f x+ in bgo bnd' $ \bond ->+ let delta = bond - nucleus+ size = realToFrac $ magnitude delta / 0.75+ orient = realToFrac $ phase delta+ atom = MuAtom{ muNucleus = nucleus, muSize = size, muOrient = orient, muPeriod = p }+ in if 10 > size && size > 0 then [MuSuccess atom] else [MuFailed]++data MuProgress'+ = MuCuspTodo+ | MuCuspDone !(Complex R)+ | MuDwellTodo+ | MuDwell !Integer+ | MuDwellDone !Integer+ | MuRayOutTodo+ | MuRayOut !Double+ | MuRayOutDone !(Complex R)+ | MuExternalTodo+ | MuExternalDone !Rational+ | MuAddressTodo+ | MuSuccess' AngledInternalAddress+ | MuFailed'+ deriving (Read, Show, Eq)++muToAddress :: MuAtom -> [MuProgress']+muToAddress mu = MuCuspTodo :+ let cusp = muNucleus mu - mkPolar (realToFrac (muSize mu)) (realToFrac ((muOrient mu)))+ er = 65536+ er2 = er * er+ in MuCuspDone cusp : MuDwellTodo :+ let dgo z n f = MuDwell n : if magnitude2 z > er2 then f n else dgo (z * z + cusp) (n + 1) f+ in dgo 0 0 $ \n -> MuDwellDone n : MuRayOutTodo :+ let rgo ((i,!_):izs@(_:_)) f = MuRayOut (fromIntegral i / (fromIntegral sharpness * fromIntegral n)) : rgo izs f+ rgo [(_,!z)] f | magnitude2 z > er2 = MuRayOutDone z : f z+ rgo _ _ = [MuFailed']+ accuracy = 1e-16+ sharpness = 16+ epsilon0 = realToFrac (muSize mu) * accuracy+ in rgo ([(1 :: Integer) ..] `zip` externalRayOut (fromIntegral n + 100) epsilon0 accuracy sharpness er cusp) $ \rend -> MuExternalTodo :+ let den = 2 ^ muPeriod mu - 1+ num' = fromIntegral den * warp (phase rend / (2 * pi))+ num = round num'+ warp t+ | t > 0 = t+ | otherwise = t + 1+ angle = num % den+ in MuExternalDone angle : MuAddressTodo : case angledInternalAddress angle of+ Nothing -> [MuFailed']+ Just addr -> if addressPeriod addr /= muPeriod mu then [MuFailed'] else [MuSuccess' addr]++data MuProgress''+ = MuScanTodo+ | MuScan+ | MuScanDone !Integer+ | MuNucleusTodo'+ | MuNucleus' !Integer+ | MuNucleusDone' !(Complex R)+ | MuBondTodo'+ | MuBond' !Integer+ | MuBondDone' !(Complex R)+ | MuSuccess'' !MuAtom+ | MuFailed''+ deriving (Read, Show, Eq)++muLocate :: Complex R -> Double -> [MuProgress'']+muLocate c r = MuScanTodo : MuScan : case findPeriod 10000000 (realToFrac r) c of+ Nothing -> [MuFailed'']+ Just p -> MuScanDone p : MuNucleusTodo' :+ let ok w = magnitude2 w < 16 -- NaN -> False+ nuc = findNucleus p c+ nuc' = takeWhile (ok . snd) $ [ 1 .. ] `zip` nuc+ ngo [] _ = [MuFailed'']+ ngo [_] _ = [MuFailed'']+ ngo ((i, x):m@((_, y):_)) f+ | not (nearZero (x - y)) = MuNucleus' i : ngo m f+ | otherwise = MuNucleusDone' x : f x+ in ngo nuc' $ \nucleus -> MuBondTodo' :+ let bnd = findBond p nucleus 0.5+ bnd' = takeWhile (ok . snd) $ [ 1.. ] `zip` bnd+ bgo [] _ = [MuFailed'']+ bgo [_] _ = [MuFailed'']+ bgo ((i, x):m@((_, y):_)) f+ | not (nearZero (x - y)) = MuBond' i : bgo m f+ | otherwise = MuBondDone' x : f x+ in bgo bnd' $ \bond ->+ let delta = bond - nucleus+ size = realToFrac $ magnitude delta / 0.75+ orient = realToFrac $ phase delta+ atom = MuAtom{ muNucleus = nucleus, muSize = size, muOrient = orient, muPeriod = p }+ in if 10 > size && size > 0 then [MuSuccess'' atom] else [MuFailed'']
+ src/Number.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}+module Number (R, toRational') where++import Data.Bits (bit)+import Data.Ratio ((%))+import Data.Vec (NearZero(nearZero))+import Fractal.RUFF.Types.Complex (Complex((:+)))++#ifdef HAVE_MPFR++import Control.Monad (guard)+import Data.Ratio (numerator, denominator)+import Numeric (readSigned)+import Data.Number.MPFR (MPFR, RoundMode(Near, Up), Precision, getPrec, int2w, fromIntegerA, stringToMPFR_, toString)+import Data.Number.MPFR.Instances.Near ()++#else++import Numeric.QD (QuadDouble(QuadDouble))+import Numeric.QD.Vec ()++#endif++#ifdef HAVE_MPFR++instance NearZero MPFR where+ nearZero x = let p = getPrec x in not (abs x > int2w Up p 1 (4 - fromIntegral p))++newtype R = R MPFR+ deriving (Eq, Ord, Floating, Real, RealFrac, NearZero)++instance Num R where+ R a + R b = R (a + b)+ R a * R b = R (a * b)+ R a - R b = R (a - b)+ negate (R a) = R (negate a)+ abs (R a) = R (abs a)+ signum (R a) = R (signum a)+ fromInteger i = R (fromIntegerA Near bits i)++instance Fractional R where+ R a / R b = R (a / b)+ recip (R a) = R (recip a)+ fromRational r = R (fromIntegerA Near bits (numerator r) / fromIntegerA Near bits (denominator r))++instance Read R where+ readsPrec _ = readParen False . readSigned $ \s -> do+ (f, r) <- lex s+ let (n, k) = stringToMPFR_ Near bits 10 f+ guard (k == 0)+ return (R n, r)++instance Show R where+ show (R m) = toString (ceiling $ (2::Double) + log 2 / log 10 * fromIntegral (getPrec m)) m++bits :: Precision+bits = 1000++#else++newtype R = R QuadDouble+ deriving (Eq, Ord, Num, Fractional, Floating, Real, RealFrac, NearZero)++instance Show R where+ show (R m) = show m++instance Read R where+ readsPrec p = map (\(m, s) -> (R m, s)) . readsPrec p++#endif++toRational' :: RealFrac a => Int -> a -> Rational+toRational' l a = round (a * fromInteger b) % b+ where b = bit (l + 16)++instance NearZero r => NearZero (Complex r) where+ nearZero (r:+i) = nearZero r && nearZero i
+ src/QuadTree.hs view
@@ -0,0 +1,110 @@+module QuadTree+ ( Child(..), north, south, west, east+ , Quad(..), root, child, children, parent, parents+ , filename, unsafeName+ , Square(..), square, Point(..), contains, Region(..), expand, outside+ , quads+ ) where++import Data.Bits (bit, shiftL, shiftR, testBit, (.|.))+import Data.List (unfoldr, sort)+import Data.Ratio ((%))++data Child = NorthWest | NorthEast | SouthWest | SouthEast+ deriving (Read, Show, Eq, Ord, Enum, Bounded)++north, south, west, east :: Child -> Bool+east c = fromEnum c `testBit` 0+south c = fromEnum c `testBit` 1+north = not . south+west = not . east++data Quad = Quad{ quadLevel :: !Int, quadWest, quadNorth :: !Integer }+ deriving (Read, Show, Eq, Ord)++root :: Quad+root = Quad{ quadLevel = 0, quadWest = 0, quadNorth = 0 }++child :: Child -> Quad -> Quad+child c Quad{ quadLevel = l, quadWest = x, quadNorth = y } = Quad+ { quadLevel = l + 1+ , quadWest = x `shiftL` 1 .|. (fromIntegral . fromEnum . east ) c+ , quadNorth = y `shiftL` 1 .|. (fromIntegral . fromEnum . south) c+ }++children :: [Child] -> Quad+children = foldr child root++parent :: Quad -> Maybe (Child, Quad)+parent Quad{ quadLevel = l, quadWest = x, quadNorth = y }+ | l > 0 = Just+ ( toEnum (fromEnum (y `testBit` 0) `shiftL` 1 .|. fromEnum (x `testBit` 0))+ , Quad{ quadLevel = l - 1, quadWest = x `shiftR` 1, quadNorth = y `shiftR` 1 }+ )+ | otherwise = Nothing++parents :: Quad -> [Child]+parents = unfoldr parent++filename :: Quad -> Maybe ([FilePath], FilePath)+filename q+ | not (0 <= quadNorth q && quadNorth q < bit (quadLevel q) && 0 <= quadWest q && quadWest q < bit (quadLevel q)) = Nothing+ | null cs = Nothing+ | otherwise = Just (init cs, last cs)+ where+ cs = chunk 2 . map unsafeName . chunk 2 . reverse . parents $ q++unsafeName :: [Child] -> Char+unsafeName [c] = ['a'..'d'] !! (fromEnum c)+unsafeName [c,d] = ['e'..'t'] !! (fromEnum c `shiftL` 2 .|. fromEnum d)+unsafeName _ = error "QuadTree.unsafeName"++chunk :: Int -> [a] -> [[a]]+chunk _ [] = []+chunk n xs = let (ys, zs) = splitAt n xs in ys : chunk n zs++data Square = Square{ squareSize, squareWest, squareNorth :: !Rational }+ deriving (Read, Show, Eq, Ord)++square :: Square -> Quad -> Square+square Square{ squareSize = s0, squareWest = x0, squareNorth = y0 } Quad{ quadLevel = l, quadWest = x, quadNorth = y } =+ Square{ squareSize = s0 / fromInteger r, squareWest = x0 + s0 * (x % r), squareNorth = y0 + s0 * (y % r) } where r = bit l++data Region = Region{ regionNorth, regionSouth, regionWest, regionEast :: !Rational }+ deriving (Read, Show, Eq, Ord)++expand :: Rational -> Region -> Region+expand f r =+ let (x, y ) = ((regionEast r + regionWest r) / 2, (regionNorth r + regionSouth r) / 2)+ (rx, ry) = ((regionEast r - regionWest r) / 2, (regionNorth r - regionSouth r) / 2)+ in Region{ regionNorth = y + f * ry, regionSouth = y - f * ry, regionEast = x + f * rx, regionWest = x - f * rx }++outside :: Region -> Square -> Bool+outside r s+ = regionSouth r < squareNorth s+ || regionEast r < squareWest s+ || regionNorth r > squareNorth s + squareSize s+ || regionWest r > squareWest s + squareSize s++data Point = Point{ pointWest, pointNorth :: !Rational }+ deriving (Read, Show, Eq, Ord)++contains :: Point -> Square -> Bool+contains p s+ = squareNorth s <= pointNorth p && pointNorth p <= squareNorth s + squareSize s+ && squareWest s <= pointWest p && pointWest p <= squareWest s + squareSize s++quads :: Square -> Region -> Int -> [Quad]+quads rootSquare region level =+ [ Quad{ quadLevel = level, quadWest = w, quadNorth = n }+ | n <- [ floor nlo' .. ceiling nhi' - 1]+ , w <- [ floor wlo' .. ceiling whi' - 1]+ ]+ where+ [nlo', nhi'] = sort [nlo, nhi]+ [wlo', whi'] = sort [wlo, whi]+ nlo = (regionSouth region - squareNorth rootSquare) / squareSize rootSquare * l+ nhi = (regionNorth region - squareNorth rootSquare) / squareSize rootSquare * l+ wlo = (regionWest region - squareWest rootSquare) / squareSize rootSquare * l+ whi = (regionEast region - squareWest rootSquare) / squareSize rootSquare * l+ l = bit level % 1
+ src/Shader.hs view
@@ -0,0 +1,29 @@+module Shader (shader) where++import Graphics.Rendering.OpenGL++shader :: Maybe FilePath -> Maybe FilePath -> IO Program+shader mV mF = do+ [p] <- genObjectNames 1+ vs <- case mV of+ Nothing -> return []+ Just v -> do+ [vert] <- genObjectNames 1+ source <- readFile v+ shaderSource vert $= [ source ]+ compileShader vert+-- print =<< get (shaderInfoLog vert)+ return [vert]+ fs <- case mF of+ Nothing -> return []+ Just f -> do+ [frag] <- genObjectNames 1+ source <- readFile f+ shaderSource frag $= [ source ]+ compileShader frag+-- print =<< get (shaderInfoLog frag)+ return [frag]+ attachedShaders p $= (vs, fs)+ linkProgram p+-- print =<< get (programInfoLog p)+ return p
+ src/Snapshot.hs view
@@ -0,0 +1,35 @@+module Snapshot (hSnapshot, writeSnapshot, snapshotWith) where++import Control.Monad(forM_)+import System.IO(Handle())+import Graphics.Rendering.OpenGL(+ readPixels,+ Position,+ Size(Size),+ PixelData(PixelData),+ PixelFormat(RGB),+ DataType(UnsignedByte))+import Foreign.Marshal.Alloc(allocaBytes)+import Foreign.Ptr(plusPtr)+import qualified Data.ByteString.Internal as BSI+import qualified Data.ByteString as BS++-- save a screenshot to a handle as binary PPM+snapshotWith :: (BS.ByteString -> IO b) -> Position -> Size -> IO b+snapshotWith f p0 vp@(Size vw vh) = do+ let fi q = fromIntegral q+ p6 = "P6\n" ++ show vw ++ " " ++ show vh ++ " 255\n"+ allocaBytes (fi (vw*vh*3)) $ \ptr -> do+ readPixels p0 vp $ PixelData RGB UnsignedByte ptr+ px <- BSI.create (fi $ vw * vh * 3) $ \d -> forM_ [0..vh-1] $ \y ->+ BSI.memcpy+ (d`plusPtr`fi(y*vw*3))+ (ptr`plusPtr`fi ((vh-1-y)*vw*3))+ (fi(vw*3))+ f $ BS.pack (map (toEnum . fromEnum) p6) `BS.append` px++hSnapshot :: Handle -> Position -> Size -> IO ()+hSnapshot h = snapshotWith (BS.hPutStr h)++writeSnapshot :: FilePath -> Position -> Size -> IO ()+writeSnapshot f = snapshotWith (BS.writeFile f)
+ src/StatusDialog.hs view
@@ -0,0 +1,31 @@+module StatusDialog where++import Control.Concurrent (forkIO, killThread)+import Graphics.UI.Gtk++type Status = (String -> IO ()) -> IO ()+data StatusDialog = StatusDialog{ statusDialog :: String -> Status -> IO () }++statusDialogNew :: IO StatusDialog+statusDialogNew = do+ window <- windowNew+ windowSetModal window True+ windowSetDefaultSize window 320 200+ b <- vBoxNew False 2+ label <- labelNew (Just "")+ cancel <- buttonNewWithLabel "Cancel"+ boxPackStartDefaults b label+ boxPackStartDefaults b cancel+ set window [ containerChild := b ]+ return StatusDialog{ statusDialog = \title task -> do+ windowSetTitle window title+ labelSetText label ""+ widgetSetSensitivity cancel True+ child <- forkIO $ do+ task $ postGUIAsync . labelSetText label+ postGUISync $ widgetHide window+ _ <- cancel `onClicked` do+ killThread child+ widgetHide window+ widgetShowAll window+ }
+ src/Tile.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+module Tile where++import Prelude hiding (log)++import Control.Exception (bracketOnError)+import Control.Monad (when)+import Data.Bits (shiftL, shiftR, (.&.))+import Foreign (Ptr, castPtr, sizeOf, mallocArray, free, Word8, with, poke, allocaBytes, withArray, peekArray)+import Foreign.C (CFloat, CDouble, CInt, CSize, withCStringLen)+import System.Directory (createDirectoryIfMissing)+import System.FilePath ((</>), (<.>))+import System.IO (withBinaryFile, IOMode(ReadMode,WriteMode), hPutBuf, hGetBuf)+--import Data.BEncode+import Numeric.QD (DoubleDouble, QuadDouble)+#ifdef HAVE_MPFR+import Foreign.C (CString, withCString)+import Number (R)+#endif++import QuadTree+import Utils (catchIO)++width, height, count, bytes :: Int+width = 256+height = 256+count = width * height+bytes = count * sizeOf (0 :: CFloat)++rootSquare :: Square+rootSquare = Square{ squareSize = 8, squareWest = -4, squareNorth = -4 }++data Tile = Tile Quad (Ptr CFloat) (Ptr CFloat) (Ptr CFloat)++mallocTile :: Quad -> IO Tile+mallocTile cs = do+ ns <- mallocArray count+ ds <- mallocArray count+ ts <- mallocArray count+ return $ Tile cs ns ds ts++freeTile :: Tile -> IO ()+freeTile (Tile _ ns ds ts) = do+ free ns+ free ds+ free ts++header :: String+header = "RuFfTiLe001\n"++writeTile :: FilePath -> Tile -> IO ()+writeTile cacheDir (Tile q ns ds ts) = do+ case filename q of+ Nothing -> return ()+ Just (dirs, file) -> do+ let dir = foldr1 (</>) (cacheDir : dirs)+ createDirectoryIfMissing True dir+ withBinaryFile (dir </> file <.> "ruff") WriteMode $ \h -> do+ withCStringLen header $ \(p, l) -> hPutBuf h p l+ withArray (wordBE (bytes * 3)) $ \p -> hPutBuf h p 4+ hPutBuf h ns bytes+ hPutBuf h ds bytes+ hPutBuf h ts bytes+-- hPut h . bPack . metaData $ q+ where+ wordBE :: Int -> [Word8]+ wordBE n = map (\b -> fromIntegral $ (n `shiftR` (8 * b)) .&. 0xFF) [3, 2, 1, 0]++{-+metaData :: Quad -> BEncode+metaData q@Quad{ quadLevel = l, quadWest = w, quadNorth = n } =+ BDict $ fromList [ ("tile", BDict $ fromList+ [ ("about", BDict $ fromList+ [ ("version", BInt 1)+ , ("generator", BString $ pack "gruff-0.1") ]+ , ("images", BDict . fromList . map image . zip [0..] $+ [ "continuous dwell", "normalized distance", "final angle"]) ]+ ]+ where+ image plane alg = (alg, BDict $ fromList+ [ ("width", BInt (fromIntegral width))+ , ("height", BInt (fromIntegral height))+ , ("real", BInt w)+ , ("imag", BInt (negate n))+ , ("scale", BInt (fromIntegral l + 2))+ , ("format", BString $ pack "float32le")+ , ("order", BString $ pack "lr,tb")+ , ("data offset", BInt (fromIntegral $ plane * count * sizeOf (0 :: CFloat)))+ ])+-}++readTile :: FilePath -> Quad -> IO (Maybe Tile)+readTile cacheDir q = flip catchIO (\_ -> return Nothing) $ do+ case filename q of+ Nothing -> return Nothing+ Just (dirs, file) -> do+ let dir = foldr1 (</>) (cacheDir : dirs)+ bracketOnError (mallocTile q) freeTile $ \t@(Tile _ ns ds ts) -> do+ withBinaryFile (dir </> file <.> "ruff") ReadMode $ \h -> do+ let headerBytes = 12+ allocaBytes headerBytes $ \p -> do+ headerBytes' <- hGetBuf h p headerBytes+ when (headerBytes /= headerBytes') $ fail "readTile header fail"+ header' <- peekArray headerBytes p+ when (header' /= (map (fromIntegral . fromEnum) header :: [Word8])) $ fail "readTile header mismatch"+ dataBytes <- allocaBytes 4 $ \p -> do+ lenBytes' <- hGetBuf h p 4+ when (lenBytes' /= 4) $ fail "readTile header length fail"+ unwordBE `fmap` peekArray 4 p+ when (dataBytes /= bytes * 3) $ fail "readTile header length mismatch"+ bytes' <- hGetBuf h ns bytes+ when (bytes /= bytes') $ fail ("readTile 0 " ++ show bytes ++ " /= " ++ show bytes')+ bytes'' <- hGetBuf h ds bytes+ when (bytes /= bytes'') $ fail ("readTile 1 " ++ show bytes ++ " /= " ++ show bytes'')+ bytes''' <- hGetBuf h ts bytes+ when (bytes /= bytes''') $ fail ("readTile 2 " ++ show bytes ++ " /= " ++ show bytes''')+ return $ Just t+ where+ unwordBE :: [Word8] -> Int+ unwordBE = sum . zipWith (\b n -> fromIntegral n `shiftL` (8 * b)) [3, 2, 1, 0]++clearTile :: Tile -> IO ()+clearTile (Tile _ ns ds ts) = do+ mapM_ clear [ns, ds, ts]+ where+ clear p = c_memset (castPtr p) 0 (fromIntegral bytes)++computeTile :: (String -> IO ()) -> Ptr CInt -> Tile -> IO Bool+computeTile log p (Tile q@Quad{ quadLevel = l } ns ds ts) = do+ its <- compute'+ log $ show ("getTile", q, "computed", its)+ return $ its /= 0+ where+ compute'+ | l < 18 = c_compute_f32 p ns ds ts cx cy l' m'+ | l < 48 = c_compute_f64 p ns ds ts cx cy l' m'+ | l < 96 = with (cx :: DoubleDouble) $ \px -> with (cy :: DoubleDouble) $ \py ->+ c_compute_f128 p ns ds ts (castPtr px) (castPtr py) l' m'+ | l < 192 = with (cx :: QuadDouble ) $ \px -> with (cy :: QuadDouble ) $ \py ->+ c_compute_f256 p ns ds ts (castPtr px) (castPtr py) l' m'+#ifdef HAVE_MPFR+ | otherwise = withCString (show (cx :: R)) $ \px -> withCString (show (cy :: R)) $ \py ->+ c_compute_mpfr p ns ds ts px py l' m'+#else+ | otherwise = error "Tile.computeTile: too deep; recompile with MPFR"+#endif+ l' = fromIntegral l+ m' = 10000000+ s = square rootSquare q+ cx, cy :: Fractional a => a+ cx = fromRational (squareWest s)+ cy = fromRational (squareNorth s)++getTile :: (String -> IO ()) -> FilePath -> Ptr CInt -> Quad -> IO (Maybe Tile)+getTile log cacheDir p q = do+ mTile <- readTile cacheDir q+ case mTile of+ Just t -> do+ log $ show ("getTile", q, "read")+ return (Just t)+ Nothing -> do+ log $ show ("getTile", q, "compute")+ t <- mallocTile q+ clearTile t+ poke p 0+ ok <- computeTile log p t+ if ok+ then writeTile cacheDir t >> return (Just t)+ else freeTile t >> return Nothing++foreign import ccall unsafe "string.h memset"+ c_memset :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8)++foreign import ccall "compute.h compute_f32"+ c_compute_f32 :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> CFloat -> CFloat -> CInt -> CInt -> IO CInt++foreign import ccall "compute.h compute_f64"+ c_compute_f64 :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> CDouble -> CDouble -> CInt -> CInt -> IO CInt++foreign import ccall "compute.h compute_f128"+ c_compute_f128 :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> Ptr CDouble -> Ptr CDouble -> CInt -> CInt -> IO CInt++foreign import ccall "compute.h compute_f256"+ c_compute_f256 :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> Ptr CDouble -> Ptr CDouble -> CInt -> CInt -> IO CInt++#ifdef HAVE_MPFR+foreign import ccall "compute.h compute_mpfr"+ c_compute_mpfr :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> CString -> CString -> CInt -> CInt -> IO CInt+#endif
+ src/Utils.hs view
@@ -0,0 +1,34 @@+module Utils where++import Prelude hiding (catch)+import Control.Exception (catch, IOException)+import Control.Monad (forM)+import System.Directory (getDirectoryContents, doesFileExist, doesDirectoryExist)+import System.FilePath ((</>))++safeRead :: Read a => String -> Maybe a+safeRead s = case filter (null . snd) (reads s) of+ [(a, "")] -> Just a+ _ -> Nothing++catchIO :: IO a -> (IOException -> IO a) -> IO a+catchIO = catch++getFilesRecursive :: FilePath -> IO [([FilePath], FilePath)]+getFilesRecursive d = (do+ fs0 <- getDirectoryContents d+ let fs = filter (`notElem` [".", ".."]) fs0+ ffs <- forM fs $ \f -> do+ let df = d </> f+ fe <- doesFileExist df+ fd <- doesDirectoryExist df+ case (fe, fd) of+ (True, False) -> return [([], f)]+ (False, True) -> map (\(ds, f') -> (f:ds, f')) `fmap` getFilesRecursive df+ _ -> return []+ return (concat ffs)) `catchIO` (\_ -> return [])++safeLast :: [a] -> Maybe a+safeLast [] = Nothing+safeLast [x] = Just x+safeLast (_:xs) = safeLast xs
+ src/View.hs view
@@ -0,0 +1,214 @@+module View+ ( Location(..), zoom, translate, defLocation+ , Viewport(..), rotate, defViewport+ , Window(..), windowSize, defWindow+ , Colours(..), defColours, Colour(..)+ , Image(..), defImage+ , BufferSize(..), bufferSize+ , pixelLocation, delta, tileSize+ , visibleQuads, originQuad+ ) where++import Control.Monad (guard)+import Data.Bits (bit)+import Data.Ratio ((%))++import Fractal.RUFF.Types.Complex (Complex((:+)))++import QuadTree (Quad(..), Child(..), child)++data Location = Location+ { center :: !(Complex Rational)+ , radius :: !Double -- accurate enough for 1000 2x zoom levels+ }+ deriving (Read, Show, Eq)++zoom :: Double -> Location -> Location+zoom f l = l{ radius = radius l * f}++translate :: Complex Rational -> Location -> Location+translate u l = l{ center = center l + u }++data Viewport = Viewport+ { aspect :: !Double -- width / height+ , orient :: !Double -- in radians+ }+ deriving (Read, Show, Eq)++rotate :: Double -> Viewport -> Viewport+rotate a v = v{ orient = orient v + a }++data Window = Window+ { width :: !Int+ , height :: !Int+ , supersamples :: !Double+ }+ deriving (Read, Show, Eq)++windowSize :: Window -> Int+windowSize w = ceiling . sqrt . (fromIntegral :: Int -> Double) . diagonal2 $ w++diagonal2 :: Window -> Int+diagonal2 w = width w * width w + height w * height w++resolution :: Window -> Double+resolution w = supersamples w * fromIntegral (windowSize w)++pixelLocation :: Window -> Viewport -> Location -> Double -> Double -> Complex Rational+pixelLocation w v l x y =+ let x' :+ y' = pixelLocation' w v l x y+ in center l + (toRational x' :+ toRational y')++pixelLocation' :: Window -> Viewport -> Location -> Double -> Double -> Complex Double+pixelLocation' w v l x y =+ let p = sqrt (aspect v)+ w' = fromIntegral (width w)+ h' = fromIntegral (height w)+ x1 = (2 * x - w') / w' * p+ y1 = (h' - 2 * y) / h' / p+ a = - orient v+ co = cos a+ si = sin a+ x2 = co * x1 + si * y1+ y2 = -si * x1 + co * y1+ r = 2 * radius l+ in (r * x2) :+ (r * y2)++data BufferSize = BufferSize+ { texels :: !Int -- power of two+ }+ deriving (Read, Show, Eq)++bufferSize :: Window -> BufferSize+bufferSize w = BufferSize{ texels = max tileSize . roundUp2 . ceiling . resolution $ w }++roundUp2 :: Int -> Int -- fails for too small and too large inputs+roundUp2 x = last . takeWhile (x >) . iterate (2 *) $ 1++level :: Location -> Int+level = floor . negate . logBase 2 . radius++radius' :: Location -> Double+radius' l = 0.5 ** fromIntegral (level l)++delta :: Location -> Double -- in [0,1)+delta l = logBase 2 $ radius' l / radius l++tileSize :: Int+tileSize = 256++tileLevel :: Location -> BufferSize -> Int+tileLevel l b = level l + (floor . logBase (2 :: Double) . fromIntegral) (texels b `div` tileSize)++tileOrigin :: Complex Rational+tileOrigin = negate $ 4 :+ 4++tileOriginRadius :: Complex Rational+tileOriginRadius = 8++bufferOrigin :: Location -> Quad -> Maybe (Complex Int)+bufferOrigin l Quad{ quadLevel = ql, quadWest = qw, quadNorth = qn } = do+ guard $ ql >= 0+ let qd = bit ql+ qc = (qw % qd) :+ (qn % qd)+ tx :+ ty = fromIntegral tileSize * fromIntegral qd * (qc - (center l - tileOrigin) / tileOriginRadius)+ return (floor tx :+ floor ty)++originQuad :: Location -> BufferSize -> Maybe Quad+originQuad l b =+ let cx :+ cy = center l+ ql = tileLevel l b+ qs = bit ql % 1+ qw = floor $ (cx + 4) / 8 * qs+ qn = floor $ (cy + 4) / 8 * qs+ in if ql <= 0 then Nothing else Just Quad{ quadLevel = ql, quadWest = qw, quadNorth = qn }++bufferQuads :: Location -> BufferSize -> Maybe [(Complex Int, Quad)]+bufferQuads l b = do+ q0 <- originQuad l b+ i0 :+ j0 <- bufferOrigin l q0+ let m = texels b+ u = fromIntegral $ (m `div` 2) `div` tileSize+ v = fromIntegral $ (m `div` 2) `div` tileSize+ return+ [ (i :+ j, q0{ quadWest = w, quadNorth = n })+ | (i, w) <- takeWhile ((< m) . fst) $ [ i0, i0 + tileSize .. ] `zip` [ quadWest q0 - u .. ]+ , (j, n) <- takeWhile ((< m) . fst) $ [ j0, j0 + tileSize .. ] `zip` [ quadNorth q0 - v .. ]+ ]++childQuads :: (Complex Int, Quad) -> [(Complex Int, Quad)]+childQuads (i :+ j, q) =+ let i0 = 2 * i+ j0 = 2 * j+ i1 = i0 + tileSize+ j1 = j0 + tileSize+ in [ (i0 :+ j0, NorthWest `child` q)+ , (i0 :+ j1, SouthWest `child` q)+ , (i1 :+ j0, NorthEast `child` q)+ , (i1 :+ j1, SouthEast `child` q)+ ]++visibleQuads :: Window -> Viewport -> Location -> Maybe ([(Complex Int, Quad)], [(Complex Int, Quad)])+visibleQuads w v l = do+ let b = bufferSize w+ a = orient v+ co = cos a+ si = sin a+ k = 0.5 ** delta l * supersamples w+ x1 = k * fromIntegral (width w)+ y1 = k * fromIntegral (height w)+ x0 = - x1+ y0 = - y1+ visible t (i :+ j, _) =+ let d = if t then texels b else texels b `div` 2+ in not . and $+ [ x < x0 || y < y0 || x1 < x || y1 < y+ | di <- [0, 1], let i' = fromIntegral (i - d + di * tileSize)+ , dj <- [0, 1], let j' = fromIntegral (j - d + dj * tileSize)+ , let x = co * i' + si * j', let y = -si * i' + co * j'+ ]+ qs0 <- bufferQuads l b+ let qs1 = concatMap childQuads qs0+ return ( filter (visible False) qs0 , filter (visible True) qs1 )++data Image = Image+ { imageWindow :: !Window+ , imageViewport :: !Viewport+ , imageLocation :: !Location+ , imageColours :: !Colours+ }+ deriving (Read, Show, Eq)++defImage :: Image+defImage = Image+ { imageWindow = defWindow+ , imageViewport = defViewport+ , imageLocation = defLocation+ , imageColours = defColours+ }++data Colours = Colours+ { colourInterior :: !Colour+ , colourBoundary :: !Colour+ , colourExterior :: !Colour+ }+ deriving (Read, Show, Eq)++data Colour = Colour !Double !Double !Double+ deriving (Read, Show, Eq)++defColours :: Colours+defColours = Colours+ { colourInterior = Colour 1 0 0+ , colourBoundary = Colour 0 0 0+ , colourExterior = Colour 1 1 1+ }++defLocation :: Location+defLocation = Location{ center = 0, radius = 4 }++defWindow :: Window+defWindow = Window{ width = 512, height = 288, supersamples = 1 }++defViewport :: Viewport+defViewport = Viewport{ aspect = 16/9, orient = 0 }
+ src/compute.cc view
@@ -0,0 +1,186 @@+#include <cmath>+#include <stdint.h>+#include <stdlib.h>++#include <qd/fpu.h>+#include <qd/dd_real.h>+#include <qd/dd_inline.h>+#include <qd/qd_real.h>+#include <qd/qd_inline.h>++#include <new>+using namespace std;++#ifdef HAVE_MPFR+#include "mp_real.h"+#endif++#define likely(x) __builtin_expect((x),1)+#define unlikely(x) __builtin_expect((x),0)++static inline float to_float(float x) { return x; }+static inline float to_float(double x) { return x; }+static inline float to_float(dd_real x) { return to_double(x); }+static inline float to_float(qd_real x) { return to_double(x); }++static inline float sqr(float x) { return x * x; }+static inline double sqr(double x) { return x * x; }++template <typename T>+struct iter {+ T zx, zy, dx, dy; int32_t n; int16_t i, j;+};++template <typename T>+static int compute(int *stop, float *out_n, float *out_d, float *out_a, T in_cx, T in_cy, int in_level, int in_iters) {+ unsigned int fpu;+ fpu_fix_start(&fpu);+ struct iter<T> *iters[2];+ iters[0] = new (nothrow) iter<T>[256 * 256];+ iters[1] = new (nothrow) iter<T>[256 * 256];+ int active[2];+ active[0] = 0;+ active[1] = 0;+ int from = 0;+ int to = 1;+ int max_iters = -1;+ { /* initialize border */ + struct iter<T> *it = iters[from];+ int n = active[from];+ { /* corners */+ it->zx = it->zy = it->dx = it->dy = it->n = 0; it->i = 0; it->j = 0; out_n[256 * ((int)it->j) + it->i] = -1; it++; n++;+ it->zx = it->zy = it->dx = it->dy = it->n = 0; it->i = 255; it->j = 0; out_n[256 * ((int)it->j) + it->i] = -1; it++; n++;+ it->zx = it->zy = it->dx = it->dy = it->n = 0; it->i = 0; it->j = 255; out_n[256 * ((int)it->j) + it->i] = -1; it++; n++;+ it->zx = it->zy = it->dx = it->dy = it->n = 0; it->i = 255; it->j = 255; out_n[256 * ((int)it->j) + it->i] = -1; it++; n++;+ }+ for (int i = 1; i < 255; ++i) { /* edges */+ it->zx = it->zy = it->dx = it->dy = it->n = 0; it->i = 0; it->j = i; out_n[256 * ((int)it->j) + it->i] = -1; it++; n++;+ it->zx = it->zy = it->dx = it->dy = it->n = 0; it->i = 255; it->j = i; out_n[256 * ((int)it->j) + it->i] = -1; it++; n++;+ it->zx = it->zy = it->dx = it->dy = it->n = 0; it->i = i; it->j = 0; out_n[256 * ((int)it->j) + it->i] = -1; it++; n++;+ it->zx = it->zy = it->dx = it->dy = it->n = 0; it->i = i; it->j = 255; out_n[256 * ((int)it->j) + it->i] = -1; it++; n++;+ }+ active[from] = n;+ }+ const T scale = T(1.0) / (T(32.0) * pow(T(2.0), T(in_level)));+ int progress = 1;+ int progress2 = 1;+ int progressed = 0;+ int min_iters = 0;+ int step_iters = 64;+ int retval = 0;+ while (active[from] && (progressed ? progress2 : 1) && step_iters < in_iters) {+ progress2 = 0;+ progress = 1;+ while (progress) {+ progress = 0;+ int o = 0;+ for (int i = 0; i < active[from]; ++i) {+ if (*stop) { goto cleanup; }+ T zx = iters[from][i].zx;+ T zy = iters[from][i].zy;+ T dx = iters[from][i].dx;+ T dy = iters[from][i].dy;+ T cx = in_cx + scale * iters[from][i].i;+ T cy = in_cy + scale * iters[from][i].j;+ int32_t n = iters[from][i].n;+ { /* iterate */+ const T er2 = 65536;+ T zx2 = sqr(zx);+ T zy2 = sqr(zy);+ T z2 = zx2 + zy2;+ T z2xy = 2 * zx * zy;+ while (likely(n < step_iters && z2 < er2)) {+ T zdzx = zx * dx - zy * dy;+ T zdzy = zx * dy + zy * dx;+ dx = 2 * zdzx + 1;+ dy = 2 * zdzy;+ zx = zx2 - zy2 + cx;+ zy = z2xy + cy;+ zx2 = sqr(zx);+ zy2 = sqr(zy);+ z2xy = 2 * zx * zy;+ z2 = zx2 + zy2;+ ++n;+ }+ if (! (z2 < er2)) {+ int k = ((int) iters[from][i].j) * 256 + iters[from][i].i;+ out_n[k] = to_float(1 + n - log(log(z2) / log(er2))/log(2.0));+ out_d[k] = to_float((log(z2) * sqrt(z2 / (sqr(dx) + sqr(dy)))) / scale);+ out_a[k] = to_float(atan2(zy, zx));+ for (int x = iters[from][i].i - 1; x <= iters[from][i].i + 1; ++x) {+ if (x < 0 || 255 < x) continue;+ for (int y = iters[from][i].j - 1; y <= iters[from][i].j + 1; ++y) {+ if (y < 0 || 255 < y) continue;+ k = y * 256 + x;+ if (out_n[k] == 0) {+ iters[to][o].zx = T(0);+ iters[to][o].zy = T(0);+ iters[to][o].dx = T(0);+ iters[to][o].dy = T(0);+ iters[to][o].n = 0;+ iters[to][o].i = x;+ iters[to][o].j = y;+ out_n[k] = -1;+ ++o;+ }+ }+ }+ if (min_iters < n) min_iters = n;+ if (max_iters < n) max_iters = n;+ ++progress;+ } else {+ iters[to][o].zx = zx;+ iters[to][o].zy = zy;+ iters[to][o].dx = dx;+ iters[to][o].dy = dy;+ iters[to][o].n = n;+ iters[to][o].i = iters[from][i].i;+ iters[to][o].j = iters[from][i].j;+ ++o;+ }+ }+ }+ active[to] = o;+ int temp = from; from = to; to = temp;+ progress2 = progress2 || progress;+ }+ step_iters *= 2;+ progressed = progressed || progress2;+ }+ { /* deinitialize border */+ int k;+ for (int i = 0; i < 256; ++i) { /* edges */+ k = 256 * i + 0; if (out_n[k] < 0) out_n[k] = 0;+ k = 256 * i + 255; if (out_n[k] < 0) out_n[k] = 0;+ k = 256 * 0 + i; if (out_n[k] < 0) out_n[k] = 0;+ k = 256 * 255 + i; if (out_n[k] < 0) out_n[k] = 0;+ }+ }+ retval = max_iters;+cleanup:+ delete[] iters[0];+ delete[] iters[1];+ fpu_fix_end(&fpu);+ return retval;+}++extern "C" {+ int compute_f32(int *stop, float *out_n, float *out_d, float *out_a, float in_cx, float in_cy, int in_level, int in_iters) {+ return compute(stop, out_n, out_d, out_a, in_cx, in_cy, in_level, in_iters);+ }+ int compute_f64(int *stop, float *out_n, float *out_d, float *out_a, double in_cx, double in_cy, int in_level, int in_iters) {+ return compute(stop, out_n, out_d, out_a, in_cx, in_cy, in_level, in_iters);+ }+ int compute_f128(int *stop, float *out_n, float *out_d, float *out_a, double *in_cx, double *in_cy, int in_level, int in_iters) {+ return compute(stop, out_n, out_d, out_a, dd_real(in_cx), dd_real(in_cy), in_level, in_iters);+ }+ int compute_f256(int *stop, float *out_n, float *out_d, float *out_a, double *in_cx, double *in_cy, int in_level, int in_iters) {+ return compute(stop, out_n, out_d, out_a, qd_real(in_cx), qd_real(in_cy), in_level, in_iters);+ }+#ifdef HAVE_MPFR+ int compute_mpfr(int *stop, float *out_n, float *out_d, float *out_a, const char *in_cx, const char *in_cy, int in_level, int in_iters) {+ mpfr_prec_t p(in_level + 20);+ return compute(stop, out_n, out_d, out_a, mp_real(in_cx, p), mp_real(in_cy, p), in_level, in_iters);+ }+#endif+}
+ src/gruff.hs view
@@ -0,0 +1,558 @@+{-# LANGUAGE StandaloneDeriving #-}+module Main (main) where++import Prelude hiding (catch, log)+import Control.Monad (forM_, liftM3, when)+import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef, writeIORef)+import Data.Maybe (isJust, fromMaybe)+import Graphics.UI.Gtk hiding (get, Region, Size, Window, Viewport)+import qualified Graphics.UI.Gtk as GTK+import Graphics.UI.Gtk.OpenGL (initGL)+import System.Directory (getAppUserDataDirectory, createDirectoryIfMissing)+import System.FilePath ((</>))++import Fractal.RUFF.Mandelbrot.Address (AngledInternalAddress, Angle, parseAngledInternalAddress, prettyAngledInternalAddress)+import Fractal.RUFF.Types.Complex (Complex((:+)), realPart, imagPart)++import Paths_gruff (getDataFileName)+import Number (R)+import Browser (Browser(..), browserNew)+import MuAtom (MuAtom(..), MuProgress(..), muFromAddress, MuProgress'(..), muToAddress, MuProgress''(..), muLocate)+import View (Image(..), Location(..), Viewport(..), Window(..), Colours(..), Colour(..), defWindow, defViewport)+import GLUTGtk (glut, Size(Size), postRedisplay)+import Logger (logger, LogLevel(Debug))+import qualified Logger as Log+import StatusDialog (StatusDialog, statusDialog, statusDialogNew)+import Utils (safeRead, catchIO)++exit :: (LogLevel -> String -> IO ()) -> FilePath -> Gruff -> IO ()+exit lg stateFile g = do+ lg Debug "exitCallback"+ aDoSave stateFile g+ mainQuit++data GruffGUI = GruffGUI+ { dStatus :: StatusDialog+ -- buttons+ , bHome+ , bLoad+ , bSave+ , bStop+ , bAddressToCoordinates+ , bPeriodScan+ , bPeriodScanPlus :: Button+ -- entries+ , eAddress+ , eRealM, eRealE+ , eImagM, eImagE+ , eSizeM, eSizeE+ , eRota+ , eWidth+ , eHeight+ , eSamples :: Entry+ -- colour pickers+ , cInterior+ , cBorder+ , cExterior :: ColorButton+ -- windows+ , wMain+ , wImage :: GTK.Window+ }++main :: IO ()+main = do+ -- contexts+ _ <- initGUI+ _ <- initGL+ gl' <- glut minSize+ -- directories+ appDir <- getAppUserDataDirectory "gruff"+ let cacheDir' = appDir </> "cache"+ logDir = appDir </> "log"+ stateFile = appDir </> "state.gruff"+ createDirectoryIfMissing False appDir+ createDirectoryIfMissing False logDir+ lg <- logger logDir+ icon <- pixbufNewFromFile =<< getDataFileName "icon.png"+ browser <- browserNew gl' icon lg cacheDir'+ let iw = browserWindow browser+ sg <- sizeGroupNew SizeGroupHorizontal+ let spacing = 2+ entryNewWithMnemonic m = entryNewWithMnemonic' m 30+ entryNewWithMnemonic' m wc = do+ e <- entryNew+ entrySetWidthChars e wc+ l <- labelNewWithMnemonic m+ labelSetMnemonicWidget l e+ sizeGroupAddWidget sg l+ h <- hBoxNew False spacing+ boxPackStart h l PackNatural 0+ boxPackStartDefaults h e+ return (e, h)+ entryNewExponent = do+ e <- entryNew+ entrySetWidthChars e 4+ l <- labelNew (Just "e")+ h <- hBoxNew False spacing+ boxPackStart h l PackNatural 0+ boxPackStart h e PackNatural 0+ return (e, h)+ frameNewWithContents box t r ws = do+ f <- frameNew+ frameSetLabel f t+ frameSetLabelAlign f (if r then 1 else 0) 0.5+ v <- box False spacing+ forM_ ws $ boxPackStartDefaults v+ set f [ containerChild := v ]+ return f+ frameNewWithContents' _ _ _ [] = error "frameNewWithContents': []"+ frameNewWithContents' box t r (w:ws) = do+ f <- frameNew+ frameSetLabel f t+ frameSetLabelAlign f (if r then 1 else 0) 0.5+ v <- box False spacing+ boxPackStart v w PackGrow 0+ forM_ ws $ \w' -> boxPackStart v w' PackNatural 0+ set f [ containerChild := v ]+ return f+ dStatus' <- statusDialogNew+ b01@bHome' <- buttonNewWithLabel "Home"+ b02@bLoad' <- buttonNewWithLabel "Load"+ b03@bSave' <- buttonNewWithLabel "Save"+ b04@bStop' <- buttonNewWithLabel "Stop"+ b7@bAddressToCoordinates' <- buttonNewWithLabel "Go"+ b8@bPeriodScan' <- buttonNewWithLabel "Scan"+ b9@bPeriodScanPlus' <- buttonNewWithLabel "Scan+"+ (eAddress', fa1) <- entryNewWithMnemonic "_Address"+ (eRealM', fc1m) <- entryNewWithMnemonic "_Real"+ (eRealE', fc1e) <- entryNewExponent+ (eImagM', fc2m) <- entryNewWithMnemonic "_Imag"+ (eImagE', fc2e) <- entryNewExponent+ (eSizeM', fc3m) <- entryNewWithMnemonic "Si_ze"+ (eSizeE', fc3e) <- entryNewExponent+ (eRota', fvR) <- entryNewWithMnemonic' "R_otation" 15+ (eWidth', fvW) <- entryNewWithMnemonic' "_Width" 5+ (eHeight', fvH) <- entryNewWithMnemonic' "_Height" 5+ (eSamples', fvS) <- entryNewWithMnemonic' "_Samples" 3+ cInterior' <- colorButtonNewWithColor red+ cBorder' <- colorButtonNewWithColor black+ cExterior' <- colorButtonNewWithColor white+ fb <- frameNewWithContents vBoxNew "Actions" False [b01, b02, b03, b04, b8, b9]+ fa <- frameNewWithContents' hBoxNew "Angled Internal Address" True [toWidget fa1, toWidget b7]+ fh <- frameNewWithContents hBoxNew "Colours" True [cInterior', cBorder', cExterior']+ fv <- frameNewWithContents hBoxNew "Viewport" True [fvR, fvW, fvH, fvS]+ let packMantissaExponent m e = do+ h <- hBoxNew False spacing+ boxPackStartDefaults h m+ boxPackStart h e PackNatural 0+ return h+ fc1 <- packMantissaExponent fc1m fc1e+ fc2 <- packMantissaExponent fc2m fc2e+ fc3 <- packMantissaExponent fc3m fc3e+ fc <- frameNewWithContents vBoxNew "Coordinates" True [fc1, fc2, fc3]+ v <- vBoxNew False spacing+ mapM_ (\w -> boxPackStart v w PackNatural 0) [fc, fv, fa, fh]+ h <- hBoxNew False spacing+ boxPackStart h fb PackNatural 0+ boxPackStartDefaults h v+ ww <- windowNew+ set ww [ windowIcon := Just icon, windowTitle := "gruff control" ]+ containerAdd ww h+ mg <- aDoLoad stateFile+ gR <- newIORef $ case mg of+ Nothing -> initialGruff+ Just g -> g+ let g0 = GruffGUI+ { dStatus = dStatus'+ , bHome = bHome'+ , bLoad = bLoad'+ , bSave = bSave'+ , bStop = bStop'+ , bAddressToCoordinates = bAddressToCoordinates'+ , bPeriodScan = bPeriodScan'+ , bPeriodScanPlus = bPeriodScanPlus'+ , eAddress = eAddress'+ , eRealM = eRealM'+ , eRealE = eRealE'+ , eImagM = eImagM'+ , eImagE = eImagE'+ , eSizeM = eSizeM'+ , eSizeE = eSizeE'+ , eRota = eRota'+ , eWidth = eWidth'+ , eHeight = eHeight'+ , eSamples = eSamples'+ , cInterior = cInterior'+ , cBorder = cBorder'+ , cExterior = cExterior'+ , wMain = ww+ , wImage = iw+ }+ but b a = do+ _ <- b g0 `onClicked` wrapA g0 gR a+ return ()+ butI b a = do+ _ <- b g0 `onClicked` (wrapA g0 gR a >> upI)+ return ()+ butJ b a = do+ _ <- b g0 `onClicked` (wrapA' g0 gR a upI)+ return ()+ butO b a = do+ _ <- b g0 `onClicked` a+ return ()+ ent e a = do+ _ <- e g0 `onEntryActivate` (entryGetText (e g0) >>= wrapE g0 gR a)+ return ()+ entI e a = do+ _ <- e g0 `onEntryActivate` (entryGetText (e g0) >>= wrapE g0 gR a >> upI)+ return ()+ entI' e a = do+ _ <- e g0 `onEntryActivate` (do+ entryGetText (e g0) >>= wrapE g0 gR a+ g <- readIORef gR+ browserResize browser (width (gWindow g)) (height (gWindow g)) (supersamples (gWindow g))+ upI)+ return ()+ colI cbi cbb cbe a = forM_ [cbi, cbb, cbe] $ \c -> do+ _ <- c g0 `onColorSet` (do+ ci <- colorButtonGetColor (cbi g0)+ cb <- colorButtonGetColor (cbb g0)+ ce <- colorButtonGetColor (cbe g0)+ _ <- a ci cb ce gR+ upI)+ return ()+ entME m e a = do+ let a' = do+ ms <- entryGetText (m g0)+ es <- entryGetText (e g0)+ let s = ms ++ if null es then "" else "e" ++ es+ wrapE g0 gR a s+ upI+ _ <- m g0 `onEntryActivate` a'+ _ <- e g0 `onEntryActivate` a'+ return ()+ upI = do+ g <- readIORef gR+ browserRender browser Image+ { imageColours = let (c1, c2, c3) = gColours g in Colours (fromColor c1) (fromColor c2) (fromColor c3)+ , imageLocation = Location+ { center = toRational (fromMaybe 0 (gReal g)) :+ toRational (fromMaybe 0 (gImag g))+ , radius = fromMaybe 0 (gSize g)+ }+ , imageViewport = (gViewport g){ orient = fromMaybe 0 (gRota g) }+ , imageWindow = gWindow g+ } (return ()) (return ())+ postRedisplay gl'+ aUpdate (re :+ im) z = do+ atomicModifyIORef gR $ \g ->+ ( g{ gReal = Just re, gImag = Just im, gSize = Just z }, () )+ g <- readIORef gR+ uReal g0 g+ uImag g0 g+ uSize g0 g+ uRota g0 g+ upI+ aReshape w' h' = do+ atomicModifyIORef gR $ \g ->+ ( g { gWindow = (gWindow g){ width = w', height = h' }+ , gViewport = (gViewport g){ aspect = fromIntegral w' / fromIntegral h' }+ }+ , () )+ g <- readIORef gR+ uEverything g0 g+ upI+ butI bHome aHome+ butI bLoad aLoad+ but bSave aSave+ butO bStop (browserAbort browser)+ butJ bAddressToCoordinates aAddressToCoordinates+ butJ bPeriodScan (aPeriodScan False)+ butJ bPeriodScanPlus (aPeriodScan True)+ ent eAddress aAddress+ entME eRealM eRealE aReal+ entME eImagM eImagE aImag+ entME eSizeM eSizeE aSize+ entI eRota aRota+ entI' eWidth aWidth+ entI' eHeight aHeight+ entI' eSamples aSamples+ colI cInterior cBorder cExterior aColours+ let aExit' = (exit (Log.log lg) stateFile =<< readIORef gR)+ browserSetExitCallback browser aExit'+ browserSetMouseCallback browser aUpdate+ browserSetReshapeCallback browser aReshape+ _ <- ww `onDestroy` aExit'+ g <- readIORef gR+ uEverything g0 g+ upI+ refreshGUI g0 g+ widgetShowAll iw+ widgetShowAll ww+ mainGUI++data Gruff = Gruff+ { gAddress :: Maybe AngledInternalAddress+ , gIsland :: Maybe AngledInternalAddress+ , gChild :: Maybe [Angle]+ , gLowerAngle :: Maybe Angle+ , gUpperAngle :: Maybe Angle+ , gReal :: Maybe R+ , gImag :: Maybe R+ , gSize :: Maybe Double+ } | Gruff2+ { gAddress :: Maybe AngledInternalAddress+ , gReal :: Maybe R+ , gImag :: Maybe R+ , gSize :: Maybe Double+ , gRota :: Maybe Double+ , gColours :: (Color, Color, Color)+ , gWindow :: Window+ , gViewport :: Viewport+ }+ deriving (Read, Show)+deriving instance Read Color++initialGruff :: Gruff+initialGruff = Gruff2+ { gAddress = parseAngledInternalAddress "1"+ , gReal = Just 0+ , gImag = Just 0+ , gSize = Just 1+ , gRota = Just 0+ , gColours = (red, black, white)+ , gWindow = defWindow+ , gViewport = defViewport+ }++refreshGUI :: GruffGUI -> Gruff -> IO ()+refreshGUI g0 g = do+ can bAddressToCoordinates $ j gAddress+ can bPeriodScan $ True+ where+ can w = widgetSetSensitive (w g0)+ j a = isJust (a g)++-- button actions++type A = GruffGUI -> Gruff -> IO Gruff+type A' = GruffGUI -> Gruff -> (Gruff -> IO ()) -> IO ()++wrapA :: GruffGUI -> IORef Gruff -> A -> IO ()+wrapA g0 gR a = do+ g <- readIORef gR+ g' <- a g0 g+ writeIORef gR $! g'+ refreshGUI g0 g'++wrapA' :: GruffGUI -> IORef Gruff -> A' -> IO () -> IO ()+wrapA' g0 gR a upI = do+ g <- readIORef gR+ a g0 g $ \g' -> postGUISync $ do+ writeIORef gR $! g'+ upI+ refreshGUI g0 g'++aHome :: A+aHome g0 g = do+ let g' = initialGruff{ gColours = gColours g, gWindow = gWindow g, gViewport = gViewport g }+ uEverything g0 g'+ return g'++aDoLoad :: FilePath -> IO (Maybe Gruff)+aDoLoad ff = (do+ gr <- safeRead `fmap` readFile ff+ return $ case gr of+ Just (Gruff a _ _ _ _ b c d) -> Just (Gruff2 a b c d (Just 0) (red, black, white) defWindow defViewport)+ g -> g+ ) `catchIO` const (return Nothing)++aLoad :: A+aLoad g0 g = do+ fc <- fileChooserDialogNew (Just "gruff load") (Just $ wMain g0) FileChooserActionOpen [("Load", ResponseAccept), ("Cancel", ResponseCancel)]+ widgetShow fc+ r <- dialogRun fc+ g' <- case r of+ ResponseAccept -> do+ mf <- fileChooserGetFilename fc+ case mf of+ Nothing -> return g+ Just f -> do+ mg <- aDoLoad f+ case mg of+ Nothing -> return g+ Just g' -> uEverything g0 g' >> return g'+ _ -> return g+ widgetDestroy fc+ return g'++aDoSave :: FilePath -> Gruff -> IO ()+aDoSave f g = writeFile f (show g) `catchIO` const (return ())++aSave :: A+aSave g0 g = do+ fc <- fileChooserDialogNew (Just "gruff save") (Just $ wMain g0) FileChooserActionSave [("Save", ResponseAccept), ("Cancel", ResponseCancel)]+ widgetShow fc+ r <- dialogRun fc+ case r of+ ResponseAccept -> do+ mf <- fileChooserGetFilename fc+ case mf of+ Nothing -> return ()+ Just f -> aDoSave f g+ _ -> return ()+ widgetDestroy fc+ return g++aPeriodScan :: Bool -> A'+aPeriodScan plus g0 g gn = do+ statusDialog (dStatus g0) "gruff status" $ \progress -> case liftM3 (,,) (gReal g) (gImag g) (gSize g) of+ Nothing -> progress "nothing to do" >> gn g+ Just (re, im, r) -> do+ forM_ (muLocate (re:+im) r) $ \mp -> case mp of+ MuScanTodo -> progress "Scanning for period..."+ MuScan -> progress "Scanning for period..."+ MuScanDone p -> progress$"Scanning for period... " ++ show p+ MuNucleusTodo' -> progress "Computing nucleus..."+ MuNucleus' i -> when (i `mod` 20 == 0) . progress$"Computing nucleus... " ++ show i+ MuNucleusDone' _ -> progress "Computing nucleus... done"+ MuBondTodo' -> progress "Computing bond..."+ MuBond' i -> when (i `mod` 20 == 0) . progress$"Computing bond... " ++ show i+ MuBondDone' _ -> progress "Computing bond... done"+ MuSuccess'' mu -> do+ let g' = g{ gReal = Just . realPart . muNucleus $ mu+ , gImag = Just . imagPart . muNucleus $ mu+ , gSize = Just . (* 4) . muSize $ mu+ , gRota = Just . subtract (pi/2) . muOrient $ mu+ }+ progress "Found!"+ postGUISync $ do+ uReal g0 g'+ uImag g0 g'+ uSize g0 g'+ uRota g0 g'+ if plus+ then+ forM_ (muToAddress mu) $ \mp' -> case mp' of+ MuCuspTodo -> progress "Computing cusp..."+ MuCuspDone _ -> progress "Computing cusp... done"+ MuDwellTodo -> progress "Computing dwell..."+ MuDwell i -> when (i `mod` 100 == 0) . progress$"Computing dwell... " ++ show i+ MuDwellDone _ -> progress "Computing dwell... done"+ MuRayOutTodo -> progress "Tracing rays..."+ MuRayOut i -> progress$"Tracing rays... " ++ show (round $ i * 100 :: Int) ++ "%"+ MuRayOutDone _ -> progress "Tracing rays... done"+ MuExternalTodo -> progress "Computing angle..."+ MuExternalDone _ -> progress "Computing angle... done"+ MuAddressTodo -> progress "Finding address..."+ MuSuccess' a -> do+ let g'' = g'{ gAddress = Just a }+ progress "Complete!"+ postGUISync $ do+ uAddress g0 g''+ gn g''+ MuFailed' -> progress "Failed!" >> gn g'+ else+ gn g'+ MuFailed'' -> progress "Failed!" >> gn g++aAddressToCoordinates :: A'+aAddressToCoordinates g0 g gn = do+ statusDialog (dStatus g0) "gruff status" $ \progress -> case gAddress g of+ Nothing -> progress "nothing to do" >> gn g+ Just addr -> do+ forM_ (muFromAddress addr) $ \mp -> do+ case mp of+ MuSplitTodo -> progress "Splitting address..."+ MuSplitDone _ _ -> progress "Splitting address... done"+ MuAnglesTodo -> progress "Computing angles..."+ MuAnglesDone _ _ -> progress "Computing angles... done"+ MuRayTodo -> progress "Tracing rays..."+ MuRay n -> when (n `mod` 20 == 0) . progress$"Tracing rays... " ++ show n+ MuRayDone _ -> progress "Tracing rays... done"+ MuNucleusTodo -> progress "Computing nucleus..."+ MuNucleus n -> when (n `mod` 20 == 0) . progress$"Computing nucleus... " ++ show n+ MuNucleusDone _ -> progress "Computing nucleus... done"+ MuBondTodo -> progress "Computing bond..."+ MuBond n -> when (n `mod` 20 == 0) . progress$"Computing bond... " ++ show n+ MuBondDone _ -> progress "Computing bond... done"+ MuSuccess mu -> do+ let g' = g{ gReal = Just . realPart . muNucleus $ mu+ , gImag = Just . imagPart . muNucleus $ mu+ , gSize = Just . (* 4) . muSize $ mu+ , gRota = Just . subtract (pi/2) . muOrient $ mu+ }+ progress "Done!"+ postGUISync $ do+ uReal g0 g'+ uImag g0 g'+ uSize g0 g'+ uRota g0 g'+ gn g'+ MuFailed -> progress "Failed!" >> gn g++-- entry update++type U = GruffGUI -> Gruff -> IO ()++uEverything, uAddress, uReal, uImag, uSize, uRota, uColours, uWidth, uHeight, uSamples :: U+uEverything g0 g = forM_ [uAddress, uReal, uImag, uSize, uRota, uColours, uWidth, uHeight, uSamples] $ \u -> u g0 g+uAddress g0 g = entrySetText (eAddress g0) (maybe "" prettyAngledInternalAddress (gAddress g))+uReal g0 g = uMantissaExponent (eRealM g0) (eRealE g0) (maybe "" show (gReal g))+uImag g0 g = uMantissaExponent (eImagM g0) (eImagE g0) (maybe "" show (gImag g))+uSize g0 g = uMantissaExponent (eSizeM g0) (eSizeE g0) (maybe "" show (gSize g))+uRota g0 g = entrySetText (eRota g0) (maybe "" show (gRota g))+uColours g0 g = do+ let (ci, cb, ce) = gColours g+ colorButtonSetColor (cInterior g0) ci+ colorButtonSetColor (cBorder g0) cb+ colorButtonSetColor (cExterior g0) ce+uWidth g0 g = entrySetText (eWidth g0) (show . width . gWindow $ g)+uHeight g0 g = entrySetText (eHeight g0) (show . height . gWindow $ g)+uSamples g0 g = entrySetText (eSamples g0) (show . supersamples . gWindow $ g)++uMantissaExponent :: (EntryClass a, EntryClass b) => a -> b -> String -> IO ()+uMantissaExponent m e s = do+ let (ms, me) = break (== 'e') s+ entrySetText m ms+ entrySetText e (drop 1 me)++-- entry actions++type E = Gruff -> String -> Gruff++wrapE :: GruffGUI -> IORef Gruff -> E -> String -> IO ()+wrapE g0 gR e s = do+ g <- readIORef gR+ let g' = e g s+ writeIORef gR $! g'+ refreshGUI g0 g'++aAddress, aReal, aImag, aSize, aRota, aWidth, aHeight, aSamples :: E+aAddress g s = g{ gAddress = parseAngledInternalAddress s }+aReal g s = g{ gReal = safeRead s }+aImag g s = g{ gImag = safeRead s }+aSize g s = g{ gSize = safeRead s }+aRota g s = g{ gRota = safeRead s }+aWidth g s = case safeRead s of+ Nothing -> g+ Just r -> g{ gWindow = (gWindow g){ width = r } }+aHeight g s = case safeRead s of+ Nothing -> g+ Just r -> g{ gWindow = (gWindow g){ height = r } }+aSamples g s = case safeRead s of+ Nothing -> g+ Just r -> g{ gWindow = (gWindow g){ supersamples = r } }++aColours :: Color -> Color -> Color -> IORef Gruff -> IO ()+aColours i b e gR = atomicModifyIORef gR $ \g -> (g{ gColours = (i, b, e) }, ())++minSize :: Size+minSize = Size 160 100++red, black, white :: Color+red = Color 65535 0 0+black = Color 0 0 0+white = Color 65535 65535 65535++fromColor :: Color -> Colour+fromColor (Color r g b) = Colour (fromIntegral r / 65535) (fromIntegral g / 65535) (fromIntegral b / 65535)
+ src/mp_real.h view
@@ -0,0 +1,116 @@+#ifndef MP_REAL_H+#define MP_REAL_H 1++#include <mpfr.h>+#define MPFR_RNDN GMP_RNDN++class mp_real {+public:+ mpfr_t m;+ mp_real() {+ mpfr_init2(m, 53);+ mpfr_set_d(m, 0, MPFR_RNDN);+ }+ mp_real(const double &s) {+ mpfr_init2(m, 53);+ mpfr_set_d(m, s, MPFR_RNDN);+ }+ mp_real(const int32_t &s) {+ mpfr_init2(m, 53);+ mpfr_set_si(m, s, MPFR_RNDN);+ }+ mp_real(const mp_real &s) {+ mpfr_init2(m, mpfr_get_prec(s.m));+ mpfr_set(m, s.m, MPFR_RNDN);+ }+ mp_real(mpfr_prec_t p) {+ mpfr_init2(m, p);+ }+ mp_real(mpfr_t s, mpfr_prec_t p) {+ mpfr_init2(m, p);+ mpfr_set(m, s, MPFR_RNDN);+ }+ mp_real(const char *s, mpfr_prec_t p) {+ mpfr_init2(m, p);+ mpfr_set_str(m, s, 10, MPFR_RNDN);+ };+ mp_real(double s, mpfr_prec_t p) {+ mpfr_init2(m, p);+ mpfr_set_d(m, s, MPFR_RNDN);+ };+ ~mp_real() {+ mpfr_clear(m);+ }+#define maxprec(x, y) max(mpfr_get_prec(x.m), mpfr_get_prec(y.m))+ inline mp_real& operator=(mp_real const &y) {+ mpfr_set_prec(m, maxprec((*this), y));+ mpfr_set(m, y.m, MPFR_RNDN);+ return *this;+ }+};++inline bool operator<(mp_real const &x, mp_real const &y) {+ return mpfr_less_p(x.m, y.m);+}++inline mp_real operator+(mp_real const &x, mp_real const &y) {+ mp_real r(maxprec(x, y));+ mpfr_add(r.m, x.m, y.m, MPFR_RNDN);+ return r;+}++inline mp_real operator-(mp_real const &x, mp_real const &y) {+ mp_real r(maxprec(x, y));+ mpfr_sub(r.m, x.m, y.m, MPFR_RNDN);+ return r;+}++inline mp_real operator*(mp_real const &x, mp_real const &y) {+ mp_real r(maxprec(x, y));+ mpfr_mul(r.m, x.m, y.m, MPFR_RNDN);+ return r;+}++inline mp_real operator/(mp_real const &x, mp_real const &y) {+ mp_real r(maxprec(x, y));+ mpfr_div(r.m, x.m, y.m, MPFR_RNDN);+ return r;+}++inline mp_real sqr(mp_real const &x) {+ mp_real r(mpfr_get_prec(x.m));+ mpfr_sqr(r.m, x.m, MPFR_RNDN);+ return r;+}++inline mp_real sqrt(mp_real const &x) {+ mp_real r(mpfr_get_prec(x.m));+ mpfr_sqrt(r.m, x.m, MPFR_RNDN);+ return r;+}++inline mp_real log(mp_real const &x) {+ mp_real r(mpfr_get_prec(x.m));+ mpfr_log(r.m, x.m, MPFR_RNDN);+ return r;+}++inline mp_real atan2(mp_real const &y, mp_real const &x) {+ mp_real r(maxprec(x, y));+ mpfr_atan2(r.m, y.m, x.m, MPFR_RNDN);+ return r;+}++inline mp_real pow(mp_real const &y, mp_real const &x) {+ mp_real r(maxprec(x, y));+ mpfr_pow(r.m, y.m, x.m, MPFR_RNDN);+ return r;+}++inline float to_float(mp_real const &x) {+ return mpfr_get_d(x.m, MPFR_RNDN);+}++#undef maxprec++#endif
+ src/rts.c view
@@ -0,0 +1,1 @@+char *ghc_rts_opts = "-N";