4 files changed, 229 insertions, 0 deletions
diff --git a/src/System/Utility/H9Clock.hs b/src/System/Utility/H9Clock.hs
new file mode 100644
index 0000000..cea4fb3
--- /dev/null
+++ b/src/System/Utility/H9Clock.hs
@@ -0,0 +1,16 @@
+module System.Utility.H9Clock (
+  drawClock
+  , mkGraphics
+  , Rectangle(..)
+  , mkHandsPts
+  , hourHandAngle
+  , minHandAngle
+  , dotsPts
+  , darkBlue
+  , paleBlue
+  , paleBlueGreen
+)
+where
+
+import System.Utility.H9Clock.Draw
+import System.Utility.H9Clock.Type
diff --git a/src/System/Utility/H9Clock/Draw.hs b/src/System/Utility/H9Clock/Draw.hs
new file mode 100644
index 0000000..6f82564
--- /dev/null
+++ b/src/System/Utility/H9Clock/Draw.hs
@@ -0,0 +1,191 @@
+module System.Utility.H9Clock.Draw
+        ( drawClock
+        , mkGraphics
+        , mkHandsPts
+        , hourHandAngle
+        , minHandAngle
+        , dotsPts
+        , darkBlue
+        , paleBlue
+        , paleBlueGreen
+        )
+where
+
+import           Graphics.HGL
+import           System.Utility.H9Clock.Type   as T
+import           System.Utility.H9Clock.Time
+import           Control.Monad
+import           Control.Concurrent
+import           Control.Concurrent.STM
+
+mkHandsPts :: Rectangle -> Int -> Int -> ([Point], [Point])
+mkHandsPts wRec hour min =
+        let hourAng  = hourHandAngle hour min
+            minAng   = minHandAngle min
+            c        = center wRec
+            hourHand = lineHourHandPts hourAng c wRec
+            minHand  = lineMinHandPts minAng c wRec
+        in (hourHand, minHand)
+
+mkGraphics :: Rectangle -> Int -> Int -> (Graphic, Graphic, [Graphic])
+mkGraphics wRec hour min = (hourHand, minHand, dots 4 4 wRec)
+  where (hourHandPts, minHandPts) = mkHandsPts wRec hour min
+        hourHand = polygon $ hourHandPts
+        minHand = polygon $ minHandPts
+
+hourHandAngle :: Integral a => a -> a -> a
+hourHandAngle hour min = 90 - ((hour * 5) + (min `div` 10)) * 6
+
+minHandAngle :: Num a => a -> a
+minHandAngle min = 90 - (min * 6)
+
+dotsPts :: Int -> Int -> Rectangle -> [(Point, Point)]
+dotsPts w h r = ePts
+    where
+        c    = center r
+        rad' = rad r
+        degs = map ((360 `div` 12) *) [0 .. 11]
+        cPts = map (circlePt c rad') degs
+        ePts = map (ellipsePt w h) cPts
+
+dots :: Int -> Int -> Rectangle -> [Graphic]
+dots w h r = map (uncurry ellipse) $ dotsPts w h r
+
+center :: Rectangle -> (Int, Int)
+center r = divPt
+    where
+        addPt = (fst (T.min r) + fst (T.max r), snd (T.min r) + snd (T.max r))
+        divPt = (fst addPt `div` 2, snd addPt `div` 2)
+
+dx :: Rectangle -> Int
+dx r = fst (T.max r) - fst (T.min r)
+
+dy :: Rectangle -> Int
+dy r = snd (T.max r) - snd (T.min r)
+
+rad :: Rectangle -> Int
+rad r = rad'
+    where
+        radD   = if dx r < dy r then dx r else dy r
+        radDiv = radD `div` 2
+        rad'   = radDiv - 8
+
+circlePt :: (Int, Int) -> Int -> Int -> (Int, Int)
+circlePt c r deg =
+        let rad' = fromIntegral deg * (pi / 180.0)
+            x    = fst c + round (cos rad' * fromIntegral r)
+            y    = snd c - round (sin rad' * fromIntegral r)
+        in  (x, y)
+
+ellipsePt :: Int -> Int -> (Int, Int) -> (Point, Point)
+ellipsePt a b c =
+        let x = fst c
+            y = snd c
+        in  ((x - a, y + b), (x + a, y - b))
+
+lineMinHandPts :: Int -> (Int, Int) -> Rectangle -> [Point]
+lineMinHandPts ang c r =
+        let
+                rad' = (rad r * 3) `div` 4
+                cPt  = circlePt c rad' ang
+        in
+          [ c
+          , (fst c + 3  , snd c + 3)
+          , (fst cPt + 3, snd cPt + 3)
+          , cPt
+          ]
+
+lineHourHandPts :: Int -> (Int, Int) -> Rectangle -> [Point]
+lineHourHandPts ang c r =
+        let
+                rad' = rad r `div` 2
+                cPt  = circlePt c rad' ang
+        in
+          [ c
+          , (fst c + 3  , snd c + 3)
+          , (fst cPt + 3, snd cPt + 3)
+          , cPt
+          ]
+
+darkBlue :: RGB
+darkBlue = RGB 0 0 85
+
+paleBlue :: RGB
+paleBlue = RGB 0 0 187
+
+paleBlueGreen :: RGB
+paleBlueGreen = RGB 236 254 252
+
+clockGraphic :: Rectangle -> (Int, Int) -> Int -> Int -> IO Graphic
+clockGraphic rectangle wSize hour min = do
+        let (hourHand, minHand, dots) = mkGraphics rectangle hour min
+        return $ overGraphics
+                [ withRGB darkBlue hourHand
+                , withRGB paleBlue minHand
+                , withColor Blue (overGraphics dots)
+                , background
+                ]
+    where
+        background =
+                withRGB paleBlueGreen $ polygon
+                        [(0, 0), (fst wSize, 0), wSize, (0, snd wSize)]
+
+redraw :: Window -> (Int, Int) -> (Int, Int) -> IO ()
+redraw w nSize (hour, min) = do g <- clockGraphic (Rectangle (0, 0) nSize) nSize hour min
+                                setGraphic w g
+
+milliSleep :: Int -> IO ()
+milliSleep = threadDelay . (*) 1000
+
+secSleep :: Int -> IO ()
+secSleep = threadDelay . (*) 1000000
+
+timeWorker :: Num a => TMVar a -> IO b
+timeWorker var = loop
+        where loop = secSleep 30 >> atomically (putTMVar var 0) >> loop
+
+eventWorker :: Window -> TMVar Size -> Size -> IO ()
+eventWorker w var wSize = loop
+    where
+        loop = do
+                milliSleep 10
+                me <- maybeGetWindowEvent w
+                case me of
+                        Just Resize -> do
+                                size <- getWindowSize w
+                                if wSize == size
+                                        then loop
+                                        else
+                                                atomically (putTMVar var size)
+                                                        >> loop
+                        Just Closed -> closeWindow w
+                        otherwise   -> loop
+
+drawClock :: IO ()
+drawClock = runGraphics $ do
+        w <- openWindowEx "h9clock" Nothing windowSize DoubleBuffered (Just 20)
+        (hour, min) <- getHourMin
+        clock <- clockGraphic rectangle windowSize hour min
+        setGraphic w clock
+        t <- newEmptyTMVarIO
+        e <- newEmptyTMVarIO
+        forkIO $ timeWorker t
+        forkIO $ eventWorker w e windowSize
+        loop w windowSize t e (hour, min)
+    where
+        windowSize = (250, 250)
+        rectangle  = Rectangle (0, 0) windowSize
+        loop w wSize t e hourMin = do
+                me <- atomically $ takeEitherTMVar e t
+                curHour <- getHourMin
+                case me of
+                  Left size -> if curHour == hourMin && size == wSize
+                               then loop w wSize t e hourMin
+                               else redraw w size curHour >> loop w size t e curHour
+                  Right _ -> if curHour == hourMin
+                             then loop w wSize t e hourMin
+                             else redraw w wSize curHour >> loop w wSize t e curHour
+
+takeEitherTMVar :: TMVar a -> TMVar b -> STM (Either a b)
+takeEitherTMVar ma mb =
+        fmap Left (takeTMVar ma) `orElse` fmap Right (takeTMVar mb)
diff --git a/src/System/Utility/H9Clock/Time.hs b/src/System/Utility/H9Clock/Time.hs
new file mode 100644
index 0000000..e78d540
--- /dev/null
+++ b/src/System/Utility/H9Clock/Time.hs
@@ -0,0 +1,16 @@
+module System.Utility.H9Clock.Time
+        ( getLocalTimeSec
+        , getHourMin
+        )
+where
+
+import           Data.Time
+
+getLocalTimeSec :: IO TimeOfDay
+getLocalTimeSec =
+        localTimeOfDay
+                <$> (utcToLocalTime <$> getCurrentTimeZone <*> getCurrentTime)
+
+getHourMin :: IO (Int, Int)
+getHourMin = do localTime <- getLocalTimeSec
+                return (todHour localTime, todMin localTime)
diff --git a/src/System/Utility/H9Clock/Type.hs b/src/System/Utility/H9Clock/Type.hs
new file mode 100644
index 0000000..db301fb
--- /dev/null
+++ b/src/System/Utility/H9Clock/Type.hs
@@ -0,0 +1,6 @@
+module System.Utility.H9Clock.Type (Rectangle(..)) where
+
+data Rectangle = Rectangle {
+    min :: (Int, Int)
+  , max :: (Int, Int) }
+  deriving (Show, Eq)