@@ -0,0 +1,86 @@
1+-- Adapted from the Yampa package.
2+-- Displays a square moving in a circle. To move the position drag the mouse.
3+--
4+-- Requires the SDL package, assuming asyncly has already been built, you can
5+-- compile it like this:
6+-- stack ghc --package SDL circle-mouse.hs
7+
8+import Data.IORef
9+import Graphics.UI.SDL as SDL
10+import Asyncly
11+import Asyncly.Time
12+
13+------------------------------------------------------------------------------
14+-- SDL Graphics Init
15+------------------------------------------------------------------------------
16+
17+sdlInit :: IO ()
18+sdlInit = do
19+ SDL.init [InitVideo]
20+
21+ let width = 640
22+ height = 480
23+ screen <- SDL.setVideoMode width height 16 [SWSurface]
24+ SDL.setCaption "Test" ""
25+
26+------------------------------------------------------------------------------
27+-- Display a box at a given coordinates
28+------------------------------------------------------------------------------
29+
30+display :: (Double, Double) -> IO ()
31+display (playerX, playerY) = do
32+ screen <- getVideoSurface
33+
34+ -- Paint screen green
35+ let format = surfaceGetPixelFormat screen
36+ bgColor <- mapRGB format 55 60 64
37+ fillRect screen Nothing bgColor
38+
39+ -- Paint small red square, at an angle 'angle' with respect to the center
40+ foreC <- mapRGB format 212 108 73
41+ let side = 10
42+ x = round playerX
43+ y = round playerY
44+ fillRect screen (Just (Rect x y side side)) foreC
45+
46+ -- Double buffering
47+ SDL.flip screen
48+
49+------------------------------------------------------------------------------
50+-- Wait and update Controller Position if it changes
51+------------------------------------------------------------------------------
52+
53+refreshRate = 40
54+
55+updateController :: IORef (Double, Double) -> IO ()
56+updateController ref = periodic refreshRate $ do
57+ e <- pollEvent
58+ case e of
59+ MouseMotion x y _ _ -> do
60+ writeIORef ref (fromIntegral x, fromIntegral y)
61+ _ -> return ()
62+
63+------------------------------------------------------------------------------
64+-- Periodically refresh the output display
65+------------------------------------------------------------------------------
66+
67+updateDisplay :: IORef (Double, Double) -> IO ()
68+updateDisplay cref = withClock clock refreshRate displaySquare
69+
70+ where
71+
72+ clock = do
73+ t <- SDL.getTicks
74+ return ((fromIntegral t) * 1000)
75+
76+ speed = 8
77+ radius = 30
78+ displaySquare time = do
79+ (x, y) <- readIORef cref
80+ let t = (fromIntegral time) * speed / 1000000
81+ in display (x + cos t * radius, y + sin t * radius)
82+
83+main = do
84+ sdlInit
85+ cref <- newIORef (0,0)
86+ runAsyncly $ liftIO (updateController cref) <|> liftIO (updateDisplay cref)