99 lines
2.3 KiB
Haskell
99 lines
2.3 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Main where
|
|
|
|
import Control.Monad (unless)
|
|
import Data.Bifunctor (Bifunctor (bimap))
|
|
import Foreign.C (CInt)
|
|
import SDL
|
|
( Event (eventPayload),
|
|
EventPayload (KeyboardEvent, QuitEvent),
|
|
InitFlag (InitVideo),
|
|
InputMotion (Pressed, Released),
|
|
KeyboardEventData (keyboardEventKeyMotion, keyboardEventKeysym),
|
|
Keysym (keysymKeycode),
|
|
Point (P),
|
|
Renderer,
|
|
V2 (V2),
|
|
V4 (V4),
|
|
Window,
|
|
WindowConfig (windowGraphicsContext, windowInitialSize),
|
|
WindowGraphicsContext (OpenGLContext),
|
|
clear,
|
|
createRenderer,
|
|
createWindow,
|
|
defaultOpenGL,
|
|
defaultRenderer,
|
|
defaultWindow,
|
|
destroyWindow,
|
|
drawLine,
|
|
get,
|
|
initialize,
|
|
present,
|
|
quit,
|
|
rendererDrawColor,
|
|
waitEvent,
|
|
windowSize,
|
|
($=),
|
|
)
|
|
import SDL.Input.Keyboard.Codes
|
|
|
|
main :: IO ()
|
|
main = do
|
|
initialize [InitVideo]
|
|
|
|
window <-
|
|
createWindow
|
|
"Test"
|
|
defaultWindow {windowGraphicsContext = OpenGLContext defaultOpenGL, windowInitialSize = V2 800 600}
|
|
|
|
renderer <- createRenderer window (-1) defaultRenderer
|
|
|
|
loop renderer window
|
|
|
|
destroyWindow window
|
|
|
|
quit
|
|
|
|
loop :: Renderer -> Window -> IO ()
|
|
loop renderer window = waitEvent >>= _loop renderer window
|
|
|
|
exitCodes :: [Keycode]
|
|
exitCodes = [KeycodeQ, KeycodeEscape]
|
|
|
|
triangle :: [(V2 Float, V2 Float)]
|
|
triangle =
|
|
[ (V2 0.25 0.75, V2 0.5 0.25),
|
|
(V2 0.5 0.25, V2 0.75 0.75),
|
|
(V2 0.75 0.75, V2 0.25 0.75)
|
|
]
|
|
|
|
_loop :: Renderer -> Window -> Event -> IO ()
|
|
_loop renderer window event = do
|
|
let stop =
|
|
case eventPayload event of
|
|
QuitEvent -> True
|
|
KeyboardEvent kevent -> case keyboardEventKeyMotion kevent of
|
|
Pressed -> False
|
|
Released
|
|
| keyof kevent `elem` exitCodes -> True
|
|
| otherwise -> False
|
|
_ -> False
|
|
|
|
rendererDrawColor renderer $= V4 255 255 255 255
|
|
clear renderer
|
|
|
|
rendererDrawColor renderer $= V4 0 0 0 255
|
|
|
|
size <- get $ windowSize window
|
|
mapM_ (uncurry (drawLine renderer) . bimap (tosdl size) (tosdl size)) triangle
|
|
|
|
present renderer
|
|
|
|
unless stop continue
|
|
where
|
|
continue = waitEvent >>= _loop renderer window
|
|
keyof = keysymKeycode . keyboardEventKeysym
|
|
|
|
tosdl :: V2 CInt -> V2 Float -> Point V2 CInt
|
|
tosdl size rel = P $ fmap round $ fmap fromIntegral size * rel
|