-- 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 by:
--    Duncan Coutts <duncan.coutts@worc.ox.ac.uk>
--

import Graphics.Rendering.Cairo
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Gdk.EventM
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
  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

main = do
  initGUI

  window <- windowNew
  windowSetDecorated window False
  windowSetResizable window True
  windowSetPosition window WinPosCenterAlways

  widgetSetAppPaintable window True
  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))

  let setAlpha widget = do
        screen <- widgetGetScreen widget
        colormap <- screenGetRGBAColormap screen
        maybe (return ()) (widgetSetColormap widget) colormap
  setAlpha window --TODO: also call setAlpha on alpha screen change

  window `on` keyPressEvent $ tryEvent $ do
    "Escape" <- eventKeyName
    liftIO mainQuit

  window `on` buttonPressEvent $ tryEvent $ do
    LeftButton <- eventButton
    time <- eventTime
    (x,y) <- eventRootCoordinates
    liftIO $ windowBeginMoveDrag window LeftButton (round x) (round y) time

  window `on` buttonPressEvent $ tryEvent $ do
    MiddleButton <- eventButton
    time <- eventTime
    (x,y) <- eventRootCoordinates
    liftIO $ windowBeginResizeDrag window WindowEdgeSouthEast MiddleButton
                                   (round x) (round y) time

  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
  window `on` configureEvent $ do
    (w,h) <- eventSize
    liftIO $ 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

  window `on` exposeEvent $ do
    drawWin <- eventWindow
    exposeRegion <- eventRegion
    liftIO $ do
    (width, height) <- drawableGetSize drawWin

    background <- readIORef backgroundRef
    foreground <- readIORef foregroundRef

    renderWithDrawable drawWin $ do
      region exposeRegion
      clip

      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

  widgetShowAll window
  mainGUI
