-- original author: -- Mirco "MacSlow" Mueller -- -- created: -- 10.1.2006 (or so) -- -- http://www.gnu.org/licenses/licenses.html#GPL -- -- ported to Haskell by: -- Duncan Coutts -- import Graphics.Rendering.Cairo import Graphics.UI.Gtk hiding (fill) import System.Glib (handleGError, GError(..)) import System.Time import Control.Monad (when) import Data.Maybe (isJust) import Data.IORef 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] $ \_ -> 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.025) (-0.025) lineTo (2/3 - 0.025) (-0.025) 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 main = do initGUI window <- windowNew windowSetDecorated window False windowSetResizable window True windowSetPosition window WinPosCenterAlways widgetSetAppPaintable window True handleGError (\_ -> return ()) $ windowSetIconFromFile window "cairo-clock-icon.png" windowSetTitle window "Gtk2Hs Cairo Clock" windowSetDefaultSize window initialSize initialSize windowSetGeometryHints window (Just window) (Just (32, 32)) (Just (512, 512)) Nothing Nothing (Just (1,1)) -- on_alpha_screen_changed (pWindow, NULL, NULL); onKeyPress window $ \Key { eventKeyName = key } -> when (key == "Escape") mainQuit >> return True onButtonPress window $ \Button { eventButton = button, eventTime = time, eventXRoot = x, eventYRoot = y } -> do case button of LeftButton -> windowBeginMoveDrag window button (round x) (round y) time MiddleButton -> windowBeginResizeDrag window WindowEdgeSouthEast button (round x) (round y) time _ -> return () return True timeoutAdd (widgetQueueDraw window >> return True) 1000 backgroundRef <- newIORef (Just undefined) foregroundRef <- newIORef (Just undefined) let redrawStaticLayers = do (width, height) <- widgetGetSize window drawWin <- widgetGetDrawWindow window 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) onRealize window redrawStaticLayers sizeRef <- newIORef (initialSize, initialSize) timeoutHandlerRef <- newIORef Nothing onConfigure window $ \Configure { eventWidth = w, eventHeight = h } -> do 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 ()) timeoutRemove timeoutHandler handler <- timeoutAddFull (do writeIORef timeoutHandlerRef Nothing redrawStaticLayers widgetQueueDraw window return False ) priorityDefaultIdle 300 writeIORef timeoutHandlerRef (Just handler) return False onExpose window $ \Expose { eventRegion = exposeRegion } -> do (width, height) <- widgetGetSize window drawWin <- widgetGetDrawWindow window background <- readIORef backgroundRef foreground <- readIORef foregroundRef renderWithDrawable drawWin $ do region exposeRegion clip setSourceRGB 1 1 1 paint 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 widgetShowAll window mainGUI