diff --git a/App/Widgets/MouseKeyboard.hs b/App/Widgets/MouseKeyboard.hs new file mode 100644 --- /dev/null +++ b/App/Widgets/MouseKeyboard.hs @@ -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 () 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 @@ -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 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 @@ -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 () diff --git a/Graphics/Rendering/Hieroglyph/OpenGL/Compile.hs b/Graphics/Rendering/Hieroglyph/OpenGL/Compile.hs --- a/Graphics/Rendering/Hieroglyph/OpenGL/Compile.hs +++ b/Graphics/Rendering/Hieroglyph/OpenGL/Compile.hs @@ -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 diff --git a/Graphics/Rendering/Hieroglyph/OpenGL/Data.hs b/Graphics/Rendering/Hieroglyph/OpenGL/Data.hs --- a/Graphics/Rendering/Hieroglyph/OpenGL/Data.hs +++ b/Graphics/Rendering/Hieroglyph/OpenGL/Data.hs @@ -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 diff --git a/Graphics/Rendering/Hieroglyph/OpenGL/Render.hs b/Graphics/Rendering/Hieroglyph/OpenGL/Render.hs --- a/Graphics/Rendering/Hieroglyph/OpenGL/Render.hs +++ b/Graphics/Rendering/Hieroglyph/OpenGL/Render.hs @@ -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') } 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 @@ -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 diff --git a/Graphics/Rendering/Hieroglyph/Stylesheets.hs b/Graphics/Rendering/Hieroglyph/Stylesheets.hs --- a/Graphics/Rendering/Hieroglyph/Stylesheets.hs +++ b/Graphics/Rendering/Hieroglyph/Stylesheets.hs @@ -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 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 @@ -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 diff --git a/Hieroglyph.cabal b/Hieroglyph.cabal --- a/Hieroglyph.cabal +++ b/Hieroglyph.cabal @@ -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: