diff --git a/Address.hs b/Address.hs new file mode 100644 --- /dev/null +++ b/Address.hs @@ -0,0 +1,47 @@ +module Address where + +import Control.Monad (guard) +import Data.Ratio ((%), denominator) +import Fractal.RUFF.Mandelbrot.Address (AngledInternalAddress(Unangled, Angled), Angle, angledFromList, angledToList) + +import Utils (safeRead) + +parseAngles :: String -> Maybe [Angle] +parseAngles = mapM parseAngle . words + +parseAngle :: String -> Maybe Angle +parseAngle s = do + let (n, d) = break ('/'==) s + n' <- safeRead (filter (' '/=) n) + d' <- safeRead (filter (' '/=) (drop 1 d)) + guard (0 < n' && n' < d') + return $ n' % d' + +splitAddress :: AngledInternalAddress -> Maybe (AngledInternalAddress, [Angle]) +splitAddress a = + let (ps0, rs0) = unzip $ angledToList a + ps1 = reverse ps0 + rs1 = reverse (Nothing : init rs0) + prs1 = zip ps1 rs1 + f ((p, Just r):qrs@((q, _):_)) acc + | p == denominator r * q = f qrs (r : acc) + f prs acc = g prs acc + g prs acc = + let (ps2, rs2) = unzip prs + ps3 = reverse ps2 + rs3 = reverse (Nothing : init rs2) + prs3 = zip ps3 rs3 + aa = angledFromList prs3 + in case aa of + Nothing -> Nothing + Just aa' -> Just (aa', acc) + in f prs1 [] + +joinAddress :: AngledInternalAddress -> [Angle] -> AngledInternalAddress +joinAddress (Unangled p) [] = Unangled p +joinAddress (Unangled p) (r:rs) = Angled p r (joinAddress (Unangled $ p * denominator r) rs) +joinAddress (Angled p r a) rs = Angled p r (joinAddress a rs) + +addressPeriod :: AngledInternalAddress -> Integer +addressPeriod (Unangled p) = p +addressPeriod (Angled _ _ a) = addressPeriod a diff --git a/Browser.hs b/Browser.hs new file mode 100644 --- /dev/null +++ b/Browser.hs @@ -0,0 +1,404 @@ +module Browser (iInitialize) where + +import Prelude hiding (log) +import Control.Concurrent + ( forkIO, MVar, newMVar, takeMVar, putMVar, tryTakeMVar, threadDelay ) +import Control.Monad (forever, forM_, liftM2, replicateM, when) +import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef) +import Data.List (sortBy) +import qualified Data.Map as M +import Data.Map (Map) +import Data.Maybe (isJust, mapMaybe) +import Data.Ord (comparing) +import qualified Data.Set as S +import Data.Set (Set, (\\)) +import Foreign (Ptr, malloc, poke) +import Foreign.C (CFloat, CInt) +import GHC.Conc (numCapabilities) +import Graphics.Rendering.OpenGL hiding (Angle, Point, Position, Size) +import qualified Graphics.Rendering.OpenGL as GL +import Graphics.Rendering.OpenGL.Raw + ( glTexImage2D, gl_TEXTURE_2D, gl_R32F, gl_LUMINANCE, gl_FLOAT + , gl_FALSE, glClampColor, gl_CLAMP_VERTEX_COLOR, gl_CLAMP_READ_COLOR + , gl_CLAMP_FRAGMENT_COLOR + ) +import Graphics.UI.Gtk hiding (get, Region, Size) +import Numeric.QD (QuadDouble) + +import GLUTGtk +import Shader (shader) +import QuadTree +import Tile (Tile(Tile), getTile, freeTile, rootSquare) +import Logger (Logger, LogLevel(Debug)) +import qualified Logger as Log +import Paths_gruff (getDataFileName) + +type TextureObject3 = (TextureObject, TextureObject, TextureObject) +data GruffImage = GruffImage + { center :: (Rational, Rational) + , level :: Int + , size :: Size + , prog :: Program + , tiles :: Map Quad TextureObject3 + , queue :: MVar [Tile] + , progress :: Set Quad + , jobs :: MVar [Quad] + , viewQuads :: [(Square, TextureObject3)] + , workers :: [Ptr CInt] + , gl :: GLUTGtk + , cacheDir :: FilePath + , log :: LogLevel -> String -> IO () + , hshift :: Double + , hscale :: Double + } + +iDisplay :: IORef GruffImage -> IO () +iDisplay iR = do + s0 <- readIORef iR + mtls <- tryTakeMVar (queue s0) + case mtls of + Just tls -> do + putMVar (queue s0) [] + forM_ tls $ \tile@(Tile q ns ds ts) -> do + tde <- upload ds + tit <- upload ns + ttt <- upload ts +-- GL.finish + freeTile tile + atomicModifyIORef iR $ \s' -> + ( s'{ tiles = M.insert q (tde, tit, ttt) (tiles s') + , progress = S.delete q (progress s') } + , ()) + update iR False + Nothing -> return () + s <- readIORef iR + let Size w h = size s + log s Debug $ "displayCallback " ++ show (center s, level s) + viewport $= + (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h)) + loadIdentity + ortho2D 0 (fromIntegral w) (fromIntegral h) 0 + clearColor $= Color4 0.5 0.5 0.5 1 + clear [ColorBuffer] + currentProgram $= Just (prog s) + lde <- get $ uniformLocation (prog s) "de" + lit <- get $ uniformLocation (prog s) "it" + ltt <- get $ uniformLocation (prog s) "tt" + lhshift <- get $ uniformLocation (prog s) "hshift" + lhscale <- get $ uniformLocation (prog s) "hscale" + uniform lde $= TexCoord1 (0 :: GLint) + uniform lit $= TexCoord1 (1 :: GLint) + uniform ltt $= TexCoord1 (2 :: GLint) + uniform lhshift $= TexCoord1 (realToFrac (hshift s) :: GLfloat) + uniform lhscale $= TexCoord1 (realToFrac (hscale s) :: GLfloat) + mapM_ (drawQuad s) (viewQuads s) + currentProgram $= Nothing +-- writeSnapshot (show (level s) ++ ".ppm") (Position 0 0) (size s) + +drawQuad :: GruffImage -> (Square, TextureObject3) -> IO () +drawQuad s (sq, (tde, tit, ttt)) = do + let t x y = texCoord $ TexCoord2 (x :: GLdouble) (y :: GLdouble) + v x y = let (x', y') = toPixel s x y + in vertex $ Vertex2 + (fromRational x' :: GLdouble) + (fromRational y' :: GLdouble) + x0 = squareWest sq + x1 = squareWest sq + squareSize sq + y0 = squareNorth sq + y1 = squareNorth sq + squareSize sq + activeTexture $= TextureUnit 0 + textureBinding Texture2D $= Just tde + activeTexture $= TextureUnit 1 + textureBinding Texture2D $= Just tit + activeTexture $= TextureUnit 2 + textureBinding Texture2D $= Just ttt + renderPrimitive Quads $ do + color $ Color3 1 1 (1::GLdouble) + t 0 1 >> v x0 y1 + t 0 0 >> v x0 y0 + t 1 0 >> v x1 y0 + t 1 1 >> v x1 y1 + textureBinding Texture2D $= Nothing + activeTexture $= TextureUnit 1 + textureBinding Texture2D $= Nothing + activeTexture $= TextureUnit 0 + textureBinding Texture2D $= Nothing + +iReshape :: IORef GruffImage -> Size -> IO () +iReshape iR size' = do + s' <- readIORef iR + log s' Debug $ "reshapeCallback " ++ show size' + atomicModifyIORef iR $ \s -> (s{ size = size' }, ()) + update iR True + +iMouse :: IORef GruffImage -> IO () -> Key -> KeyState -> [Modifier] -> Position -> IO () +iMouse sR updateGUI (MouseButton LeftButton ) Down _ p@(Position x y) = do + s' <- readIORef sR + log s' Debug $ "leftMouse " ++ show p + atomicModifyIORef sR $ \s -> let level' = (level s + 1) `min` maxLevel in + ( s{ center = fromPixel s (round x) (round y), level = level' } + , ()) + update sR True >> updateGUI +iMouse sR updateGUI (MouseButton MiddleButton) Down _ p@(Position x y) = do + s' <- readIORef sR + log s' Debug $ "middleMouse " ++ show p + atomicModifyIORef sR $ \s -> + ( s{ center = fromPixel s (round x) (round y) } + , ()) + update sR True >> updateGUI +iMouse sR updateGUI (MouseButton RightButton ) Down _ p@(Position x y) = do + s' <- readIORef sR + log s' Debug $ "rightMouse " ++ show p + atomicModifyIORef sR $ \s -> let level' = (level s - 1) `max` 0 in + ( s{ center = fromPixel s (round x) (round y), level = level' } + , ()) + update sR True >> updateGUI +iMouse _ _ _ _ _ _ = return () + +fromPixel :: GruffImage -> Int -> Int -> (Rational, Rational) +fromPixel s x y = (x', y') + where + Size w h = size s + a = fromIntegral w / fromIntegral h + (cx, cy) = center s + r = 8 / 2 ^ level s * fromIntegral h / (2 * fromIntegral tileSize) + x' = cx + r * (fromIntegral x / fromIntegral w - 0.5) * a + y' = cy + r * (fromIntegral y / fromIntegral h - 0.5) + +toPixel :: GruffImage -> Rational -> Rational -> (Rational, Rational) +toPixel s x y = (x', y') + where + Size w h = size s + a = fromIntegral w / fromIntegral h + (cx, cy) = center s + r = 8 / 2 ^ level s * fromIntegral h / (2 * fromIntegral tileSize) + x' = ((x - cx) / a / r + 0.5) * fromIntegral w + y' = ((y - cy) / r + 0.5) * fromIntegral h + +tileSize :: Int +tileSize = 256 + +cacheSizeMin, cacheSizeMax :: Int +cacheSizeMin = 160 +cacheSizeMax = 250 + +prune :: IORef GruffImage -> IO () +prune sR = do + s0 <- readIORef sR + let cacheSize = M.size (tiles s0) + when (cacheSize > cacheSizeMax) $ do + log s0 Debug . concat $ + [ "pruning texture cache " + , show cacheSize, " > ", show cacheSizeMax + , " --> ", show cacheSizeMin + ] + bad <- atomicModifyIORef sR $ \s -> + let (cx, cy) = center s + f = contains (Point cx cy) . square rootSquare + refine = filter f . liftM2 child [minBound .. maxBound] + Quad{ quadLevel = l0, quadWest = r0, quadNorth = i0 } = + head $ iterate refine [root] !! (level s + 1) + score Quad{ quadLevel = l, quadWest = r, quadNorth = i} + = dl + d r r0 + d i i0 :: Double + where + dl = abs (fromIntegral l - fromIntegral l0) + d x x0 + | l > l0 = abs (xfi - x0fi / 2 ^ (l - l0)) + | l == l0 = abs (xfi - x0fi) + | l < l0 = abs (x0fi - xfi / 2 ^ (l0 - l)) + where xfi = fromIntegral x ; x0fi = fromIntegral x0 + d _ _ = error "score" + o = comparing (score . fst) + (good, bad) + = splitAt cacheSizeMin . sortBy o . M.toList . tiles $ s + in (s{ tiles = M.fromList good }, bad) + let t (_, (t1, t2, t3)) = [t1, t2, t3] + deleteObjectNames $ concatMap t bad + +update :: IORef GruffImage -> Bool -> IO () +update sR newView = do + prune sR + s' <- readIORef sR + log s' Debug $ "updateCallback " ++ show newView + todo' <- atomicModifyIORef sR $ \s -> + let Size w h = size s + ((bw,bn),(be,bs)) = + ( fromPixel s 0 0 + , fromPixel s (fromIntegral w) (fromIntegral h) ) + view = Region + { regionWest = bw, regionNorth = bn + , regionEast = be, regionSouth = bs } + qs = S.fromList $ quads rootSquare view (level s + 1) + todo = S.filter (`M.notMember` tiles s) qs \\ progress s + getQuad q = (,) (square rootSquare q) `fmap` M.lookup q (tiles s) + drp = level s - 4 + tke = 6 + (drp `min` 0) + quads' = mapMaybe getQuad . concat . take tke . drop drp $ + quadss rootSquare view + in (s{ viewQuads = quads' }, todo) + when newView $ do + -- cancel in-progress jobs + putJobs sR [] + mapM_ (`poke` 1) (workers s') + atomicModifyIORef sR $ \s -> (s{ progress = S.empty }, ()) + -- set new jobs + putJobs sR (S.toList todo') + postRedisplay (gl s') + +putTile :: IORef GruffImage -> Tile -> IO () +putTile sR t = do + s <- readIORef sR + ts <- takeMVar (queue s) + putMVar (queue s) (t:ts) + +putJobs :: IORef GruffImage -> [Quad] -> IO () +putJobs sR qs = do + s <- readIORef sR + _ <- takeMVar (jobs s) + putMVar (jobs s) qs + +takeJob :: IORef GruffImage -> IO Quad +takeJob sR = do + s <- readIORef sR + qs <- takeMVar (jobs s) + case qs of + [] -> do + putMVar (jobs s) [] + threadDelay 10000 + takeJob sR + (q:qs') -> do + atomicModifyIORef sR $ \s' -> + ( s'{ progress = S.insert q (progress s') } + , ()) + putMVar (jobs s) qs' + return q + +worker :: IORef GruffImage -> Ptr CInt -> IO () +worker sR p = forever $ do + s <- readIORef sR + q <- takeJob sR + mt <- getTile (log s Debug) (cacheDir s) p q + case mt of + Nothing -> return () + Just t -> putTile sR t + +timer :: IORef GruffImage -> IO () +timer sR = do + s <- readIORef sR + mtls <- tryTakeMVar (queue s) + case mtls of + Just tls@(_:_) -> do + putMVar (queue s) tls + postRedisplay (gl s) + Just [] -> do + putMVar (queue s) [] + _ -> return () + +upload :: Ptr CFloat -> IO TextureObject +upload p = do + [tex] <- genObjectNames 1 + texture Texture2D $= Enabled + textureBinding Texture2D $= Just tex + glTexImage2D gl_TEXTURE_2D 0 (fromIntegral gl_R32F) + (fromIntegral tileSize) (fromIntegral tileSize) 0 + gl_LUMINANCE gl_FLOAT p + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + textureWrapMode Texture2D S $= (Repeated, ClampToEdge) + textureWrapMode Texture2D T $= (Repeated, ClampToEdge) + textureBinding Texture2D $= Nothing + texture Texture2D $= Disabled + return tex + +defSize :: Size +defSize = Size 320 200 + +maxLevel :: Int +maxLevel = 191 + +msPerFrame :: Int +msPerFrame = 40 + +iInitialize :: GLUTGtk -> Pixbuf -> Logger -> FilePath + -> IO ( Window + , Maybe QuadDouble -> Maybe QuadDouble -> Maybe QuadDouble -> Maybe Double -> Maybe Double -> IO () + , (QuadDouble -> QuadDouble -> QuadDouble -> IO ()) -> IO () -> IO () + ) +iInitialize gl' icon lg cacheDir' = do + -- image window + iw <- windowNew + let Size defW defH = defSize + windowSetDefaultSize iw defW defH + set iw + [ containerBorderWidth := 0 + , containerChild := widget gl' + , windowIcon := Just icon + , windowTitle := "gruff browser" + ] + queue' <- newMVar [] + jobs' <- newMVar [] + iR <- newIORef GruffImage + { center = (0, 0) + , level = 0 + , size = defSize + , tiles = M.empty + , queue = queue' + , jobs = jobs' + , progress = S.empty + , viewQuads = [] + , gl = gl' + , cacheDir = cacheDir' + , log = Log.log lg + , workers = [] + , prog = undefined + , hshift = 0 + , hscale = 1 + } + realizeCallback gl' $= iRealize iR + reshapeCallback gl' $= iReshape iR + displayCallback gl' $= iDisplay iR + let iUpdate mre mim mz mhshift mhscale = do + case liftM2 (,) mre mim of + Just (r, i) -> atomicModifyIORef iR $ \s -> + ( s { center = (toRational r, negate $ toRational i) }, () ) + Nothing -> return () + case mz of + Just z | z > 0 -> atomicModifyIORef iR $ \s -> + ( s { level = max 0 . min maxLevel . floor . negate . logBase 2 $ z }, () ) + _ -> return () + case mhshift of + Just x -> atomicModifyIORef iR $ \s -> + ( s { hshift = x }, () ) + _ -> return () + case mhscale of + Just x -> atomicModifyIORef iR $ \s -> + ( s { hscale = x }, () ) + _ -> return () + update iR (any isJust [mre, mim, mz]) + postRedisplay gl' + iInitializeLate aUpdate aExit = do + let updateCoordinates = do + i <- readIORef iR + let re = fromRational . fst . center $ i + im = fromRational . negate . snd . center $ i + z = 2 ^^ negate (level i) + aUpdate re im z + _ <- iw `onDestroy` aExit + _ <- timeoutAdd (timer iR >> return True) msPerFrame + keyboardMouseCallback gl' $= iMouse iR updateCoordinates + return (iw, iUpdate, iInitializeLate) + +iRealize :: IORef GruffImage -> IO () +iRealize iR = do + s <- readIORef iR + log s Debug "realizeCallback" + drawBuffer $= BackBuffers + glClampColor gl_CLAMP_VERTEX_COLOR gl_FALSE + glClampColor gl_CLAMP_READ_COLOR gl_FALSE + glClampColor gl_CLAMP_FRAGMENT_COLOR gl_FALSE + f <- getDataFileName "colourize.frag" + prog' <- shader Nothing (Just f) + ps <- replicateM numCapabilities $ do + p <- malloc + _ <- forkIO (worker iR p) + return p + atomicModifyIORef iR $ \i -> (i{ prog = prog', workers = ps }, ()) diff --git a/CacheView.hs b/CacheView.hs new file mode 100644 --- /dev/null +++ b/CacheView.hs @@ -0,0 +1,351 @@ +module CacheView (cInitialize) where + +import Control.Concurrent (forkIO) +import Control.Monad (forM_, liftM2, when) +import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef) +import qualified Data.Map as M +import Data.Map (Map) +import Data.Maybe (catMaybes, mapMaybe) +import System.FilePath ((), dropExtension) + +import Foreign (alloca, peek, nullPtr) +import Graphics.Rendering.OpenGL hiding (Position, Size) +import qualified Graphics.Rendering.OpenGL as GL +import Graphics.Rendering.OpenGL.Raw + ( glGenFramebuffers, glBindFramebuffer, glFramebufferTexture2D + , gl_FRAMEBUFFER, gl_COLOR_ATTACHMENT0, gl_TEXTURE_2D + , glTexImage2D, gl_R32F, gl_LUMINANCE, gl_FLOAT + , gl_FALSE, glClampColor, gl_CLAMP_VERTEX_COLOR, gl_CLAMP_READ_COLOR + , gl_CLAMP_FRAGMENT_COLOR ) +import Graphics.UI.Gtk hiding (Region, Size) + +import Numeric.QD (QuadDouble) + +import GLUTGtk +import Shader (shader) +import QuadTree (Child(..), unsafeName, Quad, Square(..), square, child, root, outside, Region(..)) +--import Tile (rootSquare) +import Utils (getFilesRecursive) + +import Paths_gruff (getDataFileName) + +rootSquare :: Square +rootSquare = Square{ squareSize = 8, squareWest = -4, squareNorth = -4 } + +names :: Map Char [Child] +names = M.fromList names1 `M.union` M.fromList names2 + where + names1 = [ (unsafeName [i], [i]) | i <- [minBound..maxBound] ] + names2 = [ (unsafeName [i,j], [i,j]) | i <- [minBound..maxBound], j <- [minBound..maxBound] ] + +fromPath :: ([FilePath], FilePath) -> Maybe [Child] +fromPath (ps, f) = + let s = concat ps ++ dropExtension f + p = concat $ mapMaybe (`M.lookup` names) s + in if all (`M.member` names) s then Just p else Nothing + +cDisplay :: IORef GruffCache -> IO () +cDisplay cR = do + c <- readIORef cR + let Size w h = cSize c + TextureObject tex = cTex c + when (cRecalc c) $ do + viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h)) + loadIdentity + ortho2D 0 (fromIntegral w) (fromIntegral h) 0 + withFBO (cFBO c) tex $ do + clearColor $= Color4 0 0 0 1 + clear [ColorBuffer] + let toPixel' = toPixel c + qs = cQuads c + zm = fromIntegral . snd . head $ qs + withBlend (One, One) $ renderPrimitive Quads $ forM_ qs $ \(q, z) -> do + let sq = square rootSquare q + s = squareSize sq `max` cSquareSize c + (x0, y0) = toPixel' (squareWest sq) (squareNorth sq) + (x1, y1) = toPixel' (squareWest sq + s) (squareNorth sq + s) + v x y = vertex $ Vertex2 (fromRational x :: GLdouble) (fromRational y :: GLdouble) + k = fromIntegral z / zm :: GLdouble + color $ Color3 k k k + v x0 y1 >> v x0 y0 >> v x1 y0 >> v x1 y1 + atomicModifyIORef cR $ \c' -> (c'{ cRecalc = False }, ()) + -- draw texture + loadIdentity + ortho2D 0 1 1 0 + textureBinding Texture2D $= Just (cTex c) + currentProgram $= Just (cProg c) + lt <- GL.get $ uniformLocation (cProg c) "tex" + uniform lt $= TexCoord1 (0 :: GLint) + renderPrimitive Quads $ do + let Size tw th = cTexSize c + let tx = fromIntegral w / fromIntegral tw + ty = fromIntegral h / fromIntegral th + v :: GLdouble -> GLdouble -> IO () + v x y = do + texCoord $ TexCoord2 (tx * x) (ty * (1-y)) + vertex $ Vertex2 x y + v 0 1 >> v 0 0 >> v 1 0 >> v 1 1 + currentProgram $= Nothing + textureBinding Texture2D $= Nothing + +withFBO :: GLuint -> GLuint -> IO () -> IO () +withFBO fbo tex act = do + glBindFramebuffer gl_FRAMEBUFFER fbo + glFramebufferTexture2D gl_FRAMEBUFFER gl_COLOR_ATTACHMENT0 gl_TEXTURE_2D tex 0 + act + glFramebufferTexture2D gl_FRAMEBUFFER gl_COLOR_ATTACHMENT0 gl_TEXTURE_2D 0 0 + glBindFramebuffer gl_FRAMEBUFFER 0 + +withBlend :: (BlendingFactor, BlendingFactor) -> IO a -> IO a +withBlend bf act = do + ob <- GL.get blend + obf <- GL.get blendFunc + blend $= Enabled + blendFunc $= bf + r <- act + blendFunc $= obf + blend $= ob + return r + +data GruffCache = GruffCache + { cSize :: Size + , cCenter :: (Rational, Rational) + , cLevel :: Int + , cCacheDir :: FilePath + , cGL :: GLUTGtk + , cProg :: Program + , cTex :: TextureObject + , cTexSize :: Size + , cFBO :: GLuint + , cRecalc :: Bool + , cQTree :: QTree Integer + } + +fromPixel :: GruffCache -> Int -> Int -> (Rational, Rational) +fromPixel c x y = (x', y') + where + Size w h = cSize c + a = fromIntegral w / fromIntegral h + (cx, cy) = cCenter c + r = 8 / 2 ^ cLevel c * fromIntegral h / (2 * fromIntegral tileSize) + x' = cx + r * (fromIntegral x / fromIntegral w - 0.5) * a + y' = cy + r * (fromIntegral y / fromIntegral h - 0.5) + +toPixel :: GruffCache -> Rational -> Rational -> (Rational, Rational) +toPixel c = f + where + f x y = {-# SCC "toPixel'" #-} (x', y') + where + x' = ((x - cx) / r' + 0.5) * w' + y' = ((y - cy) / r + 0.5) * h' + Size w h = cSize c + w' = fromIntegral w + h' = fromIntegral h + a = w' / h' + (cx, cy) = cCenter c + r = 8 / 2 ^ cLevel c * h' / (2 * fromIntegral tileSize) + r' = a * r + +tileSize :: Int +tileSize = 256 + +cRealize :: IORef GruffCache -> IO () +cRealize cR = do + f <- getDataFileName "cache.frag" + prog <- shader Nothing (Just f) + drawBuffer $= BackBuffers + glClampColor gl_CLAMP_VERTEX_COLOR gl_FALSE + glClampColor gl_CLAMP_READ_COLOR gl_FALSE + glClampColor gl_CLAMP_FRAGMENT_COLOR gl_FALSE + [tex] <- genObjectNames 1 + texture Texture2D $= Enabled + textureBinding Texture2D $= Just tex + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + textureWrapMode Texture2D S $= (Repeated, ClampToEdge) + textureWrapMode Texture2D T $= (Repeated, ClampToEdge) + textureBinding Texture2D $= Nothing + texture Texture2D $= Disabled + fbo <- alloca $ \p -> glGenFramebuffers 1 p >> peek p + atomicModifyIORef cR $ \c -> (c{ cProg = prog, cFBO = fbo, cTex = tex }, ()) + c <- readIORef cR + cReshape cR (cSize c) + +cSquareSize :: GruffCache -> Rational +cSquareSize c = squareSize rootSquare / 2 ^ cLevel c / (2 * fromIntegral tileSize) + +cInitialize :: GLUTGtk -> Pixbuf -> FilePath + -> IO ( Window + , Maybe QuadDouble -> Maybe QuadDouble -> Maybe QuadDouble -> IO () + , IO () -> IO () + ) +cInitialize gl' icon cacheDir' = do + -- image window + cw <- windowNew + let Size defW defH = defSize + windowSetDefaultSize cw defW defH + set cw + [ containerBorderWidth := 0 + , containerChild := widget gl' + , windowIcon := Just icon + , windowTitle := "gruff cache" + ] + cR <- newIORef GruffCache + { cCenter = (0, 0) + , cLevel = 0 + , cSize = defSize + , cQTree = QTree 0 Nothing Nothing Nothing Nothing + , cCacheDir = cacheDir' + , cGL = gl' + , cProg = undefined + , cFBO = 0 + , cTex = TextureObject 0 + , cTexSize = roundUpSize defSize + , cRecalc = False + } + realizeCallback gl' $= cRealize cR + reshapeCallback gl' $= cReshape cR + displayCallback gl' $= cDisplay cR + keyboardMouseCallback gl' $= cMouse cR + let cUpdateCoords mre mim mz = do + case liftM2 (,) mre mim of + Just (r, i) -> atomicModifyIORef cR $ \s -> + ( s { cCenter = (toRational r, negate $ toRational i) }, () ) + Nothing -> return () + case mz of + Just z | z > 0 -> atomicModifyIORef cR $ \s -> + ( s { cLevel = max 0 . min maxLevel . floor . negate . logBase 2 $ z }, () ) + _ -> return () + cUpdate cR True + cInitializeLate aExit = do + _ <- cw `onDestroy` aExit + _ <- forkIO $ cRescan cR + return () + return (cw, cUpdateCoords, cInitializeLate) + +cRescan :: IORef GruffCache -> IO () +cRescan cR = do + c' <- readIORef cR + fs <- getFilesRecursive (cCacheDir c' ".") + let q = depthQ . treeQ . mapMaybe fromPath $ fs + atomicModifyIORef cR $ \c -> (c{ cQTree = q }, ()) + postGUISync (cUpdate cR True) + +maxLevel :: Int +maxLevel = 200 +defSize :: Size +defSize = Size 320 200 + +cUpdate :: IORef GruffCache -> Bool -> IO () +cUpdate cR rec = do + c' <- readIORef cR + atomicModifyIORef cR $ \c -> (c{ cRecalc = cRecalc c || rec }, ()) + postRedisplay (cGL c') + +cReshape :: IORef GruffCache -> Size -> IO () +cReshape iR size' = do + c <- readIORef iR + let tsize@(Size tw th) = roundUpSize size' + textureBinding Texture2D $= Just (cTex c) + glTexImage2D gl_TEXTURE_2D 0 (fromIntegral gl_R32F) + (fromIntegral tw) (fromIntegral th) 0 gl_LUMINANCE gl_FLOAT nullPtr + textureBinding Texture2D $= Nothing + atomicModifyIORef iR $ \s -> (s{ cSize = size', cTexSize = tsize }, ()) + cUpdate iR True + +cMouse :: IORef GruffCache -> Key -> KeyState -> [Modifier] -> Position -> IO () +cMouse sR (MouseButton LeftButton ) Down _ (Position x y) = do + atomicModifyIORef sR $ \s -> let level' = (cLevel s + 1) `min` maxLevel in + ( s{ cCenter = fromPixel s (round x) (round y), cLevel = level' } + , ()) + cUpdate sR True +cMouse sR (MouseButton MiddleButton) Down _ (Position x y) = do + atomicModifyIORef sR $ \s -> + ( s{ cCenter = fromPixel s (round x) (round y) } + , ()) + cUpdate sR True +cMouse sR (MouseButton RightButton ) Down _ (Position x y) = do + atomicModifyIORef sR $ \s -> let level' = (cLevel s - 1) `max` 0 in + ( s{ cCenter = fromPixel s (round x) (round y), cLevel = level' } + , ()) + cUpdate sR True +cMouse _ _ _ _ _ = return () + +roundUpSize :: Size -> Size +roundUpSize (Size w h) = Size (roundUp w) (roundUp h) + +roundUp :: Int -> Int +roundUp x = head . filter (>= x) . iterate (2*) $ 1 + +data QTree a = QTree a (Maybe (QTree a)) (Maybe (QTree a)) (Maybe (QTree a)) (Maybe (QTree a)) + +payloadQ :: QTree a -> a +payloadQ (QTree w _ _ _ _) = w + +childQ :: Child -> QTree a -> Maybe (QTree a) +childQ NorthWest (QTree _ a _ _ _) = a +childQ NorthEast (QTree _ _ b _ _) = b +childQ SouthWest (QTree _ _ _ c _) = c +childQ SouthEast (QTree _ _ _ _ d) = d + +emptyQ :: QTree Bool +emptyQ = QTree False Nothing Nothing Nothing Nothing + +insertQ :: [Child] -> QTree Bool -> QTree Bool +insertQ [] (QTree _ a b c d) = QTree True a b c d +insertQ (x:xs) (QTree w a b c d) = case x of + NorthWest -> case a of + Nothing -> QTree w (Just $ insertQ xs emptyQ) b c d + Just a' -> QTree w (Just $ insertQ xs a' ) b c d + NorthEast -> case b of + Nothing -> QTree w a (Just $ insertQ xs emptyQ) c d + Just b' -> QTree w a (Just $ insertQ xs b' ) c d + SouthWest -> case c of + Nothing -> QTree w a b (Just $ insertQ xs emptyQ) d + Just c' -> QTree w a b (Just $ insertQ xs c' ) d + SouthEast -> case d of + Nothing -> QTree w a b c (Just $ insertQ xs emptyQ) + Just d' -> QTree w a b c (Just $ insertQ xs d' ) + +treeQ :: [[Child]] -> QTree Bool +treeQ = foldr insertQ emptyQ + +{- +sizeQ :: QTree Bool -> QTree Integer +sizeQ (QTree w a b c d) = QTree n a' b' c' d' + where + s@[a', b', c', d'] = fmap sizeQ `map` [a, b, c, d] + n = (if w then 1 else 0) + (sum . map payloadQ . catMaybes) s +-} + +depthQ :: QTree a -> QTree Integer +depthQ = depthQ' 0 + where + depthQ' n (QTree _ Nothing Nothing Nothing Nothing) = QTree n Nothing Nothing Nothing Nothing + depthQ' n (QTree _ a b c d) = QTree m a' b' c' d' + where + s@[a', b', c', d'] = fmap (depthQ' (n + 1)) `map` [a, b, c, d] + m = maximum . map payloadQ . catMaybes $ s + +pruneQ :: Int -> QTree a -> QTree a +pruneQ 0 (QTree w _ _ _ _) = QTree w Nothing Nothing Nothing Nothing +pruneQ n (QTree w a b c d) = QTree w a' b' c' d' + where + [a', b', c', d'] = fmap (pruneQ (n - 1)) `map` [a, b, c, d] + +cQuads :: GruffCache -> [(Quad, Integer)] +cQuads c = map (fmap payloadQ) . concat . quadsQ view . pruneQ (cLevel c + 12) . cQTree $ c + where + Size w h = cSize c + ((bw,bn),(be,bs)) = + ( fromPixel c 0 0 + , fromPixel c (fromIntegral w) (fromIntegral h) ) + view = Region + { regionWest = bw, regionNorth = bn + , regionEast = be, regionSouth = bs } + +quadsQ :: Region -> QTree a -> [[(Quad, QTree a)]] +quadsQ view q = takeWhile (not . null) . iterate (filter keep . children') $ [(root, q)] + where + keep = not . outside view . square rootSquare . fst + children' = catMaybes . liftM2 child' [minBound .. maxBound] + child' c (quad, qtree) = (,) (child c quad) `fmap` childQ c qtree diff --git a/GLUTGtk.hs b/GLUTGtk.hs new file mode 100644 --- /dev/null +++ b/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/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,339 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. diff --git a/Logger.hs b/Logger.hs new file mode 100644 --- /dev/null +++ b/Logger.hs @@ -0,0 +1,40 @@ +module Logger where + +import Prelude hiding (log) +import Control.Concurrent (forkIO, newChan, readChan, writeChan) +import Data.Time (formatTime, getCurrentTime, UTCTime) +import System.Locale (defaultTimeLocale) +import System.FilePath ((), (<.>)) +import System.IO (openFile, IOMode(WriteMode), hPutStrLn, hClose, hFlush) + +data LogLevel = Error | Warn | Info | Debug + deriving (Read, Show, Eq, Ord, Enum, Bounded) + +data Logger = Logger + { log :: LogLevel -> String -> IO () + , close :: IO () + } + +logger :: FilePath -> IO Logger +logger logDir = do + date <- getDate + let logFile = logDir filter (':'/=) date <.> "log" + h <- openFile logFile WriteMode + c <- newChan + let log' lvl msg = do + d <- getDate + writeChan c (Just $ d ++ "\t" ++ show lvl ++ "\t" ++ show msg) + close' = log' Info "closing log" >> writeChan c Nothing + writer = do + m <- readChan c + case m of + Nothing -> hClose h >> return () + Just s -> hPutStrLn h s >> hFlush h >> writer + _ <- forkIO writer + log' Info "opening log" + return Logger{ log = log', close = close' } + where + logFormat :: UTCTime -> String + logFormat = formatTime defaultTimeLocale "%FT%T" + getDate :: IO String + getDate = logFormat `fmap` getCurrentTime diff --git a/Nucleus.hs b/Nucleus.hs new file mode 100644 --- /dev/null +++ b/Nucleus.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE Rank2Types #-} +module Nucleus (refineNucleus) where + +import Prelude hiding (zipWith) +import Data.Functor ((<$>)) +import Data.List (genericIndex, genericSplitAt) +import Data.Vec ((:.)((:.)), toList, solve, fromList, matFromLists, Vec2, NearZero(nearZero), zipWith) +import Text.FShow.Raw (DecimalFormat(nanTest)) +import Numeric.AD (jacobian', FF, lift, UU, findZero) +import Fractal.RUFF.Types.Complex (Complex((:+)), cis, magnitude) +import Utils () + +refineNucleus :: (DecimalFormat r, Floating r, Fractional r, Ord r, NearZero r) => Integer -> Complex r -> (r, Complex r) +refineNucleus p g = + let c = converge $ findZero (nucleusIter' p) g + [_, bond0] = root2 (bondIter' p (cis ( pi / 3))) [c, c] + [_, bond1] = root2 (bondIter' p (cis (-pi / 3))) [c, c] + r = magnitude (bond1 - bond0) + in (r, c) + +converge :: (DecimalFormat r, NearZero r, Num r) => [Complex r] -> Complex r +converge (x:ys@(y@(yr:+yi):_)) + | nanTest yr || nanTest yi = x + | nearZero (x - y) = x + | otherwise = converge ys +converge [x] = x +converge [] = error "gruff.Nucleus.converge: internal error" + +-- finding nucleus +nucleusIter' :: Fractional r => Integer -> UU r +nucleusIter' n c = (`genericIndex` n) . iterate (\z -> z * z + c) $ 0 + +-- finding bond points +fdf :: (Integral i, Num c) => i -> c -> c -> (c, c) +fdf n z c = let (fzs, fz:_) = genericSplitAt n $ iterate (\w -> w * w + c) z + in (fz, 2 ^ n * product fzs) + +bondIter' :: (Fractional c) => Integer -> c -> FF [] [] c +bondIter' n b [z, c] = + let b' = lift b + (fz, dfz) = fdf n z c + p = fz - z + q = dfz - b' + in [p, q] +bondIter' _ _ _ = error "bondIter' internal error" + +-- Newton's method +root2' :: (Fractional r, Ord r, NearZero r) => FF [] [] r -> Vec2 r -> Vec2 r +root2' f x = go x + where + go x0 = + let (ys, js) = unzip $ jacobian' f (toList x0) + y = fromList (negate <$> ys) `asTypeOf` x + j = matFromLists js `asTypeOf` ((x:.x:.())) + mdx = solve j y + in if all nearZero ys + then x0 + else case mdx of + Nothing -> x0 + Just dx -> + let x1 = zipWith (+) x0 dx + in if all nearZero (toList dx) + then x0 + else go x1 + +root2 :: (Fractional r, NearZero r, Ord r) => FF [] [] r -> [r] -> [r] +root2 f = toList . root2' f . fromList diff --git a/PeriodScan.hs b/PeriodScan.hs new file mode 100644 --- /dev/null +++ b/PeriodScan.hs @@ -0,0 +1,55 @@ +module PeriodScan (periodScan, periodNucleus) where + +import Control.Parallel.Strategies (parMap, rseq) +import Data.List (genericIndex, nubBy) +import Data.Maybe (listToMaybe) +import Data.Function (on) +import Data.Vec (NearZero, nearZero) +import Text.FShow.Raw (DecimalFormat(nanTest, infTest)) + +import Fractal.RUFF.Types.Complex (Complex((:+))) + +import Utils (safeLast) + +periodScan :: (Floating r, Ord r) => r -> Complex r -> Maybe Integer +periodScan r c = + let cs = [ c + (r:+r), c + (r:+(-r)), c + ((-r):+(-r)), c + ((-r):+r) ] + zs = iterate (zipWith (\cc z -> z * z + cc) cs) [0,0,0,0] + in fmap fst . listToMaybe . dropWhile (not . straddlesOrigin . snd) . zip [0 ..] $ zs + +periodNucleus1 :: (Floating r, Ord r) => Integer -> r -> Complex r -> [(r, Complex r)] +periodNucleus1 p r0 c0 + = map fst . filter (straddlesOrigin . snd) + . parMap rseq (fmap (parMap rseq (\c -> iterate (\z->z * z + c) 0 `genericIndex` p))) + . fmap (\(r, c) -> ((r, c), [c + (r:+r), c + ((-r):+r), c + ((-r):+(-r)), c + (r:+(-r))])) + $( [ (r', c0 + d) | i <- [-1,1], j <- [-1,1 ], let d = ((r'*i) :+ (r'*j)) ] + ++ [ (r', c0 + d) | i <- [ 0 ], j <- [ 0 ], let d = ((r'*i) :+ (r'*j)) ]) +{- + of + [] -> [] + xs -> fmap fst . minimumBy (comparing $ offsetFromOrigin . snd) $ xs -} + where r' = r0 / 2 + +periodNucleus :: (NearZero r, DecimalFormat r, Floating r, Ord r) => Integer -> r -> Complex r -> Maybe (Complex r) +periodNucleus p r0 c0 = + let ok (r, (x:+y)) = all ok' [r, x, y] + ok' x = not (nanTest x || infTest x) + in fmap snd . safeLast . takeWhile ok . concat . takeWhile (not . null) . iterate (nubBy (approxEq `on` snd) . (uncurry (periodNucleus1 p) =<<)) $ [(r0, c0)] + +straddlesOrigin :: (Ord r, Num r) => [Complex r] -> Bool +straddlesOrigin ps = odd . length . filter id . zipWith positiveReal ps $ (drop 1 ps ++ take 1 ps) + +positiveReal :: (Ord r, Num r) => Complex r -> Complex r -> Bool +positiveReal (u:+v) (x:+y) + | v < 0 && y < 0 = False + | v > 0 && y > 0 = False + | (u * (y - v) - v * (x - u)) * (y - v) > 0 = True + | otherwise = False + +{- +offsetFromOrigin :: (Floating r) => [Complex r] -> r +offsetFromOrigin = magnitude . sum +-} + +approxEq :: (Num c, NearZero c) => c -> c -> Bool +approxEq w z = nearZero (w - z) diff --git a/QuadTree.hs b/QuadTree.hs new file mode 100644 --- /dev/null +++ b/QuadTree.hs @@ -0,0 +1,95 @@ +module QuadTree + ( Child(..), north, south, west, east + , Quad(..), root, child, children, parent, parents + , filename, unsafeName + , Square(..), square, Point(..), contains, Region(..), outside, quads, quadss + ) where + +import Control.Monad (liftM2) +import Data.Bits (bit, shiftL, shiftR, testBit, (.|.)) +import Data.List (unfoldr) +import Data.Ratio ((%)) + +data Child = NorthWest | NorthEast | SouthWest | SouthEast + deriving (Read, Show, Eq, Ord, Enum, Bounded) + +north, south, west, east :: Child -> Bool +east c = fromEnum c `testBit` 0 +south c = fromEnum c `testBit` 1 +north = not . south +west = not . east + +data Quad = Quad{ quadLevel :: !Int, quadWest, quadNorth :: !Integer } + deriving (Read, Show, Eq, Ord) + +root :: Quad +root = Quad{ quadLevel = 0, quadWest = 0, quadNorth = 0 } + +child :: Child -> Quad -> Quad +child c Quad{ quadLevel = l, quadWest = x, quadNorth = y } = Quad + { quadLevel = l + 1 + , quadWest = x `shiftL` 1 .|. (fromIntegral . fromEnum . east ) c + , quadNorth = y `shiftL` 1 .|. (fromIntegral . fromEnum . south) c + } + +children :: [Child] -> Quad +children = foldr child root + +parent :: Quad -> Maybe (Child, Quad) +parent Quad{ quadLevel = l, quadWest = x, quadNorth = y } + | l > 0 = Just + ( toEnum (fromEnum (y `testBit` 0) `shiftL` 1 .|. fromEnum (x `testBit` 0)) + , Quad{ quadLevel = l - 1, quadWest = x `shiftR` 1, quadNorth = y `shiftR` 1 } + ) + | otherwise = Nothing + +parents :: Quad -> [Child] +parents = unfoldr parent + +filename :: Quad -> Maybe ([FilePath], FilePath) +filename q + | null cs = Nothing + | otherwise = Just (init cs, last cs) + where + cs = chunk 2 . map unsafeName . chunk 2 . reverse . parents $ q + +unsafeName :: [Child] -> Char +unsafeName [c] = ['a'..'d'] !! (fromEnum c) +unsafeName [c,d] = ['e'..'t'] !! (fromEnum c `shiftL` 2 .|. fromEnum d) +unsafeName _ = error "QuadTree.unsafeName" + +chunk :: Int -> [a] -> [[a]] +chunk _ [] = [] +chunk n xs = let (ys, zs) = splitAt n xs in ys : chunk n zs + +data Square = Square{ squareSize, squareWest, squareNorth :: !Rational } + deriving (Read, Show, Eq, Ord) + +square :: Square -> Quad -> Square +square Square{ squareSize = s0, squareWest = x0, squareNorth = y0 } Quad{ quadLevel = l, quadWest = x, quadNorth = y } = + Square{ squareSize = s0 / fromInteger r, squareWest = x0 + s0 * (x % r), squareNorth = y0 + s0 * (y % r) } where r = bit l + +data Region = Region{ regionNorth, regionSouth, regionWest, regionEast :: !Rational } + deriving (Read, Show, Eq, Ord) + +outside :: Region -> Square -> Bool +outside r s + = regionSouth r < squareNorth s + || regionEast r < squareWest s + || regionNorth r > squareNorth s + squareSize s + || regionWest r > squareWest s + squareSize s + +data Point = Point{ pointWest, pointNorth :: !Rational } + deriving (Read, Show, Eq, Ord) + +contains :: Point -> Square -> Bool +contains p s + = squareNorth s <= pointNorth p && pointNorth p <= squareNorth s + squareSize s + && squareWest s <= pointWest p && pointWest p <= squareWest s + squareSize s + +quads :: Square -> Region -> Int -> [Quad] +quads rootSquare region level = quadss rootSquare region !! level + +quadss :: Square -> Region -> [[Quad]] +quadss rootSquare region = + iterate (filter (not . outside region . square rootSquare) . liftM2 child [minBound .. maxBound]) [root] diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Shader.hs b/Shader.hs new file mode 100644 --- /dev/null +++ b/Shader.hs @@ -0,0 +1,26 @@ +module Shader (shader) where + +import Graphics.Rendering.OpenGL + +shader :: Maybe FilePath -> Maybe FilePath -> IO Program +shader mV mF = do + [p] <- genObjectNames 1 + vs <- case mV of + Nothing -> return [] + Just v -> do + [vert] <- genObjectNames 1 + source <- readFile v + shaderSource vert $= [ source ] + compileShader vert + return [vert] + fs <- case mF of + Nothing -> return [] + Just f -> do + [frag] <- genObjectNames 1 + source <- readFile f + shaderSource frag $= [ source ] + compileShader frag + return [frag] + attachedShaders p $= (vs, fs) + linkProgram p + return p diff --git a/StatusDialog.hs b/StatusDialog.hs new file mode 100644 --- /dev/null +++ b/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 $ postGUISync . labelSetText label + postGUISync $ widgetHide window + _ <- cancel `onClicked` do + killThread child + widgetHide window + widgetShowAll window + } diff --git a/Tile.hs b/Tile.hs new file mode 100644 --- /dev/null +++ b/Tile.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Tile where + +import Prelude hiding (log) + +import Control.Exception (bracketOnError) +import Control.Monad (when) +import Data.Bits (shiftL, shiftR, (.&.)) +import Foreign (Ptr, castPtr, sizeOf, mallocArray, free, Word8, with, poke, allocaBytes, withArray, peekArray) +import Foreign.C (CFloat, CDouble, CInt, CSize, withCStringLen) +import System.Directory (createDirectoryIfMissing) +import System.FilePath ((), (<.>)) +import System.IO (withBinaryFile, IOMode(ReadMode,WriteMode), hPutBuf, hGetBuf) +--import Data.BEncode +import Numeric.QD + +import QuadTree +import Utils (catchIO) + +width, height, count, bytes :: Int +width = 256 +height = 256 +count = width * height +bytes = count * sizeOf (0 :: CFloat) + +rootSquare :: Square +rootSquare = Square{ squareSize = 8, squareWest = -4, squareNorth = -4 } + +data Tile = Tile Quad (Ptr CFloat) (Ptr CFloat) (Ptr CFloat) + +mallocTile :: Quad -> IO Tile +mallocTile cs = do + ns <- mallocArray count + ds <- mallocArray count + ts <- mallocArray count + return $ Tile cs ns ds ts + +freeTile :: Tile -> IO () +freeTile (Tile _ ns ds ts) = do + free ns + free ds + free ts + +header :: String +header = "RuFfTiLe001\n" + +writeTile :: FilePath -> Tile -> IO () +writeTile cacheDir (Tile q ns ds ts) = do + case filename q of + Nothing -> return () + Just (dirs, file) -> do + let dir = foldr1 () (cacheDir : dirs) + createDirectoryIfMissing True dir + withBinaryFile (dir file <.> "ruff") WriteMode $ \h -> do + withCStringLen header $ \(p, l) -> hPutBuf h p l + withArray (wordBE (bytes * 3)) $ \p -> hPutBuf h p 4 + hPutBuf h ns bytes + hPutBuf h ds bytes + hPutBuf h ts bytes +-- hPut h . bPack . metaData $ q + where + wordBE :: Int -> [Word8] + wordBE n = map (\b -> fromIntegral $ (n `shiftR` (8 * b)) .&. 0xFF) [3, 2, 1, 0] + +{- +metaData :: Quad -> BEncode +metaData q@Quad{ quadLevel = l, quadWest = w, quadNorth = n } = + BDict $ fromList [ ("tile", BDict $ fromList + [ ("about", BDict $ fromList + [ ("version", BInt 1) + , ("generator", BString $ pack "gruff-0.1") ] + , ("images", BDict . fromList . map image . zip [0..] $ + [ "continuous dwell", "normalized distance", "final angle"]) ] + ] + where + image plane alg = (alg, BDict $ fromList + [ ("width", BInt (fromIntegral width)) + , ("height", BInt (fromIntegral height)) + , ("real", BInt w) + , ("imag", BInt (negate n)) + , ("scale", BInt (fromIntegral l + 2)) + , ("format", BString $ pack "float32le") + , ("order", BString $ pack "lr,tb") + , ("data offset", BInt (fromIntegral $ plane * count * sizeOf (0 :: CFloat))) + ]) +-} + +readTile :: FilePath -> Quad -> IO (Maybe Tile) +readTile cacheDir q = flip catchIO (\_ -> return Nothing) $ do + case filename q of + Nothing -> return Nothing + Just (dirs, file) -> do + let dir = foldr1 () (cacheDir : dirs) + bracketOnError (mallocTile q) freeTile $ \t@(Tile _ ns ds ts) -> do + withBinaryFile (dir file <.> "ruff") ReadMode $ \h -> do + let headerBytes = 12 + allocaBytes headerBytes $ \p -> do + headerBytes' <- hGetBuf h p headerBytes + when (headerBytes /= headerBytes') $ fail "readTile header fail" + header' <- peekArray headerBytes p + when (header' /= (map (fromIntegral . fromEnum) header :: [Word8])) $ fail "readTile header mismatch" + dataBytes <- allocaBytes 4 $ \p -> do + lenBytes' <- hGetBuf h p 4 + when (lenBytes' /= 4) $ fail "readTile header length fail" + unwordBE `fmap` peekArray 4 p + when (dataBytes /= bytes * 3) $ fail "readTile header length mismatch" + bytes' <- hGetBuf h ns bytes + when (bytes /= bytes') $ fail ("readTile 0 " ++ show bytes ++ " /= " ++ show bytes') + bytes'' <- hGetBuf h ds bytes + when (bytes /= bytes'') $ fail ("readTile 1 " ++ show bytes ++ " /= " ++ show bytes'') + bytes''' <- hGetBuf h ts bytes + when (bytes /= bytes''') $ fail ("readTile 2 " ++ show bytes ++ " /= " ++ show bytes''') + return $ Just t + where + unwordBE :: [Word8] -> Int + unwordBE = sum . zipWith (\b n -> fromIntegral n `shiftL` (8 * b)) [3, 2, 1, 0] + +clearTile :: Tile -> IO () +clearTile (Tile _ ns ds ts) = do + mapM_ clear [ns, ds, ts] + where + clear p = c_memset (castPtr p) 0 (fromIntegral bytes) + +computeTile :: (String -> IO ()) -> Ptr CInt -> Tile -> IO Bool +computeTile log p (Tile q@Quad{ quadLevel = l } ns ds ts) = do + its <- compute' + log $ show ("getTile", q, "computed", its) + return $ its /= 0 + where + compute' + | l < 18 = c_compute_f32 p ns ds ts cx cy l' m' + | l < 48 = c_compute_f64 p ns ds ts cx cy l' m' + | l < 96 = with (cx :: DoubleDouble) $ \px -> with (cy :: DoubleDouble) $ \py -> + c_compute_f128 p ns ds ts (castPtr px) (castPtr py) l' m' + | l < 192 = with (cx :: QuadDouble ) $ \px -> with (cy :: QuadDouble ) $ \py -> + c_compute_f256 p ns ds ts (castPtr px) (castPtr py) l' m' + | otherwise = error "Tile.computeTile: too deep" + l' = fromIntegral l + m' = 10000000 + s = square rootSquare q + cx, cy :: Fractional a => a + cx = fromRational (squareWest s) + cy = fromRational (squareNorth s) + +getTile :: (String -> IO ()) -> FilePath -> Ptr CInt -> Quad -> IO (Maybe Tile) +getTile log cacheDir p q = do + mTile <- readTile cacheDir q + case mTile of + Just t -> do + log $ show ("getTile", q, "read") + return (Just t) + Nothing -> do + log $ show ("getTile", q, "compute") + t <- mallocTile q + clearTile t + poke p 0 + ok <- computeTile log p t + if ok + then writeTile cacheDir t >> return (Just t) + else freeTile t >> return Nothing + +foreign import ccall unsafe "string.h memset" + c_memset :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8) + +foreign import ccall "compute.h compute_f32" + c_compute_f32 :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> CFloat -> CFloat -> CInt -> CInt -> IO CInt + +foreign import ccall "compute.h compute_f64" + c_compute_f64 :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> CDouble -> CDouble -> CInt -> CInt -> IO CInt + +foreign import ccall "compute.h compute_f128" + c_compute_f128 :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> Ptr CDouble -> Ptr CDouble -> CInt -> CInt -> IO CInt + +foreign import ccall "compute.h compute_f256" + c_compute_f256 :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> Ptr CDouble -> Ptr CDouble -> CInt -> CInt -> IO CInt diff --git a/Utils.hs b/Utils.hs new file mode 100644 --- /dev/null +++ b/Utils.hs @@ -0,0 +1,43 @@ +module Utils where + +import Prelude hiding (catch) +import Control.Exception (catch, IOException) +import Control.Monad (forM) +import System.Directory (getDirectoryContents, doesFileExist, doesDirectoryExist) +import System.FilePath (()) +import Data.Vec (NearZero(nearZero)) +import Numeric.QD (QuadDouble) +import Fractal.RUFF.Types.Complex (Complex((:+))) + +safeRead :: Read a => String -> Maybe a +safeRead s = case reads s of + [(a, "")] -> Just a + _ -> Nothing + +catchIO :: IO a -> (IOException -> IO a) -> IO a +catchIO = catch + +getFilesRecursive :: FilePath -> IO [([FilePath], FilePath)] +getFilesRecursive d = (do + fs0 <- getDirectoryContents d + let fs = filter (`notElem` [".", ".."]) fs0 + ffs <- forM fs $ \f -> do + let df = d f + fe <- doesFileExist df + fd <- doesDirectoryExist df + case (fe, fd) of + (True, False) -> return [([], f)] + (False, True) -> map (\(ds, f') -> (f:ds, f')) `fmap` getFilesRecursive df + _ -> return [] + return (concat ffs)) `catchIO` (\_ -> return []) + +safeLast :: [a] -> Maybe a +safeLast [] = Nothing +safeLast [x] = Just x +safeLast (_:xs) = safeLast xs + +instance NearZero QuadDouble where + nearZero x = not (abs x > (1e-60)) + +instance (NearZero a) => NearZero (Complex a) where + nearZero (r :+ i) = nearZero r && nearZero i diff --git a/cache.frag b/cache.frag new file mode 100644 --- /dev/null +++ b/cache.frag @@ -0,0 +1,82 @@ +uniform sampler2D tex; + +float lin_interp(float x, float domain_low, float domain_hi, float range_low, float range_hi) { + if ((x >= domain_low) && (x <= domain_hi)) { + x = (x - domain_low) / (domain_hi - domain_low); + x = range_low + x * (range_hi - range_low); + } + return x; +} + +float pvp_adjust_3(float x) { + // red + x = lin_interp(x, 0.00, 0.125, -0.050, 0.090); + // orange + x = lin_interp(x, 0.125, 0.25, 0.090, 0.167); + // yellow + x = lin_interp(x, 0.25, 0.375, 0.167, 0.253); + // chartreuse + x = lin_interp(x, 0.375, 0.50, 0.253, 0.383); + // green + x = lin_interp(x, 0.50, 0.625, 0.383, 0.500); + // teal + x = lin_interp(x, 0.625, 0.75, 0.500, 0.667); + // blue + x = lin_interp(x, 0.75, 0.875, 0.667, 0.800); + // purple + x = lin_interp(x, 0.875, 1.00, 0.800, 0.950); + return(x); +} + +vec3 hsv2rgb(float h, float s, float v) +{ + float i, f, p, q, t, r, g, b; + int ii; + if (s == 0.0) { + // Ignore hue + r = v; + g = v; + b = v; + } else { + /* Apply physiological mapping: red, yellow, green and blue should + be equidistant. */ + h = pvp_adjust_3(h); + h = h - floor(h); + h = h * 6.0; + i = floor(h); ii = int(i); + f = h - i; + p = v*(1.0 - s); // The "low-flat" curve + q = v*(1.0 - (s*f)); // The "falling" curve + t = v*(1.0 - (s*(1.0 - f))); // The "rising" curve + switch(ii) { + case 0: // red point + r = v; g = t; b = p; // RED max, GRN rising, BLU min + break; + case 1: // yellow point + r = q; g = v; b = p; // RED falling, GRN max, BLU min + break; + case 2: // green point + r = p; g = v; b = t; // RED min, GRN max, BLU rising + break; + case 3: // cyan point + r = p; g = q; b = v; // RED min, GRN falling, BLU max + break; + case 4: // blue point + r = t; g = p; b = v; // RED rising, GRN min, BLU max + break; + case 5: // magenta point + default: + r = v; g = p; b = q; // RED max, GRN min, BLU falling + break; + } + } + return vec3(r, g, b); +} + +void main(void) { + float n = texture2D(tex, gl_TexCoord[0].st).x; + float h = n; + float s = 1.0; + float v = clamp(0.0, 1.0, 0.25 + log(h + 1.0)); + gl_FragColor = vec4(hsv2rgb(frac(h), s, v), 1.0); +} diff --git a/colourize.frag b/colourize.frag new file mode 100644 --- /dev/null +++ b/colourize.frag @@ -0,0 +1,96 @@ +uniform sampler2D de; +uniform sampler2D it; +uniform sampler2D tt; + +uniform float hshift; +uniform float hscale; + +float lin_interp(float x, float domain_low, float domain_hi, float range_low, float range_hi) { + if ((x >= domain_low) && (x <= domain_hi)) { + x = (x - domain_low) / (domain_hi - domain_low); + x = range_low + x * (range_hi - range_low); + } + return x; +} + +float pvp_adjust_3(float x) { + // red + x = lin_interp(x, 0.00, 0.125, -0.050, 0.090); + // orange + x = lin_interp(x, 0.125, 0.25, 0.090, 0.167); + // yellow + x = lin_interp(x, 0.25, 0.375, 0.167, 0.253); + // chartreuse + x = lin_interp(x, 0.375, 0.50, 0.253, 0.383); + // green + x = lin_interp(x, 0.50, 0.625, 0.383, 0.500); + // teal + x = lin_interp(x, 0.625, 0.75, 0.500, 0.667); + // blue + x = lin_interp(x, 0.75, 0.875, 0.667, 0.800); + // purple + x = lin_interp(x, 0.875, 1.00, 0.800, 0.950); + return(x); +} + +vec3 hsv2rgb(float h, float s, float v) +{ + float i, f, p, q, t, r, g, b; + int ii; + if (s == 0.0) { + // Ignore hue + r = v; + g = v; + b = v; + } else { + /* Apply physiological mapping: red, yellow, green and blue should + be equidistant. */ + h = pvp_adjust_3(h); + h = h - floor(h); + h = h * 6.0; + i = floor(h); ii = int(i); + f = h - i; + p = v*(1.0 - s); // The "low-flat" curve + q = v*(1.0 - (s*f)); // The "falling" curve + t = v*(1.0 - (s*(1.0 - f))); // The "rising" curve + switch(ii) { + case 0: // red point + r = v; g = t; b = p; // RED max, GRN rising, BLU min + break; + case 1: // yellow point + r = q; g = v; b = p; // RED falling, GRN max, BLU min + break; + case 2: // green point + r = p; g = v; b = t; // RED min, GRN max, BLU rising + break; + case 3: // cyan point + r = p; g = q; b = v; // RED min, GRN falling, BLU max + break; + case 4: // blue point + r = t; g = p; b = v; // RED rising, GRN min, BLU max + break; + case 5: // magenta point + default: + r = v; g = p; b = q; // RED max, GRN min, BLU falling + break; + } + } + return vec3(r, g, b); +} + +void main(void) { + float d = texture2D(de, gl_TexCoord[0].st).x; + float i = texture2D(it, gl_TexCoord[0].st).x; + float t = texture2D(tt, gl_TexCoord[0].st).x; + vec4 c = vec4(vec3(1.0), 1.0); + if (i > 0.0) { + float h = hscale * log(i) + hshift; + float s; + float v; + if (t > 0.0) { s = 0.55; } else { s = 0.45; } + if (frac(i / 2) < 0.5) { v = 0.95; } else { v = 1.00; } + c.rgb = hsv2rgb(h, s, v); + c.rgb *= clamp(0.5 + 0.25 * log(d), 0.0, 1.0); + } + gl_FragColor = c; +} diff --git a/compute.cc b/compute.cc new file mode 100644 --- /dev/null +++ b/compute.cc @@ -0,0 +1,173 @@ +#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/gruff.cabal b/gruff.cabal new file mode 100644 --- /dev/null +++ b/gruff.cabal @@ -0,0 +1,51 @@ +Name: gruff +Version: 0.1 +Synopsis: fractal explorer GUI using the ruff library +Description: + Currently allows exploration only of the Mandelbrot Set fractal. + Requires GTK, OpenGL, and GLSL fragment shader support. + . + Features in this version include: + . + * Interactive fractal browser display (left click to zoom in, + right click to zoom out, middle-click to center). + . + * Session persistance (stored in ~/.gruff/state.gruff - states can + also be loaded from and saved to other files). + . + * Tile cache (by default in ~/.gruff/cache - symlink it somewhere + with a few GB of space if you plan on exploring a lot). + . + * High-level feature finding using angled internal addresses + (enter an address, for example @1 2 3 1/3 10@, and hit return, + then click the address to coordinates button). + . + * Feature finding using period location (navigate to approximate + location of the desired feature, click the period scan button). + . + * Cache view (refreshed on program start) to visualize visited + locations. + . + Future features might include image saving, external ray and nucleus + period overlays, more feature finding and identification algorithms, + customizable colour schemes, higher precision for deeper zooms, etc. + +License: GPL-2 +License-file: LICENSE +Author: Claude Heiland-Allen +Maintainer: claudiusmaximus@goto10.org +Category: Graphics + +Build-type: Simple +Cabal-version: >=1.4 + +Data-files: icon.png, colourize.frag, cache.frag + +Executable gruff + Main-is: gruff.hs + Build-depends: base >= 4 && < 5, ad >= 1 && < 2, containers >= 0 && < 1, directory >= 1 && < 2, filepath >= 1 && < 2, floatshow >= 0.2 && < 0.3, gtk >= 0.11 && < 0.13, gtkglext >= 0.11 && < 0.13, old-locale >= 1 && < 2, OpenGL >= 2.4 && < 3, OpenGLRaw >= 1.1 && < 2, parallel >= 3.1 && < 3.2, qd >= 1 && < 2, time >= 1 && < 2, Vec >= 0.9 && < 1, wl-pprint-text >= 1 && < 2, bytestring, mtl, ruff >= 0.1 && < 0.2 + Other-modules: GLUTGtk, QuadTree, Tile, Logger, Nucleus, Address, Utils, Browser, Shader, StatusDialog, CacheView, PeriodScan + C-sources: compute.cc, rts.c + CC-options: -O3 -Wall -pedantic -Wextra + GHC-options: -Wall -threaded -rtsopts -O2 -funbox-strict-fields + GHC-Prof-Options: -prof -auto-all -caf-all diff --git a/gruff.hs b/gruff.hs new file mode 100644 --- /dev/null +++ b/gruff.hs @@ -0,0 +1,534 @@ +{-# LANGUAGE Rank2Types, ScopedTypeVariables #-} +module Main (main) where + +import Prelude hiding (catch, log) +import Control.Monad (forM_, liftM2) +import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef, writeIORef) +import Data.Maybe (isJust, fromMaybe) +import Data.Ratio (numerator, denominator) +import Graphics.UI.Gtk hiding (get, Region, Size) +import Graphics.UI.Gtk.OpenGL (initGL) +import System.Directory + ( getAppUserDataDirectory, createDirectoryIfMissing ) +import System.FilePath (()) +import Text.PrettyPrint.Leijen.Text (pretty) +import Text.FShow.Raw (DecimalFormat, nanTest, infTest) + +import Numeric.QD +import Fractal.RUFF.Mandelbrot.Address (AngledInternalAddress, Angle, parse, angledInternalAddress, externalAngles) +import Fractal.RUFF.Mandelbrot.Ray (externalRay) +import Fractal.RUFF.Types.Complex (Complex((:+)), magnitude) + +import GLUTGtk (glut, Size(Size)) +import PeriodScan (periodScan, periodNucleus) +import Nucleus (refineNucleus) +import Address (parseAngle, parseAngles, splitAddress, joinAddress, addressPeriod) +import Logger (logger, LogLevel(Debug)) +import qualified Logger as Log +import Utils (safeRead, catchIO) +import Paths_gruff (getDataFileName) +import Browser +import StatusDialog +import CacheView (cInitialize) + +exit :: (LogLevel -> String -> IO ()) -> FilePath -> Gruff -> IO () +exit lg stateFile g = do + lg Debug "exitCallback" + aDoSave stateFile g + mainQuit + +data GruffGUI = GruffGUI + { dStatus :: StatusDialog + -- buttons + , bHome + , bLoad + , bSave + , bAddressToCoordinates + , bAddressToIslandChild + , bIslandChildToAddress + , bAddressToAngles + , bIslandToAngles + , bLowerAngleToAddress + , bUpperAngleToAddress + , bPeriodScan :: Button + -- entries + , eAddress + , eIsland + , eChild + , eLowerAngle + , eUpperAngle + , eReal + , eImag + , eSize + , eHueShift + , eHueScale :: Entry + -- windows + , wMain + , wImage :: Window + } + +main :: IO () +main = do + -- contexts + _ <- initGUI + _ <- initGL + gl' <- glut minSize + glC <- glut minSize + -- directories + appDir <- getAppUserDataDirectory "gruff" + let cacheDir' = appDir "cache" + logDir = appDir "log" + stateFile = appDir "state.gruff" + createDirectoryIfMissing False appDir + createDirectoryIfMissing False logDir + lg <- logger logDir + icon <- pixbufNewFromFile =<< getDataFileName "icon.png" + -- widget window + (iw, iUpdate, iInitializeLate) <- iInitialize gl' icon lg cacheDir' + (cw, cUpdate, cInitializeLate) <- cInitialize glC icon cacheDir' + -- widget window + sg <- sizeGroupNew SizeGroupHorizontal + let spacing = 2 + entryNewWithMnemonic m = do + e <- entryNew + entrySetWidthChars e 80 + l <- labelNewWithMnemonic m + labelSetMnemonicWidget l e + sizeGroupAddWidget sg l + h <- hBoxNew False spacing + boxPackStart h l PackNatural 0 + boxPackStartDefaults h e + return (e, h) + frameNewWithContents t r ws = do + f <- frameNew + frameSetLabel f t + frameSetLabelAlign f (if r then 1 else 0) 0.5 + v <- vBoxNew False spacing + forM_ ws $ boxPackStartDefaults v + set f [ containerChild := v ] + return f + dStatus' <- statusDialogNew + b01@bHome' <- buttonNewWithLabel "Home" + b02@bLoad' <- buttonNewWithLabel "Load" + b03@bSave' <- buttonNewWithLabel "Save" + b7@bAddressToCoordinates' <- buttonNewWithLabel "Address → Coordinates" + b1@bAddressToIslandChild' <- buttonNewWithLabel "Address → Island + Child" + b2@bIslandChildToAddress' <- buttonNewWithLabel "Island + Child → Address" + b3@bAddressToAngles' <- buttonNewWithLabel "Address → Lower + Upper" + b4@bIslandToAngles' <- buttonNewWithLabel "Island → Lower + Upper" + b5@bLowerAngleToAddress' <- buttonNewWithLabel "Lower → Address" + b6@bUpperAngleToAddress' <- buttonNewWithLabel "Upper → Address" + b8@bPeriodScan' <- buttonNewWithLabel "Period Scan" + (eAddress', fa1) <- entryNewWithMnemonic "_Address" + (eIsland', fa2) <- entryNewWithMnemonic "I_sland" + (eChild', fa3) <- entryNewWithMnemonic "_Child" + (eLowerAngle', fe1) <- entryNewWithMnemonic "_Lower" + (eUpperAngle', fe2) <- entryNewWithMnemonic "_Upper" + (eReal', fc1) <- entryNewWithMnemonic "_Real" + (eImag', fc2) <- entryNewWithMnemonic "_Imag" + (eSize', fc3) <- entryNewWithMnemonic "Si_ze" + (eHueShift', fh1) <- entryNewWithMnemonic "Hue Shift" + (eHueScale', fh2) <- entryNewWithMnemonic "Hue Scale" + b0 <- hBoxNew False spacing + mapM_ (boxPackStartDefaults b0) [b01, b02, b03] + fb <- frameNewWithContents "Actions" False $ toWidget b0 : map toWidget [b7, b1, b2, b3, b4, b5, b6, b8] + fa <- frameNewWithContents "Angled Internal Address" True [fa1, fa2, fa3] + fe <- frameNewWithContents "External Angles" True [fe1, fe2] + fh <- frameNewWithContents "Colouring" True [fh1, fh2] + fc <- frameNewWithContents "Coordinates" True [fc1, fc2, fc3] + v <- vBoxNew False spacing + mapM_ (boxPackStartDefaults v) [fc, fa, fe, fh] + h <- hBoxNew False spacing + boxPackStartDefaults h fb + boxPackStartDefaults h v + ww <- windowNew + set ww [ windowIcon := Just icon, windowTitle := "gruff control" ] + containerAdd ww h + mg <- aDoLoad stateFile + gR <- newIORef $ case mg of + Nothing -> initialGruff + Just g -> g + let g0 = GruffGUI + { dStatus = dStatus' + , bHome = bHome' + , bLoad = bLoad' + , bSave = bSave' + , bAddressToCoordinates = bAddressToCoordinates' + , bAddressToIslandChild = bAddressToIslandChild' + , bIslandChildToAddress = bIslandChildToAddress' + , bAddressToAngles = bAddressToAngles' + , bIslandToAngles = bIslandToAngles' + , bLowerAngleToAddress = bLowerAngleToAddress' + , bUpperAngleToAddress = bUpperAngleToAddress' + , bPeriodScan = bPeriodScan' + , eAddress = eAddress' + , eIsland = eIsland' + , eChild = eChild' + , eLowerAngle = eLowerAngle' + , eUpperAngle = eUpperAngle' + , eReal = eReal' + , eImag = eImag' + , eSize = eSize' + , eHueShift = eHueShift' + , eHueScale = eHueScale' + , wMain = ww + , wImage = iw + } + but b a = do + _ <- b g0 `onClicked` wrapA g0 gR a + return () + butI b a = do + _ <- b g0 `onClicked` (wrapA g0 gR a >> upI) + return () + butJ b a = do + _ <- b g0 `onClicked` (wrapA' g0 gR a upI) + return () + ent e a = do + _ <- e g0 `onEntryActivate` (entryGetText (e g0) >>= wrapE g0 gR a) + return () + entI e a = do + _ <- e g0 `onEntryActivate` (entryGetText (e g0) >>= wrapE g0 gR a >> upI) + return () + upI = do + g <- readIORef gR + iUpdate (gReal g) (gImag g) (gSize g) (gHueShift g) (gHueScale g) + cUpdate (gReal g) (gImag g) (gSize g) + aUpdate re im z = do + atomicModifyIORef gR $ \g -> + ( g{ gReal = Just re, gImag = Just im, gSize = Just z }, () ) + g <- readIORef gR + uReal g0 g + uImag g0 g + uSize g0 g + cUpdate (gReal g) (gImag g) (gSize g) + butI bHome aHome + butI bLoad aLoad + but bSave aSave + butJ bAddressToCoordinates aAddressToCoordinates + but bAddressToIslandChild aAddressToIslandChild + but bIslandChildToAddress aIslandChildToAddress + but bAddressToAngles aAddressToAngles + but bIslandToAngles aIslandToAngles + but bLowerAngleToAddress aLowerAngleToAddress + but bUpperAngleToAddress aUpperAngleToAddress + butJ bPeriodScan aPeriodScan + ent eAddress aAddress + ent eIsland aIsland + ent eChild aChild + ent eLowerAngle aLowerAngle + ent eUpperAngle aUpperAngle + entI eReal aReal + entI eImag aImag + entI eSize aSize + entI eHueShift aHueShift + entI eHueScale aHueScale + let aExit' = (exit (Log.log lg) stateFile =<< readIORef gR) + iInitializeLate aUpdate aExit' + cInitializeLate aExit' + _ <- ww `onDestroy` aExit' + g <- readIORef gR + uEverything g0 g + upI + refreshGUI g0 g + widgetShowAll ww + widgetShowAll cw + widgetShowAll iw + mainGUI + +data Gruff = Gruff + { gAddress :: Maybe AngledInternalAddress + , gIsland :: Maybe AngledInternalAddress + , gChild :: Maybe [Angle] + , gLowerAngle :: Maybe Angle + , gUpperAngle :: Maybe Angle + , gReal :: Maybe QuadDouble + , gImag :: Maybe QuadDouble + , gSize :: Maybe QuadDouble + } | Gruff1 + { gAddress :: Maybe AngledInternalAddress + , gIsland :: Maybe AngledInternalAddress + , gChild :: Maybe [Angle] + , gLowerAngle :: Maybe Angle + , gUpperAngle :: Maybe Angle + , gReal :: Maybe QuadDouble + , gImag :: Maybe QuadDouble + , gSize :: Maybe QuadDouble + , gHueShift :: Maybe Double + , gHueScale :: Maybe Double + } + deriving (Read, Show) + +initialGruff :: Gruff +initialGruff = Gruff1 + { gAddress = parse "1" + , gIsland = parse "1" + , gChild = Just [] + , gLowerAngle = Just 0 + , gUpperAngle = Just 1 + , gReal = Just 0 + , gImag = Just 0 + , gSize = Just 1 + , gHueShift = Just 0 + , gHueScale = Just 1 + } + +refreshGUI :: GruffGUI -> Gruff -> IO () +refreshGUI g0 g = do + can bAddressToCoordinates $ j gAddress + can bAddressToIslandChild $ j gAddress + can bIslandChildToAddress $ j gIsland && j gChild + can bAddressToAngles $ j gAddress + can bIslandToAngles $ j gIsland + can bLowerAngleToAddress $ j gLowerAngle + can bUpperAngleToAddress $ j gUpperAngle + can bPeriodScan $ True + where + can w = widgetSetSensitive (w g0) + j a = isJust (a g) + +-- button actions + +type A = GruffGUI -> Gruff -> IO Gruff +type A' = GruffGUI -> Gruff -> (Gruff -> IO ()) -> IO () + +wrapA :: GruffGUI -> IORef Gruff -> A -> IO () +wrapA g0 gR a = do + g <- readIORef gR + g' <- a g0 g + writeIORef gR $! g' + refreshGUI g0 g' + +wrapA' :: GruffGUI -> IORef Gruff -> A' -> IO () -> IO () +wrapA' g0 gR a upI = do + g <- readIORef gR + a g0 g $ \g' -> postGUISync $ do + writeIORef gR $! g' + upI + refreshGUI g0 g' + +aHome :: A +aHome g0 _ = do + let g = initialGruff + uEverything g0 g + return g + +aDoLoad :: FilePath -> IO (Maybe Gruff) +aDoLoad ff = (do + gr <- safeRead `fmap` readFile ff + return $ case gr of + Just (Gruff a b c d e f g h) -> Just (Gruff1 a b c d e f g h (Just 0) (Just 1)) + g -> g + ) `catchIO` const (return Nothing) + +aLoad :: A +aLoad g0 g = do + fc <- fileChooserDialogNew (Just "gruff load") (Just $ wMain g0) FileChooserActionOpen [("Load", ResponseAccept), ("Cancel", ResponseCancel)] + widgetShow fc + r <- dialogRun fc + g' <- case r of + ResponseAccept -> do + mf <- fileChooserGetFilename fc + case mf of + Nothing -> return g + Just f -> do + mg <- aDoLoad f + case mg of + Nothing -> return g + Just g' -> uEverything g0 g' >> return g' + _ -> return g + widgetDestroy fc + return g' + +aDoSave :: FilePath -> Gruff -> IO () +aDoSave f g = writeFile f (show g) `catchIO` const (return ()) + +aSave :: A +aSave g0 g = do + fc <- fileChooserDialogNew (Just "gruff save") (Just $ wMain g0) FileChooserActionSave [("Save", ResponseAccept), ("Cancel", ResponseCancel)] + widgetShow fc + r <- dialogRun fc + case r of + ResponseAccept -> do + mf <- fileChooserGetFilename fc + case mf of + Nothing -> return () + Just f -> aDoSave f g + _ -> return () + widgetDestroy fc + return g + +aPeriodScan :: A' +aPeriodScan g0 g gn = do + statusDialog (dStatus g0) "gruff status" $ \progress -> do + progress "Scanning for period..." + let ps = do + re <- gReal g + im <- gImag g + r <- gSize g + let c = re :+ im + p <- periodScan r c + return (p, r, c) + g' <- case ps of + Just (p, r, c) -> do + progress $ "Scanning for nucleus (" ++ show p ++ ")..." + case periodNucleus p r c of + Just n -> do + progress $ "Computing nucleus (" ++ show p ++ ")..." + case refineNucleus p n of + (z, (re :+ im)) | 10 > z && z > 0 -> + return g{ gReal = Just re, gImag = Just im, gSize = Just (z * 4) } + _ -> return g{ gReal = Nothing, gImag = Nothing, gSize = Nothing } + _ -> return g{ gReal = Nothing, gImag = Nothing, gSize = Nothing } + _ -> return g{ gReal = Nothing, gImag = Nothing, gSize = Nothing } + progress "Done!" + postGUISync $ do + uReal g0 g' + uImag g0 g' + uSize g0 g' + gn g' + +aAddressToCoordinates :: A' +aAddressToCoordinates g0 g gn = do + statusDialog (dStatus g0) "gruff status" $ \progress -> do + progress "Splitting address..." + g1 <- aAddressToIslandChild g0 g + progress "Finding external angles..." + g2 <- aIslandToAngles g0 g1 + progress "Tracing external rays..." + g' <- aAnglesChildToCoordinates (progress "Computing nucleus...") g0 g2 + progress "Done!" + postGUISync $ do + uReal g0 g' + uImag g0 g' + uSize g0 g' + gn g' + +aAnglesChildToCoordinates :: IO () -> A +aAnglesChildToCoordinates progress _g0 g = do + case liftM2 (,) (gIsland g) (gLowerAngle g) of + Just (a, lo) -> + let eps = 2 ** negate 48 + eps' = 2 ** negate 40 + p = addressPeriod a + rlo = externalRay eps 8 (2**24) lo + ok' w = not (nanTest w || infTest w) + ok (w:+x) = ok' w && ok' x + converge [] = Nothing + converge [x] = Just x + converge (x:m@(y:_)) + | not $ magnitude (x - y) < eps' = converge m + | otherwise = Just x + rend = converge . takeWhile ok $ rlo + in case rend of + Just c -> progress >> case refineNucleus p c of + (z, (re :+ im)) | z > 0 -> + return g{ gReal = Just re, gImag = Just im, gSize = Just (z * 4) } + _ -> return g{ gReal = Nothing, gImag = Nothing, gSize = Nothing } + Nothing -> return g{ gReal = Nothing, gImag = Nothing, gSize = Nothing } + Nothing -> return g{ gReal = Nothing, gImag = Nothing, gSize = Nothing } + +aAddressToIslandChild :: A +aAddressToIslandChild g0 g = do + let g' = fromMaybe g{ gIsland = Nothing, gChild = Nothing } $ do + a <- gAddress g + (i, c) <- splitAddress a + return g{ gIsland = Just i, gChild = Just c } + postGUISync $ uIsland g0 g' + postGUISync $ uChild g0 g' + return g' + +aIslandChildToAddress :: A +aIslandChildToAddress g0 g = do + let g' = g{ gAddress = liftM2 joinAddress (gIsland g) (gChild g) } + postGUISync $ uAddress g0 g' + return g' + +aAddressToAngles :: A +aAddressToAngles g0 g = do + let (l, u) = case externalAngles =<< gAddress g of + Just (lo, up) -> (Just lo, Just up) + Nothing -> (Nothing, Nothing) + g' = g{ gLowerAngle = l, gUpperAngle = u } + postGUISync $ uLowerAngle g0 g' + postGUISync $ uUpperAngle g0 g' + return g' + +aIslandToAngles :: A +aIslandToAngles g0 g = do + let (l, u) = case externalAngles =<< gIsland g of + Just (lo, up) -> (Just lo, Just up) + Nothing -> (Nothing, Nothing) + g' = g{ gLowerAngle = l, gUpperAngle = u } + -- strictness hack to prevent evaluation in gui thread... + case (gLowerAngle g', gUpperAngle g') of + (Just lo, Just up) | lo + up > 0 -> return () + _ -> return () + postGUISync $ uLowerAngle g0 g' + postGUISync $ uUpperAngle g0 g' + return g' + +aLowerAngleToAddress :: A +aLowerAngleToAddress g0 g = do + let a = angledInternalAddress =<< gLowerAngle g + g' = g{ gAddress = a } + postGUISync $ uAddress g0 g' + return g' + +aUpperAngleToAddress :: A +aUpperAngleToAddress g0 g = do + let a = angledInternalAddress =<< gUpperAngle g + g' = g{ gAddress = a } + postGUISync $ uAddress g0 g' + return g' + +-- entry update + +type U = GruffGUI -> Gruff -> IO () + +uEverything, uAddress, uIsland, uChild, uLowerAngle, uUpperAngle, uReal, uImag, uSize :: U +uEverything g0 g = forM_ [uAddress, uIsland, uChild, uLowerAngle, uUpperAngle, uReal, uImag, uSize] $ \u -> u g0 g +uAddress g0 g = do + let s = filter ('"'/=) . show . pretty + entrySetText (eAddress g0) (maybe "" s (gAddress g)) +uIsland g0 g = do + let s = filter ('"'/=) . show . pretty + entrySetText (eIsland g0) (maybe "" s (gIsland g)) +uChild g0 g = do + let s x = show (numerator x) ++ "/" ++ show (denominator x) + t = unwords . map s + entrySetText (eChild g0) (maybe "" t (gChild g)) +uLowerAngle g0 g = do + let s x = show (numerator x) ++ " / " ++ show (denominator x) + entrySetText (eLowerAngle g0) (maybe "" s (gLowerAngle g)) +uUpperAngle g0 g = do + let s x = show (numerator x) ++ " / " ++ show (denominator x) + entrySetText (eUpperAngle g0) (maybe "" s (gUpperAngle g)) +uReal g0 g = entrySetText (eReal g0) (maybe "" show (gReal g)) +uImag g0 g = entrySetText (eImag g0) (maybe "" show (gImag g)) +uSize g0 g = entrySetText (eSize g0) (maybe "" show (gSize g)) + +-- entry actions + +type E = Gruff -> String -> Gruff + +wrapE :: GruffGUI -> IORef Gruff -> E -> String -> IO () +wrapE g0 gR e s = do + g <- readIORef gR + let g' = e g s + writeIORef gR $! g' + refreshGUI g0 g' + +aAddress, aIsland, aChild, aLowerAngle, aUpperAngle, aReal, aImag, aSize, aHueShift, aHueScale :: E +aAddress g s = g{ gAddress = parse s } +aIsland g s = g{ gIsland = parse s } +aChild g s = g{ gChild = parseAngles s } +aLowerAngle g s = g{ gLowerAngle = parseAngle s } +aUpperAngle g s = g{ gUpperAngle = parseAngle s } +aReal g s = g{ gReal = safeRead s } +aImag g s = g{ gImag = safeRead s } +aSize g s = g{ gSize = safeRead s } +aHueShift g s = g{ gHueShift = safeRead s } +aHueScale g s = g{ gHueScale = safeRead s } + +minSize :: Size +minSize = Size 160 100 diff --git a/icon.png b/icon.png new file mode 100644 Binary files /dev/null and b/icon.png differ diff --git a/rts.c b/rts.c new file mode 100644 --- /dev/null +++ b/rts.c @@ -0,0 +1,1 @@ +char *ghc_rts_opts = "-N";