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