Skip to content
Browse files

Added project files

  • Loading branch information...
1 parent e6f146f commit 75dc5b4af084b19fa57e23df92314b83668d4c4e @JeffHeard committed Aug 27, 2009
Showing with 15,922 additions and 0 deletions.
  1. +67 −0 App/Widgets/MouseKeyboard.hs
  2. +64 −0 App/Widgets/MouseKeyboardGLUT.hs
  3. +7 −0 Graphics/Rendering/Hieroglyph.hs
  4. +143 −0 Graphics/Rendering/Hieroglyph/Cache.hs
  5. +252 −0 Graphics/Rendering/Hieroglyph/Cairo.hs
  6. +173 −0 Graphics/Rendering/Hieroglyph/GLUT.hs
  7. +194 −0 Graphics/Rendering/Hieroglyph/OpenGL.hs
  8. +170 −0 Graphics/Rendering/Hieroglyph/OpenGL/Behaviours.hs
  9. +303 −0 Graphics/Rendering/Hieroglyph/OpenGL/Compile.hs
  10. +151 −0 Graphics/Rendering/Hieroglyph/OpenGL/Data.hs
  11. +247 −0 Graphics/Rendering/Hieroglyph/OpenGL/Render.hs
  12. +473 −0 Graphics/Rendering/Hieroglyph/Primitives.hs
  13. +93 −0 Graphics/Rendering/Hieroglyph/Stylesheets.hs
  14. +330 −0 Graphics/Rendering/Hieroglyph/UIBehaviour.hs
  15. +175 −0 Graphics/Rendering/Hieroglyph/Visual.hs
  16. +58 −0 Graphics/UI/Hieroglyph/Cache.hs
  17. +62 −0 Hieroglyph.cabal
  18. +12 −0 IDE.flags
  19. +15 −0 IDE.session
  20. +24 −0 LICENSE
  21. +2 −0 Setup.hs
  22. +294 −0 doc/Graphics-Rendering-Hieroglyph-Cache.html
  23. +615 −0 doc/Graphics-Rendering-Hieroglyph-Cairo.html
  24. +1,456 −0 doc/Graphics-Rendering-Hieroglyph-OpenGL.html
  25. +4,423 −0 doc/Graphics-Rendering-Hieroglyph-Primitives.html
  26. +1,296 −0 doc/Graphics-Rendering-Hieroglyph-Visual.html
  27. +96 −0 doc/Graphics-Rendering-Hieroglyph.html
  28. +294 −0 doc/Graphics-UI-Hieroglyph-Cache.html
  29. BIN doc/Hieroglyph.haddock
  30. +2,232 −0 doc/doc-index.html
  31. +133 −0 doc/haddock-util.js
  32. +267 −0 doc/haddock.css
  33. BIN doc/haskell_icon.gif
  34. +205 −0 doc/index.html
  35. BIN doc/minus.gif
  36. BIN doc/plus.gif
  37. +68 −0 doc/src/Graphics-Rendering-Hieroglyph-Cache.html
  38. +267 −0 doc/src/Graphics-Rendering-Hieroglyph-Cairo.html
  39. +602 −0 doc/src/Graphics-Rendering-Hieroglyph-OpenGL.html
  40. +459 −0 doc/src/Graphics-Rendering-Hieroglyph-Primitives.html
  41. +178 −0 doc/src/Graphics-Rendering-Hieroglyph-Visual.html
  42. +17 −0 doc/src/Graphics-Rendering-Hieroglyph.html
  43. +5 −0 doc/src/hscolour.css
View
67 App/Widgets/MouseKeyboard.hs
@@ -0,0 +1,67 @@
+-- |
+--
+-- 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.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 ()
View
64 App/Widgets/MouseKeyboardGLUT.hs
@@ -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 ()
View
7 Graphics/Rendering/Hieroglyph.hs
@@ -0,0 +1,7 @@
+module Graphics.Rendering.Hieroglyph
+ (module Graphics.Rendering.Hieroglyph.Primitives
+ ,module Graphics.Rendering.Hieroglyph.Visual) where
+
+import Graphics.Rendering.Hieroglyph.Primitives
+import Graphics.Rendering.Hieroglyph.Visual
+
View
143 Graphics/Rendering/Hieroglyph/Cache.hs
@@ -0,0 +1,143 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Data.Caching.Memory.LRU
+-- Copyright : Renaissance Computing Institute
+-- License : BSD3
+--
+-- Maintainer : J.R. Heard
+-- Stability : Beta
+-- Portability : GHC
+--
+-- | A simple in memory LRU cache.
+--
+-----------------------------------------------------------------------------
+
+module Graphics.Rendering.Hieroglyph.Cache where
+
+import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
+
+data Cache k a = Cache
+ { store :: Map.Map k a
+ , times :: IntMap.IntMap k
+ , now :: Int
+ , maxsize :: Int
+ , size :: Int
+ , decimation :: Int } deriving Show
+
+-- | @get key cache@ Gets a value out of the cache. Returns both the value and
+-- an updated cache reflecting that the times have been updated.
+get :: Ord k => k -> Cache k a -> (Cache k a,Maybe a)
+get key cache = (cache',value)
+ where value = Map.lookup key (store cache)
+ cache' = maybe (cache{ now = now cache + 1 })
+ (\_ -> cache{ now = now cache + 1
+ , times = IntMap.insert (now cache) key . IntMap.filter (/=key) . times $ cache })
+ value
+
+-- | @put cache list@. Put a list of key-value pairs in the cache. Returns the udpated cache.
+putList :: Ord k => Cache k a -> [(k,a)] -> Cache k a
+putList = foldr (\(a,b) m -> put a b m)
+
+-- | @put key value cache@. Put a value in the cache by key. If the key already exists, the
+-- value for that key will be replaced. If the cache is full, some values will drop off the
+-- end of it silently.
+put :: Ord k => k -> a -> Cache k a -> Cache k a
+put key value cache
+ | size cache < maxsize cache && (not $ Map.member key (store cache)) = cache
+ { now = now cache + 1
+ , times = IntMap.insert (now cache) key . times $ cache
+ , store = Map.insert key value (store cache)
+ , size = size cache + 1 }
+ | size cache < maxsize cache = cache
+ { now = now cache + 1
+ , times = IntMap.insert (now cache) key . IntMap.filter (/=key) . times $ cache
+ , store = Map.insert key value (store cache) }
+ | size cache >= maxsize cache && (Map.member key (store cache)) = cache
+ { now = now cache + 1
+ , times = IntMap.insert (now cache) key . IntMap.filter (/=key) . times $ cache
+ , store = Map.insert key value (store cache) }
+ | size cache >= maxsize cache = cache
+ { now = now cache + 1
+ , times = IntMap.insert (now cache) key times'
+ , store = Map.insert key value store'
+ , size = size cache - decimation cache }
+ where times' = foldr IntMap.delete (times cache) lowtimes
+ (lowtimes,lowtimekeys) = unzip . take (decimation cache) . IntMap.toAscList . times $ cache
+ store' = foldr Map.delete (store cache) lowtimekeys
+
+-- | @put' key value cache@. Put a key in the cache. If the cache is full, then
+-- a number of values will be expunged from the cache. Those values will be
+-- returned as the first value in the pair of (values expunged, updated cache)
+put' :: Ord k => k -> a -> Cache k a -> ([a], Cache k a)
+put' key value cache
+ | size cache < maxsize cache && (not $ Map.member key (store cache)) = ([] ,cache
+ { now = now cache + 1
+ , times = IntMap.insert (now cache) key . times $ cache
+ , store = Map.insert key value (store cache)
+ , size = size cache + 1 })
+ | size cache < maxsize cache = ([] ,cache
+ { now = now cache + 1
+ , times = IntMap.insert (now cache) key . IntMap.filter (/=key) . times $ cache
+ , store = Map.insert key value (store cache) })
+ | size cache >= maxsize cache && (Map.member key (store cache)) = ([] ,cache
+ { now = now cache + 1
+ , times = IntMap.insert (now cache) key . IntMap.filter (/=key) . times $ cache
+ , store = Map.insert key value (store cache) })
+ | size cache >= maxsize cache = (freed, cache
+ { now = now cache + 1
+ , times = IntMap.insert (now cache) key times'
+ , store = Map.insert key value store'
+ , size = size cache - decimation cache })
+ where times' = foldr IntMap.delete (times cache) lowtimes
+ (lowtimes,lowtimekeys) = unzip . take (decimation cache) . IntMap.toAscList . times $ cache
+ store' = foldr Map.delete (store cache) lowtimekeys
+ freed = map (store cache Map.!) lowtimekeys
+
+-- | @free cache@. Frees a single value from the cache. If the cache is empty,
+-- free will error out, so be sure ot check isEmpty first.
+free :: Ord k => Cache k a -> ((k,a),Cache k a)
+free cache =
+ ( (minkey,minval)
+ , cache' )
+ where minkey = IntMap.findMin (times cache)
+ minval = store cache Map.! minkey
+ cache' = cache{ now = now cache + 1
+ , times = IntMap.deleteMin (times cache)
+ , store = Map.delete minkey (store cache)
+ , size = size cache - 1 }
+
+freeN :: Ord k => Int -> Cache k a -> ([(k,a)], Cache k a)
+freeN n cache = (zip lowtimekeys freed, cache{
+ now = now cache + 1
+ , times = times'
+ , store = store'
+ , size = size cache - n })
+ where times' = foldr IntMap.delete (times cache) lowtimes
+ (lowtimes,lowtimekeys) = unzip . take (decimation cache) . IntMap.toAscList . times $ cache
+ store' = foldr Map.delete (store cache) lowtimekeys
+ freed = map (store cache Map.!) lowtimekeys
+
+
+-- | @empty maxsize decimationk@ Creates a new empty cache with maximum size /maxsize/
+-- and the number of keys to remove upon /putting/ to a full cache equal to /decimationk/.
+empty :: Int -> Int -> Cache k a
+empty mxsz dec = Cache Map.empty IntMap.empty 0 mxsz 0 dec
+
+-- | membership test for a key
+member :: Ord k => k -> Cache k a -> Bool
+member key cache = Map.member key (store cache)
+
+-- | get all keys in the cache
+keys :: Ord k => Cache k a -> [k]
+keys = Map.keys . store
+
+-- | get all values in the cache
+elems :: Ord k => Cache k a -> [a]
+elems = Map.elems . store
+
+-- | check to see if the cache is empty
+null :: Ord k => Cache k a -> Bool
+null x = Map.null . store $ x
+
View
252 Graphics/Rendering/Hieroglyph/Cairo.hs
@@ -0,0 +1,252 @@
+-- |
+-- Module : Graphics.Rendering.Hieroglyph.Cairo
+-- Copyright : (c) Renaissance Computing Institute 2009
+-- License : BSD3
+--
+--
+-- [@Author@] Jeff Heard
+--
+-- [@Copyright@] &copy; 2008 Renaissance Computing Institute
+--
+-- [@License@] A LICENSE file should be included as part of this distribution
+--
+-- [@Version@] 0.5
+--
+module Graphics.Rendering.Hieroglyph.Cairo where
+
+import qualified Graphics.Rendering.Hieroglyph.Cache as Cache
+import qualified Data.Set as Set
+import qualified Graphics.UI.Gtk.Cairo as Gtk
+import Graphics.UI.Gtk.Pango.Context
+import Graphics.UI.Gtk.Pango.Layout
+import Data.Map (Map)
+import qualified Data.Map as M
+import System.Mem.Weak
+import Control.Concurrent
+import Control.Monad.Trans (liftIO)
+import Graphics.Rendering.Hieroglyph.Primitives
+import Graphics.Rendering.Hieroglyph.Visual
+import Graphics.UI.Gtk.Gdk.Pixbuf
+import qualified Graphics.UI.Gtk.Cairo as Cairo
+import qualified Graphics.Rendering.Cairo as Cairo
+import Control.Monad
+import Control.Monad.IfElse
+import Data.Foldable (foldlM)
+import Data.List (sort)
+import Data.Colour
+import Data.Colour.SRGB
+import Data.Colour.Names (black)
+import qualified Text.PrettyPrint as Pretty
+
+type ImageCache = MVar (Cache.Cache Primitive Pixbuf)
+
+
+toCairoAntialias AntialiasDefault = Cairo.AntialiasDefault
+toCairoAntialias AntialiasNone = Cairo.AntialiasNone
+toCairoAntialias AntialiasGray = Cairo.AntialiasGray
+toCairoAntialias AntialiasSubpixel = Cairo.AntialiasSubpixel
+
+toCairoFillRule FillRuleWinding = Cairo.FillRuleWinding
+toCairoFillRule FillRuleEvenOdd = Cairo.FillRuleEvenOdd
+
+toCairoLineCap LineCapButt = Cairo.LineCapButt
+toCairoLineCap LineCapRound = Cairo.LineCapRound
+toCairoLineCap LineCapSquare = Cairo.LineCapSquare
+
+toCairoLineJoin LineJoinMiter = Cairo.LineJoinMiter
+toCairoLineJoin LineJoinRound = Cairo.LineJoinRound
+toCairoLineJoin LineJoinBevel = Cairo.LineJoinBevel
+
+toCairoOperator OperatorClear = Cairo.OperatorClear
+toCairoOperator OperatorSource = Cairo.OperatorSource
+toCairoOperator OperatorOver = Cairo.OperatorOver
+toCairoOperator OperatorIn = Cairo.OperatorIn
+toCairoOperator OperatorOut = Cairo.OperatorOut
+toCairoOperator OperatorAtop = Cairo.OperatorAtop
+toCairoOperator OperatorDest = Cairo.OperatorDest
+toCairoOperator OperatorXor = Cairo.OperatorXor
+toCairoOperator OperatorAdd = Cairo.OperatorAdd
+toCairoOperator OperatorSaturate = Cairo.OperatorSaturate
+
+colourToTuple :: AlphaColour Double -> (Double,Double,Double,Double)
+colourToTuple c = (r,g,b,alpha)
+ where alpha = alphaChannel c
+ c' = (1/alpha) `darken` (c `Data.Colour.over` black)
+ RGB r g b = toSRGB c'
+
+
+fillStrokeAndClip state action = do
+ let (fr,fg,fb,fa) = colourToTuple . afillRGBA $ state
+ (sr,sg,sb,sa) = colourToTuple . astrokeRGBA $ state
+ when (afilled state) $ Cairo.setSourceRGBA fr fg fb fa >> action >> Cairo.fill
+ when (aoutlined state) $ Cairo.setSourceRGBA sr sg sb sa >> action >> Cairo.stroke
+ when (aclipped state) $ Cairo.clip
+
+renderCurveSegs (Line (Point x0 y0)) = Cairo.lineTo x0 y0
+renderCurveSegs (EndPoint (Point x0 y0)) = Cairo.moveTo x0 y0
+renderCurveSegs (Spline (Point x0 y0) (Point x1 y1) (Point x2 y2)) = Cairo.curveTo x0 y0 x1 y1 x2 y2
+
+-- | @renderPrimitive state prim@ draws a single primitive.
+renderPrimitive :: PangoContext -> ImageCache -> Attributes -> Primitive -> Cairo.Render Attributes
+renderPrimitive _ _ s0 (Arc (Point cx cy) radius angle0 angle1 isnegative state _) = do
+ applyAttributeDelta s0 state
+ fillStrokeAndClip state $
+ if isnegative then Cairo.arcNegative cx cy radius angle0 angle1 else Cairo.arc cx cy radius angle0 angle1
+ return state
+
+renderPrimitive _ _ s0 (Dots ats attrs sig) = do
+ applyAttributeDelta s0 attrs
+ fillStrokeAndClip attrs $ do
+ forM_ ats $ \(Point ox oy) -> do
+ Cairo.moveTo ox oy
+ Cairo.arc ox oy (alinewidth attrs) 0 (2*pi)
+ return attrs
+
+renderPrimitive _ _ s0 (Path (Point ox oy) segs isclosed state _) = do
+ applyAttributeDelta s0 state
+ fillStrokeAndClip state $ do
+ Cairo.moveTo ox oy
+ forM_ segs $ renderCurveSegs
+ when isclosed (Cairo.lineTo ox oy)
+ return state
+
+renderPrimitive _ images s0 i@(Image filename (Left (Point ox oy)) _ state _) = do
+ applyAttributeDelta s0 state
+ pbuf <- loadImage images i
+ w <- liftIO $ pixbufGetWidth pbuf
+ h <- liftIO $ pixbufGetHeight pbuf
+ Cairo.save
+ Cairo.setSourcePixbuf pbuf ox oy
+ Cairo.rectangle ox oy (fromIntegral w) (fromIntegral h)
+ Cairo.fill
+ Cairo.restore
+ return state
+
+renderPrimitive _ images s0 i@(Image filename (Right (Rect ox oy w h)) _ state _) = do
+ applyAttributeDelta s0 state
+ pbuf <- loadImage images i
+ Cairo.save
+ Cairo.setSourcePixbuf pbuf ox oy
+ Cairo.rectangle ox oy w h
+ Cairo.fill
+ Cairo.restore
+ return state
+
+renderPrimitive _ _ s0 (Hidden _ _) = return s0
+renderPrimitive _ _ s0 (Rectangle (Point ox oy) w h state _) = do
+ applyAttributeDelta s0 state
+ fillStrokeAndClip state $ Cairo.rectangle ox oy w h
+ return state
+
+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
+ layoutSetJustify layout . justify $ txt
+ layoutSetWidth layout . wrapwidth $ txt
+ layoutSetWrap layout . wrapmode $ txt
+ layoutSetIndent layout . indent $ txt
+ return layout
+ applyAttributeDelta s0 (attribs txt)
+ fillStrokeAndClip (attribs txt) $ do
+ Cairo.moveTo ox oy
+ Cairo.showLayout layout
+ return (attribs txt)
+
+renderPrimitive context images s0 (Union prims state _) = do
+ let unfoc prim = prim{ attribs = (attribs prim){afilled=False, aoutlined=False, aclipped=False } }
+ applyAttributeDelta s0 state
+ fillStrokeAndClip state $ forM_ prims (renderPrimitive context images state . unfoc)
+ return state
+
+render context images d = loadStateIntoCairo attrs0
+ >> (foldlM (renderPrimitive context images) attrs0 . sort $ vis)
+ >> return ()
+ where vis = sort $ primitives d
+ attrs0 = attribs . head $ vis
+
+applyAttributeDelta a b = do
+ let different f = ((f %=> (/=)) a b)
+ whendifferent f = when (different f)
+ whendifferent afillrule . Cairo.setFillRule . toCairoFillRule . afillrule $ b
+ whendifferent adash . maybe (return ()) (uncurry Cairo.setDash) . adash $ b
+ whendifferent aantialias . Cairo.setAntialias . toCairoAntialias . aantialias $ b
+ whendifferent alinewidth . Cairo.setLineWidth . alinewidth $ b
+ whendifferent alinecap . Cairo.setLineCap . toCairoLineCap . alinecap $ b
+ whendifferent alinejoin . Cairo.setLineJoin . toCairoLineJoin . alinejoin $ b
+ whendifferent amiterlimit . Cairo.setMiterLimit . amiterlimit $ b
+ whendifferent atolerance . Cairo.setTolerance . atolerance $ b
+ whendifferent aoperator . Cairo.setOperator . toCairoOperator . aoperator $ b
+ when (different ascalex || different ascaley || different arotation || different atranslatex || different atranslatey) $ do
+ Cairo.translate (atranslatex b) (atranslatey b)
+ Cairo.scale (ascalex b) (ascaley b)
+ Cairo.rotate (arotation b)
+ return b
+
+-- | Load the Cairo state with a 'RenderState' Drawing.
+loadStateIntoCairo :: Attributes -> Cairo.Render ()
+loadStateIntoCairo s = do
+ Cairo.setFillRule . toCairoFillRule . afillrule $ s
+ awhen (adash s) $ \(a,b) -> Cairo.setDash a b
+ Cairo.setAntialias . toCairoAntialias . aantialias $ s
+
+ Cairo.setLineJoin . toCairoLineJoin . alinejoin $ s
+ Cairo.setLineWidth . alinewidth $ s
+ Cairo.setMiterLimit . amiterlimit $ s
+ Cairo.setTolerance . atolerance $ s
+ Cairo.setOperator . toCairoOperator . aoperator $ s
+
+ Cairo.translate (atranslatex s) (atranslatey s)
+ Cairo.scale (ascalex s) (ascaley s)
+ Cairo.rotate (arotation s)
+
+-- | @renderFrameToSurface surface frame@ renders a frame to a particular surface
+renderToSurfaceWithImageCache :: Visual t => PangoContext -> ImageCache -> Cairo.Surface -> t -> IO ()
+renderToSurfaceWithImageCache context images surf frame = Cairo.renderWith surf (render context images frame)
+
+renderToSurface :: Visual t => PangoContext -> Cairo.Surface -> t -> IO ()
+renderToSurface c s o = do { i <- newMVar (Cache.empty 1024 33) ;renderToSurfaceWithImageCache c i s o }
+
+-- | @renderframeToPNGWithImageCache filename xres yres frame@ renders a frame to an image file
+renderToPNGWithImageCache :: Visual t => PangoContext -> ImageCache -> FilePath -> Int -> Int -> t -> IO ()
+renderToPNGWithImageCache c images filename xres yres frame = Cairo.withImageSurface Cairo.FormatARGB32 xres yres $ \s -> renderToSurfaceWithImageCache c images s frame >> Cairo.surfaceWriteToPNG s filename
+renderToPNG f w h o = do { c <- Gtk.cairoCreateContext Nothing ; i <- newMVar (Cache.empty 1024 33) ; renderToPNGWithImageCache c i f w h o }
+
+-- | @renderToPDFWithImageCache filename width height frame@ renders a frame to a PDF file. width and height are in points.
+renderToPDFWithImageCache :: Visual t => PangoContext -> ImageCache -> FilePath -> Double -> Double -> t -> IO ()
+renderToPDFWithImageCache c images filename width height frame = Cairo.withPDFSurface filename width height $ \s -> renderToSurfaceWithImageCache c images s frame
+renderToPDF f w h o = do { c <- Gtk.cairoCreateContext Nothing ; i <- newMVar (Cache.empty 1024 33) ; renderToPDFWithImageCache c i f w h o }
+
+-- | @renderToPostscriptWithImageCache filename width height frame@ renders a frame to a Postscript file. width and height are in points.
+renderToPostscriptWithImageCache :: Visual t => PangoContext -> ImageCache -> FilePath -> Double -> Double -> t -> IO ()
+renderToPostscriptWithImageCache c images filename width height frame = Cairo.withPSSurface filename width height $ \s -> renderToSurfaceWithImageCache c images s frame
+renderToPostscript f w h o = do { c <- Gtk.cairoCreateContext Nothing ; i <- newMVar (Cache.empty 1024 33) ; renderToPostscriptWithImageCache c i f w h o }
+
+-- | @renderToSVGWithImageCache filename width height frame@ renders a frame to a SVG file. width and height are in points.
+renderToSVGWithImageCache :: Visual t => PangoContext -> ImageCache -> FilePath -> Double -> Double -> t -> IO ()
+renderToSVGWithImageCache c images filename width height frame = Cairo.withSVGSurface filename width height $ \s -> renderToSurfaceWithImageCache c images s frame
+renderToSVG f w h o = do { c <- Gtk.cairoCreateContext Nothing ; i <- newMVar (Cache.empty 1024 33) ; renderToSVGWithImageCache c i f w h o }
+
+-- | @loadImage dictRef image@ pulls an image out of the cache's hat.
+loadImage :: ImageCache -> Primitive -> Cairo.Render (Pixbuf)
+loadImage dictRef im@(Image filename (Right (Rect x y w h)) aspect _ _) = do
+ liftIO $ modifyMVar dictRef $ \dict ->
+ if im `Cache.member` dict
+ then do let (cache',value) = Cache.get im dict
+ pbuf <- case value of
+ Just pb -> return pb
+ Nothing -> pixbufNewFromFileAtScale filename (round w) (round h) aspect
+ return (cache',pbuf)
+ else do pbuf <- pixbufNewFromFileAtScale filename (round w) (round h) aspect
+ return ((Cache.put im pbuf dict), pbuf)
+loadImage dictRef im@(Image filename (Left (Point x y)) _ _ _) = do
+ liftIO $ modifyMVar dictRef $ \dict ->
+ if im `Cache.member` dict
+ then do let (cache',value) = Cache.get im dict
+ pbuf <- case value of
+ Just pb -> return pb
+ Nothing -> pixbufNewFromFile filename
+ return (dict,pbuf)
+ else do pbuf <- pixbufNewFromFile filename
+ return ((Cache.put im pbuf dict), pbuf)
+
View
173 Graphics/Rendering/Hieroglyph/GLUT.hs
@@ -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 "Hieroglyph"
+ 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 ()
+
View
194 Graphics/Rendering/Hieroglyph/OpenGL.hs
@@ -0,0 +1,194 @@
+{-# LANGUAGE BangPatterns #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Graphics.Rendering.Hieroglyph.OpenGL
+-- Copyright : Renassance Computing Institute 2009
+-- License : BSD3
+--
+-- Maintainer : J.R. Heard
+-- Stability :
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Graphics.Rendering.Hieroglyph.OpenGL
+ ( 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.MouseKeyboard
+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
+
+-- | 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 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 = bindMouseKeyboardWidget (Gtk.castToWidget (window glarea))
+ 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
+ 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 $ []
+
+
+-- | 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
+
+
+
+-- | Widget for initializing the bus
+initializeBus :: VisualEventData a => String -> Int -> Int -> Buster.Widget a
+initializeBus name w h bus = do
+ let numTextures = 512
+ numBufferObjects = 256
+
+ Gtk.unsafeInitGUIForThreadedRTS
+ win <- Gtk.windowNew
+ Gtk.windowSetTitle win name
+ Gtk.widgetSetName win "Hieroglyph"
+ 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.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]
+ return (ts,bs)
+
+ context <- Gtk.cairoCreateContext Nothing
+
+ 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
+
+ return ()
View
170 Graphics/Rendering/Hieroglyph/OpenGL/Behaviours.hs
@@ -0,0 +1,170 @@
+module Graphics.Rendering.Hieroglyph.OpenGL.Behaviours
+
+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 qualified App.Widgets.GtkMouseKeyboard as Buster
+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
+
+-- | Select based on mouse clicks
+mouseSelectionBehaviour :: Buster.Behaviour [Buster.EData HieroglyphGLRuntime]
+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]
+
+
+
+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
+ loop mv = do
+ Gtk.mainContextIteration Gtk.mainContextDefault True
+ Buster.busIteration mv behaviour
+ loop mv
+
+ let mk = Buster.bindMouseKeyboardWidget (Gtk.castToWidget (window glarea))
+ mk evBus
+ loop evBus
+
+
+
+
+
+-- | make Hieroglyph render on the main window exposure
+renderOnExpose :: Buster.Widget [Buster.EData HieroglyphGLRuntime]
+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
+ drawingEs = Set.toList $ Buster.eventsByGroup "Visible" bus
+
+ runtime' <- render runtime drawing
+ Buster.Insertion revent' <- Buster.produce "Hieroglyph" "Hieroglyph" "RenderData" Buster.Persistent [Buster.EOther 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 bus = Buster.consumeFullyQualifiedEventWith bus "Hieroglyph" "Hieroglyph" "Rerender" $ \event -> do
+
+ let Buster.EOther renderdata = head . Buster.eventdata . fromJust $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" bus
+ (w,h) <- Gtk.widgetGetSize (window renderdata)
+ Gtk.widgetQueueDrawArea (window renderdata) 0 0 w h
+
+ 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 :: Buster.Behaviour [Buster.EData HieroglyphGLRuntime]
+selectionBehaviour bus =
+ case selectionRequested of
+ Just sreq -> do -- print "Selection requested"
+ let [Buster.EDouble selx, Buster.EDouble sely] = Buster.eventdata sreq
+ (p, GL.Size sx sy ) <- GL.get GL.viewport
+ GL.matrixMode $= GL.Projection
+ GL.loadIdentity
+ GL.pickMatrix (selx-2, (fromIntegral sy)-sely+2) (6,6) (p, GL.Size sx sy)
+ GL.ortho2D 0 (fromIntegral sx) 0 (fromIntegral sy)
+ (runtime', recs) <- GL.getHitRecords 5 $ renderObjects [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
+ --print names
+ --print names'
+ Buster.produce "Selection" "Hieroglyph" (concat names') Buster.once
+ [Buster.EDouble . realToFrac $ x
+ , Buster.EDouble . realToFrac $ y
+ , Buster.EStringL $ names']
+
+ runtimeE' <- Buster.produce "Hieroglyph" "Hieroglyph" "RenderData" Buster.Persistent [Buster.EOther runtime']
+ 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
+ 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 name w h bus = do
+ let numTextures = 512
+ numBufferObjects = 256
+
+ print "Using latest version of Hieroglyph 1159"
+ Gtk.unsafeInitGUIForThreadedRTS
+ win <- Gtk.windowNew
+ Gtk.windowSetTitle win name
+ Gtk.widgetSetName win "Hieroglyph"
+ Gtk.onDestroy win (exitWith ExitSuccess)
+ Gtk.initGL
+ config <- Gtk.glConfigNew [Gtk.GLModeRGBA, Gtk.GLModeMultiSample, Gtk.GLModeDouble, Gtk.GLModeDepth, Gtk.GLModeAlpha]
+ area <- Gtk.glDrawingAreaNew config
+
+ Gtk.onRealize area $ do
+ GL.drawBuffer $= GL.BackBuffers
+
+ Gtk.windowSetDefaultSize win w h
+ Gtk.containerResizeChildren win
+ Gtk.containerAdd win area
+ Gtk.widgetShowAll win
+ (textures, buffers) <- Gtk.withGLDrawingArea area $ \_ -> do
+ ts <- (GL.genObjectNames numTextures) :: IO [GL.TextureObject]
+ bs <- (GL.genObjectNames numBufferObjects) :: IO [GL.BufferObject]
+ return (ts,bs)
+
+ 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
+
+ Gtk.onExpose area (\_ -> renderOnExpose bus >> return True)
+ return ()
View
303 Graphics/Rendering/Hieroglyph/OpenGL/Compile.hs
@@ -0,0 +1,303 @@
+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Graphics.Rendering.Hieroglyph.OpenGL
+-- Copyright :
+-- License : BSD3
+--
+-- Maintainer : J.R. Heard
+-- Stability :
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Graphics.Rendering.Hieroglyph.OpenGL.Compile where
+
+import Graphics.Rendering.Hieroglyph.OpenGL.Data
+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.Exception
+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 qualified App.Widgets.MouseKeyboard as Buster
+import Data.Colour
+import Data.Colour.Names
+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]]
+
+interleave (x:xs) (y:ys) = x:y:interleave xs ys
+interleave [] _ = []
+interleave _ [] = []
+
+cubic a c0 c1 b ts = fmap interpolateCubic ts
+ where interpolateCubic t = interpolate p20 p21 t
+ where p20 = interpolate p10 p11 t
+ p21 = interpolate p11 p12 t
+ p10 = interpolate a c0 t
+ p11 = interpolate c0 c1 t
+ p12 = interpolate c1 b t
+ interpolate x0 x1 t = x0 + ((x1 - x0)*t)
+
+splineVertices nvertices (Point ax ay) (Point c0x c0y) (Point c1x c1y) (Point bx by) = interleave xs ys
+ where xs = cubic ax c0x c1x bx [m / nvertices' | m <- [0 .. nvertices']]
+ 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
+
+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{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{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-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 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{ 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
+
+nearestPowerOfTwo w h = (log2 $ wf, log2 $ hf)
+ where log2 x = logDouble x / logDouble 2
+ wf = w
+ hf = h
+
+getFreeTexture e = if texture_whitelist e /= []
+ then (e{ texture_whitelist = tail $ texture_whitelist e }, head (texture_whitelist e))
+ else (e{ texture_greylist = c' }, t)
+ where ((_,t),c') = Cache.free . texture_greylist $ e
+
+
+
+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{bottomleft = p', attribs=attrs'} cx' cy' w' h' tex (fromIntegral (sig txt)))
+
+ | otherwise = do
+ let (e', tex) = getFreeTexture e
+
+ layout <- layoutEmpty (context e')
+ layoutSetMarkup layout . Pretty.render . str $ txt
+ layoutSetAlignment layout . align $ txt
+ layoutSetJustify layout . justify $ txt
+ layoutSetWidth layout . wrapwidth $ txt
+ layoutSetWrap layout . wrapmode $ txt
+ layoutSetIndent layout . indent $ txt
+ (PangoRectangle _ _ _ _, PangoRectangle ex ey ew eh) <- layoutGetExtents layout
+ let (po2w,po2h) = nearestPowerOfTwo ew eh
+ potw = 2 ^ (max 0 $ ceiling po2w)
+ poth = 2 ^ (max 0 $ ceiling po2h)
+ w = fromIntegral potw
+ h = fromIntegral poth
+ Point x y = bottomleft txt
+
+ textSurface <- Cairo.withImageSurface Cairo.FormatARGB32 potw poth $ \surf -> do
+ Cairo.renderWith surf $ do
+ Cairo.setOperator Cairo.OperatorSource
+ 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
+ Cairo.updateContext (context e')
+ liftIO $ layoutContextChanged layout
+ Cairo.save
+ Cairo.translate (-ex) (-ey)
+ let (fr,fg,fb,fa) = colourToTuple . afillRGBA $ state
+ (sr,sg,sb,sa) = colourToTuple . astrokeRGBA $ state
+ state = attribs txt
+ when (afilled state) $ do
+ Cairo.setSourceRGBA fr fg fb fa
+ Cairo.showLayout layout
+ Cairo.fill
+ when (aoutlined state) $ do
+ Cairo.setSourceRGBA sr sg sb sa
+ Cairo.showLayout layout
+ Cairo.stroke
+ Cairo.restore
+ Cairo.imageSurfaceGetData surf
+
+ 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
+ GL.RGBA'
+ (GL.TextureSize2D (fromIntegral potw) (fromIntegral poth))
+ 0
+ (GL.PixelData GL.BGRA
+ 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{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
+ (_,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)))
+
+ | 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.pixbufNewFromFile (filename img) >>= copydata)
+ if w > 0
+ then do
+ 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.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)
+
+ (_,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)))
+ 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
+ w0 <- Gtk.pixbufGetWidth pbuf0
+ h0 <- Gtk.pixbufGetHeight pbuf0
+ let potw = log (fromIntegral w0) / log (fromIntegral 2)
+ poth = log (fromIntegral h0) / log (fromIntegral 2)
+ w = 2 ^ (max 0 $ ceiling potw)
+ h = 2 ^ (max 0 $ ceiling poth)
+ pbuf <- if w0 == w && h0 == h then return pbuf0 else Gtk.pixbufScaleSimple pbuf0 w h Gtk.InterpBilinear
+
+ channels <- Gtk.pixbufGetNChannels pbuf
+ bpc <- (`quot`8) <$> Gtk.pixbufGetBitsPerSample pbuf
+ pixels <- Gtk.pixbufGetPixels pbuf :: IO (Gtk.PixbufData Int Word8)
+ stride <- Gtk.pixbufGetRowstride pbuf
+ buf <- SB.create (w*h*channels*bpc) $ \ptr ->
+ -- forM_ [0::Int .. h - 1] $ \row -> let stsample = row*stride in
+ -- forM_ [0::Int .. w*channels*bpc-1] $ \sample0 -> let sample = stsample + sample0 in
+ -- A.readArray pixels sample >>= pokeByteOff ptr sample
+ forM_ [0::Int .. w*h*channels*bpc - 1] $ \sample -> A.readArray pixels sample >>= pokeByteOff ptr sample
+ return (w0,h0,w,h,channels,buf)
+
View
151 Graphics/Rendering/Hieroglyph/OpenGL/Data.hs
@@ -0,0 +1,151 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleInstances #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Graphics.Rendering.Hieroglyph.OpenGL
+-- Copyright :
+-- License : BSD3
+--
+-- Maintainer : J.R. Heard
+-- Stability :
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Graphics.Rendering.Hieroglyph.OpenGL.Data 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 Data.Colour
+import Data.Colour.Names
+import Data.Colour.SRGB
+import qualified Text.PrettyPrint as Pretty
+import System.Mem.Weak
+
+data HieroglyphGLRuntime = HgGL {
+ 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
+ , 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)
+
+ , 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
+ (_,sy) <- Gtk.widgetGetSize . Gtk.castToWidget . drawarea . (\(Buster.EOther a) -> a) . head . Buster.eventdata $ renderDataE
+ return (Point x (fromIntegral sy-y))
+
+data CompiledData =
+ CompiledDots
+ { original :: Primitive
+ , vertices :: [Double]
+ , uid :: GLuint }
+ | CompiledArc
+ { original :: Primitive
+ , vertices :: [Double]
+ , uid :: GLuint }
+ | CompiledPath
+ { original :: Primitive
+ , vertices :: [Double]
+ , uid :: GLuint }
+ | CompiledRectangle
+ { original :: Primitive
+ , xx :: Double
+ , yy :: Double
+ , ww :: Double
+ , hh :: Double
+ , uid :: GLuint }
+ | CompiledImage
+ { original :: Primitive
+ , xx :: Double
+ , yy :: Double
+ , ww :: Double
+ , hh :: Double
+ , texture :: GL.TextureObject
+ , uid :: GLuint }
+
+
+texturedObjects (CompiledImage _ _ _ _ _ _ _) = True
+texturedObjects _ = False
+
+colourToTuple :: AlphaColour Double -> (Double,Double,Double,Double)
+colourToTuple c = (r,g,b,alpha)
+ where alpha = alphaChannel c
+ c' = if alpha > 0 then (1/alpha) `darken` (c `Data.Colour.over` black) else black
+ RGB r g b = toSRGB c'
+
+colourToGL :: AlphaColour Double -> GL.Color4 Double
+colourToGL = (\(r,g,b,a) -> GL.Color4 r g b a) . colourToTuple
+
+cacheimg img = show (filename img, {- show $ dimensions img,-} preserveaspect img)
+cachetxt txt = show (show . str $ txt,align txt,wrapwidth txt,wrapmode txt,justify txt,indent txt,spacing txt)
+
View
247 Graphics/Rendering/Hieroglyph/OpenGL/Render.hs
@@ -0,0 +1,247 @@
+{-# LANGUAGE BangPatterns #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Graphics.Rendering.Hieroglyph.OpenGL
+-- Copyright :
+-- License : BSD3
+--
+-- Maintainer : J.R. Heard
+-- Stability :
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+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
+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 qualified App.Widgets.MouseKeyboard as Buster
+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.Compile
+import Graphics.Rendering.Hieroglyph.OpenGL.Data
+
+renderCompiledGeometry z (CompiledDots prim vdata iid) = do
+ 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
+
+renderCompiledGeometry z obj@(CompiledArc _ _ _) =
+ (GL.textureBinding GL.Texture2D $= Nothing) >> renderObject z obj
+
+renderCompiledGeometry z obj@(CompiledPath _ _ _) =
+ (GL.textureBinding GL.Texture2D $= Nothing) >> renderObject z obj
+
+renderCompiledGeometry z obj@(CompiledRectangle prim x y w h iid) = do
+ GL.textureBinding GL.Texture2D $= Nothing
+ loadAttrs attrs
+
+ GL.lineSmooth $= GL.Disabled
+ GL.polygonSmooth $= GL.Disabled
+ GL.color . colourToGL . afillRGBA $ attrs
+
+ when (afilled attrs) .
+ GL.withName (GL.Name iid) .
+ GL.renderPrimitive GL.Quads .
+ mapM_ GL.vertex
+ $ take 4 vertices
+
+ GL.color . colourToGL . astrokeRGBA $ attrs
+ GL.lineSmooth $= GL.Enabled
+ GL.polygonSmooth $= GL.Enabled
+
+ when (aoutlined attrs) .
+ GL.withName (GL.Name iid) .
+ GL.renderPrimitive GL.LineStrip .
+ mapM_ GL.vertex
+ $ vertices
+
+ where attrs = attribs prim
+ vertices = [GL.Vertex3 x y z
+ ,GL.Vertex3 (x+w) y z
+ ,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)
+ GL.texture GL.Texture2D $= GL.Enabled
+ GL.textureBinding GL.Texture2D $= Just tex
+ GL.texture GL.Texture2D $= GL.Enabled
+ GL.textureFunction $= GL.Replace
+
+ 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
+ GL.texCoord $ GL.TexCoord2 1 (1::Double)
+ GL.vertex $ GL.Vertex3 (x+w) y z
+ GL.texCoord $ GL.TexCoord2 1 (0::Double)
+ GL.vertex $ GL.Vertex3 (x+w) (y+h) z
+ GL.texCoord $ GL.TexCoord2 0 (0::Double)
+ GL.vertex $ GL.Vertex3 x (y+h) z
+ GL.flush
+
+ GL.lineSmooth $= GL.Enabled
+ GL.polygonSmooth $= GL.Enabled
+
+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
+ GL.withName (GL.Name (uid obj)) . GL.renderPrimitive GL.TriangleFan . mapM_ GL.vertex . verticesFrom $ vertices obj
+ 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
+
+ where verticesFrom (x:y:vs) = GL.Vertex3 x y z : verticesFrom vs
+ verticesFrom [] = []
+
+
+
+loadAttrs attrs = GL.preservingMatrix $ do
+ return ()
+ -- TODO support line cap
+ -- TODO support line join
+ -- TODO support miter limit
+ -- TODO support trapezoidal tolerance
+ -- TODO support operator
+ -- TODO support antialias
+ -- TODO support dash/stipple
+ -- TODO support pattern fill rule
+
+
+getGeo (Geometry x) = x
+getGeo _ = []
+
+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
+ (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
+ Gtk.glDrawableSwapBuffers drawable
+ Gtk.glDrawableGLEnd drawable
+ return r'{ texture_blacklist = [] }
+
+
+renderObjects isSelection (z:zs) (o:os) !r = renderObj isSelection ((-2) + z/(z+1)) o r >>= renderObjects isSelection zs os
+renderObjects _ _ [] r = return r
+
+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') }
+
View
473 Graphics/Rendering/Hieroglyph/Primitives.hs
@@ -0,0 +1,473 @@
+{-# LANGUAGE BangPatterns, FlexibleContexts, UndecidableInstances, StandaloneDeriving #-}
+-- |
+
+-- 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)
+-- for more information on how to use this library.
+--
+-- [@Author@] Jeff Heard
+--
+-- [@Copyright@] &copy; 2008 Renaissance Computing Institute
+--
+-- [@License@] A LICENSE file should be included as part of this distribution
+--
+-- [@Version@] 0.5
+--
+module Graphics.Rendering.Hieroglyph.Primitives where
+import Graphics.UI.Gtk.Pango.Layout
+
+import Control.Applicative ((<$>))
+
+import System.IO.Unsafe
+import Data.Function (on)
+import Data.Maybe (fromMaybe)
+import Data.List
+import Data.Colour
+import Data.Colour.Names
+import Data.Colour.SRGB
+
+import qualified Data.Map as Map
+import qualified Data.IntMap as IM
+import Text.PrettyPrint (Doc, (<>), (<+>), render, char, empty, text)
+import qualified Text.PrettyPrint
+import qualified Data.HashTable
+import System.Random
+
+deriving instance Eq LayoutWrapMode
+deriving instance Show LayoutWrapMode
+deriving instance Ord LayoutWrapMode
+deriving instance Eq LayoutAlignment
+deriving instance Show LayoutAlignment
+deriving instance Ord LayoutAlignment
+deriving instance Read LayoutWrapMode
+deriving instance Read LayoutAlignment
+
+instance Read Doc where
+ readsPrec i = (\s -> [])
+
+-- | A 2D point
+data Point = Point Double Double deriving (Show, Read, Eq, Ord)
+
+-- | Translate a point horizontally
+xplus :: Double -> Point -> Point
+xplus x (Point a b) = Point (x+a) b
+
+-- | Translate a point vertically
+yplus :: Double -> Point -> Point
+yplus y (Point a b) = Point a (b+y)
+
+pmap f (Point a b) = Point (f a) (f b)
+
+comb f (Point x0 y0) (Point x1 y1) = Point (f x0 x1) (f y0 y1)
+
+instance Num Point where
+ (+) = comb (+)
+ (*) = comb (*)
+ (-) = comb (-)
+ abs = pmap abs
+ signum = pmap signum
+ fromInteger x = let x' = fromInteger x in Point x' x'
+
+instance Fractional Point where
+ (/) = comb (/)
+ fromRational a = Point (fromRational a) (fromRational a)
+
+-- | Find the distance between two points
+dist :: Point -> Point -> Double
+dist (Point x0 y0) (Point x1 y1) = sqrt $ (x1-x0)**2 + (y1-y0)**2
+
+-- | Find the average of a bunch of points
+centroid :: [Point] -> Point
+centroid ps = centroid' (Point 0 0) 0 ps
+centroid' !s !n (p:ps) = centroid' (s+p) (n+1) ps
+centroid' s n [] = s/n
+
+-- | A rectangle for dimensions
+data Rect = Plane | Singularity | Rect { x1 :: Double, y1 :: Double, x2 :: Double, y2 :: Double } deriving (Show, Read, Eq)
+
+-- | A line segment
+data LineSegment = Line Point | Spline Point Point Point | EndPoint Point deriving (Show,Read,Eq)
+
+-- | A convenience function for getting points out of line segments in a path
+ls2pt :: LineSegment -> Point
+ls2pt (Line x) = x
+ls2pt (Spline _ _ x) = x
+ls2pt (EndPoint x) = x
+
+instance Ord LineSegment where
+ compare (Line p) (Line p') = compare p p'
+ compare (EndPoint p) (EndPoint p') = compare p p'
+ compare (Spline p q r) (Spline p' q' r') =
+ fromMaybe EQ
+ . find (/=EQ)
+ . zipWith compare [p,q,r]
+ $ [p',q',r']
+ compare a b = (ordinal %=> compare) a b
+ where ordinal (Line _) = 0
+ ordinal (Spline _ _ _) = 1
+ ordinal (EndPoint _) = 2
+
+instance (Floating a, Ord a) => Ord (AlphaColour a) where
+ compare a b = fromMaybe EQ . find (/=EQ) . zipWith compare [channelRed a', channelGreen a', channelBlue a'] $ [channelRed b', channelGreen b', channelBlue b']
+ where a' = toSRGB $ if alphaChannel a == 0 then black else a `Data.Colour.over` black
+ b' = toSRGB $ if alphaChannel b == 0 then black else b `Data.Colour.over` black
+
+instance Ord Rect where
+ compare Plane Plane = EQ
+ compare Singularity Singularity = EQ
+ compare Plane Singularity = GT
+ compare Singularity Plane = LT
+ compare (Rect _ _ _ _) Plane = GT
+ compare (Rect _ _ _ _) Singularity = GT
+ compare Plane (Rect _ _ _ _) = LT
+ compare Singularity (Rect _ _ _ _) = LT
+ compare (Rect xa1 ya1 xa2 ya2) (Rect xb1 xb2 yb1 yb2) =
+ fromMaybe EQ
+ . find (/=EQ)
+ . zipWith compare [xa1,xa2,ya1,ya2]
+ $ [xb1,xb2,yb1,yb2]
+
+-- | Test to see if two rectangles overlap
+overlaps :: Rect -> Rect -> Bool
+overlaps _ Plane = True
+overlaps Plane _ = True
+overlaps _ Singularity = False
+overlaps Singularity _ = False
+overlaps (Rect lx1 ly1 lx2 ly2) (Rect rx1 ry1 rx2 ry2) = xoverlaps && yoverlaps
+ where xoverlaps = (lx1' > rx1' && lx1' < rx2') || (lx2' > rx1' && lx2' < rx2')
+ yoverlaps = (ly1' > ry1' && ly1' < ry2') || (ly2' > ry1' && ly2' < ry2')
+ (lx1',lx2') = if lx1 < lx2 then (lx1,lx2) else (lx2,lx1)
+ (ly1',ly2') = if ly1 < ly2 then (ly1,ly2) else (ly2,ly1)
+ (rx1',rx2') = if rx1 < rx2 then (rx1,rx2) else (rx2,rx1)
+ (ry1',ry2') = if ry1 < ry2 then (ry1,ry2) else (ry2,ry1)
+
+-- | A 2D primitive in an arbitrary Cartesian 2d space
+data Primitive =
+ -- | A list of points that is renderable.
+ Dots
+ { at :: [Point] -- The coordinates of the points in space
+ , attribs :: Attributes -- The attributes of the points
+ , sig :: Int
+ }
+ -- | An arc
+ | Arc -- A pie slice or arc
+ { center :: Point -- ^ center of the arc
+ , radius :: Double -- ^ radius of the arc
+ , angle1 :: Double -- ^ begin angle
+ , angle2 :: Double -- ^ end angle
+ , negative :: Bool -- ^ whether or not to consider this a slice of or a slice out of the pie
+ , attribs :: Attributes
+ , sig :: Int
+ }
+ -- | A cubic spline
+ | Path -- An arbitrary line or cubic spline
+ { begin :: Point -- ^ starting point
+ , segments :: [LineSegment] -- ^ A sequential list of curve segments. Note that the first two points are control points.
+ , closed :: Bool -- ^ Whether or not to close this curve with a final line
+ , attribs :: Attributes
+ , sig :: Int
+ }
+ -- | A rectangle
+ | Rectangle -- An rectangle
+ { topleft :: Point -- ^ The top left point
+ , width :: Double -- ^ The width
+ , height :: Double -- ^ The height
+ , attribs :: Attributes
+ , sig :: Int
+ }
+ -- | A simple text object
+ | Text -- A simple text string
+ { str :: Doc -- ^ The string to print, in Pango markup format
+ , bottomleft :: Point -- ^ The anchor point for the text. Baseline, not bottom.
+ , align :: LayoutAlignment
+ , wrapwidth :: Maybe Double
+ , wrapmode :: LayoutWrapMode
+ , justify :: Bool
+ , 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
+ | Union
+ { prims :: [Primitive]
+ , attribs :: Attributes
+ , sig :: Int
+ }
+ -- | A rectangular image
+ | Image
+ { filename :: String -- ^ The filename of the image. Should be something openable by Gdkpixbuf
+ , dimensions :: Either Point Rect -- ^ The dimensions of the image in current coordinates. Either you use a point, and the image is full size, top left anchored to the point, or a rectangle
+ , preserveaspect :: Bool -- ^ Whether or not to scale preserving aspect ratio
+ , attribs :: Attributes
+ , sig :: Int
+ }
+ -- | A hidden item. Used for state manipulation and to hide an object based on the current state
+ | Hidden
+ { attribs :: Attributes
+ , sig :: Int
+ }
+ deriving (Show,Read,Eq)
+
+
+instance Eq Doc where
+ x == y = show x == show y
+
+instance Ord Doc where
+ compare = show %=> compare
+
+data Attributes = Attributes
+ { afillrule :: FillRule -- ^ The pattern fill rule
+ , afillRGBA :: AlphaColour Double -- ^ The components of the stroke color in the range [0..1]
+ , adash :: Maybe ([Double],Double) -- ^ The shape of the line dashing, if any
+ , astrokeRGBA :: AlphaColour Double -- ^ The components of the stroke color in the range [0..1]
+ , aantialias :: Antialias -- ^ The way things are antialiased
+ , alinecap :: LineCap -- ^ The way lines are capped
+ , alinejoin :: LineJoin -- ^ The way lines are joined
+ , alinewidth :: Double -- ^ The width of a line in points
+ , amiterlimit :: Double -- ^ The miter limit of lines. See Cairo's documentation
+ , atolerance :: Double -- ^ The trapezoidal tolerance. See Cairo's documentation
+ , aoperator :: Operator -- ^ The transfer operator. See Cairo's documentation for more <http://cairographics.org>
+ , atranslatex :: Double -- ^ The current translation x component
+ , atranslatey :: Double -- ^ The current translation y component
+ , ascalex :: Double -- ^ The current scale x component
+ , ascaley :: Double -- ^ The current scale y component
+ , arotation :: Double -- ^ The rotation in degrees that this primitive is seen in
+ , afilled :: Bool -- ^ Whether or not this primitive is filled in
+ , aoutlined :: Bool -- ^ Whether or not this primitive is outlined
+ , aclipped :: Bool -- ^ Whether or not this primitive is part of the clipping plane
+ , layer :: Int -- ^ This sorts out which primitives are located on top of each other. Do not set this yourself. Use Graphics.Rendering.Hieroglyph.Visual.over
+ , bbox :: Rect -- ^ The clockwise rotation in radians.
+ , aname :: Maybe String -- ^ The name of the object
+ , lod :: Int -- ^ The level of detail that this primitive is at. Use Graphics.Rendering.Hieroglyph.Visual.moreSpecific
+ , updated :: Bool
+ , styleselector :: Maybe String
+ , astatic :: Bool
+ }
+ deriving (Show,Read,Eq)
+
+g %=> f = f `on` g
+
+-- | define some instance of Ord over attributes that compares attribute sets
+-- based on the occlusion layer and rendering cost of setting two primitives
+-- next to one another.
+instance Ord Attributes where
+ compare a b = fromMaybe EQ $ find (/=EQ) . map ($(a,b)) . map uncurry $ [layer %=> compare, aname %=>compare]
+
+-- | define a total ordering over the primitives based on layer and rendering cost
+instance Ord Primitive where
+ compare a b =
+ case (cmpattrs, cmpsigs, cmpprims) of
+ (EQ, EQ, x) -> x
+ (EQ, x, _) -> x
+ (x, _, _) -> x
+ where cmpattrs = (attribs %=> compare) a b
+ cmpsigs = (sig %=> compare) a b
+ cmpprims = comparePrimitives a b
+
+comparePrimitives (Dots ats0 _ _) (Dots ats1 _ _) = maybe EQ (uncurry compare) $ find (\(a,b) -> a /= b) (zip ats0 ats1)
+comparePrimitives (Arc c r a1 a2 _ _ _) (Arc c' r' a1' a2' _ _ _) = fromMaybe EQ (find (/=EQ) [compare c c', compare r r', compare a1 a1', compare a2 a2'])
+comparePrimitives (Path beg segs _ _ _) (Path beg' segs' _ _ _) = fromMaybe EQ (find (/=EQ) (compare beg beg' : compare (length segs) (length segs') : map (uncurry compareSegment) (zip segs segs')))
+ where compareSegment (Line a) (Line b) = compare a b
+ compareSegment (Spline a a1 a2) (Spline b b1 b2) = fromMaybe EQ (find (/=EQ) [compare a b, compare a1 b1, compare a2 b2])
+ compareSegment (EndPoint a) (EndPoint b) = compare a b
+ compareSegment a b = compare (lineordering a) (lineordering b)
+ lineordering (Line _) = 0
+ 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 (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)
+
+-- comparePrimitives (Text _ _ _ _ _ _ _ _ _ _) (Text _ _ _ _ _ _ _ _ _ _) =
+
+primitiveOrdering (Dots _ _ _) = 0
+primitiveOrdering (Arc _ _ _ _ _ _ _) = 1
+primitiveOrdering (Path _ _ _ _ _) = 2