1-- original author: 2-- Mirco "MacSlow" Mueller <macslow@bangang.de> 3-- 4-- created: 5-- 10.1.2006 (or so) 6-- 7-- http://www.gnu.org/licenses/licenses.html#GPL 8-- 9-- ported to Haskell by: 10-- Duncan Coutts <duncan.coutts@worc.ox.ac.uk> 11-- 12 13import Graphics.Rendering.Cairo 14import Graphics.UI.Gtk 15import Graphics.UI.Gtk.Gdk.EventM 16import System.Time 17import Control.Monad (when) 18import Data.Maybe (isJust) 19import Data.IORef 20 21drawClockBackground :: Bool -> Int -> Int -> Render () 22drawClockBackground quality width height = do 23 save 24 scale (fromIntegral width) (fromIntegral height) 25 26 save 27 setOperator OperatorOver 28 when quality drawDropShadow 29 drawClockFace quality 30 restore 31 32 translate 0.5 0.5 33 scale 0.4 0.4 34 setSourceRGB 0.16 0.18 0.19 35 setLineWidth (1.5/60) 36 setLineCap LineCapRound 37 setLineJoin LineJoinRound 38 drawHourMarks 39 40 restore 41 42drawClockHands :: Bool -> Int -> Int -> Render () 43drawClockHands quality width height = do 44 save 45 scale (fromIntegral width) (fromIntegral height) 46 47 translate 0.5 0.5 48 scale 0.4 0.4 49 setSourceRGB 0.16 0.18 0.19 50 setLineWidth (1.5/60) 51 setLineCap LineCapRound 52 setLineJoin LineJoinRound 53 54 time <- liftIO (getClockTime >>= toCalendarTime) 55 let hours = fromIntegral (if ctHour time >= 12 56 then ctHour time - 12 57 else ctHour time) 58 minutes = fromIntegral (ctMin time) 59 seconds = fromIntegral (ctSec time) 60 61 drawHourHand quality hours minutes seconds 62 drawMinuteHand quality minutes seconds 63 drawSecondHand quality seconds 64 65 restore 66 67drawClockForeground :: Bool -> Int -> Int -> Render () 68drawClockForeground quality width height = do 69 scale (fromIntegral width) (fromIntegral height) 70 71 save 72 translate 0.5 0.5 73 scale 0.4 0.4 74 setSourceRGB 0.16 0.18 0.19 75 setLineWidth (1.5/60) 76 setLineCap LineCapRound 77 setLineJoin LineJoinRound 78 79 when quality drawInnerShadow 80 when quality drawReflection 81 drawFrame quality 82 restore 83 84drawDropShadow = 85 withRadialPattern 0.55 0.55 0.25 0.5 0.5 0.525 $ \pattern -> do 86 patternAddColorStopRGBA pattern 0 0 0 0 0.811 87 patternAddColorStopRGBA pattern 0.64 0.345 0.345 0.345 0.317 88 patternAddColorStopRGBA pattern 0.84 0.713 0.713 0.713 0.137 89 patternAddColorStopRGBA pattern 1 1 1 1 0 90 patternSetFilter pattern FilterFast 91 setSource pattern 92 arc 0.5 0.5 (142/150) 0 (pi*2) 93 fill 94 95drawClockFace True = 96 withLinearPattern 0.5 0 0.5 1 $ \pattern -> do 97 patternAddColorStopRGB pattern 0 0.91 0.96 0.93 98 patternAddColorStopRGB pattern 1 0.65 0.68 0.68 99 patternSetFilter pattern FilterFast 100 setSource pattern 101 translate 0.5 0.5 102 arc 0 0 (60/150) 0 (pi*2) 103 fill 104drawClockFace False = do 105 setSourceRGB 0.78 0.82 0.805 106 translate 0.5 0.5 107 arc 0 0 (60/150) 0 (pi*2) 108 fill 109 110drawHourMarks = do 111 save 112 forM_ [1..12] $ \_ -> do 113 rotate (pi/6) 114 moveTo (4.5/6) 0 115 lineTo (5.0/6) 0 116 stroke 117 restore 118 119forM_ = flip mapM_ 120 121drawHourHand quality hours minutes seconds = do 122 save 123 rotate (-pi/2) 124 setLineCap LineCapSquare 125 setLineJoin LineJoinMiter 126 rotate ( (pi/6) * hours 127 + (pi/360) * minutes 128 + (pi/21600) * seconds) 129 130 -- hour hand's shadow 131 when quality $ do 132 setLineWidth (1.75/60) 133 setOperator OperatorAtop 134 setSourceRGBA 0.16 0.18 0.19 0.125 135 moveTo (-2/15 + 0.025) 0.025 136 lineTo (7/15 + 0.025) 0.025 137 stroke 138 139 -- the hand itself 140 setLineWidth (1/60) 141 setOperator OperatorOver 142 setSourceRGB 0.16 0.18 0.19 143 moveTo (-2/15) 0 144 lineTo (7/15) 0 145 stroke 146 restore 147 148drawMinuteHand quality minutes seconds = do 149 save 150 rotate (-pi/2) 151 setLineCap LineCapSquare 152 setLineJoin LineJoinMiter 153 rotate ( (pi/30) * minutes 154 + (pi/1800) * seconds) 155 156 -- minute hand's shadow 157 when quality $ do 158 setLineWidth (1.75/60) 159 setOperator OperatorAtop 160 setSourceRGBA 0.16 0.18 0.19 0.125 161 moveTo (-16/75 - 0.025) (-0.025) 162 lineTo (2/3 - 0.025) (-0.025) 163 stroke 164 165 -- the minute hand itself 166 setLineWidth (1/60) 167 setOperator OperatorOver 168 setSourceRGB 0.16 0.18 0.19 169 moveTo (-16/75) 0 170 lineTo (2/3) 0 171 stroke 172 restore 173 174drawSecondHand quality seconds = do 175 save 176 rotate (-pi/2) 177 setLineCap LineCapSquare 178 setLineJoin LineJoinMiter 179 rotate (seconds * pi/30); 180 181 -- shadow of second hand-part 182 when quality $ do 183 setOperator OperatorAtop 184 setSourceRGBA 0.16 0.18 0.19 0.125 185 setLineWidth (1.3125 / 60) 186 moveTo (-1.5/5 + 0.025) 0.025 187 lineTo (3/5 + 0.025) 0.025 188 stroke 189 190 -- second hand 191 setOperator OperatorOver 192 setSourceRGB 0.39 0.58 0.77 193 setLineWidth (0.75/60) 194 moveTo (-1.5/5) 0 195 lineTo (3/5) 0 196 stroke 197 198 arc 0 0 (1/20) 0 (pi*2) 199 fill 200 arc (63/100) 0 (1/35) 0 (pi*2) 201 stroke 202 setLineWidth (1/100) 203 moveTo (10/15) 0 204 lineTo (12/15) 0 205 stroke 206 setSourceRGB 0.31 0.31 0.31 207 arc 0 0 (1/25) 0 (pi*2) 208 fill 209 restore 210 211drawInnerShadow = do 212 save 213 setOperator OperatorOver 214 arc 0 0 (142/150) 0 (pi*2) 215 clip 216 withRadialPattern 0.3 0.3 0.1 0 0 0.95 $ \pattern -> do 217 patternAddColorStopRGBA pattern 0 1 1 1 0 218 patternAddColorStopRGBA pattern 0.64 0.713 0.713 0.713 0.137 219 patternAddColorStopRGBA pattern 0.84 0.345 0.345 0.345 0.317 220 patternAddColorStopRGBA pattern 1 0 0 0 0.811 221 patternSetFilter pattern FilterFast 222 setSource pattern 223 arc 0 0 (142/150) 0 (pi*2) 224 fill 225 restore 226 227drawReflection = do 228 save 229 arc 0 0 (142/150) 0 (pi*2) 230 clip 231 rotate (-75 * pi/180) 232 setSourceRGBA 0.87 0.9 0.95 0.25 233 moveTo (-1) (-1) 234 lineTo 1 (-1) 235 lineTo 1 1 236 curveTo 1 0.15 (-0.15) (-1) (-1) (-1) 237 fill 238 moveTo (-1) (-1) 239 lineTo (-1) 1 240 lineTo 1 1 241 curveTo (-0.5) 1 (-1) 0.5 (-1) (-1) 242 fill 243 restore 244 245drawFrame True = do 246 save 247 withRadialPattern (-0.1) (-0.1) 0.8 0 0 1.5 $ \pattern -> do 248 patternAddColorStopRGB pattern 0 0.4 0.4 0.4 249 patternAddColorStopRGB pattern 0.2 0.95 0.95 0.95 250 patternSetFilter pattern FilterFast 251 setSource pattern 252 setLineWidth (10/75) 253 arc 0 0 (142/150) 0 (pi*2) 254 stroke 255 256 withRadialPattern (-0.1) (-0.1) 0.8 0 0 1.5 $ \pattern -> do 257 patternAddColorStopRGB pattern 0 0.9 0.9 0.9 258 patternAddColorStopRGB pattern 0.2 0.35 0.35 0.35 259 patternSetFilter pattern FilterFast 260 setSource pattern 261 setLineWidth (10/75) 262 arc 0 0 (150/150) 0 (pi*2) 263 stroke 264 restore 265drawFrame False = do 266 save 267 setSourceRGB 0 0 0 268 setLineWidth (10/75) 269 arc 0 0 1 0 (pi*2) 270 stroke 271 restore 272 273initialSize :: Int 274initialSize = 256 275 276main = do 277 initGUI 278 279 window <- windowNew 280 windowSetDecorated window False 281 windowSetResizable window True 282 windowSetPosition window WinPosCenterAlways 283 284 widgetSetAppPaintable window True 285 windowSetIconFromFile window "../cairo-clock-icon.png" 286 windowSetTitle window "Gtk2Hs Cairo Clock" 287 windowSetDefaultSize window initialSize initialSize 288 windowSetGeometryHints window (Just window) 289 (Just (32, 32)) (Just (512, 512)) 290 Nothing Nothing (Just (1,1)) 291 292 let setAlpha widget = do 293 screen <- widgetGetScreen widget 294 colormap <- screenGetRGBAColormap screen 295 maybe (return ()) (widgetSetColormap widget) colormap 296 setAlpha window --TODO: also call setAlpha on alpha screen change 297 298 window `on` keyPressEvent $ tryEvent $ do 299 "Escape" <- eventKeyName 300 liftIO mainQuit 301 302 window `on` buttonPressEvent $ tryEvent $ do 303 LeftButton <- eventButton 304 time <- eventTime 305 (x,y) <- eventRootCoordinates 306 liftIO $ windowBeginMoveDrag window LeftButton (round x) (round y) time 307 308 window `on` buttonPressEvent $ tryEvent $ do 309 MiddleButton <- eventButton 310 time <- eventTime 311 (x,y) <- eventRootCoordinates 312 liftIO $ windowBeginResizeDrag window WindowEdgeSouthEast MiddleButton 313 (round x) (round y) time 314 315 timeoutAdd (widgetQueueDraw window >> return True) 1000 316 317 backgroundRef <- newIORef (Just undefined) 318 foregroundRef <- newIORef (Just undefined) 319 320 let redrawStaticLayers = do 321 (width, height) <- widgetGetSize window 322 drawWin <- widgetGetDrawWindow window 323 background <- createImageSurface FormatARGB32 width height 324 foreground <- createImageSurface FormatARGB32 width height 325 let clear = do 326 save 327 setOperator OperatorClear 328 paint 329 restore 330 renderWith background $ do 331 clear 332 drawClockBackground True width height 333 renderWith foreground $ do 334 clear 335 drawClockForeground True width height 336 writeIORef backgroundRef (Just background) 337 writeIORef foregroundRef (Just foreground) 338 339 onRealize window redrawStaticLayers 340 341 sizeRef <- newIORef (initialSize, initialSize) 342 timeoutHandlerRef <- newIORef Nothing 343 window `on` configureEvent $ do 344 (w,h) <- eventSize 345 liftIO $ do 346 size <- readIORef sizeRef 347 writeIORef sizeRef (w,h) 348 when (size /= (w,h)) $ do 349 350 background <- readIORef backgroundRef 351 foreground <- readIORef foregroundRef 352 maybe (return ()) surfaceFinish background 353 maybe (return ()) surfaceFinish foreground 354 355 writeIORef backgroundRef Nothing 356 writeIORef foregroundRef Nothing 357 358 timeoutHandler <- readIORef timeoutHandlerRef 359 maybe (return ()) timeoutRemove timeoutHandler 360 361 handler <- timeoutAddFull (do 362 writeIORef timeoutHandlerRef Nothing 363 redrawStaticLayers 364 widgetQueueDraw window 365 return False 366 ) priorityDefaultIdle 300 367 writeIORef timeoutHandlerRef (Just handler) 368 369 return False 370 371 window `on` exposeEvent $ do 372 drawWin <- eventWindow 373 exposeRegion <- eventRegion 374 liftIO $ do 375 (width, height) <- drawableGetSize drawWin 376 377 background <- readIORef backgroundRef 378 foreground <- readIORef foregroundRef 379 380 renderWithDrawable drawWin $ do 381 region exposeRegion 382 clip 383 384 save 385 setOperator OperatorSource 386 setSourceRGBA 0 0 0 0 387 paint 388 restore 389 390 case background of 391 Nothing -> drawClockBackground False width height 392 Just background -> do 393 setSourceSurface background 0 0 394 paint 395 396 drawClockHands (isJust background) width height 397 398 case foreground of 399 Nothing -> drawClockForeground False width height 400 Just foreground -> do 401 setSourceSurface foreground 0 0 402 paint 403 404 return True 405 406 widgetShowAll window 407 mainGUI 408