gruff (empty) → 0.1
raw patch · 21 files changed
+2683/−0 lines, 21 filesdep +OpenGLdep +OpenGLRawdep +Vecsetup-changedbinary-added
Dependencies added: OpenGL, OpenGLRaw, Vec, ad, base, bytestring, containers, directory, filepath, floatshow, gtk, gtkglext, mtl, old-locale, parallel, qd, ruff, time, wl-pprint-text
Files
- Address.hs +47/−0
- Browser.hs +404/−0
- CacheView.hs +351/−0
- GLUTGtk.hs +71/−0
- LICENSE +339/−0
- Logger.hs +40/−0
- Nucleus.hs +67/−0
- PeriodScan.hs +55/−0
- QuadTree.hs +95/−0
- Setup.hs +2/−0
- Shader.hs +26/−0
- StatusDialog.hs +31/−0
- Tile.hs +175/−0
- Utils.hs +43/−0
- cache.frag +82/−0
- colourize.frag +96/−0
- compute.cc +173/−0
- gruff.cabal +51/−0
- gruff.hs +534/−0
- icon.png binary
- rts.c +1/−0
+ Address.hs view
@@ -0,0 +1,47 @@+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 view
@@ -0,0 +1,404 @@+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 view
@@ -0,0 +1,351 @@+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 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+ }
+ LICENSE view
@@ -0,0 +1,339 @@+ GNU GENERAL PUBLIC LICENSE+ Version 2, June 1991++ Copyright (C) 1989, 1991 Free Software Foundation, Inc.,+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The licenses for most software are designed to take away your+freedom to share and change it. By contrast, the GNU General Public+License is intended to guarantee your freedom to share and change free+software--to make sure the software is free for all its users. This+General Public License applies to most of the Free Software+Foundation's software and to any other program whose authors commit to+using it. (Some other Free Software Foundation software is covered by+the GNU Lesser General Public License instead.) You can apply it to+your programs, too.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+this service if you wish), that you receive source code or can get it+if you want it, that you can change the software or use pieces of it+in new free programs; and that you know you can do these things.++ To protect your rights, we need to make restrictions that forbid+anyone to deny you these rights or to ask you to surrender the rights.+These restrictions translate to certain responsibilities for you if you+distribute copies of the software, or if you modify it.++ For example, if you distribute copies of such a program, whether+gratis or for a fee, you must give the recipients all the rights that+you have. You must make sure that they, too, receive or can get the+source code. And you must show them these terms so they know their+rights.++ We protect your rights with two steps: (1) copyright the software, and+(2) offer you this license which gives you legal permission to copy,+distribute and/or modify the software.++ Also, for each author's protection and ours, we want to make certain+that everyone understands that there is no warranty for this free+software. If the software is modified by someone else and passed on, we+want its recipients to know that what they have is not the original, so+that any problems introduced by others will not reflect on the original+authors' reputations.++ Finally, any free program is threatened constantly by software+patents. We wish to avoid the danger that redistributors of a free+program will individually obtain patent licenses, in effect making the+program proprietary. To prevent this, we have made it clear that any+patent must be licensed for everyone's free use or not licensed at all.++ The precise terms and conditions for copying, distribution and+modification follow.++ GNU GENERAL PUBLIC LICENSE+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++ 0. This License applies to any program or other work which contains+a notice placed by the copyright holder saying it may be distributed+under the terms of this General Public License. The "Program", below,+refers to any such program or work, and a "work based on the Program"+means either the Program or any derivative work under copyright law:+that is to say, a work containing the Program or a portion of it,+either verbatim or with modifications and/or translated into another+language. (Hereinafter, translation is included without limitation in+the term "modification".) Each licensee is addressed as "you".++Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope. The act of+running the Program is not restricted, and the output from the Program+is covered only if its contents constitute a work based on the+Program (independent of having been made by running the Program).+Whether that is true depends on what the Program does.++ 1. You may copy and distribute verbatim copies of the Program's+source code as you receive it, in any medium, provided that you+conspicuously and appropriately publish on each copy an appropriate+copyright notice and disclaimer of warranty; keep intact all the+notices that refer to this License and to the absence of any warranty;+and give any other recipients of the Program a copy of this License+along with the Program.++You may charge a fee for the physical act of transferring a copy, and+you may at your option offer warranty protection in exchange for a fee.++ 2. You may modify your copy or copies of the Program or any portion+of it, thus forming a work based on the Program, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++ a) You must cause the modified files to carry prominent notices+ stating that you changed the files and the date of any change.++ b) You must cause any work that you distribute or publish, that in+ whole or in part contains or is derived from the Program or any+ part thereof, to be licensed as a whole at no charge to all third+ parties under the terms of this License.++ c) If the modified program normally reads commands interactively+ when run, you must cause it, when started running for such+ interactive use in the most ordinary way, to print or display an+ announcement including an appropriate copyright notice and a+ notice that there is no warranty (or else, saying that you provide+ a warranty) and that users may redistribute the program under+ these conditions, and telling the user how to view a copy of this+ License. (Exception: if the Program itself is interactive but+ does not normally print such an announcement, your work based on+ the Program is not required to print an announcement.)++These requirements apply to the modified work as a whole. If+identifiable sections of that work are not derived from the Program,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works. But when you+distribute the same sections as part of a whole which is a work based+on the Program, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Program.++In addition, mere aggregation of another work not based on the Program+with the Program (or with a work based on the Program) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++ 3. You may copy and distribute the Program (or a work based on it,+under Section 2) in object code or executable form under the terms of+Sections 1 and 2 above provided that you also do one of the following:++ a) Accompany it with the complete corresponding machine-readable+ source code, which must be distributed under the terms of Sections+ 1 and 2 above on a medium customarily used for software interchange; or,++ b) Accompany it with a written offer, valid for at least three+ years, to give any third party, for a charge no more than your+ cost of physically performing source distribution, a complete+ machine-readable copy of the corresponding source code, to be+ distributed under the terms of Sections 1 and 2 above on a medium+ customarily used for software interchange; or,++ c) Accompany it with the information you received as to the offer+ to distribute corresponding source code. (This alternative is+ allowed only for noncommercial distribution and only if you+ received the program in object code or executable form with such+ an offer, in accord with Subsection b above.)++The source code for a work means the preferred form of the work for+making modifications to it. For an executable work, complete source+code means all the source code for all modules it contains, plus any+associated interface definition files, plus the scripts used to+control compilation and installation of the executable. However, as a+special exception, the source code distributed need not include+anything that is normally distributed (in either source or binary+form) with the major components (compiler, kernel, and so on) of the+operating system on which the executable runs, unless that component+itself accompanies the executable.++If distribution of executable or object code is made by offering+access to copy from a designated place, then offering equivalent+access to copy the source code from the same place counts as+distribution of the source code, even though third parties are not+compelled to copy the source along with the object code.++ 4. You may not copy, modify, sublicense, or distribute the Program+except as expressly provided under this License. Any attempt+otherwise to copy, modify, sublicense or distribute the Program is+void, and will automatically terminate your rights under this License.+However, parties who have received copies, or rights, from you under+this License will not have their licenses terminated so long as such+parties remain in full compliance.++ 5. You are not required to accept this License, since you have not+signed it. However, nothing else grants you permission to modify or+distribute the Program or its derivative works. These actions are+prohibited by law if you do not accept this License. Therefore, by+modifying or distributing the Program (or any work based on the+Program), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Program or works based on it.++ 6. Each time you redistribute the Program (or any work based on the+Program), the recipient automatically receives a license from the+original licensor to copy, distribute or modify the Program subject to+these terms and conditions. You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties to+this License.++ 7. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Program at all. For example, if a patent+license would not permit royalty-free redistribution of the Program by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Program.++If any portion of this section is held invalid or unenforceable under+any particular circumstance, the balance of the section is intended to+apply and the section as a whole is intended to apply in other+circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system, which is+implemented by public license practices. Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++ 8. If the distribution and/or use of the Program is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Program under this License+may add an explicit geographical distribution limitation excluding+those countries, so that distribution is permitted only in or among+countries not thus excluded. In such case, this License incorporates+the limitation as if written in the body of this License.++ 9. The Free Software Foundation may publish revised and/or new versions+of the General Public License from time to time. Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++Each version is given a distinguishing version number. If the Program+specifies a version number of this License which applies to it and "any+later version", you have the option of following the terms and conditions+either of that version or of any later version published by the Free+Software Foundation. If the Program does not specify a version number of+this License, you may choose any version ever published by the Free Software+Foundation.++ 10. If you wish to incorporate parts of the Program into other free+programs whose distribution conditions are different, write to the author+to ask for permission. For software which is copyrighted by the Free+Software Foundation, write to the Free Software Foundation; we sometimes+make exceptions for this. Our decision will be guided by the two goals+of preserving the free status of all derivatives of our free software and+of promoting the sharing and reuse of software generally.++ NO WARRANTY++ 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,+REPAIR OR CORRECTION.++ 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE+POSSIBILITY OF SUCH DAMAGES.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+convey the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License along+ with this program; if not, write to the Free Software Foundation, Inc.,+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.++Also add information on how to contact you by electronic and paper mail.++If the program is interactive, make it output a short notice like this+when it starts in an interactive mode:++ Gnomovision version 69, Copyright (C) year name of author+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+ This is free software, and you are welcome to redistribute it+ under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License. Of course, the commands you use may+be called something other than `show w' and `show c'; they could even be+mouse-clicks or menu items--whatever suits your program.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the program, if+necessary. Here is a sample; alter the names:++ Yoyodyne, Inc., hereby disclaims all copyright interest in the program+ `Gnomovision' (which makes passes at compilers) written by James Hacker.++ <signature of Ty Coon>, 1 April 1989+ Ty Coon, President of Vice++This General Public License does not permit incorporating your program into+proprietary programs. If your program is a subroutine library, you may+consider it more useful to permit linking proprietary applications with the+library. If this is what you want to do, use the GNU Lesser General+Public License instead of this License.
+ Logger.hs view
@@ -0,0 +1,40 @@+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 view
@@ -0,0 +1,67 @@+{-# 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 view
@@ -0,0 +1,55 @@+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 view
@@ -0,0 +1,95 @@+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]
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Shader.hs view
@@ -0,0 +1,26 @@+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 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 $ postGUISync . labelSetText label+ postGUISync $ widgetHide window+ _ <- cancel `onClicked` do+ killThread child+ widgetHide window+ widgetShowAll window+ }
+ Tile.hs view
@@ -0,0 +1,175 @@+{-# 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 view
@@ -0,0 +1,43 @@+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 view
@@ -0,0 +1,82 @@+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;+ int ii;+ 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); ii = int(i);+ 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+ switch(ii) {+ case 0: // red point+ r = v; g = t; b = p; // RED max, GRN rising, BLU min+ break;+ case 1: // yellow point+ r = q; g = v; b = p; // RED falling, GRN max, BLU min+ break;+ case 2: // green point+ r = p; g = v; b = t; // RED min, GRN max, BLU rising+ break;+ case 3: // cyan point+ r = p; g = q; b = v; // RED min, GRN falling, BLU max+ break;+ case 4: // blue point+ r = t; g = p; b = v; // RED rising, GRN min, BLU max+ break;+ case 5: // magenta point+ default:+ r = v; g = p; b = q; // RED max, GRN min, BLU falling+ break;+ }+ }+ 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(frac(h), s, v), 1.0);+}
+ colourize.frag view
@@ -0,0 +1,96 @@+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;+ int ii;+ 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); ii = int(i);+ 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+ switch(ii) {+ case 0: // red point+ r = v; g = t; b = p; // RED max, GRN rising, BLU min+ break;+ case 1: // yellow point+ r = q; g = v; b = p; // RED falling, GRN max, BLU min+ break;+ case 2: // green point+ r = p; g = v; b = t; // RED min, GRN max, BLU rising+ break;+ case 3: // cyan point+ r = p; g = q; b = v; // RED min, GRN falling, BLU max+ break;+ case 4: // blue point+ r = t; g = p; b = v; // RED rising, GRN min, BLU max+ break;+ case 5: // magenta point+ default:+ r = v; g = p; b = q; // RED max, GRN min, BLU falling+ break;+ }+ }+ 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; }+ if (frac(i / 2) < 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 view
@@ -0,0 +1,173 @@+#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);+ }+}
+ gruff.cabal view
@@ -0,0 +1,51 @@+Name: gruff+Version: 0.1+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.+ .+ 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+ also be loaded from and saved to other files).+ .+ * 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).+ .+ * Feature finding using period location (navigate to approximate+ location of the desired feature, click the period scan button).+ .+ * Cache view (refreshed on program start) to visualize visited+ locations.+ .+ 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.++License: GPL-2+License-file: LICENSE+Author: Claude Heiland-Allen+Maintainer: claudiusmaximus@goto10.org+Category: Graphics++Build-type: Simple+Cabal-version: >=1.4++Data-files: icon.png, colourize.frag, cache.frag++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
+ gruff.hs view
@@ -0,0 +1,534 @@+{-# 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 view
binary file changed (absent → 38921 bytes)
+ rts.c view
@@ -0,0 +1,1 @@+char *ghc_rts_opts = "-N";