Hieroglyph 3.5 → 3.8
raw patch · 10 files changed
+293/−141 lines, 10 filesdep ~base
Dependency ranges changed: base
Files
- App/Widgets/MouseKeyboard.hs +61/−0
- Graphics/Rendering/Hieroglyph/Cairo.hs +2/−2
- Graphics/Rendering/Hieroglyph/OpenGL.hs +39/−32
- Graphics/Rendering/Hieroglyph/OpenGL/Compile.hs +85/−47
- Graphics/Rendering/Hieroglyph/OpenGL/Data.hs +14/−0
- Graphics/Rendering/Hieroglyph/OpenGL/Render.hs +45/−20
- Graphics/Rendering/Hieroglyph/Primitives.hs +13/−7
- Graphics/Rendering/Hieroglyph/Stylesheets.hs +20/−20
- Graphics/Rendering/Hieroglyph/Visual.hs +2/−1
- Hieroglyph.cabal +12/−12
+ App/Widgets/MouseKeyboard.hs view
@@ -0,0 +1,61 @@+-- | 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.MouseKeyboard where++import Control.Applicative+import Control.Concurrent+import Data.Maybe+import qualified Graphics.UI.Gtk as Gtk+import qualified Graphics.UI.Gtk.Gdk.Events as Gtk+import App.EventBus+import Graphics.Rendering.Hieroglyph.OpenGL.Data++-- Gtk's button click event system is annoying, so we're ignoring it and only bothering with the single clicks.+-- when we receive a click, fire off a thread (once) that waits for 100ms to see how many clicks we get total in that time. Then fire off that number.+buttonHandler _ _ (Gtk.Button _ Gtk.DoubleClick _ _ _ _ _ _ _) = return True+buttonHandler _ _ (Gtk.Button _ Gtk.TripleClick _ _ _ _ _ _ _) = return True+buttonHandler wname b (Gtk.Button sent click time x y modifiers button _ _) = do+ produce' "Mouse" (wname ++ ".KeyboardMouseWidget") (show click) once (newHieroglyphData $ AttributedCoords x y (show button : map show modifiers)) b+ return True++scrollWheelHandler wname b (Gtk.Scroll _ _ x y direction _ _) = do+ produce' "Mouse" (wname ++ ".KeyboardMouseWidget") (show direction) once (newHieroglyphData $ AttributedCoords x y []) b+ return True++keyboardHandler wname b (Gtk.Key released sent time modifiers withCapsLock withNumLock withScrollLock keyVal keyName keyChar) = do+ produce' "Keyboard" (wname ++ "KeyboardMouseWidget") (if released then "KeyUp" else "KeyDown") once (newHieroglyphData $ AttributedCoords 0 0 (maybe (show keyName) (:[]) keyChar : map show modifiers)) b+ return False++motionHandler wname w b evt = do+ produce' "Mouse" (wname ++ ".KeyboardMouseWidget") "Position" once (newHieroglyphData $ AttributedCoords (Gtk.eventX evt) (Gtk.eventY evt) (map show . Gtk.eventModifier $ evt)) b -- [EAssocL [("coords", EDoubleL [Gtk.eventX evt, Gtk.eventY evt])+ -- ,("modifiers", EStringL . map show . Gtk.eventModifier $ evt)]] b+ dwin <- Gtk.widgetGetDrawWindow w+ Gtk.drawWindowGetPointer dwin+ return False+++-- | Bind a keyboard mouse widget to the given Gtk widget. Se module documentation for description of events.+bindMouseKeyboardWidget :: VisualEventData a => Gtk.Widget -> Widget a+bindMouseKeyboardWidget w b = do+ ref <- newEmptyMVar+ wname <- Gtk.widgetGetName w+ Gtk.onButtonPress w (buttonHandler wname b)+ Gtk.onButtonRelease w (buttonHandler wname b)+ Gtk.onScroll w (scrollWheelHandler wname b)+ Gtk.onKeyPress w (keyboardHandler wname b)+ Gtk.onKeyRelease w (keyboardHandler wname b)+ Gtk.onMotionNotify w True (motionHandler wname w b)+ return ()
Graphics/Rendering/Hieroglyph/Cairo.hs view
@@ -1,4 +1,4 @@--- | Cairo backend to Hieroglyph. +-- | Cairo backend to Hieroglyph. -- -- [@Author@] Jeff Heard --@@ -134,7 +134,7 @@ fillStrokeAndClip state $ Cairo.rectangle ox oy w h return state -renderPrimitive context _ s0 txt@(Text _ (Point ox oy) _ _ _ _ _ _ _ _) = do+renderPrimitive context _ s0 txt@(Text _ (Point ox oy) _ _ _ _ _ _ _ _ _) = do layout <- liftIO $ layoutEmpty context >>= \layout -> do layoutSetMarkup layout . Pretty.render . str $ txt layoutSetAlignment layout . align $ txt
Graphics/Rendering/Hieroglyph/OpenGL.hs view
@@ -55,7 +55,7 @@ import qualified Data.ByteString as SB import Foreign.C import qualified App.EventBus as Buster-import qualified App.Widgets.GtkMouseKeyboard as Buster+import App.Widgets.MouseKeyboard import Data.Colour import Data.Colour.Names import Data.Colour.SRGB@@ -67,52 +67,50 @@ import Graphics.Rendering.Hieroglyph.OpenGL.Compile -- | Select based on mouse clicks-mouseSelectionBehaviour :: Buster.Behaviour [Buster.EData HieroglyphGLRuntime]+mouseSelectionBehaviour :: VisualEventData a => Buster.Behaviour a mouseSelectionBehaviour bus = Buster.pollFullyQualifiedEventWith bus "Mouse" "Hieroglyph.KeyboardMouseWidget" "SingleClick" $ \event -> do- --print "MouseSelectionBehaviour"- let (Buster.EAssocL alist) = head . Buster.eventdata $ event- (Buster.EDoubleL (x:y:_)) = fromJust $ "coords" `lookup` alist- --print "Leaving mouse selection behaviour"- Buster.listM $ Buster.produce "Hieroglyph" "Hieroglyph" "PleaseSelect" Buster.once [Buster.EDouble x, Buster.EDouble y]-+ 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 Just (Buster.EOther glarea) = fmap (head . Buster.eventdata) $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" b+ let Just glarea = fmap (getHieroglyphData . Buster.eventdata) $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" b loop mv = do Gtk.mainContextIteration Gtk.mainContextDefault True Buster.busIteration mv behaviour loop mv - let mk = Buster.bindMouseKeyboardWidget (Gtk.castToWidget (window glarea))+ let mk = bindMouseKeyboardWidget (Gtk.castToWidget (window glarea)) mk evBus loop evBus -- | make Hieroglyph render on the main window exposure-renderOnExpose :: Buster.Widget [Buster.EData HieroglyphGLRuntime]+renderOnExpose :: VisualEventData a => Buster.Widget a renderOnExpose busV = do bus <- takeMVar busV putMVar busV bus let runtimeE = fromJust $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" bus- Buster.EOther runtime = head . Buster.eventdata $ runtimeE- drawing = primitives . catMaybes . map getGeo . concat . map Buster.eventdata $ drawingEs+ 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 [Buster.EOther runtime']+ 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- let Buster.EOther renderdata = head . Buster.eventdata . fromJust $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" bus+ let renderdata = getHieroglyphData . Buster.eventdata . fromJust $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" bus (w,h) <- Gtk.widgetGetSize (window renderdata) Gtk.widgetQueueDrawArea (window renderdata) 0 0 w h return $ []@@ -120,40 +118,40 @@ -- | 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 :: VisualEventData a => Buster.Behaviour a selectionBehaviour bus = case selectionRequested of Just sreq -> do -- print "Selection requested"- let [Buster.EDouble selx, Buster.EDouble sely] = Buster.eventdata sreq+ 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)- GL.ortho 0 (fromIntegral sx) 0 (fromIntegral sy) 1 2- (runtime', recs) <- GL.getHitRecords 16 $ renderObjects [1::Double,2..] (sort drawing) runtime+ 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- [Buster.EDouble . realToFrac $ x- , Buster.EDouble . realToFrac $ y- , Buster.EStringL $ names']+ (newHieroglyphData $ AttributedCoords (realToFrac x) (realToFrac y) names') - runtimeE' <- Buster.produce "Hieroglyph" "Hieroglyph" "RenderData" Buster.Persistent [Buster.EOther runtime']+ 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 = fromJust $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" bus- Buster.EOther runtime = head . Buster.eventdata $ runtimeE- drawing = primitives . catMaybes . map getGeo . concat . map Buster.eventdata $ drawingEs+ 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 -- | Widget for initializing the bus-initializeBus :: String -> Int -> Int -> Buster.Widget [Buster.EData HieroglyphGLRuntime]+initializeBus :: VisualEventData a => String -> Int -> Int -> Buster.Widget a initializeBus name w h bus = do let numTextures = 512 numBufferObjects = 256@@ -165,15 +163,25 @@ Gtk.onDestroy win (exitWith ExitSuccess) Gtk.initGL >>= mapM_ putStrLn config <- Gtk.glConfigNew [Gtk.GLModeRGBA, Gtk.GLModeMultiSample, Gtk.GLModeDouble, Gtk.GLModeDepth, Gtk.GLModeAlpha]+ vbox <- Gtk.vBoxNew True 0+ Gtk.widgetShow vbox+ Gtk.containerAdd win vbox area <- Gtk.glDrawingAreaNew config+ Gtk.widgetShow area+ Gtk.boxPackStart vbox area Gtk.PackGrow 0 + Gtk.onExpose area $ \ev -> renderOnExpose bus >> return True+ Gtk.onRealize area $ do GL.drawBuffer $= GL.BackBuffers Gtk.windowSetDefaultSize win w h- Gtk.containerResizeChildren win- Gtk.containerAdd win area Gtk.widgetShowAll win++ Gtk.onConfigure area $ \evt -> do+ GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral $ Gtk.eventWidth evt) (fromIntegral $ Gtk.eventHeight evt))+ return False+ (textures, buffers) <- Gtk.withGLDrawingArea area $ \_ -> do ts <- (GL.genObjectNames numTextures) :: IO [GL.TextureObject] bs <- (GL.genObjectNames numBufferObjects) :: IO [GL.BufferObject]@@ -181,8 +189,7 @@ context <- Gtk.cairoCreateContext Nothing - let edata = HgGL textures (Cache.empty 1024768000 0) [] buffers (Cache.empty 1024768000 0) [] Map.empty area win context Map.empty- Buster.produce' "Hieroglyph" "Hieroglyph" "RenderData" Buster.Persistent [Buster.EOther edata] bus+ let edata = HgGL textures (Cache.empty 1024768000 0) [] buffers (Cache.empty 1024768000 0) [] Map.empty area win context Map.empty Nothing+ Buster.produce' "Hieroglyph" "Hieroglyph" "RenderData" Buster.Persistent (newHieroglyphData edata) bus - Gtk.onExpose area (\_ -> renderOnExpose bus >> return True) return ()
Graphics/Rendering/Hieroglyph/OpenGL/Compile.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : Graphics.Rendering.Hieroglyph.OpenGL@@ -22,6 +22,7 @@ import Data.List import Control.Concurrent import Control.Applicative+import Control.Exception import Control.Monad.Trans import qualified System.Glib.MainLoop as Gtk import Data.List (partition)@@ -54,6 +55,7 @@ import Data.Colour.SRGB import qualified Text.PrettyPrint as Pretty import System.Mem.Weak+ arcFn _ _ _ [] = [] arcFn x y r (t:ts) = (x + r * cos t) : (y + r * sin t) : arcFn x y r ts arcVertices nvertices (Point cx cy) r t1 t2 = arcFn cx cy r $ [t1+t | t <- [0,(t2-t1)/nvertices..t2-t1]]@@ -76,45 +78,56 @@ ys = cubic ay c0y c1y by [m / nvertices' | m <- [0 .. nvertices']] nvertices' = (fromIntegral nvertices) :: Double -compile e a@(Dots _ _ _) = return $ compileDots e a-compile e a@(Arc _ _ _ _ _ _ _) = return $ compileArc e a-compile e a@(Path _ _ _ _ _ ) = return $ compilePath e a-compile e a@(Rectangle _ _ _ _ _) = return $ compileRectangle e a-compile e a@(Text _ _ _ _ _ _ _ _ _ _) = compileText e a-compile e a@(Image _ _ _ _ _) = compileImage e a+compile e a@(Dots{}) = return $ compileDots e a+compile e a@(Arc{}) = return $ compileArc e a+compile e a@(Path{}) = return $ compilePath e a+compile e a@(Rectangle{}) = return $ compileRectangle e a+compile e a@(Text{}) = compileText e a+compile e a@(Image{}) = compileImage e a -compileDots e p@(Dots ds attrs s) = (maybe e (\n -> e{ namemap=Map.insert (fromIntegral s) n (namemap e)}) (aname attrs), CompiledDots p (vdata ds) (fromIntegral s))- where vdata ((Point x y):vs) = x:y:vdata vs+compileDots e p@(Dots ds attrs s) = (maybe e (\n -> e{ namemap=Map.insert (fromIntegral s) n (namemap e)}) (aname attrs), CompiledDots p{attribs=attrs'} (vdata ds) (fromIntegral s))+ where vdata ((Point x y):vs) = x-tx:y-ty:vdata vs vdata [] = []+ attrs' = attrs{ atranslatex = atranslatex attrs + tx, atranslatey= atranslatey attrs + ty }+ Point tx ty = if (atranslatex attrs > 0 || atranslatey attrs > 0) && (not . null $ ds) then head ds else origin compileArc e p@(Arc (Point cx cy) r t1 t2 reverse attrs sg) = (maybe e (\n -> e{ namemap=Map.insert (fromIntegral sg) n (namemap e)}) (aname attrs),a0) where a0 = CompiledArc- p- (cx : cy : arcVertices 180- (Point cx cy)+ p{attribs=attrs'}+ (cx' : cy' : arcVertices 180+ p' r (if reverse then t2 else t1) (if reverse then t1 else t2)) (fromIntegral sg)+ attrs' = attrs{ atranslatex = atranslatex attrs + tx, atranslatey= atranslatey attrs + ty }+ Point tx ty = if (atranslatex attrs > 0 || atranslatey attrs > 0) then Point cx cy else origin+ p'@(Point cx' cy') = if (atranslatex attrs > 0 || atranslatey attrs > 0) then origin else Point cx cy compilePath e p = (maybe e (\n -> e{ namemap=Map.insert (fromIntegral (sig p)) n (namemap e) }) (aname . attribs $ p)- , CompiledPath p (fillablePath p) (fromIntegral (sig p)))+ , CompiledPath p{attribs=attrs'} (fillablePath p) (fromIntegral (sig p))) where fillablePath p = pathOutline' (centroid (begin p:(ls2pt <$> segments p))) (Line (begin p): segments p) pathOutline p = if closed p then pathOutline' (begin p) (segments p ++ [Line $ begin p]) else pathOutline' (begin p) (segments p)- pathOutline' (Point x0 y0) (Line (Point x1 y1) : ps) = [x0,y0,x1,y1] ++ pathOutline' (Point x1 y1) ps+ pathOutline' (Point x0 y0) (Line (Point x1 y1) : ps) = [x0-tx,y0-ty,x1-tx,y1-ty] ++ pathOutline' (Point x1 y1) ps pathOutline' (Point x0 y0) (EndPoint (Point x1 y1) : ps) = pathOutline' (Point x1 y1) ps- pathOutline' a (Spline c0 c1 b:ps) = splineVertices 256 a c0 c1 b ++ pathOutline' b ps+ pathOutline' a (Spline c0 c1 b:ps) = splineVertices 64 (a-tp) (c0-tp) (c1-tp) (b-tp) ++ pathOutline' b ps pathOutline' _ [] = []+ attrs' = attrs{ atranslatex = atranslatex attrs + tx, atranslatey= atranslatey attrs + ty }+ tp@(Point tx ty) = if (atranslatex attrs > 0 || atranslatey attrs > 0) then begin p else origin+ attrs = attribs p compileRectangle e p@(Rectangle (Point x y) w h attrs sg) = (maybe e (\n -> e{ namemap=Map.insert (fromIntegral sg) n (namemap e) }) (aname attrs)- , CompiledRectangle p x y w h (fromIntegral sg))+ , CompiledRectangle p{ attribs=attrs'} x' y' w h (fromIntegral sg))+ where (x',y') = (x-tx,y-ty)+ Point tx ty = if (atranslatex attrs > 0 || atranslatey attrs > 0) then Point x y else origin+ attrs' = attrs{ atranslatex = atranslatex attrs + tx, atranslatey= atranslatey attrs + ty } dataFrom (SB.PS d _ _) = d @@ -132,10 +145,14 @@ compileText e txt | cachetxt txt `Cache.member` texture_greylist e = do+ (_,GL.Size rx ry) <- GL.get GL.viewport let Point x y = bottomleft txt+ (w',h') = case (ortho e,astatic (attribs txt)) of+ (Just (west,east,south,north),False) -> (w*(east-west)/fromIntegral rx, h*(north-south)/fromIntegral ry)+ _ -> (w,h) (c', Just tex) = Cache.get (cachetxt txt) (texture_greylist e) (w,h) = texdims e Map.! tex- return ( e{ texture_greylist = c' }, CompiledImage txt x y w h tex (fromIntegral (sig txt)))+ return ( e{ texture_greylist = c' }, CompiledImage txt{bottomleft = p', attribs=attrs'} cx' cy' w' h' tex (fromIntegral (sig txt))) | otherwise = do let (e', tex) = getFreeTexture e@@ -158,7 +175,7 @@ textSurface <- Cairo.withImageSurface Cairo.FormatARGB32 potw poth $ \surf -> do Cairo.renderWith surf $ do Cairo.setOperator Cairo.OperatorSource- Cairo.setSourceRGBA 1 1 1 0+ maybe (Cairo.setSourceRGBA 1 1 1 0) (\colour -> let (a,b,c,d) = colourToTuple colour in Cairo.setSourceRGBA a b c d) (background txt) Cairo.rectangle 0 0 w h Cairo.fill Cairo.setOperator Cairo.OperatorOver@@ -195,52 +212,73 @@ GL.UnsignedByte (unsafeForeignPtrToPtr (dataFrom textSurface))) + (_,GL.Size rx ry) <- GL.get GL.viewport+ let (w',h') = case (ortho e',astatic (attribs txt)) of+ (Just (west,east,south,north),False) -> (w*(east-west)/fromIntegral rx, h*(north-south)/fromIntegral ry)+ _ -> (w,h)+ return ( e'{ texdims = Map.insert tex (w, h) (texdims e') , texture_greylist = Cache.put (cachetxt txt) tex (texture_greylist e') }- , CompiledImage txt x y w h tex (fromIntegral (sig txt)))-+ , CompiledImage txt{bottomleft = p', attribs=attrs'} cx' cy' w' h' tex (fromIntegral (sig txt)))+ where attrs' = (attribs txt){ atranslatex = atranslatex attrs + tx, atranslatey= atranslatey attrs + ty, ascalex=1, ascaley=1 }+ Point tx ty = if (atranslatex attrs > 0 || atranslatey attrs > 0) then bottomleft txt else origin+ p'@(Point cx' cy') = if (atranslatex attrs > 0 || atranslatey attrs > 0) then origin else bottomleft txt+ attrs = attribs txt compileImage e img | cacheimg img `Cache.member` texture_greylist e = do- let (c',Just tex) = Cache.get (cacheimg img) (texture_greylist e)+ (_,GL.Size rx ry) <- GL.get GL.viewport+ let (w',h') = case (ortho e,dimensions img,astatic (attribs img)) of+ (Just (west,east,south,north),Left{},False) -> (w*(east-west)/fromIntegral rx, h*(north-south)/fromIntegral ry)+ _ -> (w,h)+ (c',Just tex) = Cache.get (cacheimg img) (texture_greylist e) (w,h) = texdims e Map.! tex- return ( e{texture_greylist = c'} , CompiledImage img x y w h tex (fromIntegral (sig img)))+ return ( e{texture_greylist = c'} , CompiledImage img x y w' h' tex (fromIntegral (sig img))) | otherwise = do (w,h,potw,poth,channels,buffer) <- case dimensions img of- (Left (Point x y)) -> Gtk.pixbufNewFromFile (filename img) >>= copydata- (Right (Rect x y w h)) -> Gtk.pixbufNewFromFileAtScale (filename img) (round w) (round h) (preserveaspect img) >>= copydata+ (Left (Point x y)) -> Control.Exception.catch (Gtk.pixbufNewFromFile (filename img) >>= copydata) (\(err::SomeException) -> SB.readFile (filename img) >>=( \l -> print (err,filename img,SB.length l)) >> return (0,0,0,0,0,SB.empty))+ (Right (Rect x y w h)) -> Control.Exception.catch ( Gtk.pixbufNewFromFile (filename img) >>= copydata) (\(err::SomeException) -> SB.readFile (filename img) >>= (\l -> print (w,h,preserveaspect img,err,filename img,SB.length l)) >> return (0,0,0,0,0,SB.empty))+ if w > 0+ then do+ let (e', tex) = getFreeTexture e - let (e', tex) = getFreeTexture e+ GL.textureBinding GL.Texture2D $= Just tex+ GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Clamp)+ GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Clamp)+ GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')+ GL.textureFunction $= GL.Decal - GL.textureBinding GL.Texture2D $= Just tex- GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Clamp)- GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Clamp)- GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')- GL.textureFunction $= GL.Decal+ GL.texImage2D Nothing+ GL.NoProxy+ 0+ (if channels == 4 then GL.RGBA' else GL.RGB')+ (GL.TextureSize2D (fromIntegral potw) (fromIntegral poth))+ 0+ (GL.PixelData (if channels == 4 then GL.RGBA else GL.RGB)+ GL.UnsignedByte+ (unsafeForeignPtrToPtr (dataFrom buffer))) - GL.texImage2D Nothing- GL.NoProxy- 0- (if channels == 4 then GL.RGBA' else GL.RGB')- (GL.TextureSize2D (fromIntegral potw) (fromIntegral poth))- 0- (GL.PixelData (if channels == 4 then GL.RGBA else GL.RGB)- GL.UnsignedByte- (unsafeForeignPtrToPtr (dataFrom buffer)))+ let (w',h') = case dimensions img of+ Left _ -> (fromIntegral w, fromIntegral h)+ Right (Rect _ _ w0 h0) -> (w0,h0) - let (w',h') = case dimensions img of- Left _ -> (fromIntegral w, fromIntegral h)- Right (Rect _ _ w0 h0) -> (w0,h0)+ (_,GL.Size rx ry) <- GL.get GL.viewport+ let (w'',h'') = case (ortho e,dimensions img,astatic (attribs img)) of+ (Just (west,east,south,north),Left{}, False) -> (w'*(east-west)/fromIntegral rx, h'*(north-south)/fromIntegral ry)+ _ -> (w',h') - return ( e'{ texdims = Map.insert tex (w',h') (texdims e')- , texture_greylist = Cache.put (cacheimg img) tex (texture_greylist e')- }- , CompiledImage img x y w' h' tex (fromIntegral (sig img)))- where (x, y) = case dimensions img of+ return ( e'{ texdims = Map.insert tex (w',h') (texdims e')+ , texture_greylist = Cache.put (cacheimg img) tex (texture_greylist e')+ }+ , CompiledImage img x y w'' h'' tex (fromIntegral (sig img)))+ else return (e, CompiledRectangle rectangle 0 0 0 0 0)++ where (x, y) = case dimensions img of Left (Point x0 y0) -> (x0, y0) Right (Rect x0 y0 _ _) -> (x0,y0)+ {-# INLINE copydata #-} copydata pbuf0 = do
Graphics/Rendering/Hieroglyph/OpenGL/Data.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- -- Module : Graphics.Rendering.Hieroglyph.OpenGL@@ -68,8 +69,21 @@ , window :: Gtk.Window , context ::PangoContext , texdims :: Map.Map GL.TextureObject (Double,Double)++ , ortho :: Maybe (Double,Double,Double,Double) } | Geometry BaseVisual+ | AttributedCoords Double Double [String]++class VisualEventData a where+ getHieroglyphData :: a -> HieroglyphGLRuntime+ setHieroglyphData :: HieroglyphGLRuntime -> a -> a+ newHieroglyphData :: HieroglyphGLRuntime -> a++instance VisualEventData [Buster.EData HieroglyphGLRuntime] where+ getHieroglyphData = Buster.fromEOther . head+ setHieroglyphData r e = Buster.EOther r : tail e+ newHieroglyphData r = [Buster.EOther r] reverseMouseCoords b x y = do let renderDataE = fromJust $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" b
Graphics/Rendering/Hieroglyph/OpenGL/Render.hs view
@@ -61,6 +61,7 @@ let verticesFrom (x:y:vs) = GL.Vertex3 x y z : verticesFrom vs verticesFrom [] = [] loadAttrs . attribs $ prim+ GL.pointSize $= (realToFrac . alinewidth . attribs $ prim) GL.color . colourToGL . afillRGBA . attribs $ prim GL.withName (GL.Name iid) . GL.renderPrimitive GL.Points . mapM_ GL.vertex . verticesFrom $ vdata @@ -100,9 +101,9 @@ ,GL.Vertex3 (x+w) (y+h) z ,GL.Vertex3 x (y+h) z ,GL.Vertex3 x y z]- - ++ renderCompiledGeometry z obj@(CompiledImage original x y w h tex iid) = do GL.textureFunction $= GL.Replace GL.color $ GL.Color4 1 1 1 (1::Double)@@ -114,6 +115,8 @@ GL.lineSmooth $= GL.Disabled GL.polygonSmooth $= GL.Disabled ++ GL.withName (GL.Name iid) . GL.renderPrimitive GL.Quads $ do GL.texCoord $ GL.TexCoord2 0 (1::Double) GL.vertex $ GL.Vertex3 x y z@@ -130,7 +133,7 @@ renderObject z obj | afilled (attribs . original $ obj) = GL.preservingMatrix $ do- + GL.textureBinding GL.Texture2D $= Nothing loadAttrs (attribs . original $ obj ) GL.color . colourToGL . afillRGBA . attribs . original $ obj@@ -138,7 +141,7 @@ GL.color . colourToGL . astrokeRGBA . attribs . original $ obj when (aoutlined (attribs . original $ obj)) $ (GL.withName (GL.Name (uid obj)) . GL.renderPrimitive GL.LineStrip . mapM_ GL.vertex . verticesFrom . drop 2 $ vertices obj) | otherwise = GL.preservingMatrix $ do- + loadAttrs (attribs . original $ obj) GL.color . colourToGL . astrokeRGBA . attribs . original $ obj GL.withName (GL.Name (uid obj)) . GL.renderPrimitive GL.LineStrip . mapM_ GL.vertex . verticesFrom . drop 2 $ vertices obj@@ -149,14 +152,7 @@ loadAttrs attrs = GL.preservingMatrix $ do- GL.lineWidth $= (realToFrac . alinewidth $ attrs)- GL.matrixMode $= GL.Modelview 0- GL.loadIdentity- GL.translate $ GL.Vector3 (atranslatex attrs) (atranslatey attrs) 0- GL.scale (ascalex attrs) (ascaley attrs) 1- GL.rotate (arotation attrs) $ GL.Vector3 0 0 1- GL.lineSmooth $= GL.Enabled- GL.polygonSmooth $= GL.Enabled+ return () -- TODO support line cap -- TODO support line join -- TODO support miter limit@@ -167,15 +163,19 @@ -- TODO support pattern fill rule -getGeo (Buster.EOther (Geometry x)) = Just x-getGeo _ = Nothing+getGeo (Geometry x) = x+getGeo _ = [] render runtime geo = Gtk.withGLDrawingArea (drawarea runtime) $ \drawable -> do+ ctx <- Gtk.glDrawingAreaGetGLContext ( drawarea runtime )+ Gtk.glDrawableGLBegin drawable ctx GL.drawBuffer $= GL.BackBuffers (GL.Position px py, GL.Size sx sy ) <- GL.get GL.viewport GL.matrixMode $= GL.Projection GL.loadIdentity- GL.ortho 0 (fromIntegral sx) 0 (fromIntegral sy) 1 2+ 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@@ -184,18 +184,43 @@ GL.lineSmooth $= GL.Enabled GL.polygonSmooth $= GL.Enabled GL.pointSmooth $= GL.Enabled- r' <- renderObjects [1::Double,2..] (sort geo) runtime+ r' <- renderObjects Nothing [1::Double,2..] (sort geo) runtime Gtk.glDrawableSwapBuffers drawable+ Gtk.glDrawableGLEnd drawable return r'{ texture_blacklist = [] } -renderObjects (z:zs) (o:os) !r = renderObj ((-2) + z/(z+1)) o r >>= renderObjects zs os-renderObjects _ [] r = return r+renderObjects isSelection (z:zs) (o:os) !r = renderObj isSelection ((-2) + z/(z+1)) o r >>= renderObjects isSelection zs os+renderObjects _ _ [] r = return r -renderObj :: Double -> Primitive -> HieroglyphGLRuntime -> IO HieroglyphGLRuntime-renderObj z obj runtime = do+renderObj :: Maybe (Double,Double) -> Double -> Primitive -> HieroglyphGLRuntime -> IO HieroglyphGLRuntime+renderObj isSelection z obj runtime = do (runtime',cg0) <- compile runtime obj+ let attrs = attribs obj+ GL.lineWidth $= (realToFrac . alinewidth $ attrs)+ GL.matrixMode $= GL.Modelview 0+ GL.loadIdentity+ GL.translate $ GL.Vector3 (atranslatex attrs) (atranslatey attrs) 0+ GL.scale (ascalex attrs) (ascaley attrs) 1+ GL.rotate (arotation attrs) $ GL.Vector3 0 0 1+ GL.lineSmooth $= GL.Enabled+ GL.polygonSmooth $= GL.Enabled++ when ((isJust (ortho runtime)) && (astatic (attribs obj))) $ do+ GL.matrixMode $= GL.Projection+ GL.loadIdentity+ (p,GL.Size rx ry) <- GL.get GL.viewport+ maybe (return ()) (\(selx,sely) -> GL.pickMatrix (selx-2, (fromIntegral ry)-sely+2) (6,6) (p, GL.Size rx ry)) isSelection+ GL.ortho 0 (fromIntegral rx) 0 (fromIntegral ry) 1 2+ renderCompiledGeometry z cg0++ when ((isJust (ortho runtime)) && (astatic (attribs obj))) $ do+ GL.matrixMode $= GL.Projection+ GL.loadIdentity+ let (a,b,c,d) = fromJust (ortho runtime) in GL.ortho a b c d 1 2+ GL.matrixMode $= GL.Modelview 0+ return runtime'{ namemap=Map.insert (uid cg0) (fromMaybe "" . aname . attribs . original $ cg0) (namemap runtime') }
Graphics/Rendering/Hieroglyph/Primitives.hs view
@@ -186,6 +186,7 @@ , indent :: Double , attribs :: Attributes , spacing :: Double+ , background :: Maybe (AlphaColour Double) , sig :: Int } -- | Not a primitive shape, exactly, but the union of several primitives. No order is implied in a union, merely that the areas that intersect are@@ -242,6 +243,7 @@ , lod :: Int -- ^ The level of detail that this primitive is at. Use Graphics.Rendering.Hieroglyph.Visual.moreSpecific , updated :: Bool , styleselector :: Maybe String+ , astatic :: Bool } deriving (Show,Read,Eq) @@ -275,7 +277,7 @@ lineordering (Spline _ _ _) = 1 lineordering (EndPoint _) = 2 comparePrimitives (Rectangle o w h _ _) (Rectangle o' w' h' _ _) = fromMaybe EQ (find (/=EQ) [compare o o', compare w w', compare h h'])-comparePrimitives (Text s b _ _ _ _ _ _ _ _) (Text s' b' _ _ _ _ _ _ _ _) = fromMaybe EQ (find (/=EQ) [compare s s', compare b b'])+comparePrimitives (Text s b _ _ _ _ _ _ _ _ _) (Text s' b' _ _ _ _ _ _ _ _ _) = fromMaybe EQ (find (/=EQ) [compare s s', compare b b']) comparePrimitives (Union p _ _) (Union p' _ _) = fromMaybe EQ . find (/=EQ) . map (uncurry compare) $ zip p p' comparePrimitives (Image f d p _ _) (Image f' d' p' _ _) = fromMaybe EQ . find (/=EQ) $ [compare f f', compare d d', compare p p'] comparePrimitives a b = compare (primitiveOrdering a) (primitiveOrdering b)@@ -286,7 +288,7 @@ primitiveOrdering (Arc _ _ _ _ _ _ _) = 1 primitiveOrdering (Path _ _ _ _ _) = 2 primitiveOrdering (Rectangle _ _ _ _ _) = 3-primitiveOrdering (Text _ _ _ _ _ _ _ _ _ _) = 4+primitiveOrdering (Text{}) = 4 primitiveOrdering (Union _ _ _) = 5 primitiveOrdering (Image _ _ _ _ _) = 6 primitiveOrdering (Hidden _ _) = 7@@ -364,8 +366,9 @@ , layer = 0 , lod = 0 , aname = Nothing- , updated = True - , styleselector = Nothing }+ , updated = True+ , styleselector = Nothing+ , astatic = False } -- | See pango span tag@@ -422,6 +425,9 @@ origin :: Point origin = Point 0 0 +points :: Primitive+points = sign $ Dots [] plain 0+ arc :: Primitive -- ^ A unit circle by default, modifiable with record syntax. arc = sign $ Arc origin 1 0 (2*pi) False plain 0 @@ -435,7 +441,7 @@ rectangle = sign $ Rectangle (Point 0 1) 1 1 plain 0 string :: Primitive -- ^ A rendered string starting at the origin.-string = sign $ Text empty origin AlignLeft Nothing WrapWholeWords False 0 plain{ afilled=True } 0 0+string = sign $ Text empty origin AlignLeft Nothing WrapWholeWords False 0 plain{ afilled=True } 0 Nothing 0 compound :: Primitive -- ^ An outlined compound object compound = sign $ Union [] plain 0@@ -449,8 +455,8 @@ image :: Primitive -- ^ An image. These are efficiently cached where possible image = sign $ Image "" (Left origin) False plain 0 -textExtents context txt = unsafePerformIO $ do - layout <- layoutEmpty context +textExtents context txt = unsafePerformIO $ do+ layout <- layoutEmpty context layoutSetMarkup layout . render . str $ txt layoutSetAlignment layout . align $ txt layoutSetJustify layout . justify $ txt
Graphics/Rendering/Hieroglyph/Stylesheets.hs view
@@ -1,21 +1,21 @@ module Graphics.Rendering.Hieroglyph.Stylesheets where- + import Graphics.Rendering.Hieroglyph.Primitives import Graphics.Rendering.Hieroglyph.Visual import Data.Map (Map) import qualified Data.Map as Map- + type Style = BaseVisual -> BaseVisual -data Styling = +data Styling = StyleSelector String Style | ArcStyle Style | DotsStyle Style | PathStyle Style | RectStyle Style | TextStyle Style- -data Stylesheet = Stylesheet ++data Stylesheet = Stylesheet { selectors :: Map String Style , arcstyle :: Style , dotstyle :: Style@@ -24,33 +24,33 @@ , textstyle :: Style } -data BaseSel = - IsArc (Maybe String) - | IsDots (Maybe String) +data BaseSel =+ IsArc (Maybe String)+ | IsDots (Maybe String) | IsPath (Maybe String) | IsRect (Maybe String) | IsText (Maybe String) | IsRest (Maybe String) deriving (Ord,Eq)- -stylesheet styles = foldr mkStylesheet' (Stylesheet Map.empty id id id id id) styles ++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 } mkStylesheet' (PathStyle s) ss = ss{ pathstyle = s } 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)) ++binHelper p k = maybe+ (k Nothing,p)+ (\s -> (k (Just s),p)) (styleselector . attribs $ p)- -bin p@(Dots _ _ _) = binHelper p IsDots-bin p@(Arc _ _ _ _ _ _ _) = binHelper p IsArc-bin p@(Path _ _ _ _ _) = binHelper p IsPath-bin p@(Rectangle _ _ _ _ _) = binHelper p IsRect-bin p@(Text _ _ _ _ _ _ _ _ _ _) = binHelper p IsText++bin p@(Dots{}) = binHelper p IsDots+bin p@(Arc{}) = binHelper p IsArc+bin p@(Path{}) = binHelper p IsPath+bin p@(Rectangle{}) = binHelper p IsRect+bin p@(Text{}) = binHelper p IsText bin p = binHelper p IsRest styledPrims ss = style ss . primitives
Graphics/Rendering/Hieroglyph/Visual.hs view
@@ -171,4 +171,5 @@ style :: Visual a => String -> a -> BaseVisual style s os = (\o -> o{ styleselector=Just s }) <%> primitives os -+static :: Visual a => Bool -> a -> BaseVisual+static s os = (\o -> o{ astatic=s }) <%> primitives os
Hieroglyph.cabal view
@@ -1,15 +1,15 @@ name: Hieroglyph-version: 3.5+version: 3.8 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 <=5,- buster >=2.0, bytestring -any, cairo -any, colour -any,- containers -any, gtk -any, gtkglext -any, mtl -any, parallel -any,- pretty -any, random -any, glib -any, buster-gtk -any+build-depends: IfElse -any, OpenGL -any, array -any, base == 4.1.0.0,+ buster >=2.0, buster-gtk -any, bytestring -any, cairo -any,+ colour -any, containers -any, glib -any, gtk -any, gtkglext -any,+ mtl -any, parallel -any, pretty -any, random -any stability: homepage: http://vis.renci.org/jeff/hieroglyph package-url:@@ -22,18 +22,18 @@ tested-with: data-files: data-dir: ""-extra-source-files: +extra-source-files: extra-tmp-files:-exposed-modules: Graphics.Rendering.Hieroglyph- Graphics.Rendering.Hieroglyph.Cairo+exposed-modules: App.Widgets.MouseKeyboard+ Graphics.Rendering.Hieroglyph Graphics.Rendering.Hieroglyph.Cairo Graphics.Rendering.Hieroglyph.OpenGL+ Graphics.Rendering.Hieroglyph.Cache Graphics.Rendering.Hieroglyph.Primitives Graphics.Rendering.Hieroglyph.Visual- Graphics.Rendering.Hieroglyph.OpenGL.Data- Graphics.Rendering.Hieroglyph.OpenGL.Render - Graphics.Rendering.Hieroglyph.OpenGL.Compile - Graphics.Rendering.Hieroglyph.Cache Graphics.Rendering.Hieroglyph.Stylesheets+ Graphics.Rendering.Hieroglyph.OpenGL.Render+ Graphics.Rendering.Hieroglyph.OpenGL.Data+ Graphics.Rendering.Hieroglyph.OpenGL.Compile exposed: True buildable: True build-tools: