Hieroglyph 3.85 → 3.88
raw patch · 11 files changed
+336/−22 lines, 11 filesdep +GLUTdep −buster-gtk
Dependencies added: GLUT
Dependencies removed: buster-gtk
Files
- App/Widgets/MouseKeyboard.hs +7/−1
- App/Widgets/MouseKeyboardGLUT.hs +64/−0
- Graphics/Rendering/Hieroglyph/Cairo.hs +5/−1
- Graphics/Rendering/Hieroglyph/GLUT.hs +173/−0
- Graphics/Rendering/Hieroglyph/OpenGL.hs +1/−2
- Graphics/Rendering/Hieroglyph/OpenGL/Compile.hs +1/−1
- Graphics/Rendering/Hieroglyph/OpenGL/Data.hs +15/−1
- Graphics/Rendering/Hieroglyph/OpenGL/Render.hs +22/−2
- Graphics/Rendering/Hieroglyph/Primitives.hs +7/−1
- Graphics/Rendering/Hieroglyph/Stylesheets.hs +34/−9
- Hieroglyph.cabal +7/−4
App/Widgets/MouseKeyboard.hs view
@@ -1,4 +1,10 @@--- | Gtk mouse keyboard widget.+-- | +-- +-- Module : App.Widgets.MouseKeyboard+-- Copyright : (c) Renaissance Computing Institute 2009+-- License : BSD3+--+-- Gtk mouse keyboard widget. -- -- For a mouse button press or release, add events named SingleClick or ClickRelease respectively to the bus. -- For this widget, all events have source \"KeyboardMouseWidget\", and group \"Mouse\"
+ App/Widgets/MouseKeyboardGLUT.hs view
@@ -0,0 +1,64 @@+-- | +-- +-- Module : App.Widgets.MouseKeyboard+-- Copyright : (c) Renaissance Computing Institute 2009+-- License : BSD3+--+-- Gtk mouse keyboard widget.+--+-- For a mouse button press or release, add events named SingleClick or ClickRelease respectively to the bus.+-- For this widget, all events have source \"KeyboardMouseWidget\", and group \"Mouse\"+-- Additionally, the data attached to the event follows the form [EString SingleClick|ClickRelease, EDouble x, EDouble y, EStringL [Gtk modifier names]]+--+-- For a keyboard press or release, add events named KeyDown or KeyUp respectively to the bus.+-- All keyboard events have group ''Keyboard'' and source ''WidgetName.KeyboardMouseWidget''+-- Additionally, the data attached to a keyboard event follows the form [EString keyName | EChar keyChar, EStringL [Gtk modifier names]]+--+-- For a tablet proximity, add events named \"Proximity\" with source WidgetName.KeyboardMouseWidget, group \"Mouse\" and with attached data+-- [EBool True] for the tablet is in proximity and [EBool False] for the tablet is out of proximity.+--+-- For mouse motion, add events named \"Position\" with group \"Mouse\" and attached data [EDouble x, EDouble y, EStringL modifiers]+--+module App.Widgets.MouseKeyboardGLUT where++import Control.Applicative+import Control.Concurrent+import Data.Maybe+import qualified Graphics.UI.GLUT as GLUT+import qualified Graphics.Rendering.OpenGL as GL+import Graphics.Rendering.OpenGL (($=))+import App.EventBus+import Graphics.Rendering.Hieroglyph.OpenGL.Data+++keyboardMouseHandler wname b key keystate modifiers position = if isKey + then produce' "Mouse" (wname++".KeyboardMouseWidget") mousebuttonstate once (newHieroglyphData $ AttributedCoords (fromIntegral x) (fromIntegral y) (button : mods)) b+ else produce' "Keyboard" (wname++".KeyboardMouseWidget") keyboardkeystate once (newHieroglyphData $ AttributedCoords 0 0 (button : mods)) b+ where mousebuttonstate = if keystate == GLUT.Up then "ReleaseClick" else "SingleClick"+ keyboardkeystate = if keystate == GLUT.Up then "KeyUp" else "KeyDown" + button = case key of + GLUT.MouseButton x -> show x+ GLUT.Char c -> c:[]+ GLUT.SpecialKey k -> show k+ isKey = case key of + GLUT.MouseButton x -> False+ GLUT.Char c -> True+ GLUT.SpecialKey _ -> True+ mods = catMaybes [if GLUT.shift modifiers==GLUT.Down then Just "Shift" else Nothing+ ,if GLUT.ctrl modifiers==GLUT.Down then Just "Control" else Nothing+ ,if GLUT.alt modifiers==GLUT.Down then Just "Alt" else Nothing]+ (GL.Position x y) = position+ +motionHandler wname b (GL.Position x y) = do + produce' "Mouse" (wname ++ ".KeyboardMouseWidget") "Position" once (newHieroglyphData $ AttributedCoords (fromIntegral x) (fromIntegral y) []) b+ +scrollWheelHandler wname b evt = passthrough b++++-- | Bind a keyboard mouse widget to the given Gtk widget. Se module documentation for description of events.+bindMouseKeyboardWidget :: VisualEventData a => String -> Widget a+bindMouseKeyboardWidget wname b = do+ GLUT.motionCallback $= Just (motionHandler wname b)+ GLUT.keyboardMouseCallback $= Just (keyboardMouseHandler wname b)+ return ()
Graphics/Rendering/Hieroglyph/Cairo.hs view
@@ -1,4 +1,8 @@--- | Cairo backend to Hieroglyph.+-- | +-- Module : Graphics.Rendering.Hieroglyph.Cairo+-- Copyright : (c) Renaissance Computing Institute 2009+-- License : BSD3+-- -- -- [@Author@] Jeff Heard --
+ Graphics/Rendering/Hieroglyph/GLUT.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE BangPatterns #-}+-----------------------------------------------------------------------------+--+-- Module : Graphics.Rendering.Hieroglyph.OpenGL+-- Copyright : Renassance Computing Institute 2009+-- License : BSD3+--+-- Maintainer : J.R. Heard+-- Stability :+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Graphics.Rendering.Hieroglyph.GLUT+ ( module Graphics.Rendering.Hieroglyph.OpenGL.Data+ , mouseSelectionBehaviour+ , boilerplateOpenGLMain+ , renderOnExpose+ , renderBehaviour+ , selectionBehaviour+ , initializeBus)+where++import qualified Graphics.Rendering.Hieroglyph.Cache as Cache+import System.Exit+import GHC.Float+import Data.List+import Control.Concurrent+import Control.Applicative+import Control.Monad.Trans+import qualified System.Glib.MainLoop as Gtk+import Data.List (partition)+import qualified Data.Set as Set+import Data.Maybe+import Graphics.UI.Gtk.Cairo as Cairo+import qualified Graphics.Rendering.Cairo as Cairo+import qualified Data.Array.MArray as A+import Control.Monad+import Graphics.UI.Gtk.Pango.Context+import Graphics.UI.Gtk.Pango.Layout+import Foreign+import qualified Data.Map as Map+import qualified Graphics.UI.Gtk as Gtk+import qualified Graphics.UI.Gtk.OpenGL as Gtk+import qualified Graphics.UI.Gtk.OpenGL.Drawable as Gtk+import qualified Graphics.UI.Gtk.Gdk.Events as Gtk+import qualified Data.ByteString.Internal as SB+import qualified Graphics.Rendering.Cairo as Cairo -- for rendering fonts+import qualified Graphics.Rendering.OpenGL as GL+import Graphics.Rendering.OpenGL(GLuint, Vertex2, ($=))+import Graphics.Rendering.Hieroglyph.Primitives+import Graphics.Rendering.Hieroglyph.Visual+import qualified Data.ByteString as SB+import Foreign.C+import qualified App.EventBus as Buster+import App.Widgets.MouseKeyboardGLUT+import Data.Colour+import Data.Colour.Names+import Data.Colour.SRGB+import qualified Text.PrettyPrint as Pretty+import System.Mem.Weak++import Graphics.Rendering.Hieroglyph.OpenGL.Render+import Graphics.Rendering.Hieroglyph.OpenGL.Data+import Graphics.Rendering.Hieroglyph.OpenGL.Compile+import qualified Graphics.UI.GLUT as GLUT++-- | Select based on mouse clicks+mouseSelectionBehaviour :: VisualEventData a => Buster.Behaviour a+mouseSelectionBehaviour bus = Buster.pollFullyQualifiedEventWith bus "Mouse" "Hieroglyph.KeyboardMouseWidget" "SingleClick" $ \event -> do+ let (AttributedCoords x y _) = getHieroglyphData . Buster.eventdata $ event+ Buster.listM $ Buster.produce "Hieroglyph" "Hieroglyph" "PleaseSelect" Buster.once (newHieroglyphData $ AttributedCoords x y [])++boilerplateOpenGLMain :: VisualEventData a => [Buster.Widget a] -> Buster.Behaviour a -> IO ()+boilerplateOpenGLMain widgets behaviour = do+ evBus <- newMVar Buster.emptyBus+ forM_ widgets ($evBus)+ b <- takeMVar evBus+ putMVar evBus b++ let loop mv = do+ GLUT.mainLoopEvent+ Buster.busIteration mv behaviour+ loop mv++ let mk = bindMouseKeyboardWidget "window"+ mk evBus+ loop evBus+++-- | make Hieroglyph render on the main window exposure+renderOnExpose :: VisualEventData a => Buster.Widget a+renderOnExpose busV = do+ bus <- takeMVar busV+ putMVar busV bus+ let runtimeE = fromJust $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" bus+ runtime = getHieroglyphData . Buster.eventdata $ runtimeE+ drawing = primitives . map (getGeo . getHieroglyphData . Buster.eventdata) $ drawingEs+ drawingEs = Set.toList $ Buster.eventsByGroup "Visible" bus++ runtime' <- render runtime drawing+ Buster.Insertion revent' <- Buster.produce "Hieroglyph" "Hieroglyph" "RenderData" Buster.Persistent (newHieroglyphData runtime')+ takeMVar busV+ let bus' = Buster.addEvent revent' bus+ putMVar busV bus'++-- | Make Hieroglyph send out expose events when it sees a (Hieroglyph,Hieroglyph,Rerender) event.+renderBehaviour :: VisualEventData a => Buster.Behaviour a+renderBehaviour bus = Buster.consumeFullyQualifiedEventWith bus "Hieroglyph" "Hieroglyph" "Rerender" $ \event -> do+ GLUT.postRedisplay Nothing+ return $ []+++-- | a behaviour to render hieroglyph data to the selection buffer when it sees a (Hieroglyph,Hieroglyph,PleaseSelect) event.+-- Produces (Selection,Hieroglyph,@objectname@) events.+selectionBehaviour :: VisualEventData a => Buster.Behaviour a+selectionBehaviour bus =+ case selectionRequested of+ Just sreq -> do -- print "Selection requested"+ let (AttributedCoords selx sely _) = getHieroglyphData $ Buster.eventdata sreq+ (p, GL.Size sx sy ) <- GL.get GL.viewport+ GL.depthFunc $= Just GL.Less+ GL.clear [GL.ColorBuffer, GL.DepthBuffer]+ GL.matrixMode $= GL.Projection+ GL.loadIdentity+ GL.pickMatrix (selx-2, (fromIntegral sy)-sely+2) (6,6) (p, GL.Size sx sy)+ maybe (GL.ortho 0 (fromIntegral sx) 0 (fromIntegral sy) 1 2)+ (\(a,b,c,d) -> GL.ortho a b c d 1 2)+ (ortho runtime)+ (runtime', recs) <- GL.getHitRecords 16 $ renderObjects (Just (selx,sely)) [1::Double,2..] (sort drawing) runtime+ selectionEvents <- forM (fromMaybe [] recs) $ \(GL.HitRecord x y names) ->+ let names' = (fromMaybe "" . ((flip Map.lookup) (namemap runtime')) . (\(GL.Name x) -> x)) <$> names in do+ Buster.produce "Selection" "Hieroglyph" (unlines names') Buster.once+ (newHieroglyphData $ AttributedCoords (realToFrac x) (realToFrac y) names')++ runtimeE' <- Buster.produce "Hieroglyph" "Hieroglyph" "RenderData" Buster.Persistent (setHieroglyphData runtime' runtimeE)+ Buster.future bus . return $ [Buster.Deletion sreq , runtimeE'] ++ selectionEvents++ Nothing -> Buster.future bus . return $ []+ where runtimeE = Buster.eventdata . fromJust $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" bus+ runtime = getHieroglyphData runtimeE+ drawing = primitives . map (getGeo . getHieroglyphData . Buster.eventdata) $ drawingEs+ drawingEs = Set.toList $ Buster.eventsByGroup "Visible" bus+ selectionRequested = Buster.eventByQName "Hieroglyph" "Hieroglyph" "PleaseSelect" bus++initializeBus :: VisualEventData a => String -> Int -> Int -> Buster.Widget a+initializeBus name w h bus = do+ let numTextures = 512+ numBufferObjects = 256++ GLUT.initialWindowSize $= GL.Size (fromIntegral w) (fromIntegral h)+ GLUT.getArgsAndInitialize + GLUT.initialDisplayMode $= [GLUT.RGBAMode, GLUT.DoubleBuffered, GLUT.Multisampling, GLUT.WithSamplesPerPixel 4, GLUT.WithDepthBuffer]+ GLUT.createWindow name+ GLUT.closeCallback $= Just (GLUT.leaveMainLoop)+ + GLUT.displayCallback $= (GL.drawBuffer $= GL.BackBuffers >> renderOnExpose bus >> GLUT.swapBuffers) ++ GLUT.reshapeCallback $= Just (\(GL.Size w h) -> + GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral $ w) (fromIntegral $ h)))+ + + textures <- (GL.genObjectNames numTextures) :: IO [GL.TextureObject]+ buffers <- (GL.genObjectNames numBufferObjects) :: IO [GL.BufferObject]+ + context <- Gtk.cairoCreateContext Nothing+ let edata = HgGLUT textures (Cache.empty (1024768*64) 0) [] buffers (Cache.empty (10247680*64) 0) [] Map.empty context Map.empty Nothing+ Buster.produce' "Hieroglyph" "Hieroglyph" "RenderData" Buster.Persistent (newHieroglyphData edata) bus++ return ()+
Graphics/Rendering/Hieroglyph/OpenGL.hs view
@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- -- Module : Graphics.Rendering.Hieroglyph.OpenGL--- Copyright :+-- Copyright : Renassance Computing Institute 2009 -- License : BSD3 -- -- Maintainer : J.R. Heard@@ -89,7 +89,6 @@ let mk = bindMouseKeyboardWidget (Gtk.castToWidget (window glarea)) mk evBus loop evBus- -- | make Hieroglyph render on the main window exposure renderOnExpose :: VisualEventData a => Buster.Widget a
Graphics/Rendering/Hieroglyph/OpenGL/Compile.hs view
@@ -49,7 +49,7 @@ import qualified Data.ByteString as SB import Foreign.C import qualified App.EventBus as Buster-import qualified App.Widgets.GtkMouseKeyboard as Buster+import qualified App.Widgets.MouseKeyboard as Buster import Data.Colour import Data.Colour.Names import Data.Colour.SRGB
Graphics/Rendering/Hieroglyph/OpenGL/Data.hs view
@@ -48,7 +48,6 @@ import qualified Data.ByteString as SB import Foreign.C import qualified App.EventBus as Buster-import qualified App.Widgets.GtkMouseKeyboard as Buster import Data.Colour import Data.Colour.Names import Data.Colour.SRGB@@ -67,6 +66,21 @@ , namemap :: Map.Map GLuint String , drawarea :: Gtk.GLDrawingArea , window :: Gtk.Window+ , context ::PangoContext+ , texdims :: Map.Map GL.TextureObject (Double,Double)++ , ortho :: Maybe (Double,Double,Double,Double)+ }+ | HgGLUT {+ texture_whitelist :: [GL.TextureObject]+ , texture_greylist :: Cache.Cache String GL.TextureObject+ , texture_blacklist :: [GL.TextureObject]++ , buffer_whitelist :: [GL.BufferObject]+ , buffer_greylist :: Cache.Cache Int GL.BufferObject+ , buffer_blacklist :: [GL.BufferObject]++ , namemap :: Map.Map GLuint String , context ::PangoContext , texdims :: Map.Map GL.TextureObject (Double,Double)
Graphics/Rendering/Hieroglyph/OpenGL/Render.hs view
@@ -15,6 +15,7 @@ module Graphics.Rendering.Hieroglyph.OpenGL.Render where +import qualified Graphics.UI.GLUT as GLUT import qualified Graphics.Rendering.Hieroglyph.Cache as Cache import System.Exit import GHC.Float@@ -47,7 +48,7 @@ import qualified Data.ByteString as SB import Foreign.C import qualified App.EventBus as Buster-import qualified App.Widgets.GtkMouseKeyboard as Buster+import qualified App.Widgets.MouseKeyboard as Buster import Data.Colour import Data.Colour.Names import Data.Colour.SRGB@@ -166,7 +167,26 @@ getGeo (Geometry x) = x getGeo _ = [] -render runtime geo = Gtk.withGLDrawingArea (drawarea runtime) $ \drawable -> do+render runtime@HgGLUT{} geo = do+ GL.drawBuffer $= GL.BackBuffers+ (GL.Position px py, GL.Size sx sy ) <- GL.get GL.viewport+ GL.matrixMode $= GL.Projection+ GL.loadIdentity+ maybe (GL.ortho 0 (fromIntegral sx) 0 (fromIntegral sy) 1 2)+ (\(a,b,c,d) -> GL.ortho a b c d 1 2)+ (ortho runtime)+ GL.clearColor $= GL.Color4 1 1 1 1+ GL.clear [GL.ColorBuffer, GL.DepthBuffer]+ GL.depthFunc $= Just GL.Less+ GL.blend $= GL.Enabled+ GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)+ GL.lineSmooth $= GL.Enabled+ GL.polygonSmooth $= GL.Enabled+ GL.pointSmooth $= GL.Enabled+ r' <- renderObjects Nothing [1::Double,2..] (sort geo) runtime+ GLUT.swapBuffers+ return r'{ texture_blacklist = [] }+render runtime@HgGL{} geo = Gtk.withGLDrawingArea (drawarea runtime) $ \drawable -> do ctx <- Gtk.glDrawingAreaGetGLContext ( drawarea runtime ) Gtk.glDrawableGLBegin drawable ctx GL.drawBuffer $= GL.BackBuffers
Graphics/Rendering/Hieroglyph/Primitives.hs view
@@ -1,5 +1,11 @@ {-# LANGUAGE BangPatterns, FlexibleContexts, UndecidableInstances, StandaloneDeriving #-}--- | This is Hieroglyph, a 2D scenegraph library similar in functionality to a barebones+-- | + +-- Module : Graphics.Rendering.Hieroglyph.Primitives+-- Copyright : (c) Renaissance Computing Institute 2009+-- License : BSD3+--+-- This is Hieroglyph, a 2D scenegraph library similar in functionality to a barebones -- stripped down version of Processing, but written in a purely functional manner. -- -- See individual implementations (like the Graphics.Rendering.Hieroglyph.Cairo module)
Graphics/Rendering/Hieroglyph/Stylesheets.hs view
@@ -1,12 +1,33 @@-module Graphics.Rendering.Hieroglyph.Stylesheets where+-- |+ +-- Module : App.DebugEventBus+-- Copyright : (c) Renaissance Computing Institute 2009+-- License : BSD3+--+-- Declarative stylesheets for Hieroglyph+--+module Graphics.Rendering.Hieroglyph.Stylesheets + (Styling (StyleSelector, ArcStyle, DotsStyle, PathStyle, RectStyle, TextStyle)+ ,stylesheet+ ,styledPrims+ ,withStylesheet+ ,selectors+ ,arcstyle+ ,dotstyle+ ,pathstyle+ ,textstyle+ ,Stylesheet)+where import Graphics.Rendering.Hieroglyph.Primitives import Graphics.Rendering.Hieroglyph.Visual import Data.Map (Map) import qualified Data.Map as Map +-- | Basic type of a style combinator type Style = BaseVisual -> BaseVisual +-- | Styling individual primitives data Styling = StyleSelector String Style | ArcStyle Style@@ -15,17 +36,18 @@ | RectStyle Style | TextStyle Style +-- | A complete stylesheet data Stylesheet = Stylesheet- { selectors :: Map String Style- , arcstyle :: Style- , dotstyle :: Style- , pathstyle :: Style- , rectanglestyle :: Style- , textstyle :: Style+ { selectors :: Map String Style -- ^ A list of style selectors that can be selected via the @style@ combinator in Graphics.Rendering.Hieroglyph.Visual+ , arcstyle :: Style -- ^ The style to apply to arc objects+ , dotstyle :: Style -- ^ The style to apply to dots primitives+ , pathstyle :: Style -- ^ The default style to apply to path primitives+ , rectanglestyle :: Style -- ^ The default style to apply to rectangle primitives+ , textstyle :: Style -- ^ The default style to apply to text primitives } data BaseSel =- IsArc (Maybe String)+ IsArc (Maybe String) | IsDots (Maybe String) | IsPath (Maybe String) | IsRect (Maybe String)@@ -33,6 +55,8 @@ | IsRest (Maybe String) deriving (Ord,Eq) +-- | Compose stylesheet from Styling information+stylesheet :: [Styling] -> Stylesheet stylesheet styles = foldr mkStylesheet' (Stylesheet Map.empty id id id id id) styles where mkStylesheet' (ArcStyle s) ss = ss{ arcstyle = s } mkStylesheet' (DotsStyle s) ss = ss{ dotstyle = s }@@ -40,7 +64,6 @@ mkStylesheet' (RectStyle s) ss = ss{ rectanglestyle = s } mkStylesheet' (TextStyle s) ss = ss{ textstyle = s } mkStylesheet' (StyleSelector k s) ss = ss{ selectors = Map.insert k s . selectors $ ss }- binHelper p k = maybe (k Nothing,p) (\s -> (k (Just s),p))@@ -53,8 +76,10 @@ bin p@(Text{}) = binHelper p IsText bin p = binHelper p IsRest +styledPrims :: Visual a => String -> a -> BaseVisual styledPrims ss = style ss . primitives +withStylesheet :: Stylesheet -> BaseVisual -> BaseVisual withStylesheet ss v = concat $ Map.elems styledVisuals where binnedVisuals = foldr (\(b,p) -> Map.insertWith (++) b [p]) Map.empty . map bin $ v styledVisuals = Map.mapWithKey applyStyle binnedVisuals
Hieroglyph.cabal view
@@ -1,5 +1,5 @@ name: Hieroglyph-version: 3.85+version: 3.88 cabal-version: >=1.2 build-type: Simple license: BSD3@@ -7,9 +7,9 @@ copyright: maintainer: J.R. Heard build-depends: IfElse -any, OpenGL <= 2.2.3.0, array -any, base == 4.1.0.0,- buster ==2.51, buster-gtk -any, bytestring -any, cairo -any,+ buster ==2.51, bytestring -any, cairo -any, colour -any, containers -any, glib -any, gtk >= 0.10.0, gtkglext -any,- mtl -any, parallel -any, pretty -any, random -any+ mtl -any, parallel -any, pretty -any, random -any, GLUT < 2.2.0.0 stability: homepage: http://vis.renci.org/jeff/hieroglyph package-url:@@ -25,8 +25,11 @@ extra-source-files: extra-tmp-files: exposed-modules: App.Widgets.MouseKeyboard- Graphics.Rendering.Hieroglyph Graphics.Rendering.Hieroglyph.Cairo+ App.Widgets.MouseKeyboardGLUT+ Graphics.Rendering.Hieroglyph + Graphics.Rendering.Hieroglyph.Cairo Graphics.Rendering.Hieroglyph.OpenGL+ Graphics.Rendering.Hieroglyph.GLUT Graphics.Rendering.Hieroglyph.Cache Graphics.Rendering.Hieroglyph.Primitives Graphics.Rendering.Hieroglyph.Visual