diff --git a/Graphics/Rendering/Hieroglyph.hs b/Graphics/Rendering/Hieroglyph.hs --- a/Graphics/Rendering/Hieroglyph.hs +++ b/Graphics/Rendering/Hieroglyph.hs @@ -1,11 +1,7 @@ -module Graphics.Rendering.Hieroglyph - (module Graphics.Rendering.Hieroglyph.Cairo - ,module Graphics.Rendering.Hieroglyph.Primitives - ,module Graphics.Rendering.Hieroglyph.Interactive +module Graphics.Rendering.Hieroglyph + (module Graphics.Rendering.Hieroglyph.Primitives ,module Graphics.Rendering.Hieroglyph.Visual) where -import Graphics.Rendering.Hieroglyph.Cairo import Graphics.Rendering.Hieroglyph.Primitives -import Graphics.Rendering.Hieroglyph.Interactive import Graphics.Rendering.Hieroglyph.Visual diff --git a/Graphics/Rendering/Hieroglyph/Cache.hs b/Graphics/Rendering/Hieroglyph/Cache.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Hieroglyph/Cache.hs @@ -0,0 +1,58 @@ +----------------------------------------------------------------------------- +-- +-- Module : Graphics.UI.Hieroglyph.Cache +-- Copyright : +-- License : BSD3 +-- +-- Maintainer : J.R. Heard +-- Stability : +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Graphics.Rendering.Hieroglyph.Cache where + +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap + +data Cache k a = Cache { store :: Map.Map k a, times :: IntMap.IntMap k, now :: Int, maxsize :: Int, size :: Int, decimation :: Int } + +empty mxsz dec = Cache Map.empty IntMap.empty 0 mxsz 0 dec + +get :: Ord k => k -> Cache k a -> (Cache k a,Maybe a) +get key cache = (cache',value) + where value = Map.lookup key (store cache) + cache' = maybe (cache{ now = now cache + 1 }) (\_ -> cache{ now = now cache + 1, times = IntMap.insert (now cache) key (times cache) }) value + +put :: Ord k => k -> a -> Cache k a -> Cache k a +put key value cache + | size cache < maxsize cache && (not $ Map.member key (store cache)) = cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) , size = size cache + 1 } + | size cache < maxsize cache = cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) } + | size cache >= maxsize cache && (Map.member key (store cache)) = cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) } + | size cache >= maxsize cache = cache{ now = now cache + 1, times = IntMap.insert (now cache) key times', store = Map.insert key value store', size = size cache - decimation cache } + where times' = foldr IntMap.delete (times cache) lowtimes + (lowtimes,lowtimekeys) = unzip . take (decimation cache) . IntMap.toAscList . times $ cache + store' = foldr Map.delete (store cache) lowtimekeys + +put' :: Ord k => k -> a -> Cache k a -> ([a], Cache k a) +put' key value cache + | size cache < maxsize cache && (not $ Map.member key (store cache)) = ([],cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) , size = size cache + 1 }) + | size cache < maxsize cache = ([],cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) }) + | size cache >= maxsize cache && (Map.member key (store cache)) = ([],cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) }) + | size cache >= maxsize cache = (freed, cache{ now = now cache + 1, times = IntMap.insert (now cache) key times', store = Map.insert key value store', size = size cache - decimation cache }) + where times' = foldr IntMap.delete (times cache) lowtimes + (lowtimes,lowtimekeys) = unzip . take (decimation cache) . IntMap.toAscList . times $ cache + store' = foldr Map.delete (store cache) lowtimekeys + freed = map (store cache Map.!) lowtimekeys + +free :: Ord k => Cache k a -> ((k,a),Cache k a) +free cache = ((minkey,minval),cache') + where minkey = IntMap.findMin (times cache) + minval = store cache Map.! minkey + cache' = cache{ now = now cache + 1, times = IntMap.deleteMin (times cache), store = Map.delete minkey (store cache), size = (size cache) } + +member :: Ord k => k -> Cache k a -> Bool +member key cache = Map.member key (store cache) + diff --git a/Graphics/Rendering/Hieroglyph/Cairo.hs b/Graphics/Rendering/Hieroglyph/Cairo.hs --- a/Graphics/Rendering/Hieroglyph/Cairo.hs +++ b/Graphics/Rendering/Hieroglyph/Cairo.hs @@ -19,6 +19,7 @@ -- module Graphics.Rendering.Hieroglyph.Cairo where +import qualified Graphics.UI.Hieroglyph.Cache as Cache import qualified Data.Set as Set import qualified Graphics.UI.Gtk.Cairo as Gtk import Graphics.UI.Gtk.Pango.Context @@ -29,7 +30,6 @@ import Control.Concurrent import Control.Monad.Trans (liftIO) import Graphics.Rendering.Hieroglyph.Primitives -import Graphics.Rendering.Hieroglyph.ImageCache import Graphics.Rendering.Hieroglyph.Visual import Graphics.UI.Gtk.Gdk.Pixbuf import qualified Graphics.UI.Gtk.Cairo as Cairo @@ -43,7 +43,9 @@ import Data.Colour.Names (black) import qualified Text.PrettyPrint as Pretty +type ImageCache = MVar (Cache.Cache Primitive Pixbuf) + toCairoAntialias AntialiasDefault = Cairo.AntialiasDefault toCairoAntialias AntialiasNone = Cairo.AntialiasNone toCairoAntialias AntialiasGray = Cairo.AntialiasGray @@ -208,50 +210,48 @@ renderToSurfaceWithImageCache context images surf frame = Cairo.renderWith surf (render context images frame) renderToSurface :: Visual t => PangoContext -> Cairo.Surface -> t -> IO () -renderToSurface c s o = do { i <- initImageCache; renderToSurfaceWithImageCache c i s o } +renderToSurface c s o = do { i <- newMVar (Cache.empty 1024 33) ;renderToSurfaceWithImageCache c i s o } -- | @renderframeToPNGWithImageCache filename xres yres frame@ renders a frame to an image file renderToPNGWithImageCache :: Visual t => PangoContext -> ImageCache -> FilePath -> Int -> Int -> t -> IO () renderToPNGWithImageCache c images filename xres yres frame = Cairo.withImageSurface Cairo.FormatARGB32 xres yres $ \s -> renderToSurfaceWithImageCache c images s frame >> Cairo.surfaceWriteToPNG s filename -renderToPNG f w h o = do { c <- Gtk.cairoCreateContext Nothing ; i <- initImageCache ; renderToPNGWithImageCache c i f w h o } +renderToPNG f w h o = do { c <- Gtk.cairoCreateContext Nothing ; i <- newMVar (Cache.empty 1024 33) ; renderToPNGWithImageCache c i f w h o } -- | @renderToPDFWithImageCache filename width height frame@ renders a frame to a PDF file. width and height are in points. renderToPDFWithImageCache :: Visual t => PangoContext -> ImageCache -> FilePath -> Double -> Double -> t -> IO () renderToPDFWithImageCache c images filename width height frame = Cairo.withPDFSurface filename width height $ \s -> renderToSurfaceWithImageCache c images s frame -renderToPDF f w h o = do { c <- Gtk.cairoCreateContext Nothing ; i <- initImageCache ; renderToPDFWithImageCache c i f w h o } +renderToPDF f w h o = do { c <- Gtk.cairoCreateContext Nothing ; i <- newMVar (Cache.empty 1024 33) ; renderToPDFWithImageCache c i f w h o } -- | @renderToPostscriptWithImageCache filename width height frame@ renders a frame to a Postscript file. width and height are in points. renderToPostscriptWithImageCache :: Visual t => PangoContext -> ImageCache -> FilePath -> Double -> Double -> t -> IO () renderToPostscriptWithImageCache c images filename width height frame = Cairo.withPSSurface filename width height $ \s -> renderToSurfaceWithImageCache c images s frame -renderToPostscript f w h o = do { c <- Gtk.cairoCreateContext Nothing ; i <- initImageCache ; renderToPostscriptWithImageCache c i f w h o } +renderToPostscript f w h o = do { c <- Gtk.cairoCreateContext Nothing ; i <- newMVar (Cache.empty 1024 33) ; renderToPostscriptWithImageCache c i f w h o } -- | @renderToSVGWithImageCache filename width height frame@ renders a frame to a SVG file. width and height are in points. renderToSVGWithImageCache :: Visual t => PangoContext -> ImageCache -> FilePath -> Double -> Double -> t -> IO () renderToSVGWithImageCache c images filename width height frame = Cairo.withSVGSurface filename width height $ \s -> renderToSurfaceWithImageCache c images s frame -renderToSVG f w h o = do { c <- Gtk.cairoCreateContext Nothing ; i <- initImageCache ; renderToSVGWithImageCache c i f w h o } +renderToSVG f w h o = do { c <- Gtk.cairoCreateContext Nothing ; i <- newMVar (Cache.empty 1024 33) ; renderToSVGWithImageCache c i f w h o } -- | @loadImage dictRef image@ pulls an image out of the cache's hat. loadImage :: ImageCache -> Primitive -> Cairo.Render (Pixbuf) loadImage dictRef im@(Image filename (Right (Rect x y w h)) aspect _ _) = do liftIO $ modifyMVar dictRef $ \dict -> - if (show im) `M.member` dict - then do value <- deRefWeak $ dict M.! (show im) + if im `Cache.member` dict + then do let (cache',value) = Cache.get im dict pbuf <- case value of Just pb -> return pb Nothing -> pixbufNewFromFileAtScale filename (round w) (round h) aspect - return (dict,pbuf) + return (cache',pbuf) else do pbuf <- pixbufNewFromFileAtScale filename (round w) (round h) aspect - wk <- mkWeakPtr pbuf Nothing - return ((M.insert (show im) wk dict), pbuf) + return ((Cache.put im pbuf dict), pbuf) loadImage dictRef im@(Image filename (Left (Point x y)) _ _ _) = do liftIO $ modifyMVar dictRef $ \dict -> - if (show im) `M.member` dict - then do value <- deRefWeak $ dict M.! (show im) + if im `Cache.member` dict + then do let (cache',value) = Cache.get im dict pbuf <- case value of Just pb -> return pb Nothing -> pixbufNewFromFile filename return (dict,pbuf) else do pbuf <- pixbufNewFromFile filename - wk <- mkWeakPtr pbuf Nothing - return ((M.insert (show im) wk dict), pbuf) + return ((Cache.put im pbuf dict), pbuf) diff --git a/Graphics/Rendering/Hieroglyph/ImageCache.hs b/Graphics/Rendering/Hieroglyph/ImageCache.hs deleted file mode 100644 --- a/Graphics/Rendering/Hieroglyph/ImageCache.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Graphics.Rendering.Hieroglyph.ImageCache where - -import Data.Map (Map,empty) -import Control.Concurrent -import System.Mem.Weak -import qualified Graphics.UI.Gtk as Gtk - -type ImageCache = MVar (Map String (Weak Gtk.Pixbuf)) - -initImageCache = newMVar empty diff --git a/Graphics/Rendering/Hieroglyph/Interactive.hs b/Graphics/Rendering/Hieroglyph/Interactive.hs deleted file mode 100644 --- a/Graphics/Rendering/Hieroglyph/Interactive.hs +++ /dev/null @@ -1,226 +0,0 @@ --- | An interactive scene graph library for Cairo --- --- [@Author@] Jeff Heard --- --- [@Copyright@] © 2008 Renaissance Computing Institute --- -module Graphics.Rendering.Hieroglyph.Interactive where - -import qualified Data.Set as Set -import Graphics.UI.Gtk.Pango.Context -import Graphics.Rendering.Hieroglyph.Primitives -import Graphics.Rendering.Hieroglyph.ImageCache -import Graphics.Rendering.Hieroglyph.Cairo -import Graphics.Rendering.Hieroglyph.Scaffolds.Interactive -import Graphics.Rendering.Hieroglyph.Visual -import qualified Graphics.UI.Gtk.Cairo as Gtk -import qualified Graphics.Rendering.Cairo as Cairo -import qualified Graphics.UI.Gtk as Gtk -import qualified Graphics.UI.Gtk.Cairo as Gtk -import qualified Graphics.UI.Gtk.Gdk.Events as Gtk -import Control.Parallel.Strategies - -import Data.List -import Data.Maybe -import Control.Monad -import Control.Concurrent.MVar - --- | Applies the current Interactive instance to a single scene element, returning an Object -applyDataToVisual :: (Interactive a, Visual b) => a -> (a -> b) -> b -applyDataToVisual vdata obj = obj vdata - --- | Render function. All Cairo is called through here. You do not need to call this in your own code. -renderer :: (Interactive a, Visual b) => PangoContext -> MVar [Primitive] -> MVar a -> (a -> b) -> IO () -renderer context extant_geometry state scene = do - geom <- takeMVar extant_geometry - st <- takeMVar state - let state' = interactionFold st geom - geom' = scene state' - dwin <- Gtk.widgetGetDrawWindow . fromJust . getDrawing $ st - Gtk.renderWithDrawable dwin (render context (fromJust (getImageCache st)) geom') - putMVar extant_geometry . sort . primitives $ geom' - putMVar state state' - - --- | Gets the keyboard state from Gtk and changes the Interactive. You do not need --- to call this in your own code -keyboardHandler :: Interactive a => MVar a -> Gtk.Event -> IO Bool -keyboardHandler uistate_mvar event = do - let k = case Gtk.eventKeyName event of - "Insert" -> Insert - "Delete" -> Delete - "Enter" -> Enter - "F1" -> PF1 - "F2" -> PF2 - "F3" -> PF3 - "F4" -> PF4 - "F5" -> PF5 - "F6" -> PF6 - "F7" -> PF7 - "F8" -> PF8 - "F9" -> PF9 - "F10" -> PF10 - "F11" -> PF11 - "F12" -> PF12 - "Home" -> Home - "End" -> End - "PageUp" -> PgUp - "PageDown" -> PgDown - [x] -> Character x - _ -> Character '\0' - modifyMVar_ uistate_mvar $ return . setKey k - withMVar uistate_mvar $ \s -> do - dwin <- Gtk.widgetGetDrawWindow . fromJust . getDrawing $ s - Gtk.drawWindowInvalidateRect dwin (Gtk.Rectangle 0 0 (round . getSizeX $ s) (round . getSizeY $ s)) False - return False - --- | Gets the mouse position and changes the Interactive to reflect it. YOu do not need this in your own code. -mouseMotionHandler :: Interactive a => MVar a -> Gtk.Event -> IO Bool -mouseMotionHandler uistate_mvar event = do - state <- takeMVar uistate_mvar - putMVar uistate_mvar - $ setMousePosition (Point (Gtk.eventX event) (Gtk.eventY event)) state - dwin <- Gtk.widgetGetDrawWindow . fromJust . getDrawing $ state - Gtk.drawWindowGetPointer dwin - Gtk.drawWindowInvalidateRect dwin (Gtk.Rectangle 0 0 (round . getSizeX $ state) (round . getSizeY $ state)) False - return False - -mouseReleaseHandler :: Interactive a => MVar a -> Gtk.Event -> IO Bool -mouseReleaseHandler uistate_mvar event = do - let x = Gtk.eventX event - y = Gtk.eventY event - button = Gtk.eventButton event - modifiers = Gtk.eventModifier event - shift = elem Gtk.Shift modifiers - alt = elem Gtk.Alt modifiers - ctrl = elem Gtk.Control modifiers - - modifyMVar_ uistate_mvar - $ return - . setMousePosition (Point x y) - . setKeyShift shift - . setKeyAlt alt - . setKeyCtrl ctrl - . (case button of - Gtk.LeftButton -> setMouseLeftButtonDown False - . setMouseWheel 0 - Gtk.RightButton -> setMouseRightButtonDown False - . setMouseWheel 0 - Gtk.MiddleButton -> setMouseRightButtonDown False - . setMouseWheel 0) - withMVar uistate_mvar $ \s -> do - dwin <- Gtk.widgetGetDrawWindow . fromJust . getDrawing $ s - Gtk.drawWindowInvalidateRect dwin (Gtk.Rectangle 0 0 (round . getSizeX $ s) (round . getSizeY $ s)) False - return True - --- | Gets the mouse button state and changes the Interactive to reflect it. You do not need this in your own code. -mouseButtonHandler :: Interactive a => MVar a -> Gtk.Event -> IO Bool -mouseButtonHandler uistate_mvar event = do - let x = Gtk.eventX event - y = Gtk.eventY event - button = Gtk.eventButton event - modifiers = Gtk.eventModifier event - shift = elem Gtk.Shift modifiers - alt = elem Gtk.Alt modifiers - ctrl = elem Gtk.Control modifiers - - modifyMVar_ uistate_mvar - $ return - . setMousePosition (Point x y) - . setKeyShift shift - . setKeyAlt alt - . setKeyCtrl ctrl - . (case button of - Gtk.LeftButton -> setMouseLeftButtonDown True - . setMouseRightButtonDown False - . setMouseMiddleButtonDown False - . setMouseWheel 0 - Gtk.RightButton -> setMouseLeftButtonDown False - . setMouseRightButtonDown True - . setMouseMiddleButtonDown False - . setMouseWheel 0 - Gtk.MiddleButton -> setMouseLeftButtonDown False - . setMouseRightButtonDown False - . setMouseRightButtonDown True - . setMouseWheel 0) - withMVar uistate_mvar $ \s -> do - dwin <- Gtk.widgetGetDrawWindow . fromJust . getDrawing $ s - Gtk.drawWindowInvalidateRect dwin (Gtk.Rectangle 0 0 (round . getSizeX $ s) (round . getSizeY $ s)) False - return True - --- | Window resize handler. Changes the Interactive to reflect the new sizing. You do not need this in your own code. -resize state event = do - let sizex = Gtk.eventWidth event - sizey = Gtk.eventHeight event - modifyMVar_ state $ return . setSizeX (fromIntegral sizex) . setSizeY (fromIntegral sizey) - withMVar state $ \s -> do - dwin <- Gtk.widgetGetDrawWindow . fromJust . getDrawing $ s - Gtk.drawWindowInvalidateRect dwin (Gtk.Rectangle 0 0 sizex sizey) False - return False - - --- | A lowish level funtion for creating a GUI. Does not set the size of the --- window or expose any windows. -guiInit :: (Interactive a, Visual b) - => MVar a -- ^ The current Interactive - -> (a-> b) -- ^ The scene to render - -> String -- ^ The name of the window - -> Bool -- ^ Whether or not to make this GUI motion sensitive - -> IO Gtk.DrawingArea -- ^ Returns the window that was created -guiInit state scene name motionSensitive = do - Gtk.unsafeInitGUIForThreadedRTS - - canvas <- Gtk.drawingAreaNew - imgcache <- initImageCache - modifyMVar_ state $ return . setDrawing (Just . Gtk.castToWidget $ canvas) . setImageCache (Just imgcache) - primitiveData <- newMVar [] - context <- Gtk.cairoCreateContext Nothing - - Gtk.onExpose canvas $ \evt -> renderer context primitiveData state scene >> return True - Gtk.onConfigure canvas $ resize state - Gtk.onButtonPress canvas $ mouseButtonHandler state - Gtk.onButtonRelease canvas $ mouseReleaseHandler state - Gtk.onKeyPress canvas $ keyboardHandler state - when motionSensitive $ (Gtk.onMotionNotify canvas True $ mouseMotionHandler state) >> return () - return canvas - --- | A higher level function for creating a GUI. Does not set the size of the --- window or expose any windows, but does kill the app if this window is --- closed -guiConstruct :: (Interactive a, Visual b) - => a -- ^ The default Interactive - -> ( a -> b ) -- ^ The scene to render - -> String -- ^ The name of the scene - -> Bool -- ^ Whether or not this GUI is motion sensitive - -> IO Gtk.Window -guiConstruct state scene name motionSensitive = do - mvar <- newMVar state - canvas <- guiInit mvar scene name motionSensitive - window <- Gtk.windowNew - Gtk.windowSetTitle window name - Gtk.containerAdd window canvas - Gtk.onDestroy window Gtk.mainQuit - return window - --- | A high level function for creating a GUI. Just specify a default --- state, the name of the scene, and the scene, and you get an 800 by --- 600 motion insensitive GUI. -simpleGui :: (Interactive a, Visual b) - => a - -> (a -> b) - -> String - -> IO () -simpleGui state scene name = do - win <- guiConstruct state scene name False - Gtk.windowSetDefaultSize win 800 600 - Gtk.widgetShowAll win - Gtk.mainGUI - --- | A high level function for creating a GUI. Just specify the default --- state, the name of the scene, and the scene, and you get an 800 by --- 600 motion sensitive GUI -simpleMotionSensitiveGui state scene name = do - win <- guiConstruct state scene name True - Gtk.windowSetDefaultSize win 800 600 - Gtk.widgetShowAll win - Gtk.mainGUI diff --git a/Graphics/Rendering/Hieroglyph/OpenGL.hs b/Graphics/Rendering/Hieroglyph/OpenGL.hs --- a/Graphics/Rendering/Hieroglyph/OpenGL.hs +++ b/Graphics/Rendering/Hieroglyph/OpenGL.hs @@ -66,7 +66,7 @@ reverseMouseCoords b x y = do let renderDataE = fromJust $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" b - (_,sy) <- Gtk.drawingAreaGetSize . Gtk.castToDrawingArea . drawarea . head . Buster.eventdata $ renderDataE + (_,sy) <- Gtk.widgetGetSize . Gtk.castToWidget . drawarea . (\(Buster.EOther a) -> a) . head . Buster.eventdata $ renderDataE return (Point x (fromIntegral sy-y)) arcFn _ _ _ [] = [] @@ -410,32 +410,7 @@ --optimize !ptr i (CompiledImage _ attrs vs c b w h t iid) = --optimize !ptr i (Optimized attrs vbo tbo t iid) = -{- - { afillrule :: FillRule -- ^ The pattern fill rule - , afillRGBA :: AlphaColour Double -- ^ The components of the stroke color in the range [0..1] - , adash :: Maybe ([Double],Double) -- ^ The shape of the line dashing, if any - , astrokeRGBA :: AlphaColour Double -- ^ The components of the stroke color in the range [0..1] - , aantialias :: Antialias -- ^ The way things are antialiased - , alinecap :: LineCap -- ^ The way lines are capped - , alinejoin :: LineJoin -- ^ The way lines are joined - , alinewidth :: Double -- ^ The width of a line in points - , amiterlimit :: Double -- ^ The miter limit of lines. See Cairo's documentation - , atolerance :: Double -- ^ The trapezoidal tolerance. See Cairo's documentation - , aoperator :: Operator -- ^ The transfer operator. See Cairo's documentation for more - , atranslatex :: Double -- ^ The current translation x component - , atranslatey :: Double -- ^ The current translation y component - , ascalex :: Double -- ^ The current scale x component - , ascaley :: Double -- ^ The current scale y component - , arotation :: Double -- ^ The rotation in degrees that this primitive is seen in - , afilled :: Bool -- ^ Whether or not this primitive is filled in - , aoutlined :: Bool -- ^ Whether or not this primitive is outlined - , aclipped :: Bool -- ^ Whether or not this primitive is part of the clipping plane - , layer :: Int -- ^ This sorts out which primitives are located on top of each other. Do not set this yourself. Use Graphics.Rendering.Hieroglyph.Visual.over - , bbox :: Rect -- ^ The clockwise rotation in radians. - , aname :: Maybe String -- ^ The name of the object - , lod :: Int -- ^ The level of detail that this primitive is at. Use Graphics.Rendering.Hieroglyph.Visual.moreSpecific - } --} + loadAttrs attrs = GL.preservingMatrix $ do GL.lineWidth $= (realToFrac . alinewidth $ attrs) GL.matrixMode $= GL.Modelview 0 @@ -454,21 +429,9 @@ -- TODO support dash/stipple -- TODO support pattern fill rule --- the idea here is that we should: --- * initialize the GL subsystem --- * allocate some number of textures --- * allocate some buffer objects for tex coords and vertices --- * add any other state variables we want to check on to save time. --- * add lookup tables for geometry. --- * add weak table for optimized geometry. +-- | Widget for initializing the bus +initializeBus :: String -> Int -> Int -> Buster.Widget [Buster.EData HieroglyphGLRuntime] initializeBus name w h bus = do --- b <- takeMVar bus --- let numTexturesE = Buster.topEvent . Buster.eventsFor (Just "Environment") Nothing (Just "numTextures") $ b --- numBufferObjectsE = Buster.topEvent . Buster.eventsFor (Just "Environment") Nothing (Just "numBufferObjects") $ b --- Buster.EInt numTextures = head . Buster.eventdata $ numTexturesE --- Buster.EInt numBufferObjects = head . Buster.eventdata $ numBufferObjectsE --- putMVar bus b - let numTextures = 400 numBufferObjects = 1 Gtk.unsafeInitGUIForThreadedRTS @@ -499,24 +462,9 @@ Gtk.onExpose area (\_ -> renderOnExpose bus >> return True) return () - -- print "bus initialized" --- a behaviour to actually render hieroglyph data. --- On a separate thread and using STM: --- * get the lookup tables for geometry and optimized geometry. --- * merge the two by checking the guids of the current geometry against the optimized geometry and the non-optimized geometry --- * compile any uncompiled geometry --- * load unloaded textures --- * queue geometry to optimize --- * clear the buffers --- * setup GL state machine for a fresh render. --- * setup the viewport --- * setup the frustum --- * render the buffer --- * optimize any queued optimizable geometry --- * add optimized geometry to the weak table --- * wash hands, rinse, repeat. - +-- | a behaviour to render hieroglyph data to the selection buffer when it sees a (Hieroglyph,Hieroglyph,PleaseSelect) event. +-- Produces (Selection,Hieroglyph,@objectname@) events. selectionBehaviour :: Buster.Behaviour [Buster.EData HieroglyphGLRuntime] selectionBehaviour bus = case selectionRequested of @@ -544,7 +492,8 @@ drawingEs = Set.toList $ Buster.eventsByGroup "Visible" bus selectionRequested = Buster.eventByQName "Hieroglyph" "Hieroglyph" "PleaseSelect" bus - +-- | make Hieroglyph render on the main window exposure +renderOnExpose :: Buster.Widget [Buster.EData HieroglyphGLRuntime] renderOnExpose busV = do bus <- takeMVar busV putMVar busV bus @@ -565,6 +514,7 @@ let bus' = Buster.addEvent revent' bus putMVar busV bus' +-- | Make Hieroglyph send out expose events when it sees a (Hieroglyph,Hieroglyph,Rerender) event. renderBehaviour bus = Buster.consumeFullyQualifiedEventWith bus "Hieroglyph" "Hieroglyph" "Rerender" $ \event -> do let Buster.EOther renderdata = head . Buster.eventdata . fromJust $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" bus (w,h) <- Gtk.widgetGetSize (window renderdata) @@ -572,11 +522,8 @@ return [] render runtime@(HgGL _ _ _ _ win _ _ _) geo = Gtk.withGLDrawingArea win $ \drawable -> do - -- print "rendering" GL.drawBuffer $= GL.BackBuffers (GL.Position px py, GL.Size sx sy ) <- GL.get GL.viewport - -- print (px,py) - -- print (sx,sy) GL.matrixMode $= GL.Projection GL.loadIdentity GL.ortho2D 0 (fromIntegral sx) 0 (fromIntegral sy) @@ -587,19 +534,15 @@ GL.lineSmooth $= GL.Enabled GL.polygonSmooth $= GL.Enabled r' <- renderObjects (sort geo) runtime - -- print "finished rednering objects" Gtk.glDrawableSwapBuffers drawable - -- print "swapped buffers" return r' -renderObjects (o:os) !r = {- print o >> -} renderObj o r >>= renderObjects os +renderObjects (o:os) !r = renderObj o r >>= renderObjects os renderObjects [] r = return r renderObj :: Primitive -> HieroglyphGLRuntime -> IO HieroglyphGLRuntime renderObj obj runtime = do - -- print (aname . attribs $ obj) (runtime',cg0) <- compile runtime obj - -- print "compiled" renderCompiledGeometry cg0 return runtime'{ compiledgeometry = Map.insert (uid cg0) cg0 . compiledgeometry $ runtime' , namemap=Map.insert (uid cg0) @@ -627,8 +570,9 @@ A.readArray pixels sample >>= pokeByteOff ptr sample return (w0,h0,w,h,channels,buf) - -mouseSelectionBehaviour bus = Buster.pollFullyQualifiedEventWith bus "Mouse" "Hierolgyph.KeyboardMouseWidget" "SingleClick" $ \event -> do +-- | Select based on mouse clicks +mouseSelectionBehaviour :: Buster.Behaviour [Buster.EData HieroglyphGLRuntime] +mouseSelectionBehaviour bus = Buster.pollFullyQualifiedEventWith bus "Mouse" "Hieroglyph.KeyboardMouseWidget" "SingleClick" $ \event -> do let (Buster.EAssocL alist) = head . Buster.eventdata $ event (Buster.EDoubleL (x:y:_)) = fromJust $ "coords" `lookup` alist Buster.listM $ Buster.produce "Hieroglyph" "Hieroglyph" "PleaseSelect" Buster.once [Buster.EDouble x, Buster.EDouble y] diff --git a/Graphics/Rendering/Hieroglyph/Primitives.hs b/Graphics/Rendering/Hieroglyph/Primitives.hs --- a/Graphics/Rendering/Hieroglyph/Primitives.hs +++ b/Graphics/Rendering/Hieroglyph/Primitives.hs @@ -48,7 +48,12 @@ -- | A 2D point data Point = Point Double Double deriving (Show, Read, Eq, Ord) +-- | Translate a point horizontally +xplus :: Double -> Point -> Point xplus x (Point a b) = Point (x+a) b + +-- | Translate a point vertically +yplus :: Double -> Point -> Point yplus y (Point a b) = Point a (b+y) pmap f (Point a b) = Point (f a) (f b) @@ -67,16 +72,24 @@ (/) = comb (/) fromRational a = Point (fromRational a) (fromRational a) +-- | Find the distance between two points +dist :: Point -> Point -> Double dist (Point x0 y0) (Point x1 y1) = sqrt $ (x1-x0)**2 + (y1-y0)**2 +-- | Find the average of a bunch of points +centroid :: [Point] -> Point centroid ps = centroid' (Point 0 0) 0 ps centroid' !s !n (p:ps) = centroid' (s+p) (n+1) ps centroid' s n [] = s/n +-- | A rectangle for dimensions data Rect = Plane | Singularity | Rect { x1 :: Double, y1 :: Double, x2 :: Double, y2 :: Double } deriving (Show, Read, Eq) +-- | A line segment data LineSegment = Line Point | Spline Point Point Point | EndPoint Point deriving (Show,Read,Eq) +-- | A convenience function for getting points out of line segments in a path +ls2pt :: LineSegment -> Point ls2pt (Line x) = x ls2pt (Spline _ _ x) = x ls2pt (EndPoint x) = x @@ -114,6 +127,7 @@ . zipWith compare [xa1,xa2,ya1,ya2] $ [xb1,xb2,yb1,yb2] +-- | Test to see if two rectangles overlap overlaps :: Rect -> Rect -> Bool overlaps _ Plane = True overlaps Plane _ = True @@ -352,18 +366,46 @@ , updated = True } --- | following combinators added to Text.PrettyPrint +-- | See pango span tag +tspan :: String -> Doc -> Doc tspan a s = text " text a <> char '>' <> s <> text "" mark m d = char '<' <> text m <> char '>' <> d <> text " text m <> char '>' + +-- | See pango layout bold tag +bold :: Doc -> Doc bold = mark "b" + +-- | See pango layout bigger tag +bigger :: Doc -> Doc bigger = mark "big" + +-- | See pango layout italic tag +italic :: Doc -> Doc italic = mark "i" + +-- | See pango layout strikethrough tag +strikethrough :: Doc -> Doc strikethrough = mark "s" + +-- | See pango layout superscript tag +subscript :: Doc -> Doc subscript = mark "sub" + +-- | See pango layout superscript tag +superscript :: Doc -> Doc superscript = mark "sup" + +-- | See pango layout smaller tag +smaller :: Doc -> Doc smaller = mark "small" + +-- | See pango layout monospace tag +monospace :: Doc -> Doc monospace = mark "tt" + +-- | See pango layout underline tag +underline :: Doc -> Doc underline = mark "u" -- end Text.PrettyPrint combinators. @@ -371,6 +413,7 @@ nguid :: () -> Int -- GAAAH!!! Just name your objects, folks, please. nguid () = unsafePerformIO $ getStdRandom (randomR (0,2147483648)) +sign :: Primitive -> Primitive sign x = x{ sig = fromMaybe (nguid ()) (fromIntegral . Data.HashTable.hashString <$> (aname . attribs $ x)) } -- | the origin point diff --git a/Graphics/Rendering/Hieroglyph/Scaffolds/Interactive.hs b/Graphics/Rendering/Hieroglyph/Scaffolds/Interactive.hs deleted file mode 100644 --- a/Graphics/Rendering/Hieroglyph/Scaffolds/Interactive.hs +++ /dev/null @@ -1,186 +0,0 @@ --- | If the items in the UIState module are the only state you need in your --- program, then it is sufficient to import this module and start with the --- defaultBasicState. --- --- [@Author@] Jeff Heard --- --- [@Copyright@] © 2008 Renaissance Computing Institute --- -module Graphics.Rendering.Hieroglyph.Scaffolds.Interactive where - -import Graphics.Rendering.Hieroglyph.Primitives -import Graphics.Rendering.Hieroglyph.ImageCache -import Graphics.Rendering.Hieroglyph.Visual -import qualified Graphics.UI.Gtk as Gtk -import Control.Concurrent -import Data.Map (Map,empty) -import System.Mem.Weak - - --- | A keystroke -data Key = - Character Char - | Enter - | Tab - | BackSpace - | Insert - | Delete - | Home - | End - | PgUp - | PgDown - | PF1 | PF2 | PF3 | PF4 | PF5 | PF6 | PF7 | PF8 | PF9 | PF10 | PF11 | PF12 - --- | All that you need to provide interactivity -data Scaffolding = Scaffolding - { mousePosition :: Point - , mouseLeftButtonDown :: Bool - , mouseRightButtonDown :: Bool - , mouseMiddleButtonDown :: Bool - , mouseWheel :: Int - , keyCtrl :: Bool - , keyShift :: Bool - , keyAlt :: Bool - , key :: Key - , drawing :: Maybe Gtk.Widget - , sizeX :: Double - , sizeY :: Double - , imageCache :: Maybe ImageCache } - -instance Interactive Scaffolding where - getInteractiveScaffolding = id - setInteractiveScaffolding a b = b - interactionFold a b = a - --- | Implement this class to make your application interactive -class Interactive a where - getInteractiveScaffolding :: a -> Scaffolding -- ^ get the interactive Scaffolding record from your data - setInteractiveScaffolding :: a -> Scaffolding -> a -- ^ set the Interactive Scaffolding record in your data - -- | Interaction can be thought of as a foldr on an infinite list of data. - -- The intent of implementing this function is that the implementer will - -- fold the given event data (in the Scaffolding instance) with the data - -- being visualized and the geometry that goes with the event data to - -- produce a new set of data to visualize. - interactionFold :: a -> [Primitive] -> a - --- | The initial Scaffolding record. Start with this. -scaffold :: Scaffolding -scaffold = Scaffolding (Point 0 0) False False False 0 False False False (Character '\0') Nothing 800 600 Nothing - --- | Get the mouse position in window coordinates -getMousePosition :: Interactive a => a -> Point -getMousePosition = mousePosition . getInteractiveScaffolding - --- | Get the left button state -getMouseLeftButtonDown :: Interactive a => a -> Bool -getMouseLeftButtonDown = mouseLeftButtonDown . getInteractiveScaffolding - --- | Get the right button state -getMouseRightButtonDown :: Interactive a => a -> Bool -getMouseRightButtonDown = mouseRightButtonDown . getInteractiveScaffolding - --- | Get the middle button state -getMouseMiddleButtonDown :: Interactive a => a -> Bool -getMouseMiddleButtonDown = mouseMiddleButtonDown . getInteractiveScaffolding - --- | Get the number of clicks up or down the mouse button has gone -getMouseWheel :: Interactive a => a -> Int -getMouseWheel = mouseWheel . getInteractiveScaffolding - --- | Get the ctrl modifier state -getKeyCtrl :: Interactive a => a -> Bool -getKeyCtrl = keyCtrl . getInteractiveScaffolding - --- | Get the shift modifier state -getKeyShift :: Interactive a => a -> Bool -getKeyShift = keyShift . getInteractiveScaffolding - --- | Get the shift modifier state -getKeyAlt :: Interactive a => a -> Bool -getKeyAlt = keyAlt . getInteractiveScaffolding - --- | Get the key that was pressed -getKey :: Interactive a => a -> Key -getKey = key . getInteractiveScaffolding - --- | Get the drawing window. Not usually needed by the user, as there's not much you can do with it. -getDrawing :: Interactive a => a -> Maybe Gtk.Widget -getDrawing = drawing . getInteractiveScaffolding - --- | Get the width of the drawing window -getSizeX :: Interactive a => a -> Double -getSizeX = sizeX . getInteractiveScaffolding - --- | Get the height of the drawing window -getSizeY :: Interactive a => a -> Double -getSizeY = sizeY . getInteractiveScaffolding - --- | Get the image cache -getImageCache :: Interactive a => a -> Maybe ImageCache -getImageCache = imageCache . getInteractiveScaffolding - -setMousePosition :: Interactive a => Point -> a -> a -setMousePosition p v = setInteractiveScaffolding v s' - where s = getInteractiveScaffolding v - s' = s{ mousePosition = p } - -setMouseLeftButtonDown :: Interactive a => Bool -> a -> a -setMouseLeftButtonDown p v = setInteractiveScaffolding v s' - where s = getInteractiveScaffolding v - s' = s{ mouseLeftButtonDown = p } - -setMouseRightButtonDown :: Interactive a => Bool -> a -> a -setMouseRightButtonDown p v = setInteractiveScaffolding v s' - where s = getInteractiveScaffolding v - s' = s{ mouseRightButtonDown = p } - -setMouseMiddleButtonDown :: Interactive a => Bool -> a -> a -setMouseMiddleButtonDown p v = setInteractiveScaffolding v s' - where s = getInteractiveScaffolding v - s' = s{ mouseMiddleButtonDown = p } - -setMouseWheel :: Interactive a => Int -> a -> a -setMouseWheel p v = setInteractiveScaffolding v s' - where s = getInteractiveScaffolding v - s' = s{ mouseWheel = p } - -setKeyCtrl :: Interactive a => Bool -> a -> a -setKeyCtrl p v = setInteractiveScaffolding v s' - where s = getInteractiveScaffolding v - s' = s{ keyCtrl = p } - -setKeyShift :: Interactive a => Bool -> a -> a -setKeyShift p v = setInteractiveScaffolding v s' - where s = getInteractiveScaffolding v - s' = s{ keyShift = p } - -setKeyAlt :: Interactive a => Bool -> a -> a -setKeyAlt p v = setInteractiveScaffolding v s' - where s = getInteractiveScaffolding v - s' = s{ keyAlt = p } - -setKey :: Interactive a => Key -> a -> a -setKey p v = setInteractiveScaffolding v s' - where s = getInteractiveScaffolding v - s' = s{ key = p } - -setDrawing :: Interactive a => Maybe Gtk.Widget -> a -> a -setDrawing p v = setInteractiveScaffolding v s' - where s = getInteractiveScaffolding v - s' = s{ drawing = p } - -setSizeX :: Interactive a => Double -> a -> a -setSizeX p v = setInteractiveScaffolding v s' - where s = getInteractiveScaffolding v - s' = s{ sizeX = p } - -setSizeY :: Interactive a => Double -> a -> a -setSizeY p v = setInteractiveScaffolding v s' - where s = getInteractiveScaffolding v - s' = s{ sizeY = p } - -setImageCache :: Interactive a => Maybe ImageCache -> a -> a -setImageCache p v = setInteractiveScaffolding v s' - where s = getInteractiveScaffolding v - s' = s{ imageCache = p } - diff --git a/Graphics/Rendering/Hieroglyph/Visual.hs b/Graphics/Rendering/Hieroglyph/Visual.hs --- a/Graphics/Rendering/Hieroglyph/Visual.hs +++ b/Graphics/Rendering/Hieroglyph/Visual.hs @@ -6,6 +6,7 @@ -- forall a, Visual b : a -> Visual b module Graphics.Rendering.Hieroglyph.Visual where +import Data.Colour import Data.Monoid import qualified Data.Map as M import qualified Data.IntMap as IM @@ -55,6 +56,7 @@ occludes this that = ((\p -> p{ layer = maxlev+1 }) <%> primitives this) ++ (primitives that) where maxlev = maximum . map (layer . attribs) . primitives $ that +-- | Declare that a Visual doesn't occlude another Visual beside :: (Visual t, Visual u) => t -> u -> BaseVisual beside this that = ((\p -> p{ layer = maxlev }) <%> primitives this) ++ (primitives that) where maxlev = maximum . map (layer . attribs) . primitives $ that @@ -62,8 +64,17 @@ pure x = [x] f <%> x = map (\a -> a{ attribs = (f . attribs $ a)}) x + +-- | The beside operator. Same as @beside@ +(#+#) :: BaseVisual -> BaseVisual -> BaseVisual (#+#) = (++) + +-- | The occludes operator. The left occludes the right. +(#/#) :: BaseVisual -> BaseVisual -> BaseVisual (#/#) = occludes + +-- | The under operator. The right occludes the left. +(#\#) :: BaseVisual -> BaseVisual -> BaseVisual (#\#) = flip occludes infixr 9 `occludes` @@ -72,25 +83,86 @@ infixr 9 #/# infixr 9 #\# +-- | Set the fill rule for this visual (Cairo) +fillrule :: Visual a => FillRule -> a -> BaseVisual fillrule x os = (\o -> o{ afillrule = x }) <%> primitives os + +-- | Set the fill colour +fillcolour :: Visual a => AlphaColour Double -> a -> BaseVisual fillcolour x os = (\o -> o{ afillRGBA = x }) <%> primitives os + +-- | Set the stipple pattern for lines (Cairo) +dash :: Visual a => Maybe ([Double],Double) -> a -> BaseVisual dash x os = (\o -> o{adash = x}) <%> primitives os + +-- | Set the stroke colour +strokecolour :: Visual a => AlphaColour Double -> a -> BaseVisual strokecolour x os = (\o -> o{ astrokeRGBA = x }) <%> primitives os + +-- | Set the line cap shape (Cairo) +linecap :: Visual a => LineCap -> a -> BaseVisual linecap x os = (\o -> o{alinecap = x}) <%> primitives os + +-- | Set the miter limit (Cairo) +miterlimit :: Visual a => Double -> a -> BaseVisual miterlimit x os = (\o -> o{amiterlimit = x}) <%> primitives os + +-- | Set the polygon tolerance (Cairo) +tolerance :: Visual a => Double -> a -> BaseVisual tolerance x os = (\o -> o{atolerance = x}) <%> primitives os + +-- | Set the scale of the Visual +scalex :: Visual a => Double -> a -> BaseVisual scalex x os = (\o -> o{ascalex = x}) <%> primitives os + +-- | Set the scale of the Visual +scaley :: Visual a => Double -> a -> BaseVisual scaley x os = (\o -> o{ascaley = x}) <%> primitives os + +-- | Adjust the scale of the visual +scale :: Visual a => Double -> Double -> a -> BaseVisual scale x y os = (\o -> o{ascalex = x * ascalex o, ascaley = y * ascaley o})<%> primitives os + +-- | Set the translation of the visual +settranslatex :: Visual a => Double -> a -> BaseVisual settranslatex x os = (\o -> o{atranslatex = x })<%> primitives os + +-- | Set the translation of the visual +settranslatey :: Visual a => Double -> a -> BaseVisual settranslatey y os = (\o -> o{atranslatey = y })<%> primitives os + +-- | Adjust the translation of the visual +translate :: Visual a => Double -> Double -> a -> BaseVisual translate x y os = (\o -> o{atranslatex = x + atranslatex o, atranslatey = y + atranslatey o})<%> primitives os + +-- | Set the rotation of the visual +rotation :: Visual a => Double -> a -> BaseVisual rotation x os = (\o -> o{arotation = x}) <%> primitives os + +-- | Set whether or not objects in the visual are filled +filled :: Visual a => Bool -> a -> BaseVisual filled x os = (\o -> o{afilled = x}) <%> primitives os + +-- | Set whether or not objects in the visual are outlined +outlined :: Visual a => Bool -> a -> BaseVisual outlined x os = (\o -> o{aoutlined = x}) <%> primitives os + +-- | Set whether or not the objects in the visual are part of the clipping plane (Cairo) +clipped :: Visual a => Bool -> a -> BaseVisual clipped x os = (\o -> o{aclipped = x}) <%> primitives os + +-- | Set the name of the objects for selection purposes +name :: Visual a => String -> a -> BaseVisual name x os = (\o -> o{aname = Just x}) <%> primitives os + +-- | Set whether the objects have already been cached. +cached :: Visual a => a -> BaseVisual cached os = (\o -> o{updated = False}) <%> primitives os + +-- | Set whether the objects have been updated. +fresh :: Visual a => a -> BaseVisual fresh os = (\o -> o{updated = True}) <%> primitives os + +linewidth :: Visual a => Double -> a -> BaseVisual linewidth x os = (\o -> o{alinewidth = x}) <%> primitives os diff --git a/Graphics/UI/Hieroglyph/Cache.hs b/Graphics/UI/Hieroglyph/Cache.hs deleted file mode 100644 --- a/Graphics/UI/Hieroglyph/Cache.hs +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Graphics.UI.Hieroglyph.Cache --- Copyright : --- License : BSD3 --- --- Maintainer : J.R. Heard --- Stability : --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module Graphics.UI.Hieroglyph.Cache where - -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap - -data Cache k a = Cache { store :: Map.Map k a, times :: IntMap.IntMap k, now :: Int, maxsize :: Int, size :: Int, decimation :: Int } - -empty mxsz dec = Cache Map.empty IntMap.empty 0 mxsz 0 dec - -get :: Ord k => k -> Cache k a -> (Cache k a,Maybe a) -get key cache = (cache',value) - where value = Map.lookup key (store cache) - cache' = maybe (cache{ now = now cache + 1 }) (\_ -> cache{ now = now cache + 1, times = IntMap.insert (now cache) key (times cache) }) value - -put :: Ord k => k -> a -> Cache k a -> Cache k a -put key value cache - | size cache < maxsize cache && (not $ Map.member key (store cache)) = cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) , size = size cache + 1 } - | size cache < maxsize cache = cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) } - | size cache >= maxsize cache && (Map.member key (store cache)) = cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) } - | size cache >= maxsize cache = cache{ now = now cache + 1, times = IntMap.insert (now cache) key times', store = Map.insert key value store', size = size cache - decimation cache } - where times' = foldr IntMap.delete (times cache) lowtimes - (lowtimes,lowtimekeys) = unzip . take (decimation cache) . IntMap.toAscList . times $ cache - store' = foldr Map.delete (store cache) lowtimekeys - -put' :: Ord k => k -> a -> Cache k a -> ([a], Cache k a) -put' key value cache - | size cache < maxsize cache && (not $ Map.member key (store cache)) = ([],cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) , size = size cache + 1 }) - | size cache < maxsize cache = ([],cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) }) - | size cache >= maxsize cache && (Map.member key (store cache)) = ([],cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) }) - | size cache >= maxsize cache = (freed, cache{ now = now cache + 1, times = IntMap.insert (now cache) key times', store = Map.insert key value store', size = size cache - decimation cache }) - where times' = foldr IntMap.delete (times cache) lowtimes - (lowtimes,lowtimekeys) = unzip . take (decimation cache) . IntMap.toAscList . times $ cache - store' = foldr Map.delete (store cache) lowtimekeys - freed = map (store cache Map.!) lowtimekeys - -free :: Ord k => Cache k a -> ((k,a),Cache k a) -free cache = ((minkey,minval),cache') - where minkey = IntMap.findMin (times cache) - minval = store cache Map.! minkey - cache' = cache{ now = now cache + 1, times = IntMap.deleteMin (times cache), store = Map.delete minkey (store cache), size = (size cache) } - -member :: Ord k => k -> Cache k a -> Bool -member key cache = Map.member key (store cache) - diff --git a/Hieroglyph.cabal b/Hieroglyph.cabal --- a/Hieroglyph.cabal +++ b/Hieroglyph.cabal @@ -1,13 +1,13 @@ name: Hieroglyph -version: 2.22 +version: 2.23 cabal-version: >=1.2 build-type: Simple license: BSD3 license-file: LICENSE copyright: maintainer: J.R. Heard -build-depends: IfElse -any, OpenGL -any, array -any, - base -any, buster >=2.0, bytestring -any, cairo -any, colour -any, +build-depends: IfElse -any, OpenGL -any, array -any, base -any, + buster >=2.0, bytestring -any, cairo -any, colour -any, containers -any, gtk -any, gtkglext -any, mtl -any, parallel -any, pretty -any, random -any stability: @@ -24,14 +24,12 @@ data-dir: "" extra-source-files: extra-tmp-files: -exposed-modules: Graphics.UI.Hieroglyph.Cache - Graphics.Rendering.Hieroglyph Graphics.Rendering.Hieroglyph.Cairo +exposed-modules: Graphics.Rendering.Hieroglyph + Graphics.Rendering.Hieroglyph.Cairo Graphics.Rendering.Hieroglyph.OpenGL - Graphics.Rendering.Hieroglyph.ImageCache - Graphics.Rendering.Hieroglyph.Interactive + Graphics.Rendering.Hieroglyph.Cache Graphics.Rendering.Hieroglyph.Primitives Graphics.Rendering.Hieroglyph.Visual - Graphics.Rendering.Hieroglyph.Scaffolds.Interactive exposed: True buildable: True build-tools: