1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
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)
|
