Ticket #1191: window-tick

File window-tick, 3.1 kB (added by guest, 4 years ago)

Patch against version 0.11.0

Line 
1--- a/Graphics/SOE/Gtk.chs
2+++ b/Graphics/SOE/Gtk.chs
3@@ -80,6 +80,7 @@
4   maybeGetWindowEvent,
5   getWindowEvent,
6   Word32,
7+  getWindowTick,
8   timeGetTime,
9   word32ToInt
10   ) where
11@@ -139,15 +140,17 @@
12   window :: Gtk.Window,
13   canvas :: Gtk.DrawingArea,
14   graphicVar :: MVar Graphic,
15-  eventsChan :: Chan Event
16+  eventsChan :: Chan Event,
17+  tickChan :: Chan Tick
18 }
19 
20 openWindow :: Title -> Size -> IO Window
21 openWindow title size =
22-  openWindowEx title Nothing (Just size) drawBufferedGraphic
23+  openWindowEx title Nothing (Just size) drawBufferedGraphic Nothing
24 
25-openWindowEx :: Title -> Maybe Point -> Maybe Size -> RedrawMode -> IO Window
26-openWindowEx title position size (RedrawMode useDoubleBuffer) =
27+openWindowEx :: Title -> Maybe Point -> Maybe Size -> RedrawMode ->
28+                Maybe Time -> IO Window
29+openWindowEx title position size (RedrawMode useDoubleBuffer) tick =
30   Gtk.postGUISync $ do
31   window <- Gtk.windowNew
32   Gtk.windowSetTitle window title
33@@ -170,6 +173,8 @@
34   graphicVar <- newMVar emptyGraphic
35   eventsChan <- newChan
36 
37+  tickChan <- newChan
38+
39   -- set up the fonts
40 #ifdef USE_CAIRO
41   pc <- Gtk.Cairo.cairoCreateContext Nothing
42@@ -214,10 +219,24 @@
43 #endif
44     return True
45 
46-  Gtk.onDelete window $ \_ -> do writeChan eventsChan Closed
47-                                 Gtk.widgetHide window
48-                                 return True
49-                     
50+  case tick of
51+    Just t  -> do
52+         timer <- Gtk.timeoutAddFull
53+                    (writeChan tickChan () >> return True)
54+                    Gtk.priorityDefaultIdle t
55+         Gtk.onDelete window $ \_ -> do
56+                    writeChan eventsChan Closed
57+                    Gtk.timeoutRemove timer
58+                    Gtk.widgetHide window
59+                    return True
60+         return ()
61+    Nothing -> do
62+        Gtk.onDelete window $ \_ -> do
63+                    writeChan eventsChan Closed
64+                    Gtk.widgetHide window
65+                    return True
66+        return ()
67+
68   Gtk.onMotionNotify canvas True $ \Events.Motion { Events.eventX=x, Events.eventY=y} ->
69     writeChan eventsChan MouseMove {
70       pt = (round x, round y)
71@@ -250,7 +269,8 @@
72     window  = window,
73     canvas  = canvas,
74     graphicVar = graphicVar,
75-    eventsChan = eventsChan
76+    eventsChan = eventsChan,
77+    tickChan = tickChan
78   }
79 
80 getWindowSize :: Window -> IO Size
81@@ -767,6 +787,22 @@
82 getRBP :: Window -> IO Point
83 getRBP w = getButton w 2 True
84 
85+---------------------------------
86+-- Window Tick Handling Functions
87+---------------------------------
88+
89+type Time = Int
90+
91+type Tick = ()
92+
93+-- We make sure we completely clear the channel when getting a window tick,
94+-- so that if we have been delayed, we don't keep running to catch up with
95+-- ourselves
96+getWindowTick :: Window -> IO ()
97+getWindowTick w = do readChan (tickChan w)
98+                     noTicks <- isEmptyChan (tickChan w)
99+                     if not noTicks then getWindowTick w else return ()
100+
101 timeGetTime :: IO Word32
102 timeGetTime = do
103   System.Time.TOD sec psec <- System.Time.getClockTime