mirror of
https://github.com/composewell/streamly.git
synced 2024-09-21 00:20:08 +03:00
84 lines
2.5 KiB
Haskell
84 lines
2.5 KiB
Haskell
-- Adapted from the Yampa package.
|
|
-- Displays a square moving in a circle. To move the position drag it with the
|
|
-- mouse.
|
|
--
|
|
-- Requires the SDL package, assuming streamly has already been built, you can
|
|
-- compile it like this:
|
|
-- stack ghc --package SDL CirclingSquare.hs
|
|
|
|
import Data.IORef
|
|
import Graphics.UI.SDL as SDL
|
|
import Streamly
|
|
import Streamly.Prelude as S
|
|
|
|
------------------------------------------------------------------------------
|
|
-- SDL Graphics Init
|
|
------------------------------------------------------------------------------
|
|
|
|
sdlInit :: IO ()
|
|
sdlInit = do
|
|
SDL.init [InitVideo]
|
|
|
|
let width = 640
|
|
height = 480
|
|
_ <- SDL.setVideoMode width height 16 [SWSurface]
|
|
SDL.setCaption "Test" ""
|
|
|
|
------------------------------------------------------------------------------
|
|
-- Display a box at a given coordinates
|
|
------------------------------------------------------------------------------
|
|
|
|
display :: (Double, Double) -> IO ()
|
|
display (playerX, playerY) = do
|
|
screen <- getVideoSurface
|
|
|
|
-- Paint screen green
|
|
let format = surfaceGetPixelFormat screen
|
|
bgColor <- mapRGB format 55 60 64
|
|
_ <- fillRect screen Nothing bgColor
|
|
|
|
-- Paint small red square, at an angle 'angle' with respect to the center
|
|
foreC <- mapRGB format 212 108 73
|
|
let side = 20
|
|
x = round playerX
|
|
y = round playerY
|
|
_ <- fillRect screen (Just (Rect x y side side)) foreC
|
|
|
|
-- Double buffering
|
|
SDL.flip screen
|
|
|
|
------------------------------------------------------------------------------
|
|
-- Wait and update Controller Position if it changes
|
|
------------------------------------------------------------------------------
|
|
|
|
updateController :: IORef (Double, Double) -> IO ()
|
|
updateController ref = do
|
|
e <- pollEvent
|
|
case e of
|
|
MouseMotion x y _ _ -> writeIORef ref (fromIntegral x, fromIntegral y)
|
|
_ -> return ()
|
|
|
|
------------------------------------------------------------------------------
|
|
-- Periodically refresh the output display
|
|
------------------------------------------------------------------------------
|
|
|
|
updateDisplay :: IORef (Double, Double) -> IO ()
|
|
updateDisplay cref = do
|
|
time <- SDL.getTicks
|
|
(x, y) <- readIORef cref
|
|
let t = fromIntegral time * speed / 1000
|
|
in display (x + cos t * radius, y + sin t * radius)
|
|
|
|
where
|
|
|
|
speed = 6
|
|
radius = 60
|
|
|
|
main :: IO ()
|
|
main = do
|
|
sdlInit
|
|
cref <- newIORef (0,0)
|
|
S.drain $ asyncly $ constRate 40
|
|
$ S.repeatM (updateController cref)
|
|
`parallel` S.repeatM (updateDisplay cref)
|