gruff 0.2.1 → 0.3
raw patch · 14 files changed
+814/−722 lines, 14 filesdep +FTGLdep +gruffdep ~basedep ~ruff
Dependencies added: FTGL, gruff
Dependency ranges changed: base, ruff
Files
- TODO +1/−10
- gruff.cabal +54/−26
- src/Browser.hs +255/−95
- src/Fractal/GRUFF.hs +154/−0
- src/GLUTGtk.hs +1/−1
- src/Interact.hs +91/−0
- src/MuAtom.hs +0/−171
- src/Number.hs +3/−6
- src/Progress.hs +109/−0
- src/Snapshot.hs +1/−1
- src/StatusDialog.hs +4/−3
- src/Tile.hs +6/−1
- src/View.hs +12/−63
- src/gruff.hs +123/−345
TODO view
@@ -6,7 +6,6 @@ navigation configurable zoom mode: center on click vs expand about click continuous zoom mode while button is pressed- configurable zoom speed undo/history tree navigation log annotation and search log browser view with filtering@@ -32,10 +31,7 @@ re-use pixels from parent/child tiles in renderer don't compute known-interior tiles features- feature overlay in browser window- feature overlay save as svg (save image as png and embed it too?) scan whole image for atoms, subdivide for more- draw external rays in feature overlay draw internal rays in feature overlay feature database - try lookup before calculating, cache results algorithms@@ -45,13 +41,8 @@ non-slow angled internal address to external angle misc tiled rendering mode for huge images without seams- use custom icon for status dialog window scripting- haskell scripting with edsl/library for common tasks- command line flag to load a script at startup- interpreter REPL window+ helper library for using GHCI via fifo to gruff exe internal- split MuAtom into separate modules- backport appropriate algorithms to 'ruff' source code documentation
gruff.cabal view
@@ -1,5 +1,5 @@ Name: gruff-Version: 0.2.1+Version: 0.3 Synopsis: fractal explorer GUI using the ruff library Description: Mandelbrot Set fractal explorer using the ruff library.@@ -8,10 +8,16 @@ and multiple CPU cores recommended. If you want to explore very deep zooms, you'll need hmpfr which currently requires GHC to be compiled with integer-simple instead of the default integer-gmp. To install- without MPFR support, use @cabal install gruff -f-mpfr@.+ with MPFR support, use @cabal install gruff -fmpfr@. (Note that the+ default setting for this flag has changed since the previous release.) .- This version is a bugfix release. Changes since gruff-0.2:+ gruff-0.3 includes a small library to allow external programs to+ create diagrams and animations with gruff. See the gruff-examples+ package. The interface has been remodelled to simplify it and add+ informative feature overlays. .+ gruff-0.2.1 was a bugfix release. Changes since gruff-0.2:+ . * Supersampling bugs are fixed (no more undocumented quantization leading to inconsistent appearance at different zoom levels). .@@ -22,36 +28,39 @@ . Features in this version include: .- * Interactive fractal browser display (left click to zoom in,- right click to zoom out, middle-click to center).+ * Interactive fractal browser display with mouse controls:+ .+ * Left click to zoom in (press shift for bigger jumps).+ .+ * Right click to zoom out (press shift for bigger jumps).+ .+ * Middle click to center.+ .+ * Shift middle click to auto-focus.+ .+ * Control left click to label with period.+ .+ * Control right click to label with angled internal address (slow!). . * Session persistance (stored in @~\/.gruff\/state.gruff@ - states can- also be loaded from and saved to other files).+ also be loaded from and saved to other files, including labels and+ rays). Note that the file format is incompatible with previous+ releases of gruff. . * 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 adjacent Go button).- .- * Feature finding using period location (navigate to approximate- location of the desired feature, click the Scan button).- .- * Angled internal address calculation using reverse ray trace- (navigate to approximate feature location, click the Scan+ button).- .- * Uses MPFR where available for higher precision, allowing deeper+ * Can use MPFR if desired for higher precision, allowing deeper zooms and locating high period nucleii. . * Limited amount of customizable colouring (colours for interior,- border, and exterior points).+ border, and exterior points, as well as labels and rays). . * Supersampling for more detailed images (useful range is 1 to 16). .- Future features might include image saving, external ray and feature- information overlays, more feature finding and identification- algorithms, scripting support for rendering animations, ...+ * Rudimentary scripting support (see the gruff-examples package).+ .+ Future versions will focus on enhancing the scripting support. License: GPL-2 License-file: LICENSE@@ -60,7 +69,7 @@ Category: Graphics Build-type: Simple-Cabal-version: >=1.4+Cabal-version: >=1.8 Data-dir: data Data-files: icon.png, merge.frag, minimal.frag@@ -68,16 +77,24 @@ Flag mpfr description: use MPFR for higher precision floating point- default: True+ default: False +Library+ Hs-source-dirs: src+ Exposed-modules: Fractal.GRUFF+ Build-depends: base >= 3 && < 5,+ ruff >= 0.3 && < 0.4+ GHC-options: -Wall+ Executable gruff Hs-source-dirs: src Main-is: gruff.hs Other-modules: Browser GLUTGtk+ Interact Logger- MuAtom Number+ Progress QuadTree Shader Snapshot@@ -85,10 +102,12 @@ Tile Utils View- Build-depends: base >= 4 && < 5,+ Build-depends: gruff == 0.3,+ base >= 4 && < 5, containers >= 0 && < 1, directory >= 1 && < 2, filepath >= 1 && < 2,+ FTGL == 1.333, gtk >= 0.11 && < 0.13, gtkglext >= 0.11 && < 0.13, old-locale >= 1 && < 2,@@ -99,7 +118,7 @@ qd-vec >= 1 && < 2, time >= 1 && < 2, Vec >= 0.9 && < 1,- ruff >= 0.2 && < 0.3,+ ruff >= 0.3 && < 0.4, bytestring, mtl if (flag(mpfr))@@ -110,3 +129,12 @@ CC-options: -O3 -Wall -pedantic -Wextra GHC-options: -O2 -Wall -threaded -rtsopts GHC-Prof-Options: -prof -auto-all -caf-all++source-repository head+ type: git+ location: git://gitorious.org/ruff/gruff.git++source-repository this+ type: git+ location: git://gitorious.org/ruff/gruff.git+ tag: v0.3
src/Browser.hs view
@@ -1,6 +1,6 @@ module Browser (Browser(..), browserNew, browserRenders) where -import Prelude hiding (log)+import Prelude hiding (log, lines) import Control.Concurrent ( forkIO, MVar, newEmptyMVar, newMVar, takeMVar, putMVar, tryTakeMVar, threadDelay ) import Control.Monad (foldM, forever, forM_, replicateM, unless, when)@@ -15,24 +15,28 @@ import Foreign (Ptr, malloc, alloca, peek, poke, nullPtr) import Foreign.C (CFloat, CInt) import GHC.Conc (numCapabilities)-import Graphics.Rendering.OpenGL hiding (viewport, Angle, Color, Point, Position, Size)+import Graphics.Rendering.OpenGL hiding+ ( viewport, Angle, Color, Point, Position, Size, S, R ) import qualified Graphics.Rendering.OpenGL as GL import Graphics.Rendering.OpenGL.Raw- ( glTexImage2D, gl_TEXTURE_2D, gl_R32F, gl_RGBA, gl_LUMINANCE+ ( glTexImage2D, gl_TEXTURE_2D, gl_LUMINANCE32F, gl_RGBA, gl_LUMINANCE , gl_FLOAT, gl_UNSIGNED_BYTE, gl_FALSE, glClampColor , gl_CLAMP_VERTEX_COLOR, gl_CLAMP_READ_COLOR, gl_CLAMP_FRAGMENT_COLOR , glGenFramebuffers, glBindFramebuffer, glFramebufferTexture2D , gl_FRAMEBUFFER, gl_COLOR_ATTACHMENT0, glGenerateMipmap+ , gl_FRAMEBUFFER_COMPLETE, glCheckFramebufferStatus , glGetError )-import Graphics.UI.Gtk hiding (get, Window, Viewport, Region, Size, Action, Image)+import Graphics.UI.Gtk hiding+ ( get, Window, Viewport, Region, Size, Action, Image, Label, labelText ) import qualified Graphics.UI.Gtk as GTK +import Graphics.Rendering.FTGL as FTGL+ import Fractal.RUFF.Types.Complex (Complex((:+))) -import Number (R) import GLUTGtk- ( GLUTGtk, Size(Size), Key(MouseButton), KeyState(Down), Position(Position)+ ( GLUTGtk, Size(Size), Key(MouseButton), KeyState(Down), Position(Position) , postRedisplay, widget, realizeCallback, reshapeCallback , displayCallback, keyboardMouseCallback )@@ -43,20 +47,21 @@ import qualified Logger as Log import Snapshot (writeSnapshot) import View- ( Image(..), Location(..), Window(..), Viewport(..)+ ( Image(..), Window(..), Viewport(..), Label(..), Line(..) , BufferSize(..), bufferSize, tileSize, delta- , Colours(..), Colour(..), defColours- , pixelLocation, originQuad, visibleQuads- , defLocation, defWindow, defViewport+ , Colours(..), Colour(..)+ , pixelLocation, originQuad, visibleQuads, locationPixel+ , defImage, defWindow )+import Interact (MouseCallbacks, Mod(..), But(..))+ import Paths_gruff (getDataFileName) type TextureObject3 = (TextureObject, TextureObject, TextureObject) type QuadList = [(Complex Int, Quad)] data GruffImage = GruffImage- { location :: Location- , window :: Window- , viewport :: Viewport+ { image :: Image+ -- tile cache , tiles :: Map Quad TextureObject3 , queue :: MVar [Tile] , jobs :: MVar [Quad]@@ -66,7 +71,6 @@ , gl :: GLUTGtk , cacheDir :: FilePath , log :: LogLevel -> String -> IO ()- , colours :: Colours , prog :: Program , combineProg :: Program , tsheet0 :: TextureObject@@ -80,38 +84,45 @@ -- callbacks , exitCallback :: Maybe (IO ()) , reshapeCallback :: Maybe (Int -> Int -> IO ())- , mouseCallback :: Maybe (Complex R -> Double -> IO ())+ , mouseCallback :: MouseCallbacks , doneCallback :: Maybe (IO ()) , abortCallback :: Maybe (IO ()) , doClear :: Bool+ , font :: FTGL.Font } sheetSize :: GruffImage -> BufferSize-sheetSize g = bufferSize (sheetOffset g) (window g)+sheetSize g = bufferSize (sheetOffset g) (imageWindow (image g)) zoomPhase :: GruffImage -> Double-zoomPhase = delta . location+zoomPhase = delta . imageLocation . image rotationA :: GruffImage -> Double-rotationA = orient . viewport+rotationA = orient . imageViewport . image -sheetBlend :: GruffImage -> (Int, Double)+sheetBlend :: GruffImage -> (Int, (Double, Double)) sheetBlend g = let z = zoomPhase g- s = supersamples (window g)+ s = supersamples (imageWindow (image g)) b = logBase 4 (4 ** z * s) h = floor b d = fromIntegral h - b- in (h, 1 - (1 - 4**d) / (4**(d+1) - 4**d))+ in (h, (d, 1 - (1 - 4**d) / (4**(d+1) - 4**d))) sheetOffset :: GruffImage -> Int sheetOffset = fst . sheetBlend +{-+sheetDelta :: GruffImage -> Double+sheetDelta = fst . snd . sheetBlend+-}+ blendFactor :: GruffImage -> Double-blendFactor = snd . sheetBlend+blendFactor = snd . snd . sheetBlend iDisplay :: IORef GruffImage -> IO () iDisplay iR = do+ checkError "display begin" s0 <- readIORef iR mtls <- tryTakeMVar (queue s0) case mtls of@@ -119,8 +130,11 @@ putMVar (queue s0) [] forM_ tls $ \tile@(Tile q ns ds ts) -> do tde <- upload ds+ checkError "upload ds" tit <- upload ns+ checkError "upload ns" ttt <- upload ts+ checkError "upload ts" freeTile tile atomicModifyIORef iR $ \s' -> ( s'{ tiles = M.insert q (tde, tit, ttt) (tiles s')@@ -128,37 +142,61 @@ , ()) Nothing -> return () s <- readIORef iR- log s Debug $ "displayCallback " ++ show (location s)+ log s Debug $ "displayCallback " ++ show (imageLocation (image s)) c <- atomicModifyIORef iR $ \s' -> (s'{ doClear = False }, doClear s') when c $ do clearSheet s False+ checkError "clear sheet F" clearSheet s True+ checkError "clear sheet T" atomicModifyIORef iR $ \s' -> (s'{ sheetCount0 = 0, sheetCount1 = 0 }, ()) (todo0, upped0) <- renderSheet s False+ checkError "render sheet F" (todo1, upped1) <- renderSheet s True- atomicModifyIORef iR $ \s' -> (s'{ viewQuads = (todo0, todo1), sheetCount0 = sheetCount0 s' + upped0 , sheetCount1 = sheetCount1 s' + upped1 }, ())- let w = width (window s)- h = height (window s)+ checkError "render sheet T"+ atomicModifyIORef iR $ \s' ->+ ( s'{ viewQuads = (todo0, todo1)+ , sheetCount0 = sheetCount0 s' + upped0+ , sheetCount1 = sheetCount1 s' + upped1+ }, () )+ let w = width (imageWindow (image s))+ h = height (imageWindow (image s)) GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))+ checkError "clear V" loadIdentity+ checkError "clear I" ortho2D 0 (fromIntegral w) 0 (fromIntegral h)+ checkError "clear O" clearColor $= Color4 0.5 0.5 0.5 1+ checkError "clear CC" clear [ColorBuffer]+ checkError "clear C" currentProgram $= Just (combineProg s)+ checkError "shader 1" lsheet0 <- get $ uniformLocation (combineProg s) "sheet0"+ checkError "shader 2a" lsheet1 <- get $ uniformLocation (combineProg s) "sheet1"+ checkError "shader 2b" lblend <- get $ uniformLocation (combineProg s) "blend"+ checkError "shader 2c" uniform lsheet0 $= TexCoord1 (0 :: GLint)+ checkError "shader 3a" uniform lsheet1 $= TexCoord1 (1 :: GLint)+ checkError "shader 3b" uniform lblend $= TexCoord1 (realToFrac (blendFactor s) :: GLfloat)+ checkError "shader 3c" activeTexture $= TextureUnit 0+ checkError "shader 4" textureBinding Texture2D $= Just (tsheet0 s)+ checkError "shader 5" activeTexture $= TextureUnit 1+ checkError "shader 6" textureBinding Texture2D $= Just (tsheet1 s)+ checkError "shader 7" let t x0 y0 = texCoord $ TexCoord2 (0.5 + x' :: GLdouble) (0.5 + y' :: GLdouble) where- p = realToFrac . sqrt . aspect . viewport $ s+ p = realToFrac . sqrt . aspect . imageViewport . image $ s x = k * x0 * p y = k * y0 / p a = - rotationA s@@ -175,10 +213,43 @@ t (-1) (-1) >> v 0 0 t 1 (-1) >> v w 0 t 1 1 >> v w h+ checkError "quad" textureBinding Texture2D $= Nothing+ checkError "shader 8" activeTexture $= TextureUnit 0+ checkError "shader 9" textureBinding Texture2D $= Nothing+ checkError "shader A" currentProgram $= Nothing+ checkError "shader B"++ -- save state+ m <- get matrixMode+ matrixMode $= Modelview 0+ colour0 <- get currentColor+ -- pixel mapping+ let i = image s+ locP = locationPixel (imageWindow i) (imageViewport i) (imageLocation i)+ locL (a, b) = [locP a, locP b]+ -- draw lines+ forM_ (imageLines i) $ \l -> do+ let ps = concatMap locL (lineSegments l)+ Colour r g b = lineColour l+ currentColor $= Color4 (realToFrac r) (realToFrac g) (realToFrac b) 1+ renderPrimitive Lines $ forM_ ps $ \(x, y) -> do+ vertex $ Vertex2 (realToFrac x) (fromIntegral h - realToFrac y :: GLdouble)+ -- draw labels+ forM_ (imageLabels i) $ \l -> do+ let (x, y) = locP (labelCoords l)+ Colour r g b = labelColour l+ currentColor $= Color4 (realToFrac r) (realToFrac g) (realToFrac b) 1+ translate (Vector3 (realToFrac x) (fromIntegral h - realToFrac y) (0 :: GLdouble))+ renderFont (font s) (labelText l) All+ translate (Vector3 (-realToFrac x) (realToFrac y - fromIntegral h) (0 :: GLdouble))+ -- restore state+ currentColor $= colour0+ matrixMode $= m+ s'' <- readIORef iR when (sheetCount0 s'' + sheetCount1 s'' >= sheetCountTarget s'') $ do case doneCallback s of@@ -187,29 +258,40 @@ atomicModifyIORef iR $ \s' -> (s'{ doneCallback = Nothing, abortCallback = Nothing }, ()) act prune iR- err <- glGetError- when (err /= 0) $ print ("error: " ++ show err)+ checkError "display end" clearSheet :: GruffImage -> Bool -> IO () clearSheet s b = do+ checkError "clearSheet begin" let tw' = texels $ sheetSize s th' = tw' tw = if b then tw' * 2 else tw' th = if b then th' * 2 else th' tsheet = (if b then tsheet1 else tsheet0) s bindFBO (fbo s) tsheet+ checkError "clearSheet fbo bind" GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral tw) (fromIntegral th))+ checkError "clearSheet V" loadIdentity+ checkError "clearSheet I" clearColor $= Color4 0 0 1 1+ checkError "clearSheet CC" clear [ColorBuffer]+ checkError "clearSheet C" unbindFBO+ checkError "clearSheet fbo unbind" textureBinding Texture2D $= Just tsheet+ checkError "clearSheet tex bind" glGenerateMipmap gl_TEXTURE_2D+ checkError "clearSheet tex mipmap" textureBinding Texture2D $= Nothing+ checkError "clearSheet tex unbind"+ checkError "clear end" renderSheet :: GruffImage -> Bool -> IO ([(Complex Int, Quad)], Int) renderSheet s b = do+ checkError "renderSheet begin" let tw' = texels $ sheetSize s th' = tw' tw = if b then tw' * 2 else tw'@@ -218,38 +300,63 @@ vquads = (if b then snd else fst) (viewQuads s) if null vquads then return ([], 0) else do bindFBO (fbo s) tsheet+ checkError "renderSheet fbo bind" GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral tw) (fromIntegral th))+ checkError "renderSheet V" loadIdentity+ checkError "renderSheet I" ortho2D 0 (fromIntegral tw) 0 (fromIntegral th)+ checkError "renderSheet O" currentProgram $= Just (prog s)+ checkError "renderSheet shader 1" lde <- get $ uniformLocation (prog s) "de"+ checkError "renderSheet shader u1" lit <- get $ uniformLocation (prog s) "it"+ checkError "renderSheet shader u2" ltt <- get $ uniformLocation (prog s) "tt"+ checkError "renderSheet shader u3" lint <- get $ uniformLocation (prog s) "interior"+ checkError "renderSheet shader u4" lbrd <- get $ uniformLocation (prog s) "border"+ checkError "renderSheet shader u5" lext <- get $ uniformLocation (prog s) "exterior"+ checkError "renderSheet shader u6" uniform lde $= TexCoord1 (0 :: GLint)+ checkError "renderSheet shader t1" uniform lit $= TexCoord1 (1 :: GLint)+ checkError "renderSheet shader t2" uniform ltt $= TexCoord1 (2 :: GLint)- let (ci, cb, ce) = fromColours $ colours s+ checkError "renderSheet shader t3"+ let (ci, cb, ce) = fromColours . imageColours . image $ s uniform lint $= ci+ checkError "renderSheet shader s1" uniform lbrd $= cb+ checkError "renderSheet shader s2" uniform lext $= ce+ checkError "renderSheet shader s3" todo <- foldM (\a t -> do a' <- drawQuad (tiles s) t ; return (a' ++ a)) [] vquads+ checkError "renderSheet drawQuads" currentProgram $= Nothing+ checkError "renderSheet shader 2" unbindFBO+ checkError "renderSheet fbo unbind" let upped = length vquads - length todo when (upped > 0) $ do textureBinding Texture2D $= Just tsheet+ checkError "renderSheet tex bind" glGenerateMipmap gl_TEXTURE_2D+ checkError "renderSheet tex mipmap" textureBinding Texture2D $= Nothing+ checkError "renderSheet tex unbind"+ checkError "renderSheet end" return (todo, upped) drawQuad :: Map Quad TextureObject3 -> (Complex Int, Quad) -> IO [(Complex Int, Quad)] drawQuad m ijq@(i :+ j, q) = case q `M.lookup` m of Nothing -> return [ijq] Just (tde, tit, ttt) -> do+ checkError "drawQuad begin" let t x y = texCoord $ TexCoord2 (x :: GLdouble) (y :: GLdouble) v x y = vertex $ Vertex2 (x :: GLdouble) (y :: GLdouble) x0 = fromIntegral i@@ -257,30 +364,45 @@ x1 = x0 + fromIntegral tileSize y1 = y0 + fromIntegral tileSize activeTexture $= TextureUnit 0+ checkError "drawQuad tex 0" textureBinding Texture2D $= Just tde+ checkError "drawQuad tex 0b" activeTexture $= TextureUnit 1+ checkError "drawQuad tex 1" textureBinding Texture2D $= Just tit+ checkError "drawQuad tex 1b" activeTexture $= TextureUnit 2+ checkError "drawQuad tex 2" textureBinding Texture2D $= Just ttt+ checkError "drawQuad tex 2b" 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+ checkError "drawQuad render" textureBinding Texture2D $= Nothing+ checkError "drawQuad tex 3b" activeTexture $= TextureUnit 1+ checkError "drawQuad tex 3" textureBinding Texture2D $= Nothing+ checkError "drawQuad tex 4b" activeTexture $= TextureUnit 0+ checkError "drawQuad tex 4" textureBinding Texture2D $= Nothing+ checkError "drawQuad tex 5b" return [] iReshape :: IORef GruffImage -> Maybe Double -> Size -> IO () iReshape iR ms size'@(Size w h) = do s' <- readIORef iR log s' Debug $ "reshapeCallback " ++ show size'- let ss = case ms of Nothing -> supersamples (window s') ; Just r -> r- atomicModifyIORef iR $ \s -> (s{ window = (window s){ width = w, height = h, supersamples = ss }, viewport = (viewport s){ aspect = fromIntegral w / fromIntegral h } }, ())+ let ss = case ms of Nothing -> supersamples (imageWindow (image s')) ; Just r -> r+ atomicModifyIORef iR $ \s -> (s{ image = (image s)+ { imageWindow = (imageWindow (image s)){ width = w, height = h, supersamples = ss }+ , imageViewport = (imageViewport (image s)){ aspect = fromIntegral w / fromIntegral h }+ } }, ()) s'' <- readIORef iR unless (sheetSize s' == sheetSize s'') (reallocateBuffers iR) case Browser.reshapeCallback s' of@@ -288,43 +410,29 @@ Just act -> act w h iMouse :: IORef GruffImage -> Key -> KeyState -> [Modifier] -> Position -> IO ()-iMouse sR (MouseButton LeftButton ) Down _ p@(Position x y) = do- s <- readIORef sR- log s Debug $ "leftMouse " ++ show p- case mouseCallback s of- Nothing -> return ()- Just act -> do- let o = fromPixel s x y- cx :+ cy = center (location s)- c = fromRational cx :+ fromRational cy- r = radius (location s)- r' = 0.9 * r- c' = 0.9 * c + 0.1 * o- act c' r'-iMouse sR (MouseButton MiddleButton) Down _ p@(Position x y) = do- s <- readIORef sR- log s Debug $ "middleMouse " ++ show p- case mouseCallback s of- Nothing -> return ()- Just act -> act (fromPixel s x y) (radius (location s))-iMouse sR (MouseButton RightButton ) Down _ p@(Position x y) = do+iMouse sR (MouseButton but) Down mods p@(Position x y) | but `elem` buts = do+ let shift = Shift `elem` mods+ ctrl = Control `elem` mods+ m | shift && ctrl = SC+ | ctrl = C+ | shift = S+ | otherwise = U+ b = case but of+ LeftButton -> L+ MiddleButton -> M+ RightButton -> R+ _ -> error "weasels!!!!111one" s <- readIORef sR- log s Debug $ "rightMouse " ++ show p- case mouseCallback s of+ log s Debug $ "mouse " ++ show (b, m) ++ " " ++ show p+ case (b, m) `M.lookup` mouseCallback s of Nothing -> return ()- Just act -> do- let o = fromPixel s x y- cx :+ cy = center (location s)- c = fromRational cx :+ fromRational cy- r = radius (location s)- r' = 1.1 * r- c' = 1.1 * c - 0.1 * o- act c' r'+ Just cb -> do+ let i = image s+ c = pixelLocation (imageWindow i) (imageViewport i) (imageLocation i) x y+ cb c i+ where buts = [LeftButton, MiddleButton, RightButton] iMouse _ _ _ _ _ = return () -fromPixel :: GruffImage -> Double -> Double -> Complex R-fromPixel g x y = let r:+i = pixelLocation (window g) (viewport g) (location g) x y in fromRational r :+ fromRational i- quadDistance :: Quad -> Quad -> Double quadDistance q0 q1 = let Quad{ quadLevel = l0, quadWest = r0, quadNorth = i0 } = q0@@ -345,13 +453,14 @@ s0 <- readIORef sR let cacheSize = M.size (tiles s0) when (cacheSize > cacheSizeMax s0) $ do+ checkError "prune begin" log s0 Debug . concat $ [ "pruning texture cache " , show cacheSize, " > ", show (cacheSizeMax s0) , " --> ", show (cacheSizeMin s0) ] bad <- atomicModifyIORef sR $ \s -> - let Just q0 = originQuad (location s) (sheetSize s)+ let Just q0 = originQuad (imageLocation (image s)) (sheetSize s) score = quadDistance q0 o = comparing (score . fst) (good, bad)@@ -359,23 +468,29 @@ in (s{ tiles = M.fromList good }, bad) let t (_, (t1, t2, t3)) = [t1, t2, t3] deleteObjectNames $ concatMap t bad+ checkError "prune end" update :: IORef GruffImage -> IO () update sR = do s' <- readIORef sR log s' Debug $ "updateCallback " todo' <- atomicModifyIORef sR $ \s ->- let vq@(qs0, qs1) = fromMaybe ([],[]) $ visibleQuads (window s) (viewport s) (location s) (sheetOffset s)+ let i = image s+ vq@(qs0, qs1) = fromMaybe ([],[]) $+ visibleQuads (imageWindow i) (imageViewport i) (imageLocation i) (sheetOffset s) qs = qs0 ++ qs1 todo = S.filter (`M.notMember` tiles s) (S.fromList (map snd qs)) in (s{ viewQuads = vq, sheetCountTarget = length qs }, todo) -- cancel in-progress jobs that aren't still needed _ <- takeMVar (jobs s')- p <- atomicModifyIORef sR $ \s -> (s{ progress = M.filter (`S.member` todo') (progress s) }, progress s)- mapM_ (`poke` 1) . filter (\w -> case M.lookup w p of Nothing -> False ; Just q -> q `S.notMember` todo') . workers $ s'+ p <- atomicModifyIORef sR $ \s ->+ (s{ progress = M.filter (`S.member` todo') (progress s) }, progress s)+ mapM_ (`poke` 1) . filter (\w -> case M.lookup w p of+ Nothing -> False+ Just q -> q `S.notMember` todo') . workers $ s' -- set new jobs s <- readIORef sR- let Just q0 = originQuad (location s) (sheetSize s)+ let Just q0 = originQuad (imageLocation (image s)) (sheetSize s) score = quadDistance q0 putMVar (jobs s') . sortBy (comparing score) . S.toList $ todo' \\ S.fromList (M.elems p) @@ -428,17 +543,27 @@ upload :: Ptr CFloat -> IO TextureObject upload p = do+ checkError "upload begin" [tex] <- genObjectNames 1+ checkError "upload 1" texture Texture2D $= Enabled+ checkError "upload 2" textureBinding Texture2D $= Just tex- glTexImage2D gl_TEXTURE_2D 0 (fromIntegral gl_R32F)+ checkError "upload 3"+ glTexImage2D gl_TEXTURE_2D 0 (fromIntegral gl_LUMINANCE32F) (fromIntegral tileSize) (fromIntegral tileSize) 0 gl_LUMINANCE gl_FLOAT p+ checkError "upload 4" textureFilter Texture2D $= ((Nearest, Nothing), Nearest)- textureWrapMode Texture2D S $= (Repeated, ClampToEdge)- textureWrapMode Texture2D T $= (Repeated, ClampToEdge)+ checkError "upload 5"+ textureWrapMode Texture2D GL.S $= (Repeated, ClampToEdge)+ checkError "upload 6"+ textureWrapMode Texture2D GL.T $= (Repeated, ClampToEdge)+ checkError "upload 7" textureBinding Texture2D $= Nothing+ checkError "upload 7" texture Texture2D $= Disabled+ checkError "upload end" return tex msPerFrame :: Int@@ -452,8 +577,7 @@ , browserSaveImage :: FilePath -> IO () , browserSetExitCallback :: IO () -> IO () , browserSetReshapeCallback :: (Int -> Int -> IO ()) -> IO ()- , browserSetMouseCallback :: (Complex R -> Double -> IO ()) -> IO ()--- , browserResize :: Int -> Int -> Double -> IO ()+ , browserSetMouseCallback :: MouseCallbacks -> IO () } browserRenders :: Browser -> [(Image, FilePath)] -> IO ()@@ -475,7 +599,8 @@ let defW = width defWindow defH = height defWindow windowSetDefaultSize iw defW defH- windowSetGeometryHints iw (Nothing `asTypeOf` Just iw) (Just (160, 120)) (Just (2048, 1536)) Nothing Nothing Nothing+ windowSetGeometryHints iw (Nothing `asTypeOf` Just iw)+ (Just (160, 120)) (Just (4096, 4096)) Nothing Nothing Nothing set iw [ containerBorderWidth := 0 , containerChild := widget gl'@@ -486,14 +611,11 @@ jobs' <- newMVar [] iR <- newIORef GruffImage -- image parameters- { location = defLocation- , viewport = defViewport- , window = defWindow- , colours = defColours+ { image = defImage -- callbacks , exitCallback = Nothing , Browser.reshapeCallback = Nothing- , mouseCallback = Nothing+ , mouseCallback = M.empty , doneCallback = Nothing , abortCallback = Nothing -- job queue@@ -517,6 +639,7 @@ , cacheSizeMin = 1000 , cacheSizeMax = 1500 , doClear = False+ , font = error "font" } realizeCallback gl' $= iRealize iR GLUTGtk.reshapeCallback gl' $= iReshape iR Nothing@@ -540,14 +663,10 @@ s <- readIORef iR let wr = width (imageWindow img) hr = height (imageWindow img)- unless (width (window s) == wr && height (window s) == hr) $ do+ unless (width (imageWindow (image s)) == wr &&+ height (imageWindow (image s)) == hr) $ do windowResize iw wr hr- atomicModifyIORef iR $ \s' -> (s'- { window = imageWindow img- , viewport = imageViewport img- , location = imageLocation img- , colours = imageColours img- }, ())+ atomicModifyIORef iR $ \s' -> (s'{ image = img }, ()) s' <- readIORef iR unless (sheetSize s == sheetSize s') (reallocateBuffers iR) atomicModifyIORef iR $ \i -> (i@@ -558,14 +677,15 @@ update iR browserSaveImage' fname = do s <- readIORef iR- writeSnapshot fname (GL.Position 0 0) (GL.Size (fromIntegral (width (window s))) (fromIntegral (height (window s))))+ writeSnapshot fname (GL.Position 0 0)+ (GL.Size (fromIntegral (width (imageWindow (image s))))+ (fromIntegral (height (imageWindow (image s))))) browserSetExitCallback' act = atomicModifyIORef iR $ \i -> ( i{ exitCallback = Just act }, () ) browserSetReshapeCallback' act = atomicModifyIORef iR $ \i -> ( i{ Browser.reshapeCallback = Just act }, () ) browserSetMouseCallback' act = atomicModifyIORef iR $ \i ->- ( i{ mouseCallback = Just act }, () )--- browserResize' w h s = windowResize iw w h >> iReshape iR (Just s) (Size w h)+ ( i{ mouseCallback = act }, () ) keyboardMouseCallback gl' $= iMouse iR _ <- timeoutAdd (timer iR >> return True) msPerFrame _ <- iw `onDestroy` atExit@@ -578,7 +698,6 @@ , browserSetExitCallback = browserSetExitCallback' , browserSetReshapeCallback = browserSetReshapeCallback' , browserSetMouseCallback = browserSetMouseCallback'--- , browserResize = browserResize' } fromColours :: Colours -> (Color3 GLfloat, Color3 GLfloat, Color3 GLfloat)@@ -593,18 +712,31 @@ iRealize :: IORef GruffImage -> IO () iRealize iR = do+ checkError "realize begin" s <- readIORef iR log s Debug "realizeCallback" drawBuffer $= BackBuffers+ checkError "realize db" glClampColor gl_CLAMP_VERTEX_COLOR gl_FALSE+ checkError "realize clv" glClampColor gl_CLAMP_READ_COLOR gl_FALSE+ checkError "realize clr" glClampColor gl_CLAMP_FRAGMENT_COLOR gl_FALSE+ checkError "realize clf" f <- getDataFileName "minimal.frag" prog' <- shader Nothing (Just f)+ checkError "realize s1" f' <- getDataFileName "merge.frag" combineProg' <- shader Nothing (Just f')+ checkError "realize s2" fbo' <- newFBO+ checkError "realize fbo" [tsheet0', tsheet1'] <- genObjectNames 2+ checkError "realize sheets"+ -- FIXME hardcoded font path+ font' <- createTextureFont "/usr/share/fonts/truetype/ttf-dejavu/DejaVuSansMono-Bold.ttf"+ -- FIXME destroyFont (font s) at exit+ _ <- setFontFaceSize font' 16 72 ps <- replicateM numCapabilities $ do p <- malloc _ <- forkIO (worker iR p)@@ -619,37 +751,65 @@ , sheetCount0 = 0 , sheetCount1 = 0 , sheetCountTarget = maxBound+ , font = font' }, ()) reallocateBuffers iR+ checkError "realize end" reallocateBuffers :: IORef GruffImage -> IO () reallocateBuffers iR = do+ checkError "reallocate begin" s <- readIORef iR let tw' = texels $ sheetSize s th' = tw' ts = [tsheet0 s, tsheet1 s] forM_ (ts `zip` [(tw', th'), (tw' * 2, th' * 2)]) $ \(t, (tw, th)) -> do texture Texture2D $= Enabled+ checkError "reallocate 1" textureBinding Texture2D $= Just t+ checkError "reallocate 2" glTexImage2D gl_TEXTURE_2D 0 (fromIntegral gl_RGBA) (fromIntegral tw) (fromIntegral th) 0 gl_RGBA gl_UNSIGNED_BYTE nullPtr+ checkError "reallocate 3" textureFilter Texture2D $= ((Linear', Just Linear'), Linear')- textureWrapMode Texture2D S $= (Repeated, ClampToEdge)- textureWrapMode Texture2D T $= (Repeated, ClampToEdge)+ checkError "reallocate 4"+ textureWrapMode Texture2D GL.S $= (Repeated, ClampToEdge)+ checkError "reallocate 5"+ textureWrapMode Texture2D GL.T $= (Repeated, ClampToEdge)+ checkError "reallocate 6" textureBinding Texture2D $= Nothing+ checkError "reallocate 7" texture Texture2D $= Disabled- atomicModifyIORef iR $ \s' -> (s'{ sheetCount0 = 0, sheetCount1 = 0, sheetCountTarget = maxBound }, ())+ checkError "reallocate 8"+ atomicModifyIORef iR $ \s' ->+ (s'{ sheetCount0 = 0, sheetCount1 = 0, sheetCountTarget = maxBound }, ())+ checkError "reallocate end" newFBO :: IO GLuint newFBO = alloca $ \p -> glGenFramebuffers 1 p >> peek p bindFBO :: GLuint -> TextureObject -> IO () bindFBO f (TextureObject t) = do+ checkError "bindFBO begin" glBindFramebuffer gl_FRAMEBUFFER f+ checkError "bindFBO 1" glFramebufferTexture2D gl_FRAMEBUFFER gl_COLOR_ATTACHMENT0 gl_TEXTURE_2D t 0+ checkError "bindFBO 2"+ err <- glCheckFramebufferStatus gl_FRAMEBUFFER+ when (err /= gl_FRAMEBUFFER_COMPLETE) $+ putStrLn ("OpenGL framebuffer error: " ++ show err)+ checkError "bindFBO end" unbindFBO :: IO () unbindFBO = do+ checkError "unbindFBO begin" glFramebufferTexture2D gl_FRAMEBUFFER gl_COLOR_ATTACHMENT0 gl_TEXTURE_2D 0 0+ checkError "unbindFBO 1" glBindFramebuffer gl_FRAMEBUFFER 0+ checkError "unbindFBO end"++checkError :: String -> IO ()+checkError s = do+ err <- glGetError+ when (err /= 0) $ putStrLn ("OpenGL error (" ++ s ++ "): " ++ show err)
+ src/Fractal/GRUFF.hs view
@@ -0,0 +1,154 @@+{- |+Module : Fractal.GRUFF+Copyright : (c) Claude Heiland-Allen 2011+License : GPL-2++Maintainer : claudiusmaximus@goto10.org+Stability : unstable+Portability : portable++Support library for rendering animations of the Mandelbrot Set fractal+using the gruff executable.++An example program might have a structure similar to:++ > import Fractal.GRUFF+ >+ > animation :: Animation+ > animation = ...+ >+ > main :: IO ()+ > main = defaultMain animation++with its output fed to the gruff executable.++See also:++ * the @ruff@ package for feature location algorithms; and+ + * the @gruff-examples@ package for concrete examples.++-}+module Fractal.GRUFF where++import System.IO (hFlush, stdout)++import Fractal.RUFF.Types.Complex (Complex((:+)))++-- | Animation specification+type Animation = [(Image, FilePath)]++-- | Image specification.+data Image = Image+ { imageWindow :: !Window+ , imageViewport :: !Viewport+ , imageLocation :: !Location+ , imageColours :: !Colours+ , imageLabels :: [Label]+ , imageLines :: [Line]+ }+ deriving (Read, Show, Eq)++-- | Window specification.+data Window = Window+ { width :: !Int+ , height :: !Int+ , supersamples :: !Double+ }+ deriving (Read, Show, Eq)++-- | Viewport specification+data Viewport = Viewport+ { aspect :: !Double -- width / height+ , orient :: !Double -- in radians+ }+ deriving (Read, Show, Eq)++-- | Location specification (center of view).+data Location = Location+ { center :: !(Complex Rational)+ , radius :: !Double -- accurate enough for 1000 2x zoom levels+ }+ deriving (Read, Show, Eq)++-- | Colour specification.+data Colours = Colours+ { colourInterior :: !Colour+ , colourBoundary :: !Colour+ , colourExterior :: !Colour+ }+ deriving (Read, Show, Eq)++-- | RGB colour data (each channel between 0 and 1).+data Colour = Colour !Double !Double !Double+ deriving (Read, Show, Eq)++-- | Labels can be added to points in the complex plane.+data Label = Label+ { labelCoords :: !(Complex Rational)+ , labelColour :: !Colour+ , labelText :: String+ }+ deriving (Read, Show, Eq)++-- | Append a label to an image.+labelAppend :: Complex Rational -> Colour -> String -> Image -> Image+labelAppend c v t i = i{ imageLabels = imageLabels i ++ [Label{ labelCoords = c, labelColour = v, labelText = t }] }++-- | Prepend a label to an image.+labelPrepend :: Complex Rational -> Colour -> String -> Image -> Image+labelPrepend c v t i = i{ imageLabels = [Label{ labelCoords = c, labelColour = v, labelText = t }] ++ imageLabels i }++-- ! Line segments.+data Line = Line+ { lineSegments :: [(Complex Rational, Complex Rational)]+ , lineColour :: !Colour+ }+ deriving (Read, Show, Eq)++-- | Transform a point from screen coordinates.+fromScreenCoords :: (Fractional r, Real r) => Window -> Viewport -> Location -> Complex Double -> Complex r+fromScreenCoords w v l = \(x :+ y) ->+ let x1 = (2 * x - w') / w' * p+ y1 = (h' - 2 * y) / h' / p+ x2 = co * x1 + si * y1+ y2 = -si * x1 + co * y1+ x3 = r * toRational x2+ y3 = r * toRational y2+ x4 :+ y4 = (x3 :+ y3) + c+ in fromRational x4 :+ fromRational y4+ where+ p = sqrt (aspect v)+ w' = fromIntegral (width w)+ h' = fromIntegral (height w)+ a = - orient v+ co = cos a+ si = sin a+ r = toRational $ radius l+ c = center l++-- | Transform a point to screen coordinates.+toScreenCoords :: Real r => Window -> Viewport -> Location -> Complex r -> Complex Double+toScreenCoords w v l = \(x' :+ y') ->+ let x = (x1 / p * w' + w') / 2+ y = (y1 * p * h' - h') / (-2)+ x1 = co * x2 + si * y2+ y1 = -si * x2 + co * y2+ x2 = fromRational (x3 / r)+ y2 = fromRational (y3 / r)+ x3 :+ y3 = (toRational x' :+ toRational y') - c+ in x :+ y+ where+ p = sqrt (aspect v)+ w' = fromIntegral (width w)+ h' = fromIntegral (height w)+ a = orient v+ co = cos a+ si = sin a+ r = toRational (radius l)+ c = center l++-- | Serialize an animation to stdout.+defaultMain :: Animation -> IO ()+defaultMain a = do+ mapM_ (\f -> print f >> hFlush stdout) a
src/GLUTGtk.hs view
@@ -20,7 +20,7 @@ data KeyState = Down | Up deriving (Eq, Ord, Show) -data Key = Char Char | MouseButton MouseButton+data Key = MouseButton MouseButton deriving (Eq, Show) data GLUTGtk = GLUTGtk
+ src/Interact.hs view
@@ -0,0 +1,91 @@+module Interact+ ( mouseCallbacks+ , MouseCallbacks+ , MouseCallback+ , Click+ , But(..)+ , Mod(..)+ ) where++import Data.Map (Map, fromList)++import Fractal.RUFF.Mandelbrot.Address+import Fractal.RUFF.Mandelbrot.Atom+import Fractal.RUFF.Types.Complex++import Fractal.GRUFF++import Progress++type MouseCallbacks = Map Click MouseCallback++type Click = (But, Mod)++data But = L | M | R deriving (Eq, Ord, Show)+data Mod = U | S | C | SC deriving (Eq, Ord, Show)++type MouseCallback = Complex Rational -> Image -> IO ()++type MouseHandler = Progress -> Complex Rational -> Image -> Cont Image++mouseCallbacks :: IO Colour -> Progress -> (Maybe Image -> IO ()) -> MouseCallbacks+mouseCallbacks gc p next = fromList+ [ ( (L, U), w $ mouseZoom 0.9 )+ , ( (R, U), w $ mouseZoom 1.1 )+ , ( (M, U), w $ mouseCenter )+ , ( (L, S), w $ mouseZoom 0.1 )+ , ( (R, S), w $ mouseZoom 10 )+ , ( (M, S), w $ mouseLocateGo )+ , ( (L, C), w $ mousePeriod gc )+ , ( (R, C), w $ mouseAddress gc )+ ]+ where w cb c i = cb p c i next++mouseCenter :: MouseHandler+mouseCenter _ c i next = do+ next . Just $ i{ imageLocation = (imageLocation i){ center = c } }++mouseZoom :: Double -> MouseHandler+mouseZoom f _ c i next = do+ let o = center (imageLocation i)+ r = radius (imageLocation i)+ f' = toRational f :+ 0+ r' = f * r+ o' = f' * o + (1 - f') * c+ next . Just $ i{ imageLocation = (imageLocation i){ center = o', radius = r' } }++mouseLocateGo :: MouseHandler+mouseLocateGo p c i next = do+ let r0 = radius (imageLocation i) / 32+ progressLocate p c r0 $ \mmu -> case mmu of+ Nothing -> next Nothing+ Just mu -> do+ let n = muNucleus mu+ r = muSize mu * 16+ a = muOrient mu - pi/2+ next . Just $ i{ imageLocation = (imageLocation i){ center = n, radius = r }, imageViewport = (imageViewport i){ orient = a } }++mousePeriod :: IO Colour -> MouseHandler+mousePeriod gv p c i next = do+ let r = radius (imageLocation i) / 32+ progressLocate p c r $ \mmu -> case mmu of+ Nothing -> next Nothing+ Just mu -> do+ let n = muNucleus mu+ t = show (muPeriod mu)+ v <- gv+ next . Just $ labelAppend n v t i++mouseAddress :: IO Colour -> MouseHandler+mouseAddress gv p c i next = do+ let r = radius (imageLocation i) / 32+ progressLocate p c r $ \mmu -> case mmu of+ Nothing -> next Nothing+ Just mu -> do+ progressAddress p mu $ \mad -> case mad of+ Nothing -> next Nothing+ Just ad -> do+ let n = muNucleus mu+ t = prettyAngledInternalAddress ad+ v <- gv+ next . Just $ labelAppend n v t i
− src/MuAtom.hs
@@ -1,171 +0,0 @@-{-# LANGUAGE BangPatterns #-}-module MuAtom(MuAtom(..), MuProgress(..), muFromAddress, MuProgress'(..), muToAddress, MuProgress''(..), muLocate) where--import Control.Arrow ((***))-import Data.Ratio ((%))-import Data.Vec (NearZero, nearZero)--import Fractal.RUFF.Mandelbrot.Address (AngledInternalAddress, Angle, splitAddress, addressPeriod, externalAngles, angledInternalAddress)-import Fractal.RUFF.Mandelbrot.Nucleus (findNucleus, findBond, findPeriod)-import Fractal.RUFF.Mandelbrot.Ray (externalRay, externalRayOut)-import Fractal.RUFF.Types.Complex (Complex, magnitude, magnitude2, phase, mkPolar)--import Number (R)--data MuAtom = MuAtom- { muNucleus :: !(Complex R)- , muSize :: !Double- , muOrient :: !Double- , muPeriod :: !Integer- }- deriving (Read, Show, Eq)--data MuProgress- = MuSplitTodo- | MuSplitDone AngledInternalAddress [Angle]- | MuAnglesTodo- | MuAnglesDone !Rational !Rational- | MuRayTodo- | MuRay !Integer- | MuRayDone !(Complex R)- | MuNucleusTodo- | MuNucleus !Integer- | MuNucleusDone !(Complex R)- | MuBondTodo- | MuBond !Integer- | MuBondDone !(Complex R)- | MuSuccess !MuAtom- | MuFailed- deriving (Read, Show, Eq)--muFromAddress :: AngledInternalAddress -> [MuProgress]-muFromAddress addr = MuSplitTodo :- let (!iaddr, !caddr) = splitAddress addr- !p = addressPeriod iaddr- in MuSplitDone iaddr caddr : MuAnglesTodo : case externalAngles iaddr of- Nothing -> [MuFailed]- Just (!lo, !hi) -> MuAnglesDone lo hi : MuRayTodo :- let sharpness = 8- er = 65536- accuracy = 1e-10- ok w = magnitude2 w < 2 * er ^ (2::Int) -- NaN -> False- rayl = externalRay accuracy sharpness er lo- rayh = externalRay accuracy sharpness er hi- ray' = takeWhile (uncurry (&&) . (ok *** ok) . snd) $ [ 1 .. ] `zip` (rayl `zip` rayh)- rgo [] _ = [MuFailed]- rgo [_] _ = [MuFailed]- rgo ((i, (xl, xh)):m@((_, (yl, yh)):_)) f- | i < fromIntegral sharpness * (p + 16) = MuRay i : rgo m f- | dl + dh > dx + dy = MuRay i : rgo m f- | otherwise = MuRayDone x : f x- where- x = 0.5 * (xl + xh)- dl = magnitude2 (xl - yl)- dh = magnitude2 (xh - yh)- dx = magnitude2 (xl - xh)- dy = magnitude2 (yl - yh)- in rgo ray' $ \rayend -> MuNucleusTodo :- let nuc = findNucleus p rayend- nuc' = takeWhile (ok . snd) $ [ 1 .. ] `zip` nuc- ngo [] _ = [MuFailed]- ngo [_] _ = [MuFailed]- ngo ((i, x):m@((_, y):_)) f- | not (nearZero (x - y)) = MuNucleus i : ngo m f- | otherwise = MuNucleusDone x : f x- in ngo nuc' $ \nucleus -> MuBondTodo :- let bnd = findBond p nucleus 0.5- bnd' = takeWhile (ok . snd) $ [ 1.. ] `zip` bnd- bgo [] _ = [MuFailed]- bgo [_] _ = [MuFailed]- bgo ((i, x):m@((_, y):_)) f- | not (nearZero (x - y)) = MuBond i : bgo m f- | otherwise = MuBondDone x : f x- in bgo bnd' $ \bond ->- let delta = bond - nucleus- size = realToFrac $ magnitude delta / 0.75- orient = realToFrac $ phase delta- atom = MuAtom{ muNucleus = nucleus, muSize = size, muOrient = orient, muPeriod = p }- in if 10 > size && size > 0 then [MuSuccess atom] else [MuFailed]--data MuProgress'- = MuCuspTodo- | MuCuspDone !(Complex R)- | MuDwellTodo- | MuDwell !Integer- | MuDwellDone !Integer- | MuRayOutTodo- | MuRayOut !Double- | MuRayOutDone !(Complex R)- | MuExternalTodo- | MuExternalDone !Rational- | MuAddressTodo- | MuSuccess' AngledInternalAddress- | MuFailed'- deriving (Read, Show, Eq)--muToAddress :: MuAtom -> [MuProgress']-muToAddress mu = MuCuspTodo :- let cusp = muNucleus mu - mkPolar (realToFrac (muSize mu)) (realToFrac ((muOrient mu)))- er = 65536- er2 = er * er- in MuCuspDone cusp : MuDwellTodo :- let dgo z n f = MuDwell n : if magnitude2 z > er2 then f n else dgo (z * z + cusp) (n + 1) f- in dgo 0 0 $ \n -> MuDwellDone n : MuRayOutTodo :- let rgo ((i,!_):izs@(_:_)) f = MuRayOut (fromIntegral i / (fromIntegral sharpness * fromIntegral n)) : rgo izs f- rgo [(_,!z)] f | magnitude2 z > er2 = MuRayOutDone z : f z- rgo _ _ = [MuFailed']- accuracy = 1e-16- sharpness = 16- epsilon0 = realToFrac (muSize mu) * accuracy- in rgo ([(1 :: Integer) ..] `zip` externalRayOut (fromIntegral n + 100) epsilon0 accuracy sharpness er cusp) $ \rend -> MuExternalTodo :- let den = 2 ^ muPeriod mu - 1- num' = fromIntegral den * warp (phase rend / (2 * pi))- num = round num'- warp t- | t > 0 = t- | otherwise = t + 1- angle = num % den- in MuExternalDone angle : MuAddressTodo : case angledInternalAddress angle of- Nothing -> [MuFailed']- Just addr -> if addressPeriod addr /= muPeriod mu then [MuFailed'] else [MuSuccess' addr]--data MuProgress''- = MuScanTodo- | MuScan- | MuScanDone !Integer- | MuNucleusTodo'- | MuNucleus' !Integer- | MuNucleusDone' !(Complex R)- | MuBondTodo'- | MuBond' !Integer- | MuBondDone' !(Complex R)- | MuSuccess'' !MuAtom- | MuFailed''- deriving (Read, Show, Eq)--muLocate :: Complex R -> Double -> [MuProgress'']-muLocate c r = MuScanTodo : MuScan : case findPeriod 10000000 (realToFrac r) c of- Nothing -> [MuFailed'']- Just p -> MuScanDone p : MuNucleusTodo' :- let ok w = magnitude2 w < 16 -- NaN -> False- nuc = findNucleus p c- nuc' = takeWhile (ok . snd) $ [ 1 .. ] `zip` nuc- ngo [] _ = [MuFailed'']- ngo [_] _ = [MuFailed'']- ngo ((i, x):m@((_, y):_)) f- | not (nearZero (x - y)) = MuNucleus' i : ngo m f- | otherwise = MuNucleusDone' x : f x- in ngo nuc' $ \nucleus -> MuBondTodo' :- let bnd = findBond p nucleus 0.5- bnd' = takeWhile (ok . snd) $ [ 1.. ] `zip` bnd- bgo [] _ = [MuFailed'']- bgo [_] _ = [MuFailed'']- bgo ((i, x):m@((_, y):_)) f- | not (nearZero (x - y)) = MuBond' i : bgo m f- | otherwise = MuBondDone' x : f x- in bgo bnd' $ \bond ->- let delta = bond - nucleus- size = realToFrac $ magnitude delta / 0.75- orient = realToFrac $ phase delta- atom = MuAtom{ muNucleus = nucleus, muSize = size, muOrient = orient, muPeriod = p }- in if 10 > size && size > 0 then [MuSuccess'' atom] else [MuFailed'']
src/Number.hs view
@@ -3,11 +3,11 @@ import Data.Bits (bit) import Data.Ratio ((%))-import Data.Vec (NearZero(nearZero))-import Fractal.RUFF.Types.Complex (Complex((:+)))+import Data.Vec (NearZero) #ifdef HAVE_MPFR +import Data.Vec (nearZero) import Control.Monad (guard) import Data.Ratio (numerator, denominator) import Numeric (readSigned)@@ -16,7 +16,7 @@ #else -import Numeric.QD (QuadDouble(QuadDouble))+import Numeric.QD (QuadDouble) import Numeric.QD.Vec () #endif@@ -72,6 +72,3 @@ toRational' :: RealFrac a => Int -> a -> Rational toRational' l a = round (a * fromInteger b) % b where b = bit (l + 16)--instance NearZero r => NearZero (Complex r) where- nearZero (r:+i) = nearZero r && nearZero i
+ src/Progress.hs view
@@ -0,0 +1,109 @@+module Progress (Progress(..), progressNew, Cont) where++import Control.Monad (forM_, when)++import Graphics.UI.Gtk (Pixbuf)++import Fractal.RUFF.Mandelbrot.Address+import Fractal.RUFF.Mandelbrot.Atom+import Fractal.RUFF.Types.Complex++import Number (R)+import StatusDialog++-- | A continuation gets passed the result.+type Cont a = (Maybe a -> IO ()) -> IO ()++-- | Cancellable actions with status updates.+data Progress = Progress+ { progressLocate :: Complex Rational -> Double -> Cont (MuAtom Rational)+ , progressAtom :: AngledInternalAddress -> Cont (MuAtom Rational)+ , progressAddress :: MuAtom Rational -> Cont AngledInternalAddress+ }++-- | Create a new Progress with a status dialog.+progressNew :: Pixbuf -> IO Progress+progressNew icon = do+ -- FIXME this is a horrible hack to avoid race conditions when re-using the same status dialog+ sd1 <- statusDialogNew icon+ sd2 <- statusDialogNew icon+ sd3 <- statusDialogNew icon+ return Progress+ { progressLocate = progressLocate' sd1+ , progressAtom = progressAtom' sd2+ , progressAddress = progressAddress' sd3+ }++-- | Much like Fractal.RUFF.Mandelbrot.Atom.locate_+progressLocate' :: StatusDialog -> Complex Rational -> Double -> Cont (MuAtom Rational)+progressLocate' sd (re :+ im) r next = do+ statusDialog sd "gruff status" $ \progress' -> do+ let c = fromRational re :+ fromRational im :: Complex R+ forM_ (locate c r) $ \mp -> case mp of+ LocateScanTodo -> progress' "Scanning for period..."+ LocateScan -> progress' "Scanning for period..."+ LocateScanDone p -> progress'$"Scanning for period... " ++ show p+ LocateNucleusTodo -> progress' "Computing nucleus..."+ LocateNucleus i -> when (i `mod` 20 == 0) . progress'$"Computing nucleus... " ++ show i+ LocateNucleusDone _ -> progress' "Computing nucleus... done"+ LocateBondTodo -> progress' "Computing bond..."+ LocateBond i -> when (i `mod` 20 == 0) . progress'$"Computing bond... " ++ show i+ LocateBondDone _ -> progress' "Computing bond... done"+ LocateSuccess mu -> do+ progress' "Success!"+ let (re' :+ im') = muNucleus mu+ next $ Just mu{ muNucleus = toRational re' :+ toRational im' }+ LocateFailed -> do+ progress' "Failed!"+ next $ Nothing++-- | Much like Fractal.RUFF.Mandelbrot.Atom.findAddress_+progressAddress' :: StatusDialog -> MuAtom Rational -> Cont AngledInternalAddress+progressAddress' sd mu next = do+ statusDialog sd "gruff status" $ \progress' -> do+ let re :+ im = muNucleus mu+ c = fromRational re :+ fromRational im :: Complex R+ forM_ (findAddress mu{ muNucleus = c }) $ \mp' -> case mp' of+ AddressCuspTodo -> progress' "Computing cusp..."+ AddressCuspDone _ -> progress' "Computing cusp... done"+ AddressDwellTodo -> progress' "Computing dwell..."+ AddressDwell i -> when (i `mod` 100 == 0) . progress'$"Computing dwell... " ++ show i+ AddressDwellDone _ -> progress' "Computing dwell... done"+ AddressRayOutTodo -> progress' "Tracing rays..."+ AddressRayOut i -> progress'$"Tracing rays... " ++ show (round $ i * 100 :: Int) ++ "%"+ AddressRayOutDone _ -> progress' "Tracing rays... done"+ AddressExternalTodo -> progress' "Computing angle..."+ AddressExternalDone _ -> progress' "Computing angle... done"+ AddressAddressTodo -> progress' "Finding address..."+ AddressSuccess a -> do+ progress' "Success!"+ next $ Just a+ AddressFailed -> do+ progress' "Failed!"+ next $ Nothing++-- | Much like Fractal.RUFF.Mandelbrot.Atom.findAtom_+progressAtom' :: StatusDialog -> AngledInternalAddress -> Cont (MuAtom Rational)+progressAtom' sd addr next = do+ statusDialog sd "gruff status" $ \progress' -> do+ forM_ (findAtom addr) $ \mp -> case mp of+ AtomSplitTodo -> progress' "Splitting address..."+ AtomSplitDone _ _ -> progress' "Splitting address... done"+ AtomAnglesTodo -> progress' "Computing angles..."+ AtomAnglesDone _ _ -> progress' "Computing angles... done"+ AtomRayTodo -> progress' "Tracing rays..."+ AtomRay n -> when (n `mod` 20 == 0) . progress'$"Tracing rays... " ++ show n+ AtomRayDone _ -> progress' "Tracing rays... done"+ AtomNucleusTodo -> progress' "Computing nucleus..."+ AtomNucleus n -> when (n `mod` 20 == 0) . progress'$"Computing nucleus... " ++ show n+ AtomNucleusDone _ -> progress' "Computing nucleus... done"+ AtomBondTodo -> progress' "Computing bond..."+ AtomBond n -> when (n `mod` 20 == 0) . progress'$"Computing bond... " ++ show n+ AtomBondDone _ -> progress' "Computing bond... done"+ AtomSuccess mu -> do+ progress' "Success!"+ let (re' :+ im') = muNucleus mu :: Complex R+ next $ Just mu{ muNucleus = toRational re' :+ toRational im' }+ AtomFailed -> do+ progress' "Failed!"+ next $ Nothing
src/Snapshot.hs view
@@ -14,7 +14,7 @@ import qualified Data.ByteString.Internal as BSI import qualified Data.ByteString as BS --- save a screenshot to a handle as binary PPM+-- save a screenshot as binary PPM snapshotWith :: (BS.ByteString -> IO b) -> Position -> Size -> IO b snapshotWith f p0 vp@(Size vw vh) = do let fi q = fromIntegral q
src/StatusDialog.hs view
@@ -6,9 +6,10 @@ type Status = (String -> IO ()) -> IO () data StatusDialog = StatusDialog{ statusDialog :: String -> Status -> IO () } -statusDialogNew :: IO StatusDialog-statusDialogNew = do+statusDialogNew :: Pixbuf -> IO StatusDialog+statusDialogNew icon = do window <- windowNew+ set window [ windowIcon := Just icon ] windowSetModal window True windowSetDefaultSize window 320 200 b <- vBoxNew False 2@@ -17,7 +18,7 @@ boxPackStartDefaults b label boxPackStartDefaults b cancel set window [ containerChild := b ]- return StatusDialog{ statusDialog = \title task -> do+ return StatusDialog{ statusDialog = \title task -> postGUIAsync $ do windowSetTitle window title labelSetText label "" widgetSetSensitivity cancel True
src/Tile.hs view
@@ -30,7 +30,12 @@ rootSquare :: Square rootSquare = Square{ squareSize = 8, squareWest = -4, squareNorth = -4 } -data Tile = Tile Quad (Ptr CFloat) (Ptr CFloat) (Ptr CFloat)+data Tile = Tile+ { tileQuad :: Quad+ , tileIter :: Ptr CFloat+ , tileDist :: Ptr CFloat+ , tileAngle :: Ptr CFloat+ } mallocTile :: Quad -> IO Tile mallocTile cs = do
src/View.hs view
@@ -3,9 +3,10 @@ , Viewport(..), rotate, defViewport , Window(..), windowSize, defWindow , Colours(..), defColours, Colour(..)+ , Label(..), Line(..) , Image(..), defImage , BufferSize(..), bufferSize- , pixelLocation, delta, tileSize+ , pixelLocation, delta, tileSize, locationPixel , visibleQuads, originQuad ) where @@ -15,67 +16,31 @@ import Fractal.RUFF.Types.Complex (Complex((:+))) +import Fractal.GRUFF+ import QuadTree (Quad(..), Child(..), child) -data Location = Location- { center :: !(Complex Rational)- , radius :: !Double -- accurate enough for 1000 2x zoom levels- }- deriving (Read, Show, Eq)+pixelLocation :: Window -> Viewport -> Location -> Double -> Double -> Complex Rational+pixelLocation w v l = let f = fromScreenCoords w v l in \x y -> f (x :+ y) +locationPixel :: Window -> Viewport -> Location -> Complex Rational -> (Double, Double)+locationPixel w v l = let f = toScreenCoords w v l in \c -> let (x :+ y) = f c in (x, y)+ zoom :: Double -> Location -> Location zoom f l = l{ radius = radius l * f} translate :: Complex Rational -> Location -> Location translate u l = l{ center = center l + u } -data Viewport = Viewport- { aspect :: !Double -- width / height- , orient :: !Double -- in radians- }- deriving (Read, Show, Eq)- rotate :: Double -> Viewport -> Viewport rotate a v = v{ orient = orient v + a } -data Window = Window- { width :: !Int- , height :: !Int- , supersamples :: !Double- }- deriving (Read, Show, Eq)- windowSize :: Window -> Int windowSize w = ceiling . sqrt . (fromIntegral :: Int -> Double) . diagonal2 $ w diagonal2 :: Window -> Int diagonal2 w = width w * width w + height w * height w -{--resolution :: Window -> Double-resolution w = sqrt $ supersamples w * fromIntegral (diagonal2 w)--}--pixelLocation :: Window -> Viewport -> Location -> Double -> Double -> Complex Rational-pixelLocation w v l x y =- let x' :+ y' = pixelLocation' w v l x y- in center l + (toRational x' :+ toRational y')--pixelLocation' :: Window -> Viewport -> Location -> Double -> Double -> Complex Double-pixelLocation' w v l x y =- let p = sqrt (aspect v)- w' = fromIntegral (width w)- h' = fromIntegral (height w)- x1 = (2 * x - w') / w' * p- y1 = (h' - 2 * y) / h' / p- a = - orient v- co = cos a- si = sin a- x2 = co * x1 + si * y1- y2 = -si * x1 + co * y1- r = radius l- in (r * x2) :+ (r * y2)- data BufferSize = BufferSize { texels :: !Int -- power of two }@@ -173,32 +138,16 @@ let qs1 = concatMap childQuads qs0 return ( filter (visible False) qs0 , filter (visible True) qs1 ) -data Image = Image- { imageWindow :: !Window- , imageViewport :: !Viewport- , imageLocation :: !Location- , imageColours :: !Colours- }- deriving (Read, Show, Eq)- defImage :: Image defImage = Image { imageWindow = defWindow , imageViewport = defViewport , imageLocation = defLocation , imageColours = defColours+ , imageLabels = []+ , imageLines = [] } -data Colours = Colours- { colourInterior :: !Colour- , colourBoundary :: !Colour- , colourExterior :: !Colour- }- deriving (Read, Show, Eq)--data Colour = Colour !Double !Double !Double- deriving (Read, Show, Eq)- defColours :: Colours defColours = Colours { colourInterior = Colour 1 0 0@@ -207,7 +156,7 @@ } defLocation :: Location-defLocation = Location{ center = 0, radius = 4 }+defLocation = Location{ center = 0, radius = 2 } defWindow :: Window defWindow = Window{ width = 512, height = 288, supersamples = 1 }
src/gruff.hs view
@@ -1,29 +1,30 @@-{-# LANGUAGE StandaloneDeriving #-} module Main (main) where import Prelude hiding (catch, log)---import Control.Concurrent (forkIO)-import Control.Monad (forM_, liftM3, when)+import Control.Concurrent (forkIO)+import Control.Monad (forM_) import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef, writeIORef)-import Data.Maybe (isJust, fromMaybe) -- , mapMaybe)+import Data.Maybe (mapMaybe) import Graphics.UI.Gtk hiding (get, Region, Size, Window, Viewport) import qualified Graphics.UI.Gtk as GTK import Graphics.UI.Gtk.OpenGL (initGL) import System.Directory (getAppUserDataDirectory, createDirectoryIfMissing) import System.FilePath ((</>)) -import Fractal.RUFF.Mandelbrot.Address (AngledInternalAddress, Angle, parseAngledInternalAddress, prettyAngledInternalAddress) import Fractal.RUFF.Types.Complex (Complex((:+)), realPart, imagPart) import Paths_gruff (getDataFileName) import Number (R)-import Browser (Browser(..), browserNew) -- , browserRenders)-import MuAtom (MuAtom(..), MuProgress(..), muFromAddress, MuProgress'(..), muToAddress, MuProgress''(..), muLocate)-import View (Image(..), Location(..), Viewport(..), Window(..), Colours(..), Colour(..), defWindow, defViewport) -- , defColours)+import Browser (Browser(..), browserNew, browserRenders)+import Progress (progressNew)+import Interact (mouseCallbacks)+import View+ ( Image(..), Location(..), Viewport(..), Window(..)+ , Colours(..), Colour(..), defImage, defLocation+ ) import GLUTGtk (glut, Size(Size), postRedisplay) import Logger (logger, LogLevel(Debug)) import qualified Logger as Log-import StatusDialog (StatusDialog, statusDialog, statusDialogNew) import Utils (safeRead, catchIO) exit :: (LogLevel -> String -> IO ()) -> FilePath -> Gruff -> IO ()@@ -33,17 +34,13 @@ mainQuit data GruffGUI = GruffGUI- { dStatus :: StatusDialog -- buttons- , bHome+ { bHome , bLoad , bSave , bStop- , bAddressToCoordinates- , bPeriodScan- , bPeriodScanPlus :: Button+ , bClear :: Button -- entries- , eAddress , eRealM, eRealE , eImagM, eImagE , eSizeM, eSizeE@@ -78,8 +75,11 @@ browser <- browserNew gl' icon lg cacheDir' let iw = browserWindow browser sg <- sizeGroupNew SizeGroupHorizontal+ let spacing = 2+ entryNewWithMnemonic m = entryNewWithMnemonic' m 30+ entryNewWithMnemonic' m wc = do e <- entryNew entrySetWidthChars e wc@@ -90,6 +90,7 @@ boxPackStart h l PackNatural 0 boxPackStartDefaults h e return (e, h)+ entryNewExponent = do e <- entryNew entrySetWidthChars e 4@@ -98,6 +99,7 @@ boxPackStart h l PackNatural 0 boxPackStart h e PackNatural 0 return (e, h)+ frameNewWithContents box t r ws = do f <- frameNew frameSetLabel f t@@ -106,25 +108,13 @@ forM_ ws $ boxPackStartDefaults v set f [ containerChild := v ] return f- frameNewWithContents' _ _ _ [] = error "frameNewWithContents': []"- frameNewWithContents' box t r (w:ws) = do- f <- frameNew- frameSetLabel f t- frameSetLabelAlign f (if r then 1 else 0) 0.5- v <- box False spacing- boxPackStart v w PackGrow 0- forM_ ws $ \w' -> boxPackStart v w' PackNatural 0- set f [ containerChild := v ]- return f- dStatus' <- statusDialogNew- b01@bHome' <- buttonNewWithLabel "Home"- b02@bLoad' <- buttonNewWithLabel "Load"- b03@bSave' <- buttonNewWithLabel "Save"- b04@bStop' <- buttonNewWithLabel "Stop"- b7@bAddressToCoordinates' <- buttonNewWithLabel "Go"- b8@bPeriodScan' <- buttonNewWithLabel "Scan"- b9@bPeriodScanPlus' <- buttonNewWithLabel "Scan+"- (eAddress', fa1) <- entryNewWithMnemonic "_Address"++ b01@bHome' <- buttonNewWithLabel "Home"+ b02@bLoad' <- buttonNewWithLabel "Load"+ b03@bSave' <- buttonNewWithLabel "Save"+ b04@bStop' <- buttonNewWithLabel "Stop"+ b05@bClear' <- buttonNewWithLabel "Clear"+ (eRealM', fc1m) <- entryNewWithMnemonic "_Real" (eRealE', fc1e) <- entryNewExponent (eImagM', fc2m) <- entryNewWithMnemonic "_Imag"@@ -135,13 +125,19 @@ (eWidth', fvW) <- entryNewWithMnemonic' "_Width" 5 (eHeight', fvH) <- entryNewWithMnemonic' "_Height" 5 (eSamples', fvS) <- entryNewWithMnemonic' "_Samples" 3+ cInterior' <- colorButtonNewWithColor red cBorder' <- colorButtonNewWithColor black cExterior' <- colorButtonNewWithColor white- fb <- frameNewWithContents vBoxNew "Actions" False [b01, b02, b03, b04, b8, b9]- fa <- frameNewWithContents' hBoxNew "Angled Internal Address" True [toWidget fa1, toWidget b7]- fh <- frameNewWithContents hBoxNew "Colours" True [cInterior', cBorder', cExterior']++ labelColourR <- newIORef (fromColor blue)+ cLabels' <- colorButtonNewWithColor blue+ _ <- cLabels' `onColorSet` (colorButtonGetColor cLabels' >>= writeIORef labelColourR . fromColor)++ fb <- frameNewWithContents vBoxNew "Actions" False [b01, b02, b03, b04, b05]+ fh <- frameNewWithContents hBoxNew "Colours" True [cInterior', cBorder', cExterior', cLabels'] fv <- frameNewWithContents hBoxNew "Viewport" True [fvR, fvW, fvH, fvS]+ let packMantissaExponent m e = do h <- hBoxNew False spacing boxPackStartDefaults h m@@ -152,27 +148,26 @@ fc3 <- packMantissaExponent fc3m fc3e fc <- frameNewWithContents vBoxNew "Coordinates" True [fc1, fc2, fc3] v <- vBoxNew False spacing- mapM_ (\w -> boxPackStart v w PackNatural 0) [fc, fv, fa, fh]+ mapM_ (\w -> boxPackStart v w PackNatural 0) [fc, fv, {- fa, -} fh] h <- hBoxNew False spacing boxPackStart h fb PackNatural 0 boxPackStartDefaults h v+ ww <- windowNew set ww [ windowIcon := Just icon, windowTitle := "gruff control" ]+ containerAdd ww h mg <- aDoLoad stateFile gR <- newIORef $ case mg of Nothing -> initialGruff Just g -> g+ let g0 = GruffGUI- { dStatus = dStatus'- , bHome = bHome'+ { bHome = bHome' , bLoad = bLoad' , bSave = bSave' , bStop = bStop'- , bAddressToCoordinates = bAddressToCoordinates'- , bPeriodScan = bPeriodScan'- , bPeriodScanPlus = bPeriodScanPlus'- , eAddress = eAddress'+ , bClear = bClear' , eRealM = eRealM' , eRealE = eRealE' , eImagM = eImagM'@@ -195,27 +190,15 @@ butI b a = do _ <- b g0 `onClicked` (wrapA g0 gR a >> upI) return ()- butJ b a = do- _ <- b g0 `onClicked` (wrapA' g0 gR a upI)- return ()+ butO b a = do _ <- b g0 `onClicked` a return ()- ent e a = do- _ <- e g0 `onEntryActivate` (entryGetText (e g0) >>= wrapE g0 gR a)- return ()+ entI e a = do _ <- e g0 `onEntryActivate` (entryGetText (e g0) >>= wrapE g0 gR a >> upI) return ()-{-- entI' e a = do- _ <- e g0 `onEntryActivate` (do- entryGetText (e g0) >>= wrapE g0 gR a- g <- readIORef gR- browserResize browser (width (gWindow g)) (height (gWindow g)) (supersamples (gWindow g))- upI)- return ()--}+ colI cbi cbb cbe a = forM_ [cbi, cbb, cbe] $ \c -> do _ <- c g0 `onColorSet` (do ci <- colorButtonGetColor (cbi g0)@@ -224,6 +207,7 @@ _ <- a ci cb ce gR upI) return ()+ entME m e a = do let a' = do ms <- entryGetText (m g0)@@ -234,44 +218,40 @@ _ <- m g0 `onEntryActivate` a' _ <- e g0 `onEntryActivate` a' return ()++ upI :: IO () upI = do g <- readIORef gR- browserRender browser Image- { imageColours = let (c1, c2, c3) = gColours g in Colours (fromColor c1) (fromColor c2) (fromColor c3)- , imageLocation = Location- { center = toRational (fromMaybe 0 (gReal g)) :+ toRational (fromMaybe 0 (gImag g))- , radius = fromMaybe 0 (gSize g)- }- , imageViewport = (gViewport g){ orient = fromMaybe 0 (gRota g) }- , imageWindow = gWindow g- } (return ()) (return ())+ browserRender browser g (return ()) (return ()) postRedisplay gl'- aUpdate (re :+ im) z = do- atomicModifyIORef gR $ \g ->- ( g{ gReal = Just re, gImag = Just im, gSize = Just z }, () )- g <- readIORef gR- uReal g0 g- uImag g0 g- uSize g0 g- uRota g0 g++ aUpdate :: Maybe View.Image -> IO ()+ aUpdate Nothing = return ()+ aUpdate (Just i) = do+ writeIORef gR i+ uReal g0 i+ uImag g0 i+ uSize g0 i+ uRota g0 i upI++ aReshape :: Int -> Int -> IO () aReshape w' h' = do atomicModifyIORef gR $ \g ->- ( g { gWindow = (gWindow g){ width = w', height = h' }- , gViewport = (gViewport g){ aspect = fromIntegral w' / fromIntegral h' }+ ( g { imageWindow = (imageWindow g){ width = w', height = h' }+ , imageViewport = (imageViewport g){ aspect = fromIntegral w' / fromIntegral h' } } , () ) g <- readIORef gR uEverything g0 g--- upI+ upI+ butI bHome aHome butI bLoad aLoad but bSave aSave butO bStop (browserAbort browser)- butJ bAddressToCoordinates aAddressToCoordinates- butJ bPeriodScan (aPeriodScan False)- butJ bPeriodScanPlus (aPeriodScan True)- ent eAddress aAddress+ butI bClear aClear+ entME eRealM eRealE aReal entME eImagM eImagE aImag entME eSizeM eSizeE aSize@@ -279,100 +259,57 @@ entI eWidth aWidth entI eHeight aHeight entI eSamples aSamples-{-- entI' eWidth aWidth- entI' eHeight aHeight- entI' eSamples aSamples--} colI cInterior cBorder cExterior aColours let aExit' = (exit (Log.log lg) stateFile =<< readIORef gR) browserSetExitCallback browser aExit'- browserSetMouseCallback browser aUpdate++ progress <- progressNew icon+ let mcbs = mouseCallbacks (readIORef labelColourR) progress aUpdate+ browserSetMouseCallback browser mcbs+ browserSetReshapeCallback browser aReshape _ <- ww `onDestroy` aExit' g <- readIORef gR uEverything g0 g upI- refreshGUI g0 g widgetShowAll iw widgetShowAll ww--- _ <- forkIO $ script browser+ _ <- forkIO $ script browser mainGUI -data Gruff = Gruff- { gAddress :: Maybe AngledInternalAddress- , gIsland :: Maybe AngledInternalAddress- , gChild :: Maybe [Angle]- , gLowerAngle :: Maybe Angle- , gUpperAngle :: Maybe Angle- , gReal :: Maybe R- , gImag :: Maybe R- , gSize :: Maybe Double- } | Gruff2- { gAddress :: Maybe AngledInternalAddress- , gReal :: Maybe R- , gImag :: Maybe R- , gSize :: Maybe Double- , gRota :: Maybe Double- , gColours :: (Color, Color, Color)- , gWindow :: Window- , gViewport :: Viewport- }- deriving (Read, Show)-deriving instance Read Color+type Gruff = View.Image initialGruff :: Gruff-initialGruff = Gruff2- { gAddress = parseAngledInternalAddress "1"- , gReal = Just 0- , gImag = Just 0- , gSize = Just 2- , gRota = Just 0- , gColours = (red, black, white)- , gWindow = defWindow- , gViewport = defViewport- }--refreshGUI :: GruffGUI -> Gruff -> IO ()-refreshGUI g0 g = do- can bAddressToCoordinates $ j gAddress- can bPeriodScan $ True- where- can w = widgetSetSensitive (w g0)- j a = isJust (a g)+initialGruff = defImage -- button actions type A = GruffGUI -> Gruff -> IO Gruff-type A' = GruffGUI -> Gruff -> (Gruff -> IO ()) -> IO () wrapA :: GruffGUI -> IORef Gruff -> A -> IO () wrapA g0 gR a = do g <- readIORef gR g' <- a g0 g writeIORef gR $! g'- refreshGUI g0 g' -wrapA' :: GruffGUI -> IORef Gruff -> A' -> IO () -> IO ()-wrapA' g0 gR a upI = do- g <- readIORef gR- a g0 g $ \g' -> postGUISync $ do- writeIORef gR $! g'- upI- refreshGUI g0 g'- aHome :: A aHome g0 g = do- let g' = initialGruff{ gColours = gColours g, gWindow = gWindow g, gViewport = gViewport g }+ let g' = g{ imageLocation = defLocation, imageViewport = (imageViewport g){ orient = 0 } } uEverything g0 g' return g' +aClear :: A+aClear g0 g = do+ let g' = g{ imageLabels = [], imageLines = [] }+ uEverything g0 g'+ return g'+ aDoLoad :: FilePath -> IO (Maybe Gruff) aDoLoad ff = (do gr <- safeRead `fmap` readFile ff- return $ case gr of- Just (Gruff a _ _ _ _ b c d) -> Just (Gruff2 a b c d (Just 0) (red, black, white) defWindow defViewport)- g -> g+ case gr of+ g@(Just _) -> return g+ _ -> putStrLn "file format not supported, sorry" >> return Nothing ) `catchIO` const (return Nothing) aLoad :: A@@ -412,112 +349,23 @@ widgetDestroy fc return g -aPeriodScan :: Bool -> A'-aPeriodScan plus g0 g gn = do- statusDialog (dStatus g0) "gruff status" $ \progress -> case liftM3 (,,) (gReal g) (gImag g) (gSize g) of- Nothing -> progress "nothing to do" >> gn g- Just (re, im, r) -> do- forM_ (muLocate (re:+im) r) $ \mp -> case mp of- MuScanTodo -> progress "Scanning for period..."- MuScan -> progress "Scanning for period..."- MuScanDone p -> progress$"Scanning for period... " ++ show p- MuNucleusTodo' -> progress "Computing nucleus..."- MuNucleus' i -> when (i `mod` 20 == 0) . progress$"Computing nucleus... " ++ show i- MuNucleusDone' _ -> progress "Computing nucleus... done"- MuBondTodo' -> progress "Computing bond..."- MuBond' i -> when (i `mod` 20 == 0) . progress$"Computing bond... " ++ show i- MuBondDone' _ -> progress "Computing bond... done"- MuSuccess'' mu -> do- let g' = g{ gReal = Just . realPart . muNucleus $ mu- , gImag = Just . imagPart . muNucleus $ mu- , gSize = Just . (* 16) . muSize $ mu- , gRota = Just . subtract (pi/2) . muOrient $ mu- }- progress "Found!"- postGUISync $ do- uReal g0 g'- uImag g0 g'- uSize g0 g'- uRota g0 g'- if plus- then- forM_ (muToAddress mu) $ \mp' -> case mp' of- MuCuspTodo -> progress "Computing cusp..."- MuCuspDone _ -> progress "Computing cusp... done"- MuDwellTodo -> progress "Computing dwell..."- MuDwell i -> when (i `mod` 100 == 0) . progress$"Computing dwell... " ++ show i- MuDwellDone _ -> progress "Computing dwell... done"- MuRayOutTodo -> progress "Tracing rays..."- MuRayOut i -> progress$"Tracing rays... " ++ show (round $ i * 100 :: Int) ++ "%"- MuRayOutDone _ -> progress "Tracing rays... done"- MuExternalTodo -> progress "Computing angle..."- MuExternalDone _ -> progress "Computing angle... done"- MuAddressTodo -> progress "Finding address..."- MuSuccess' a -> do- let g'' = g'{ gAddress = Just a }- progress "Complete!"- postGUISync $ do- uAddress g0 g''- gn g''- MuFailed' -> progress "Failed!" >> gn g'- else- gn g'- MuFailed'' -> progress "Failed!" >> gn g--aAddressToCoordinates :: A'-aAddressToCoordinates g0 g gn = do- statusDialog (dStatus g0) "gruff status" $ \progress -> case gAddress g of- Nothing -> progress "nothing to do" >> gn g- Just addr -> do- forM_ (muFromAddress addr) $ \mp -> do- case mp of- MuSplitTodo -> progress "Splitting address..."- MuSplitDone _ _ -> progress "Splitting address... done"- MuAnglesTodo -> progress "Computing angles..."- MuAnglesDone _ _ -> progress "Computing angles... done"- MuRayTodo -> progress "Tracing rays..."- MuRay n -> when (n `mod` 20 == 0) . progress$"Tracing rays... " ++ show n- MuRayDone _ -> progress "Tracing rays... done"- MuNucleusTodo -> progress "Computing nucleus..."- MuNucleus n -> when (n `mod` 20 == 0) . progress$"Computing nucleus... " ++ show n- MuNucleusDone _ -> progress "Computing nucleus... done"- MuBondTodo -> progress "Computing bond..."- MuBond n -> when (n `mod` 20 == 0) . progress$"Computing bond... " ++ show n- MuBondDone _ -> progress "Computing bond... done"- MuSuccess mu -> do- let g' = g{ gReal = Just . realPart . muNucleus $ mu- , gImag = Just . imagPart . muNucleus $ mu- , gSize = Just . (* 16) . muSize $ mu- , gRota = Just . subtract (pi/2) . muOrient $ mu- }- progress "Done!"- postGUISync $ do- uReal g0 g'- uImag g0 g'- uSize g0 g'- uRota g0 g'- gn g'- MuFailed -> progress "Failed!" >> gn g- -- entry update type U = GruffGUI -> Gruff -> IO () -uEverything, uAddress, uReal, uImag, uSize, uRota, uColours, uWidth, uHeight, uSamples :: U-uEverything g0 g = forM_ [uAddress, uReal, uImag, uSize, uRota, uColours, uWidth, uHeight, uSamples] $ \u -> u g0 g-uAddress g0 g = entrySetText (eAddress g0) (maybe "" prettyAngledInternalAddress (gAddress g))-uReal g0 g = uMantissaExponent (eRealM g0) (eRealE g0) (maybe "" show (gReal g))-uImag g0 g = uMantissaExponent (eImagM g0) (eImagE g0) (maybe "" show (gImag g))-uSize g0 g = uMantissaExponent (eSizeM g0) (eSizeE g0) (maybe "" show (gSize g))-uRota g0 g = entrySetText (eRota g0) (maybe "" show (gRota g))+uEverything, uReal, uImag, uSize, uRota, uColours, uWidth, uHeight, uSamples :: U+uEverything g0 g = forM_ [uReal, uImag, uSize, uRota, uColours, uWidth, uHeight, uSamples] $ \u -> u g0 g+uReal g0 g = uMantissaExponent (eRealM g0) (eRealE g0) (show . (fromRational :: Rational -> R) . realPart . center . imageLocation $ g)+uImag g0 g = uMantissaExponent (eImagM g0) (eImagE g0) (show . (fromRational :: Rational -> R) . imagPart . center . imageLocation $ g)+uSize g0 g = uMantissaExponent (eSizeM g0) (eSizeE g0) (show . radius . imageLocation $ g)+uRota g0 g = entrySetText (eRota g0) (show . orient . imageViewport $ g) uColours g0 g = do- let (ci, cb, ce) = gColours g- colorButtonSetColor (cInterior g0) ci- colorButtonSetColor (cBorder g0) cb- colorButtonSetColor (cExterior g0) ce-uWidth g0 g = entrySetText (eWidth g0) (show . width . gWindow $ g)-uHeight g0 g = entrySetText (eHeight g0) (show . height . gWindow $ g)-uSamples g0 g = entrySetText (eSamples g0) (show . supersamples . gWindow $ g)+ colorButtonSetColor (cInterior g0) (fromColour . colourInterior . imageColours $ g)+ colorButtonSetColor (cBorder g0) (fromColour . colourBoundary . imageColours $ g)+ colorButtonSetColor (cExterior g0) (fromColour . colourExterior . imageColours $ g)+uWidth g0 g = entrySetText (eWidth g0) (show . width . imageWindow $ g)+uHeight g0 g = entrySetText (eHeight g0) (show . height . imageWindow $ g)+uSamples g0 g = entrySetText (eSamples g0) (show . supersamples . imageWindow $ g) uMantissaExponent :: (EntryClass a, EntryClass b) => a -> b -> String -> IO () uMantissaExponent m e s = do@@ -530,130 +378,60 @@ type E = Gruff -> String -> Gruff wrapE :: GruffGUI -> IORef Gruff -> E -> String -> IO ()-wrapE g0 gR e s = do+wrapE _g0 gR e s = do g <- readIORef gR let g' = e g s writeIORef gR $! g'- refreshGUI g0 g' -aAddress, aReal, aImag, aSize, aRota, aWidth, aHeight, aSamples :: E-aAddress g s = g{ gAddress = parseAngledInternalAddress s }-aReal g s = g{ gReal = safeRead s }-aImag g s = g{ gImag = safeRead s }-aSize g s = g{ gSize = safeRead s }-aRota g s = g{ gRota = safeRead s }+aReal, aImag, aSize, aRota, aWidth, aHeight, aSamples :: E+aReal g s = let _ :+ i = center (imageLocation g) in case safeRead s :: Maybe R of+ Nothing -> g+ Just r -> g{ imageLocation = (imageLocation g){ center = toRational r :+ i } }+aImag g s = let r :+ _ = center (imageLocation g) in case safeRead s :: Maybe R of+ Nothing -> g+ Just i -> g{ imageLocation = (imageLocation g){ center = r :+ toRational i } }+aSize g s = case safeRead s :: Maybe Double of+ Nothing -> g+ Just r -> g{ imageLocation = (imageLocation g){ radius = r } }+aRota g s = case safeRead s :: Maybe Double of+ Nothing -> g+ Just a -> g{ imageViewport = (imageViewport g){ orient = a } } aWidth g s = case safeRead s of Nothing -> g- Just r -> g{ gWindow = (gWindow g){ width = r } }+ Just r -> (\g' -> g'{ imageViewport = (imageViewport g'){ aspect = (fromIntegral . width . imageWindow) g' / (fromIntegral . height . imageWindow) g' } }) (g{ imageWindow = (imageWindow g){ width = r } }) aHeight g s = case safeRead s of Nothing -> g- Just r -> g{ gWindow = (gWindow g){ height = r } }+ Just r -> (\g' -> g'{ imageViewport = (imageViewport g'){ aspect = (fromIntegral . width . imageWindow) g' / (fromIntegral . height . imageWindow) g' } }) (g{ imageWindow = (imageWindow g){ height = r } }) aSamples g s = case safeRead s of Nothing -> g- Just r -> g{ gWindow = (gWindow g){ supersamples = r } }+ Just r -> g{ imageWindow = (imageWindow g){ supersamples = r } } aColours :: Color -> Color -> Color -> IORef Gruff -> IO ()-aColours i b e gR = atomicModifyIORef gR $ \g -> (g{ gColours = (i, b, e) }, ())+aColours i b e gR = atomicModifyIORef gR $ \g -> (g{ imageColours = Colours{ colourInterior = fromColor i, colourBoundary = fromColor b, colourExterior = fromColor e} }, ()) minSize :: Size minSize = Size 160 100 -red, black, white :: Color+red, black, white, blue :: Color red = Color 65535 0 0 black = Color 0 0 0 white = Color 65535 65535 65535+blue = Color 0 0 65535 fromColor :: Color -> Colour fromColor (Color r g b) = Colour (fromIntegral r / 65535) (fromIntegral g / 65535) (fromIntegral b / 65535) -{--strings :: [String]-strings = [ "1 1/3 " ++ (unwords . map show . scanl (+) 3) (replicate m 1 ++ replicate (n - m) 2) | m <- [0 .. n - 1] ]- ++ [ "1 1/3 " ++ (unwords . map show . scanl (+) 3) (replicate m 2 ++ replicate (n - m) 1) | m <- [0 .. n - 1] ]- where n = 21 -- 15+fromColour :: Colour -> Color+fromColour (Colour r g b) = Color (round $ r * 65535) (round $ g * 65535) (round $ b * 65535) script :: Browser -> IO ()-script b = browserRenders b images'--filename :: String -> Int -> String-filename s n = (reverse . take 4 . (++ "0000") . reverse . show) n ++ "__" ++ map filechar s ++ ".ppm"- where filechar ' ' = '_'- filechar '/' = '-'- filechar c = c+script b = do+ c <- getContents+ case mapMaybe readMay (lines c) of+ [] -> return ()+ images@(_:_) -> browserRenders b images -findMu :: AngledInternalAddress -> Maybe MuAtom-findMu a = case last (muFromAddress a) of- MuSuccess m -> Just m+readMay :: Read a => String -> Maybe a+readMay s = case reads s of+ [(a, "")] -> Just a _ -> Nothing--scene :: (String, Int) -> Maybe (View.Image, String)-scene (s, n) = do- a <- parseAngledInternalAddress s- m <- findMu a- let cx :+ cy = muNucleus m- f = filename s n- i = Image- { imageLocation = Location{ center = toRational cx :+ toRational cy, radius = muSize m * 8 } -- 6- , imageViewport = viewportDVD{ orient = muOrient m - pi / 2 }- , imageWindow = windowDVD- , imageColours = defColours- }- return (i, f)--windowDVD :: View.Window-windowDVD = Window{ width = 1080, height = 576, supersamples = 2 }--viewportDVD :: View.Viewport-viewportDVD = Viewport{ aspect = 1080/576, orient = 0 }--images :: [(View.Image, String)]-images = mapMaybe scene (score `zip` [0..])--kick, snare :: Int -> [String]-kick n = [ "1 2 " ++ (unwords . map show . take m . scanl (+) (3 :: Int) . repeat) 1 | m <- [n, n - 1 .. 1] ]-snare n = [ "1 2 " ++ (unwords . map show . take (2 * m) . filter (\x -> x `mod` 3 /= 0)) [(3 :: Int) ..] | m <- [n, n - 1 .. 1] ]--score :: [String]-score = concat- [ kick 21- , snare 32- , kick 20- , snare 11- , kick 8- , kick 8- , kick 5- , snare 32- , kick 20- , snare 11- ]--images' :: [(View.Image, String)]-images' = {-drop 49 . -} map frame . take 1200 $ [0 ..]--frame :: Int -> (View.Image, String)-frame n = (img, (reverse . take 4 . (++ "0000") . reverse . show) n ++ ".ppm")- where- t = fromIntegral n / 25- r = 4 * 2 ** negate t- a = c0a * t / 48- img = Image- { imageLocation = Location{ center = c0x :+ c0y, radius = r }- , imageViewport = viewportHD{ orient = a }- , imageWindow = windowHD- , imageColours = defColours- }--windowHD :: View.Window-windowHD = Window{ width = 1920, height = 1080, supersamples = 5 }--viewportHD :: View.Viewport-viewportHD = Viewport{ aspect = 1920/1080, orient = 0 }--c0x, c0y :: Rational-c0x = -1.249654501250026535305564290406342641357245044812024384076696041016544263255410210573644817965421364058466642283047810126900443791060999959661828661014819271180654290498245641835647321878524004347784493127325654028742057010462138345395182421783064045422740334072967042829523926305969086019115635907387177-c0y = 2.62964442060409470886060596680625049122647005543488791701840256388323764840498489578760240122036234473238581692886963706321452429283848754125169118310897168288049653283033547961422702057918968158064636527854942947851448063883186797623535011066501329732840334929404268157442692714476422929470502521447535e-2--c0a :: Double-c0a = -2.651738023427396---}