module FWGL.Backend.GLFW.Common ( loadTextFile, loadImage, initBackend, createCanvas, setCanvasSize, setCanvasTitle, setCanvasResizeCallback, setCanvasRefreshCallback, popInput, getInput, drawCanvas, safeFork, refreshLoop, FWGL.Backend.GLFW.Common.getTime, terminateBackend, Canvas, BackendState, ClientAPI(..) ) where import Codec.Picture import Codec.Picture.Types (promoteImage) import Control.Concurrent import Control.Monad import Control.Exception.Base (catch) import qualified Data.HashMap.Strict as H import Data.Hashable import Data.IORef import Data.Vector.Storable (unsafeWith) import Foreign.Ptr import FWGL.Backend.GLES hiding (Image) import FWGL.Input as Input import Graphics.UI.GLFW as GLFW loadImage :: (Num sz, Num sz') => String -> (((sz', sz', Ptr ()), sz, sz) -> IO a) -> IO a loadImage path c = do eimg <- readImage path case eimg of Left err -> error err Right img -> case convert img of Image w h v -> unsafeWith v $ \p -> c ( ( fromIntegral w , fromIntegral h , castPtr p) , fromIntegral w , fromIntegral h) where convert :: DynamicImage -> Image PixelRGBA8 convert (ImageRGBA8 img) = img convert (ImageRGB8 img) = promoteImage img convert (ImageYA8 img) = promoteImage img convert (ImageY8 img) = promoteImage img convert _ = error "Unsupported image format." loadTextFile :: String -> (Either String String -> IO ()) -> IO () loadTextFile fname handler = (>> return ()) . forkIO $ catch (fmap (\s -> s `seq` Right s) $ readFile fname) (\e -> return (Left $ show (e :: IOError))) >>= handler data BackendState = BackendState { eventThread :: ThreadId } data Canvas = Canvas GLFW.Window (IORef (H.HashMap InputEvent [EventData])) (IORef (Int -> Int -> IO ())) (IORef (IO ())) (MVar ()) initBackend :: IO BackendState initBackend = do GLFW.init setTime 0 evTid <- forkIO . forever $ waitEvents >> threadDelay 10000 return $ BackendState evTid createCanvas :: ClientAPI -> Int -> Int -> String -> Int -> Int -> BackendState -> IO (Canvas, Int, Int) createCanvas clientAPI maj min title w h _ = do windowHint $ WindowHint'ClientAPI clientAPI windowHint $ WindowHint'ContextVersionMajor maj windowHint $ WindowHint'ContextVersionMinor min -- TODO: context sharing Just win <- createWindow w h title Nothing Nothing bufferSem <- newMVar () resizeRef <- newIORef $ \_ _ -> return () refreshRef <- newIORef $ return () eventsRef <- newIORef $ H.singleton Resize [ emptyEventData { dataFramebufferSize = Just (w, h) }] setKeyCallback win . Just . const $ keyCallback eventsRef setMouseButtonCallback win . Just $ mouseCallback eventsRef setCursorPosCallback win . Just . const $ cursorCallback eventsRef -- XXX: windows that are not using refreshLoop should receive this {- setWindowRefreshCallback win . Just . const $ refreshCallback bufferSem refreshRef -} setFramebufferSizeCallback win . Just . const $ resizeCallback eventsRef resizeRef return (Canvas win eventsRef resizeRef refreshRef bufferSem, w, h) where keyCallback events key _ keyState _ = do Just t <- GLFW.getTime modifyIORef' events $ case keyState of KeyState'Pressed -> insertEvent t KeyDown keyData KeyState'Released -> insertEvent t KeyUp keyData _ -> id where keyData = emptyEventData { dataKey = Just $ toKey key } mouseCallback events win mb mbState _ = do Just t <- GLFW.getTime pos <- fmap convertCursorPos $ getCursorPos win modifyIORef' events $ case mbState of MouseButtonState'Pressed -> insertEvent t MouseDown $ keyData pos MouseButtonState'Released -> insertEvent t MouseUp $ keyData pos where keyData p = emptyEventData { dataButton = Just $ toMouseButton mb, dataPointer = Just p } cursorCallback events x y = GLFW.getTime >>= \(Just t) -> modifyIORef' events $ insertEvent t MouseMove $ emptyEventData { dataPointer = Just $ convertCursorPos (x, y) } resizeCallback events resizeRef x y = do Just t <- GLFW.getTime callback <- readIORef resizeRef modifyIORef' events $ insertEvent t Resize $ emptyEventData { dataFramebufferSize = Just $ (x, y) } callback x y refreshCallback bufferSem refreshRef = do empty <- isEmptyMVar bufferSem unless empty $ join $ readIORef refreshRef convertCursorPos (x, y) = (floor x, floor y) insertEvent t e = H.insertWith (++) e . (: []) . setTime t where setTime t ed = ed { dataTime = t } emptyEventData = EventData { dataFramebufferSize = Nothing, dataPointer = Nothing, dataButton = Nothing, dataKey = Nothing, dataTime = 0 } setCanvasSize :: Int -> Int -> Canvas -> BackendState -> IO () setCanvasSize w h (Canvas win _ _ _ _) _ = setWindowSize win w h setCanvasTitle :: String -> Canvas -> BackendState -> IO () setCanvasTitle str (Canvas win _ _ _ _) _ = setWindowTitle win str setCanvasResizeCallback :: (Int -> Int -> IO ()) -> Canvas -> BackendState -> IO () setCanvasResizeCallback callback (Canvas _ _ ref _ _) _ = writeIORef ref callback setCanvasRefreshCallback :: IO () -> Canvas -> BackendState -> IO () setCanvasRefreshCallback callback (Canvas _ _ _ ref _) _ = writeIORef ref callback popInput :: a -> Canvas -> BackendState -> IO (Input a) popInput c canvas@(Canvas _ events _ _ _) bs = do i <- getInput c canvas bs writeIORef events H.empty return i getInput :: a -> Canvas -> BackendState -> IO (Input a) getInput c (Canvas _ events _ _ _) _ = flip Input c <$> readIORef events draw :: IO a -> Bool -> MVar () -> Window -> IO a draw act shouldSwap bufferSem win = do () <- takeMVar bufferSem makeContextCurrent $ Just win r <- act when shouldSwap $ swapBuffers win makeContextCurrent Nothing putMVar bufferSem () return r drawCanvas :: (MVar () -> IO a) -> Bool -> Canvas -> BackendState -> IO a drawCanvas act swap (Canvas win _ _ _ sem) _ = draw (act sem) swap sem win safeFork :: MVar () -> (IO () -> IO ThreadId) -> IO () -> IO ThreadId safeFork sem fork thread = do mctx <- getCurrentContext fork $ case mctx of Just ctx -> draw thread False sem ctx Nothing -> thread refreshLoop :: Int -> Canvas -> BackendState -> IO () refreshLoop fps c@(Canvas win _ _ refreshCallback _) bs = do Just t1 <- GLFW.getTime closed <- windowShouldClose win join $ readIORef refreshCallback pollEvents Just t2 <- GLFW.getTime let passed = (t2 - t1) * 1000000 if closed then destroyWindow win else do when (passed > 0) $ threadDelay . ceiling $ delay - passed refreshLoop fps c bs where delay = 1000000 / fromIntegral fps getTime :: BackendState -> IO Double getTime _ = do Just t <- GLFW.getTime return t terminateBackend :: BackendState -> IO () terminateBackend (BackendState tid) = killThread tid >> terminate toMouseButton :: GLFW.MouseButton -> Input.MouseButton toMouseButton MouseButton'1 = MouseLeft toMouseButton MouseButton'3 = MouseMiddle toMouseButton MouseButton'2 = MouseRight toKey :: GLFW.Key -> Input.Key toKey Key'A = KeyA toKey Key'B = KeyB toKey Key'C = KeyC toKey Key'D = KeyD toKey Key'E = KeyE toKey Key'F = KeyF toKey Key'G = KeyG toKey Key'H = KeyH toKey Key'I = KeyI toKey Key'J = KeyJ toKey Key'K = KeyK toKey Key'L = KeyL toKey Key'M = KeyM toKey Key'N = KeyN toKey Key'O = KeyO toKey Key'P = KeyP toKey Key'Q = KeyQ toKey Key'R = KeyR toKey Key'S = KeyS toKey Key'T = KeyT toKey Key'U = KeyU toKey Key'V = KeyV toKey Key'W = KeyW toKey Key'X = KeyX toKey Key'Y = KeyY toKey Key'Z = KeyZ toKey Key'0 = Key0 toKey Key'1 = Key1 toKey Key'2 = Key2 toKey Key'3 = Key3 toKey Key'4 = Key4 toKey Key'5 = Key5 toKey Key'6 = Key6 toKey Key'7 = Key7 toKey Key'8 = Key8 toKey Key'9 = Key9 toKey Key'Space = KeySpace toKey Key'Enter = KeyEnter toKey Key'Tab = KeyTab toKey Key'Escape = KeyEsc toKey Key'Backspace = KeyBackspace toKey Key'LeftShift = KeyShift -- TODO: different shifts toKey Key'RightShift = KeyShift toKey Key'LeftControl = KeyControl -- TODO: // toKey Key'RightControl = KeyControl toKey Key'LeftAlt = KeyAlt -- TODO: // toKey Key'RightAlt = KeyAlt toKey Key'CapsLock = KeyCapsLock toKey Key'NumLock = KeyNumLock toKey Key'Left = KeyArrowLeft toKey Key'Up = KeyArrowUp toKey Key'Right = KeyArrowRight toKey Key'Down = KeyArrowDown toKey Key'Insert = KeyIns toKey Key'Delete = KeyDel toKey Key'Home = KeyHome toKey Key'End = KeyEnd toKey Key'PageUp = KeyPgUp toKey Key'PageDown = KeyPgDown toKey Key'F1 = KeyF1 toKey Key'F2 = KeyF2 toKey Key'F3 = KeyF3 toKey Key'F4 = KeyF4 toKey Key'F5 = KeyF5 toKey Key'F6 = KeyF6 toKey Key'F7 = KeyF7 toKey Key'F8 = KeyF8 toKey Key'F9 = KeyF9 toKey Key'F10 = KeyF10 toKey Key'F11 = KeyF11 toKey Key'F12 = KeyF12 toKey Key'PadAdd = KeyPadAdd toKey Key'PadSubtract = KeyPadSub toKey Key'PadMultiply = KeyPadMul toKey Key'PadDivide = KeyPadDiv toKey Key'PadEnter = KeyPadEnter toKey Key'PadDecimal = KeyPadDot toKey Key'Pad0 = KeyPad0 toKey Key'Pad1 = KeyPad1 toKey Key'Pad2 = KeyPad2 toKey Key'Pad3 = KeyPad3 toKey Key'Pad4 = KeyPad4 toKey Key'Pad5 = KeyPad5 toKey Key'Pad6 = KeyPad6 toKey Key'Pad7 = KeyPad7 toKey Key'Pad8 = KeyPad8 toKey Key'Pad9 = KeyPad9 toKey _ = KeyUnknown