mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
439 lines
12 KiB
Haskell
439 lines
12 KiB
Haskell
{-# LANGUAGE OverloadedLabels #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
-- original author:
|
|
-- Mirco "MacSlow" Mueller <macslow@bangang.de>
|
|
--
|
|
-- created:
|
|
-- 10.1.2006 (or so)
|
|
--
|
|
-- http://www.gnu.org/licenses/licenses.html#GPL
|
|
--
|
|
-- ported to Haskell (gtk2hs) by:
|
|
-- Duncan Coutts <duncan.coutts@worc.ox.ac.uk>
|
|
--
|
|
-- ported to haskell-gi from the gtk2hs port by:
|
|
-- Iñaki García Etxebarria <garetxe@gmail.com>
|
|
--
|
|
|
|
import Control.Monad (when)
|
|
import Control.Monad.Trans.Reader (runReaderT)
|
|
import Data.Maybe (isJust)
|
|
import Data.IORef
|
|
import System.Time
|
|
|
|
import Data.GI.Base
|
|
|
|
import qualified GI.Cairo as GI.Cairo
|
|
import qualified GI.GLib as GLib
|
|
import qualified GI.Gdk as Gdk
|
|
import qualified GI.GdkPixbuf as GP
|
|
import qualified GI.Gtk as Gtk
|
|
|
|
import Graphics.Rendering.Cairo
|
|
import Graphics.Rendering.Cairo.Internal (Render(runRender))
|
|
import Graphics.Rendering.Cairo.Types (Cairo(Cairo))
|
|
import Foreign.Ptr (castPtr)
|
|
|
|
drawClockBackground :: Bool -> Int -> Int -> Render ()
|
|
drawClockBackground quality width height = do
|
|
save
|
|
scale (fromIntegral width) (fromIntegral height)
|
|
|
|
save
|
|
setOperator OperatorOver
|
|
when quality drawDropShadow
|
|
drawClockFace quality
|
|
restore
|
|
|
|
translate 0.5 0.5
|
|
scale 0.4 0.4
|
|
setSourceRGB 0.16 0.18 0.19
|
|
setLineWidth (1.5/60)
|
|
setLineCap LineCapRound
|
|
setLineJoin LineJoinRound
|
|
drawHourMarks
|
|
|
|
restore
|
|
|
|
drawClockHands :: Bool -> Int -> Int -> Render ()
|
|
drawClockHands quality width height = do
|
|
save
|
|
scale (fromIntegral width) (fromIntegral height)
|
|
|
|
translate 0.5 0.5
|
|
scale 0.4 0.4
|
|
setSourceRGB 0.16 0.18 0.19
|
|
setLineWidth (1.5/60)
|
|
setLineCap LineCapRound
|
|
setLineJoin LineJoinRound
|
|
|
|
time <- liftIO (getClockTime >>= toCalendarTime)
|
|
let hours = fromIntegral (if ctHour time >= 12
|
|
then ctHour time - 12
|
|
else ctHour time)
|
|
minutes = fromIntegral (ctMin time)
|
|
seconds = fromIntegral (ctSec time)
|
|
|
|
drawHourHand quality hours minutes seconds
|
|
drawMinuteHand quality minutes seconds
|
|
drawSecondHand quality seconds
|
|
|
|
restore
|
|
|
|
drawClockForeground :: Bool -> Int -> Int -> Render ()
|
|
drawClockForeground quality width height = do
|
|
scale (fromIntegral width) (fromIntegral height)
|
|
|
|
save
|
|
translate 0.5 0.5
|
|
scale 0.4 0.4
|
|
setSourceRGB 0.16 0.18 0.19
|
|
setLineWidth (1.5/60)
|
|
setLineCap LineCapRound
|
|
setLineJoin LineJoinRound
|
|
|
|
when quality drawInnerShadow
|
|
when quality drawReflection
|
|
drawFrame quality
|
|
restore
|
|
|
|
drawDropShadow =
|
|
withRadialPattern 0.55 0.55 0.25 0.5 0.5 0.525 $ \pattern -> do
|
|
patternAddColorStopRGBA pattern 0 0 0 0 0.811
|
|
patternAddColorStopRGBA pattern 0.64 0.345 0.345 0.345 0.317
|
|
patternAddColorStopRGBA pattern 0.84 0.713 0.713 0.713 0.137
|
|
patternAddColorStopRGBA pattern 1 1 1 1 0
|
|
patternSetFilter pattern FilterFast
|
|
setSource pattern
|
|
arc 0.5 0.5 (142/150) 0 (pi*2)
|
|
fill
|
|
|
|
drawClockFace True =
|
|
withLinearPattern 0.5 0 0.5 1 $ \pattern -> do
|
|
patternAddColorStopRGB pattern 0 0.91 0.96 0.93
|
|
patternAddColorStopRGB pattern 1 0.65 0.68 0.68
|
|
patternSetFilter pattern FilterFast
|
|
setSource pattern
|
|
translate 0.5 0.5
|
|
arc 0 0 (60/150) 0 (pi*2)
|
|
fill
|
|
drawClockFace False = do
|
|
setSourceRGB 0.78 0.82 0.805
|
|
translate 0.5 0.5
|
|
arc 0 0 (60/150) 0 (pi*2)
|
|
fill
|
|
|
|
drawHourMarks = do
|
|
save
|
|
forM_ ([1..12] :: [Integer]) $ \_ -> do
|
|
rotate (pi/6)
|
|
moveTo (4.5/6) 0
|
|
lineTo (5.0/6) 0
|
|
stroke
|
|
restore
|
|
|
|
forM_ = flip mapM_
|
|
|
|
drawHourHand quality hours minutes seconds = do
|
|
save
|
|
rotate (-pi/2)
|
|
setLineCap LineCapSquare
|
|
setLineJoin LineJoinMiter
|
|
rotate ( (pi/6) * hours
|
|
+ (pi/360) * minutes
|
|
+ (pi/21600) * seconds)
|
|
|
|
-- hour hand's shadow
|
|
when quality $ do
|
|
setLineWidth (1.75/60)
|
|
setOperator OperatorAtop
|
|
setSourceRGBA 0.16 0.18 0.19 0.125
|
|
moveTo (-2/15 + 0.025) 0.025
|
|
lineTo (7/15 + 0.025) 0.025
|
|
stroke
|
|
|
|
-- the hand itself
|
|
setLineWidth (1/60)
|
|
setOperator OperatorOver
|
|
setSourceRGB 0.16 0.18 0.19
|
|
moveTo (-2/15) 0
|
|
lineTo (7/15) 0
|
|
stroke
|
|
restore
|
|
|
|
drawMinuteHand quality minutes seconds = do
|
|
save
|
|
rotate (-pi/2)
|
|
setLineCap LineCapSquare
|
|
setLineJoin LineJoinMiter
|
|
rotate ( (pi/30) * minutes
|
|
+ (pi/1800) * seconds)
|
|
|
|
-- minute hand's shadow
|
|
when quality $ do
|
|
setLineWidth (1.75/60)
|
|
setOperator OperatorAtop
|
|
setSourceRGBA 0.16 0.18 0.19 0.125
|
|
moveTo (-16/75 - 0.025) (-0.025)
|
|
lineTo (2/3 - 0.025) (-0.025)
|
|
stroke
|
|
|
|
-- the minute hand itself
|
|
setLineWidth (1/60)
|
|
setOperator OperatorOver
|
|
setSourceRGB 0.16 0.18 0.19
|
|
moveTo (-16/75) 0
|
|
lineTo (2/3) 0
|
|
stroke
|
|
restore
|
|
|
|
drawSecondHand quality seconds = do
|
|
save
|
|
rotate (-pi/2)
|
|
setLineCap LineCapSquare
|
|
setLineJoin LineJoinMiter
|
|
rotate (seconds * pi/30);
|
|
|
|
-- shadow of second hand-part
|
|
when quality $ do
|
|
setOperator OperatorAtop
|
|
setSourceRGBA 0.16 0.18 0.19 0.125
|
|
setLineWidth (1.3125 / 60)
|
|
moveTo (-1.5/5 + 0.025) 0.025
|
|
lineTo (3/5 + 0.025) 0.025
|
|
stroke
|
|
|
|
-- second hand
|
|
setOperator OperatorOver
|
|
setSourceRGB 0.39 0.58 0.77
|
|
setLineWidth (0.75/60)
|
|
moveTo (-1.5/5) 0
|
|
lineTo (3/5) 0
|
|
stroke
|
|
|
|
arc 0 0 (1/20) 0 (pi*2)
|
|
fill
|
|
arc (63/100) 0 (1/35) 0 (pi*2)
|
|
stroke
|
|
setLineWidth (1/100)
|
|
moveTo (10/15) 0
|
|
lineTo (12/15) 0
|
|
stroke
|
|
setSourceRGB 0.31 0.31 0.31
|
|
arc 0 0 (1/25) 0 (pi*2)
|
|
fill
|
|
restore
|
|
|
|
drawInnerShadow = do
|
|
save
|
|
setOperator OperatorOver
|
|
arc 0 0 (142/150) 0 (pi*2)
|
|
clip
|
|
withRadialPattern 0.3 0.3 0.1 0 0 0.95 $ \pattern -> do
|
|
patternAddColorStopRGBA pattern 0 1 1 1 0
|
|
patternAddColorStopRGBA pattern 0.64 0.713 0.713 0.713 0.137
|
|
patternAddColorStopRGBA pattern 0.84 0.345 0.345 0.345 0.317
|
|
patternAddColorStopRGBA pattern 1 0 0 0 0.811
|
|
patternSetFilter pattern FilterFast
|
|
setSource pattern
|
|
arc 0 0 (142/150) 0 (pi*2)
|
|
fill
|
|
restore
|
|
|
|
drawReflection = do
|
|
save
|
|
arc 0 0 (142/150) 0 (pi*2)
|
|
clip
|
|
rotate (-75 * pi/180)
|
|
setSourceRGBA 0.87 0.9 0.95 0.25
|
|
moveTo (-1) (-1)
|
|
lineTo 1 (-1)
|
|
lineTo 1 1
|
|
curveTo 1 0.15 (-0.15) (-1) (-1) (-1)
|
|
fill
|
|
moveTo (-1) (-1)
|
|
lineTo (-1) 1
|
|
lineTo 1 1
|
|
curveTo (-0.5) 1 (-1) 0.5 (-1) (-1)
|
|
fill
|
|
restore
|
|
|
|
drawFrame True = do
|
|
save
|
|
withRadialPattern (-0.1) (-0.1) 0.8 0 0 1.5 $ \pattern -> do
|
|
patternAddColorStopRGB pattern 0 0.4 0.4 0.4
|
|
patternAddColorStopRGB pattern 0.2 0.95 0.95 0.95
|
|
patternSetFilter pattern FilterFast
|
|
setSource pattern
|
|
setLineWidth (10/75)
|
|
arc 0 0 (142/150) 0 (pi*2)
|
|
stroke
|
|
|
|
withRadialPattern (-0.1) (-0.1) 0.8 0 0 1.5 $ \pattern -> do
|
|
patternAddColorStopRGB pattern 0 0.9 0.9 0.9
|
|
patternAddColorStopRGB pattern 0.2 0.35 0.35 0.35
|
|
patternSetFilter pattern FilterFast
|
|
setSource pattern
|
|
setLineWidth (10/75)
|
|
arc 0 0 (150/150) 0 (pi*2)
|
|
stroke
|
|
restore
|
|
drawFrame False = do
|
|
save
|
|
setSourceRGB 0 0 0
|
|
setLineWidth (10/75)
|
|
arc 0 0 1 0 (pi*2)
|
|
stroke
|
|
restore
|
|
|
|
initialSize :: Int
|
|
initialSize = 256
|
|
|
|
-- | This function bridges gi-cairo with the hand-written cairo
|
|
-- package. It takes a `GI.Cairo.Context` (as it appears in gi-cairo),
|
|
-- and a `Render` action (as in the cairo lib), and renders the
|
|
-- `Render` action into the given context.
|
|
renderWithContext :: GI.Cairo.Context -> Render () -> IO ()
|
|
renderWithContext ct r = withManagedPtr ct $ \p ->
|
|
runReaderT (runRender r) (Cairo (castPtr p))
|
|
|
|
main :: IO ()
|
|
main = do
|
|
_ <- Gtk.init Nothing
|
|
|
|
window <- new Gtk.Window
|
|
[ #decorated := False
|
|
, #resizable := True
|
|
, #windowPosition := Gtk.WindowPositionCenterAlways
|
|
, #appPaintable := True
|
|
, #icon :=> GP.pixbufNewFromFile "cairo-clock-icon.png"
|
|
, #title := "Haskell-gi Cairo Clock"
|
|
, #defaultWidth := fromIntegral initialSize
|
|
, #defaultHeight := fromIntegral initialSize
|
|
]
|
|
|
|
geometry <- new Gdk.Geometry [ #minWidth := 32
|
|
, #minHeight := 32
|
|
, #maxWidth := 512
|
|
, #maxHeight := 512 ]
|
|
#setGeometryHints window (Just window) (Just geometry)
|
|
[Gdk.WindowHintsMinSize, Gdk.WindowHintsMaxSize]
|
|
|
|
screen <- window `get` #screen
|
|
visual <- #getRgbaVisual screen
|
|
#setVisual window visual
|
|
|
|
on window #keyPressEvent $ \event -> do
|
|
name <- event `get` #keyval >>= Gdk.keyvalName
|
|
when (name == Just "Escape") Gtk.mainQuit
|
|
return False
|
|
|
|
on window #buttonPressEvent $ \event -> do
|
|
button <- event `get` #button
|
|
time <- event `get` #time
|
|
x <- event `get` #xRoot
|
|
y <- event `get` #yRoot
|
|
case button of
|
|
1 -> do
|
|
#beginMoveDrag window 1 (round x) (round y) time
|
|
return True
|
|
3 -> do
|
|
#beginResizeDrag window Gdk.WindowEdgeSouthEast 3
|
|
(round x) (round y) time
|
|
return True
|
|
_ -> return False
|
|
|
|
GLib.timeoutAdd GLib.PRIORITY_DEFAULT 1000
|
|
(#queueDraw window >> return True)
|
|
|
|
backgroundRef <- newIORef (Just undefined)
|
|
foregroundRef <- newIORef (Just undefined)
|
|
|
|
let redrawStaticLayers = do
|
|
(width32, height32) <- #getSize window
|
|
let (width, height) = (fromIntegral width32, fromIntegral height32)
|
|
background <- createImageSurface FormatARGB32 width height
|
|
foreground <- createImageSurface FormatARGB32 width height
|
|
let clear = do
|
|
save
|
|
setOperator OperatorClear
|
|
paint
|
|
restore
|
|
renderWith background $ do
|
|
clear
|
|
drawClockBackground True width height
|
|
renderWith foreground $ do
|
|
clear
|
|
drawClockForeground True width height
|
|
writeIORef backgroundRef (Just background)
|
|
writeIORef foregroundRef (Just foreground)
|
|
|
|
on window #realize redrawStaticLayers
|
|
|
|
sizeRef <- newIORef (initialSize, initialSize)
|
|
timeoutHandlerRef <- newIORef Nothing
|
|
on window #configureEvent $ \event -> do
|
|
w <- fromIntegral <$> event `get` #width
|
|
h <- fromIntegral <$> event `get` #height
|
|
|
|
size <- readIORef sizeRef
|
|
writeIORef sizeRef (w,h)
|
|
when (size /= (w,h)) $ do
|
|
|
|
background <- readIORef backgroundRef
|
|
foreground <- readIORef foregroundRef
|
|
maybe (return ()) surfaceFinish background
|
|
maybe (return ()) surfaceFinish foreground
|
|
|
|
writeIORef backgroundRef Nothing
|
|
writeIORef foregroundRef Nothing
|
|
|
|
timeoutHandler <- readIORef timeoutHandlerRef
|
|
_ <- maybe (return True) GLib.sourceRemove timeoutHandler
|
|
|
|
handler <- GLib.timeoutAdd GLib.PRIORITY_DEFAULT_IDLE 300
|
|
(do
|
|
writeIORef timeoutHandlerRef Nothing
|
|
redrawStaticLayers
|
|
#queueDraw window
|
|
return False
|
|
)
|
|
writeIORef timeoutHandlerRef (Just handler)
|
|
|
|
return False
|
|
|
|
on window #draw $ \context -> do
|
|
width <- fromIntegral <$> #getAllocatedWidth window
|
|
height <- fromIntegral <$> #getAllocatedHeight window
|
|
|
|
background <- readIORef backgroundRef
|
|
foreground <- readIORef foregroundRef
|
|
|
|
renderWithContext context $ do
|
|
save
|
|
setOperator OperatorSource
|
|
setSourceRGBA 0 0 0 0
|
|
paint
|
|
restore
|
|
|
|
case background of
|
|
Nothing -> drawClockBackground False width height
|
|
Just background -> do
|
|
setSourceSurface background 0 0
|
|
paint
|
|
|
|
drawClockHands (isJust background) width height
|
|
|
|
case foreground of
|
|
Nothing -> drawClockForeground False width height
|
|
Just foreground -> do
|
|
setSourceSurface foreground 0 0
|
|
paint
|
|
|
|
return True
|
|
|
|
#showAll window
|
|
|
|
Gtk.main
|