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