diff --git a/Graphics/Aosd.hs b/Graphics/Aosd.hs new file mode 100644 --- /dev/null +++ b/Graphics/Aosd.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE ExistentialQuantification, NamedFieldPuns, RecordWildCards #-} +{-# OPTIONS -Wall #-} +-- | For a higher-level API for textual OSDs using /Pango/, use "Graphics.Aosd.Pango". +module Graphics.Aosd( + -- * Renderers + AosdRenderer(..), GeneralRenderer(..), +-- -- ** Simple combinators +-- HCatRenderer(..), VCatRenderer(..), + -- * Options + AosdOptions(..), Transparency(..), Position(..), XClassHint(..), defaultOpts, + -- * Displaying + aosdFlash, + FlashDurations(..), symDurations, + -- ** Low-level operations + AosdPtr(..),aosdNew,reconfigure, + aosdRender, aosdShow, aosdHide, aosdLoopOnce, aosdLoopFor, + + -- * Reexports + module Graphics.Rendering.Cairo, + Rectangle(..), + CInt, CUInt + + + + ) where + +import Control.Exception +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import Foreign +import Foreign.C +import Graphics.Aosd.AOSD_H +import Graphics.Aosd.Util +import Graphics.Rendering.Cairo +import Graphics.Rendering.Cairo.Internal(runRender) +import Data.Functor +import Graphics.Rendering.Pango.Enums +import Graphics.X11.Xlib(openDisplay,displayHeight,displayWidth,defaultScreen) + +class AosdRenderer a where + toGeneralRenderer :: a -> IO GeneralRenderer + + +data XClassHint = XClassHint { resName, resClass :: String } + deriving(Show) + +data Transparency = None | Fake | Composite + deriving(Show) + +data Position = Min -- ^ Left/top + | Center + | Max -- ^ Right/bottom + deriving(Show,Enum,Bounded) + +data AosdOptions = AosdOptions { + -- | 'Nothing' = use /libaosd/ default. + classHint :: Maybe XClassHint, + -- | 'Nothing' = use /libaosd/ default. + transparency :: Maybe Transparency, + xPos :: Position, + yPos :: Position, + -- | Positive values denote a rightwards respectively downwards offset (in pixels). + offset :: (CInt,CInt), + -- | 'Nothing' = use /libaosd/ default. + hideUponMouseEvent :: Maybe Bool, + -- | Mouse-click event handler. + mouseEventCB :: Maybe (C'AosdMouseEvent -> IO ()) +} + +data GeneralRenderer = GeneralRenderer { + grRender :: Render (), + -- | Part of the surface that the renderer actually draws on (determines the window size). + grInkExtent :: Rectangle, + -- | Part of the surface whose... + -- + -- * ... left edge is aligned to the left edge of the screen, if 'xPos' is 'Min' + -- + -- * ... center is aligned to the center of the screen, if 'xPos' is 'Center' + -- + -- * ... right edge is aligned to the right edge of the screen, if 'xPos' is 'Max' + -- + -- (Likewise for the /y/ axis) + grPositioningExtent :: Rectangle +} + + +-- -- | Horizontal concatenation +-- data HCatRenderer = forall r1 r2. (AosdRenderer r1, AosdRenderer r2) => HCat r1 r2 +-- +-- +-- -- | Vertical concatenation +-- data VCatRenderer = forall r1 r2. (AosdRenderer r1, AosdRenderer r2) => VCat r1 r2 + + +instance AosdRenderer GeneralRenderer where + toGeneralRenderer = return + +-- instance AosdRenderer HCatRenderer where +-- toGeneralRenderer (HCat r1 r2) = do +-- gr1 <- toGeneralRenderer r1 +-- gr2 <- toGeneralRenderer r2 +-- return GeneralRenderer { +-- grWidth = ((+) `on` grWidth) gr1 gr2, +-- grHeight = (max `on` grHeight) gr1 gr2, +-- grRender = do +-- grRender gr1 +-- translate (fromIntegral $ grWidth gr1) 0 +-- grRender gr2 +-- } +-- +-- instance AosdRenderer VCatRenderer where +-- toGeneralRenderer (VCat r1 r2) = do +-- gr1 <- toGeneralRenderer r1 +-- gr2 <- toGeneralRenderer r2 +-- return GeneralRenderer { +-- grWidth = (max `on` grWidth) gr1 gr2, +-- grHeight = ((+) `on` grHeight) gr1 gr2, +-- grRender = do +-- grRender gr1 +-- translate 0 (fromIntegral $ grHeight gr1) +-- grRender gr2 +-- } + +toC'AosdRenderer :: Render () -> IO C'AosdRenderer +toC'AosdRenderer r = mk'AosdRenderer f + where + f cairo _ = runReaderT (runRender r) cairo + + +toAosdTransparency :: Transparency -> C'AosdTransparency +toAosdTransparency None = c'TRANSPARENCY_NONE +toAosdTransparency Fake = c'TRANSPARENCY_FAKE +toAosdTransparency Composite = c'TRANSPARENCY_COMPOSITE + + +-- toAosdCoordinate :: Position -> C'AosdCoordinate +-- toAosdCoordinate Min = c'COORDINATE_MINIMUM +-- toAosdCoordinate Center = c'COORDINATE_CENTER +-- toAosdCoordinate Max = c'COORDINATE_MAXIMUM + + +withAosd :: (Ptr C'Aosd -> IO a) -> IO a +withAosd k = do + a <- c'aosd_new + finally (k a) (c'aosd_destroy a) + + + +withConfiguredAosd :: AosdRenderer a => AosdOptions -> a -> (Ptr C'Aosd -> IO r) -> IO r +withConfiguredAosd opts x k = + withAosd (\a -> do + reconfigure0 opts x a + k a + ) + + + +reconfigure0 :: AosdRenderer a => AosdOptions -> a -> Ptr C'Aosd -> IO () +reconfigure0 AosdOptions{..} renderer a = do + GeneralRenderer{..} <- toGeneralRenderer renderer + maybeDo (setClassHint a) classHint + + maybeDo (c'aosd_set_transparency a . toAosdTransparency) transparency + + display <- openDisplay "" + let screen = defaultScreen display + screenWidth = fromIntegral $ displayWidth display screen + screenHeight = fromIntegral $ displayHeight display screen + + + + let -- l=Left, t=Top, w=Width, h=Height + Rectangle li ti wi hi = grInkExtent + Rectangle lp tp wp hp = grPositioningExtent + +{- +(These comments only look at the x dimension; the other is analogous) + +Consider the mapping "screenx" from grRender x coordinates to screen x coordinates + +Since we translate grRender by -(li,ti), we have: + + screenx x = windowLeft + x - li + +If xPos is Min, we want: + + screenx lp = 0 + <=> + windowLeft + lp - li = 0 + <=> + windowLeft = li - lp + +If xPos is Center, we want: + + screenx (lp + wp/2) = screenWidth/2 + <=> + windowLeft + (lp + wp/2) - li = screenWidth/2 + <=> + windowLeft = li - lp + (screenWidth - wp)/2 + +If xPos is Max, we want: + + screenx (lp+wp) = screenWidth + <=> + windowLeft + (lp+wp) - li = screenWidth + <=> + windowLeft = li - lp + screenWidth - wp + +-} + calculateOffsetAdjustment pos min_ink min_positioning size_positioning size_screen = fromIntegral $ + case pos of + Min -> min_ink - min_positioning + Center -> min_ink - min_positioning + div (size_screen - size_positioning) 2 + Max -> min_ink - min_positioning + size_screen - size_positioning + + + + windowLeft = calculateOffsetAdjustment xPos li lp wp screenWidth + fst offset + windowTop = calculateOffsetAdjustment yPos ti tp hp screenHeight + snd offset + + windowWidth = fromIntegral wi + windowHeight = fromIntegral hi + + finalRenderer = do + translate (fi . negate $ li) (fi . negate $ ti) + grRender + + + + c'aosd_set_geometry a windowLeft windowTop windowWidth windowHeight + + + rendererPtr <- toC'AosdRenderer finalRenderer + c'aosd_set_renderer a rendererPtr nullPtr + + maybeDo (setHideUponMouseEvent a) hideUponMouseEvent + + maybeDo (setMouseEventCB a) mouseEventCB + +setClassHint :: Ptr C'Aosd -> XClassHint -> IO () +setClassHint a XClassHint{ resName, resClass } = + withCString resName (\resName' -> + withCString resClass (\resClass' -> + c'aosd_set_names a resName' resClass')) + +setHideUponMouseEvent :: Ptr C'Aosd -> Bool -> IO () +setHideUponMouseEvent a b = c'aosd_set_hide_upon_mouse_event a (if b then 1 else 0) + +setMouseEventCB :: Ptr C'Aosd -> (C'AosdMouseEvent -> IO ()) -> IO () +setMouseEventCB a f = do + fptr <- mk'AosdMouseEventCb f' + c'aosd_set_mouse_event_cb a fptr nullPtr + where + f' :: Ptr C'AosdMouseEvent -> Ptr () -> IO () + f' p _ = do + mouseEvent <- peek p + f mouseEvent + +-- | Non-'Nothing' defaults: +-- +-- * transparency = Just Composite, +-- +-- * xPos = Center, +-- +-- * yPos = Center, +-- +-- * offset = (0,0), +-- +-- * hideUponMouseEvent = Just True +defaultOpts :: AosdOptions +defaultOpts = + AosdOptions { + classHint = Nothing, + transparency = Just Composite, + xPos = Center, + yPos = Center, + offset = (0,0), + hideUponMouseEvent = Just True, + mouseEventCB = Nothing + } + +data FlashDurations = FlashDurations { + inMillis :: CUInt -- ^ Fade-in time in milliseconds + , fullMillis :: CUInt -- ^ Full display time in milliseconds + , outMillis :: CUInt -- ^ Fade-out time in milliseconds +} + deriving(Show) + +-- | Construct a 'FlashDurations' with equal 'inMillis' and 'outMillis'. +symDurations :: + CUInt -- ^ 'inMillis' and 'outMillis'. + -> CUInt -- ^ 'fullMillis'. + -> FlashDurations +symDurations fadeMillis fullMillis = FlashDurations fadeMillis fullMillis fadeMillis + +-- | Main high-level displayer. Blocks. +aosdFlash :: AosdRenderer a => AosdOptions -> a -> FlashDurations -> IO () +aosdFlash opts renderer FlashDurations{..} = + withConfiguredAosd opts renderer (\p -> c'aosd_flash p inMillis fullMillis outMillis) + + + + + +newtype AosdPtr = AosdPtr { unAosdPtr :: ForeignPtr C'Aosd } + +-- | Create an /Aosd/ object managed by the garbage collector. +aosdNew :: AosdRenderer a => AosdOptions -> a -> IO AosdPtr +aosdNew opts r = do + p <- c'aosd_new + reconfigure0 opts r p + AosdPtr <$> Foreign.newForeignPtr p'aosd_destroy p + + +reconfigure :: AosdRenderer a => AosdOptions -> a -> AosdPtr -> IO () +reconfigure opts r = (`withForeignPtr` reconfigure0 opts r) . unAosdPtr + +aosdRender :: AosdPtr -> IO () +aosdRender = (`withForeignPtr` c'aosd_render) . unAosdPtr + +aosdShow :: AosdPtr -> IO () +aosdShow = (`withForeignPtr` c'aosd_show) . unAosdPtr + +aosdHide :: AosdPtr -> IO () +aosdHide = (`withForeignPtr` c'aosd_hide) . unAosdPtr + +aosdLoopOnce :: AosdPtr -> IO () +aosdLoopOnce = (`withForeignPtr` c'aosd_loop_once) . unAosdPtr + +aosdLoopFor :: AosdPtr + -> CUInt -- ^ Time in milliseconds. + -> IO () +aosdLoopFor (AosdPtr fp) millis = (fp `withForeignPtr` (`c'aosd_loop_for` millis)) + diff --git a/Graphics/Aosd/AOSD_H.hsc b/Graphics/Aosd/AOSD_H.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Aosd/AOSD_H.hsc @@ -0,0 +1,74 @@ +#include +#include + +-- | Raw bindings. +-- +-- Note: The 'Cairo' type (C @cairo_t*@) is from "Graphics.Rendering.Cairo.Types", whose haddock is (as of writing) hidden +module Graphics.Aosd.AOSD_H where +#strict_import +import Graphics.Rendering.Cairo.Types + + +#opaque_t Aosd + +#integral_t AosdCoordinate +#num COORDINATE_MINIMUM +#num COORDINATE_CENTER +#num COORDINATE_MAXIMUM + +#starttype AosdMouseEvent +#field x, CInt +#field y, CInt +#field x_root, CInt +#field y_root, CInt +#field button, CUInt +#field time, CULong +#stoptype + +#callback AosdRenderer, Cairo -> Ptr () -> IO () +#callback AosdMouseEventCb, Ptr -> Ptr () -> IO () + +#integral_t AosdTransparency +#num TRANSPARENCY_NONE +#num TRANSPARENCY_FAKE +#num TRANSPARENCY_COMPOSITE + +#starttype XClassHint +#field res_name, CString +#field res_class, CString +#stoptype + +#ccall aosd_new, IO (Ptr ) +#ccall aosd_destroy, Ptr -> IO () + +-- * object configurators + +#ccall aosd_set_name, Ptr -> Ptr -> IO () +#ccall aosd_set_names, Ptr -> CString -> CString -> IO () +#ccall aosd_set_transparency, Ptr -> -> IO () +#ccall aosd_set_geometry, Ptr -> CInt -> CInt -> CInt -> CInt -> IO () +#ccall aosd_set_position, Ptr -> CUInt -> CInt -> CInt -> IO () +#ccall aosd_set_position_offset, Ptr -> CInt -> CInt -> IO () +#ccall aosd_set_position_with_offset, Ptr -> -> -> CInt -> CInt -> CInt -> CInt -> IO () +#ccall aosd_set_renderer, Ptr -> -> Ptr () -> IO () +#ccall aosd_set_mouse_event_cb, Ptr -> -> Ptr () -> IO () +#ccall aosd_set_hide_upon_mouse_event, Ptr -> CInt -> IO () + + +-- * object manipulators + +#ccall aosd_render, Ptr -> IO () +#ccall aosd_show, Ptr -> IO () +#ccall aosd_hide, Ptr -> IO () + + +-- * X main loop processing + +#ccall aosd_loop_once, Ptr -> IO () +#ccall aosd_loop_for, Ptr -> CUInt -> IO () + + +-- * automatic object manipulator + +#ccall aosd_flash, Ptr -> CUInt -> CUInt -> CUInt -> IO () + diff --git a/Graphics/Aosd/Pango.hs b/Graphics/Aosd/Pango.hs new file mode 100644 --- /dev/null +++ b/Graphics/Aosd/Pango.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE ViewPatterns, NoMonomorphismRestriction, ScopedTypeVariables, GeneralizedNewtypeDeriving, TypeSynonymInstances, NamedFieldPuns, RecordWildCards #-} +{-# OPTIONS -Wall #-} + +module Graphics.Aosd.Pango( + + -- * Base + TextRenderer(..),Width(..),textRenderer, + -- * PangoText + PangoText,pText,pRaw,pEmpty,pTag, + -- ** Markup tags + pSpan,pBold,pBig,pItalic,pStrikethrough,pSmall,pSub,pSup,pUnderline,pMono, + -- *** Span shorthands + pSized, + -- ** Standard text combinators + pIntercalate,pUnlines,pUnwords,pShow, + + + -- * Reexports + SpanAttribute(..), + LayoutAlignment(..), + LayoutWrapMode(..), + TabPosition, + Size(..), + sRGB, + module Graphics.Aosd, + module Data.Monoid, + module Data.Colour.Names + + + + ) where + +import Control.Monad.IO.Class +import Foreign.C +import Graphics.Aosd +import Graphics.Aosd.Util +import Graphics.Rendering.Pango.Cairo +import Graphics.Rendering.Pango.Enums +import Graphics.Rendering.Pango.Layout +import Control.Monad(void) +import Graphics.Rendering.Pango.Markup +import Data.Monoid +import Data.String +import Data.List(intersperse) +import Data.Colour +import Data.Colour.SRGB +import Data.Colour.Names + + +data TextRenderer = TextRenderer { + -- | Hint: Use 'sRGB' or "Data.Colour.Names". + colour :: Colour Double, + -- | 0: Transparent, 1: Opaque. + opacity :: Double, + -- | Uses 'layoutSetWidth' if set. + width :: Maybe Width, + -- | Uses 'layoutSetWrap' if set. + wrapMode :: Maybe LayoutWrapMode, + -- | Uses 'layoutSetJustify' if set. + justify :: Maybe Bool, + -- | Uses 'layoutSetAlignment' if set. + alignment :: Maybe LayoutAlignment, + -- | Uses 'layoutSetSpacing' if set. + lineSpacing :: Maybe Double, + -- | Uses 'layoutSetTabs' if set. + tabs :: Maybe [TabPosition], + -- | Uses 'layoutSetSingleParagraphMode' if set. + singleParagraphMode :: Maybe Bool, + -- | The actual text + tcText :: PangoText +} + +data Width = Unlimited -- ^ The layout will be as wide as necessary to hold all the lines without wrapping + | Width Double -- ^ The layout will be wrapped (according to 'wrapMode') to the given width in Pango units + deriving(Show,Eq) + +unsup :: String -> t +unsup s = error (s ++ " unsupported for Graphics.Aosd.Pango.Width") + +-- | Supports only 'fromInteger'. +instance Num Width where + fromInteger = Width . fromIntegral + (+) = unsup "(+)" + (*) = unsup "(*)" + abs = unsup "abs" + signum = unsup "signum" + (-) = unsup "(-)" + negate = unsup "negate" + +-- | Supports only 'fromRational'. +instance Fractional Width where + fromRational = Width . fromRational + (/) = unsup "/" + recip = unsup "recip" + + + +-- | Construct a 'TextConf' with most fields set to 'Nothing' +textRenderer :: PangoText -> TextRenderer +textRenderer t = TextRenderer { + colour = green, + opacity = 1, + width = Nothing, + wrapMode = Nothing, + justify = Nothing, + alignment = Nothing, + lineSpacing = Nothing, + tabs = Nothing, + singleParagraphMode = Nothing, + tcText = t + } + +-- | Plain text or some Pango markup. Suggestion: Use {-\# LANGUAGE OverloadedStrings \#-}. +data PangoText = PlainText ShowS + | PangoMarkup ShowS + | Empty + +toMarkup :: PangoText -> ShowS +toMarkup (PlainText s) = showString (escapeMarkup (s "")) +toMarkup (PangoMarkup s) = s +toMarkup Empty = mempty + +-- | Uses 'pText' (not 'pRaw'). +instance IsString PangoText where + fromString = pText + +instance Monoid PangoText where + mempty = Empty + mappend Empty x2 = x2 + mappend x1 Empty = x1 + mappend (PlainText s1) (PlainText s2) = PlainText (s1 . s2) + mappend x1 x2 = PangoMarkup (toMarkup x1 . toMarkup x2) + +instance Show PangoText where + showsPrec _ Empty = showString "pEmpty" + showsPrec prec (PlainText s) = showParen (prec >= 11) (showString "pText " . shows (s "")) + showsPrec prec (PangoMarkup s) = showParen (prec >= 11) (showString "pRaw " . shows (s "")) + +pEmpty :: PangoText +pEmpty = Empty + +-- | Raw Pango markup, see . +pRaw :: String -> PangoText +pRaw = PangoMarkup . showString + +-- | Plain text. +pText :: String -> PangoText +pText = PlainText . showString + +pSpan :: [SpanAttribute] -> PangoText -> PangoText +pSpan (attrs :: [SpanAttribute]) inner = PangoMarkup it + where + it = -- adapted from 'Graphics.Rendering.Pango.Markup.markSpan' + showString "') (map shows attrs) . + toMarkup inner . + showString "" + +pIntercalate :: PangoText -> [PangoText] -> PangoText +pIntercalate x = mconcat . intersperse x + +pUnlines :: [PangoText] -> PangoText +pUnlines = pIntercalate (pText "\n") + +pUnwords :: [PangoText] -> PangoText +pUnwords = pIntercalate (pText " ") + +pShow :: Show a => a -> PangoText +pShow = pText . show + +-- | Set font size in points +pSized :: Double -> PangoText -> PangoText +pSized pt = pSpan [FontSize (SizePoint pt)] + +pTag :: String -- ^ Tag name + -> PangoText -> PangoText +pTag tagName inner = PangoMarkup $ + showChar '<' . showString tagName . showChar '>' . + toMarkup inner . + showString "' + +pBold :: PangoText -> PangoText +pBold = pTag "b" +pBig :: PangoText -> PangoText +pBig = pTag "big" +pItalic :: PangoText -> PangoText +pItalic = pTag "i" +pStrikethrough :: PangoText -> PangoText +pStrikethrough = pTag "s" + + +-- | Subscript +pSub :: PangoText -> PangoText +pSub = pTag "sub" + +-- | Superscript +pSup :: PangoText -> PangoText +pSup = pTag "sup" + +pSmall :: PangoText -> PangoText +pSmall = pTag "small" + +-- | Monospace font +pMono :: PangoText -> PangoText +pMono = pTag "tt" + + +-- | Underline +pUnderline :: PangoText -> PangoText +pUnderline = pTag "u" + + + + + + + +layoutSetWidth' :: PangoLayout -> Width -> IO () +layoutSetWidth' layout w = layoutSetWidth layout (case w of + Unlimited -> Nothing + Width x -> Just x) + + + +instance AosdRenderer TextRenderer where + toGeneralRenderer TextRenderer{..} = do + fm <- cairoFontMapGetDefault + -- resolution <- cairoFontMapGetResolution fm + cxt <- cairoCreateContext (Just fm) + layout <- layoutEmpty cxt + + case tcText of + Empty -> return () + PlainText s -> layoutSetText layout (s "") + PangoMarkup s -> void (layoutSetMarkup layout (s "")) + + let go :: (PangoLayout -> a -> IO ()) -> Maybe a -> IO () + go f = maybeDo (f layout) + + + go layoutSetWidth' width + go layoutSetWrap wrapMode + go layoutSetJustify justify + go layoutSetAlignment alignment + go layoutSetSpacing lineSpacing + go layoutSetTabs tabs + go layoutSetSingleParagraphMode singleParagraphMode + + + (grInkExtent,grPositioningExtent) <- layoutGetPixelExtents layout + let render = do + --updateLayout layout -- No idea when this is neccessary + setSourceColour colour opacity + showLayout layout + + + return GeneralRenderer { grInkExtent, grPositioningExtent, grRender = render } + + + + + +-- getSize l = do +-- -- (ink,logical) +-- a@(Rectangle xi yi wi hi, Rectangle xl yl wl hl) <- layoutGetPixelExtents l +-- +-- -- print ("ink",fst a) +-- -- print ("logical",snd a) +-- +-- let w = max (xi+wi) (xl+wl) +-- h = max (yi+hi) (yl+hl) +-- +-- +-- return (fi w, fi h) +-- +-- where +-- fi = fromIntegral +-- +-- diff --git a/Graphics/Aosd/Util.hs b/Graphics/Aosd/Util.hs new file mode 100644 --- /dev/null +++ b/Graphics/Aosd/Util.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE ViewPatterns, NoMonomorphismRestriction #-} +module Graphics.Aosd.Util where +import Graphics.Rendering.Pango.Enums +import Control.Arrow +import Data.Colour.SRGB +import Graphics.Rendering.Cairo + +maybeDo :: Monad m => (a -> m ()) -> Maybe a -> m () +maybeDo f = maybe (return ()) f + +(^+^) :: (Num t) => (t, t) -> (t, t) -> (t, t) +(x,y) ^+^ (x',y') = (x+x',y+y') + +negate2 :: (Num t) => (t, t) -> (t, t) +negate2 (x,y) = (-x,-y) + +(^-^) :: (Num t) => (t, t) -> (t, t) -> (t, t) +v ^-^ w = v ^+^ negate2 w + +fi :: (Num b, Integral a) => a -> b +fi = fromIntegral + +rectLeft :: Rectangle -> Int +rectLeft (Rectangle a _ _ _) = a +rectTop :: Rectangle -> Int +rectTop (Rectangle _ a _ _) = a +rectWidth :: Rectangle -> Int +rectWidth (Rectangle _ _ a _) = a +rectHeight :: Rectangle -> Int +rectHeight (Rectangle _ _ _ a) = a + +rectRight :: Rectangle -> Int +rectRight r = rectLeft r + rectWidth r +rectBottom :: Rectangle -> Int +rectBottom r = rectTop r + rectHeight r + +rectLeftTop :: Rectangle -> (Int, Int) +rectLeftTop = rectLeft &&& rectTop + +rectSize :: Rectangle -> (Int, Int) +rectSize = rectWidth &&& rectHeight + +max2 :: (Ord t, Ord t1) => (t, t) -> (t1, t1) -> (t, t1) +max2 (x,y) (x',y') = (max x y, max x' y') + +min2 :: (Ord t, Ord t1) => (t, t) -> (t1, t1) -> (t, t1) +min2 (x,y) (x',y') = (min x y, min x' y') + +rectDiff :: Rectangle -> Rectangle -> Rectangle +rectDiff (Rectangle a b c d) (Rectangle a' b' c' d') = Rectangle (a-a') (b-b') (c-c') (d-d') + +scale2 :: Num t => t -> (t, t) -> (t, t) +scale2 s (x,y) = (s*x,s*y) + +fi2 :: (Integral a, Num b) => (a,a) -> (b,b) +fi2 = fi *** fi + +rectCenterX :: Rectangle -> Rational +rectCenterX r = fi (2 * rectRight r + rectWidth r) / 2 +rectCenterY :: Rectangle -> Rational +rectCenterY r = fi (2 * rectTop r + rectHeight r) / 2 + +setSourceColour :: Colour Double -> Double -> Render () +setSourceColour (toSRGB -> RGB r g b) a = setSourceRGBA r g b a + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Daniel Schüssler + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Daniel Schüssler nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/aosd.cabal b/aosd.cabal new file mode 100644 --- /dev/null +++ b/aosd.cabal @@ -0,0 +1,57 @@ +-- aosd.cabal auto-generated by cabal init. For additional options, +-- see +-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. +Name: aosd +Version: 0.1 +Synopsis: Bindings to libaosd, a library for Cairo-based on-screen displays +Description: + + . + @An advanced on screen display (OSD) library, which uses Cairo to create high quality rendered graphics to be overlaid on top of the screen.@ + . + Example: + . + @ + {-\# LANGUAGE OverloadedStrings \#-} + import "Graphics.Aosd.Pango" + . + markup = pSized 50 (pUnlines [pItalic \"AOSD\",\"Example\"]) + . + main = aosdFlash + \ defaultOpts + \ (textRenderer markup) { alignment = Just AlignCenter, colour = orange } + \ (symDurations 3000 3000) + @ + +License: BSD3 +License-file: LICENSE +Author: Daniel Schüssler +Maintainer: anotheraddress@gmx.de +-- Copyright: +Category: Graphics +Build-type: Simple +Extra-source-files: test/test.hs +Cabal-version: >=1.10 + +Library + Default-Extensions: ForeignFunctionInterface + Exposed-modules: + Graphics.Aosd.AOSD_H + Graphics.Aosd + Graphics.Aosd.Pango + Other-modules: + Graphics.Aosd.Util + + + Build-depends: colour, transformers, X11, base >= 4 && < 5, bindings-DSL >= 1.0.11, cairo >= 0.12, pango >= 0.12 + Build-tools: hsc2hs + Pkgconfig-depends: libaosd, libaosd-text + Default-language: Haskell2010 + +Test-Suite test-aosd + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: test.hs + Build-depends: colour, base,aosd,pango,language-haskell-extract,template-haskell + Default-language: Haskell2010 + ghc-options: -threaded diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE NoMonomorphismRestriction, StandaloneDeriving, OverloadedStrings, NamedFieldPuns, TemplateHaskell, RecordWildCards #-} +import Graphics.Aosd.Pango +import Control.Monad +import Control.Concurrent +import Data.Monoid +import Language.Haskell.TH +import Language.Haskell.Extract +import Data.Functor +import Graphics.Rendering.Pango.Enums + +deriving instance Show LayoutAlignment +deriving instance Show LayoutWrapMode + +main = mapM_ run ( $(functionExtractor "Test$") :: [(String,IO ())] ) + where + run :: (String,IO()) -> IO () + run (n,a) = do + putStrLn ("Running "++n) + header <- aosdNew (defaultOpts { yPos = Min, offset = (0,100) }) (textRenderer (pText n)) + aosdShow header + aosdRender header + aosdLoopOnce header + a + aosdHide header + aosdLoopOnce header + +go t r = aosdFlash defaultOpts r (symDurations 100 t) +goText t f pm = go t (f (textRenderer pm)) + +tagsMarkup = pUnlines $(listE [ appE (varE (mkName n)) (litE (stringL n)) | n <- words "pBold pBig pItalic pStrikethrough pSmall pSub pSup pUnderline pMono"]) + +tagsTest = goText 7000 (\x -> x { colour=green }) tagsMarkup + + +-- catTest = do +-- go 3000 (HCat (textRenderer "Horizontal") (textRenderer "Cat")) +-- go 3000 (VCat (textRenderer "Vertical") (textRenderer "Cat")) + + +alignmentsTest = do + sequence_ [ goText 2000 (\x -> x { width = Just width, + wrapMode = wrap, + alignment = Just al, + colour = magenta }) + + (pSized 14 $ pUnlines [ pText firstLine + , pShow width + , pShow wrap + , pShow al]) + + | al <- [AlignLeft, AlignRight, AlignCenter], + firstLine <- flip replicate 'o' <$> [5,80], + (width,wrap) <- [(Unlimited,Nothing) , + (100,Just WrapWholeWords) , + (100,Just WrapAnywhere) + ] + + + ] + + +leftOverflowTest = + sequence_ [ do + print ("xPos",xPos) + aosdFlash + (defaultOpts {xPos}) + (textRenderer txt) + { alignment = Just AlignRight, width = Just 300, wrapMode = Just WrapWholeWords } + (symDurations 100 3000) + | xPos <- [Center,Min,Max] ] + + where + txt0 = "LeftOverflow" + txt = pSized 24 (pBold "LeftEnd" `mappend` + pText (concat (replicate 4 txt0)) `mappend` + pBold "RightEnd" + ) + + +sizesTest = do + goText 2000 id $ mconcat [ pSpan [FontSize s] (pText (show s)) | s <- [ SizeSmall, SizeMedium, SizeLarge, SizeHuge, SizeGiant, SizePoint 12 ] ] + +singleParagraphModeTest = do + goText 1000 (\x -> x { singleParagraphMode = Just True }) (pText . unlines . words $ "single paragraph mode") + +dur = 5000 + +posTest = forEachPos f + where + f xPos yPos = do + let tr = (textRenderer (pText $ show (xPos,yPos))) { colour = red } + aosdFlash defaultOpts { xPos, yPos } tr (symDurations 500 dur) + +forEachPos f = do + + sequence [ forkOS $ f xPos yPos + + | (xPos,yPos) <- join (liftM2 (,)) [minBound..maxBound] + ] + + threadDelay ((fromIntegral dur+1000)*1000) + + + --mapM f strings + +--f s = flashText defaultTextConf s (symDurations 200 200) + +prStatus = liftIO . print =<< status + + +circleTest = forEachPos doCircle + +doCircle xPos yPos = aosdFlash defaultOpts { xPos, yPos } GeneralRenderer{..} (symDurations 100 2000) + where + grInkExtent = Rectangle (-r) (-r) (2*r) (2*r) + grPositioningExtent = Rectangle (-r_half) (-r_half) r r + + r_half = 50 + + r = 2*r_half + + lw = 10 + + grRender = do + setSourceRGBA 0 1 1 1 + setLineWidth lw + arc 0 0 (r-lw) 0 (2*pi) + stroke + setSourceRGBA 1 0 1 1 + setLineWidth 2 + arc 0 0 (r_half-2) 0 (2*pi) + stroke + prStatus + +transparencyTest = goText 3000 (\s -> s { colour = lime, opacity = 0.5 }) + (pSized 100 "Transparency")