GLFW.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}

module Aztecs.GLFW
  ( Key (..),
    Keys (..),
    keyPressed,
    keyJustPressed,
    keyJustUnpressed,
    Cursor (..),
    Window (..),
    RawWindow (..),
    runAccessGLFW,
  )
where

import Aztecs
import Control.Monad
import Control.Monad.IO.Class
import Data.IORef
import Data.Set (Set)
import qualified Data.Set as Set
import Graphics.UI.GLFW (Key (..))
import qualified Graphics.UI.GLFW as GLFW
import Prelude hiding (lookup)

type KeySet = Set Key

data KeyStates = KeyStates
  { keysJustPressed :: KeySet,
    keysJustUnpressed :: KeySet
  }
  deriving (Show, Eq)

instance Monoid KeyStates where
  mempty = KeyStates Set.empty Set.empty

instance Semigroup KeyStates where
  (KeyStates p1 u1) <> (KeyStates p2 u2) = KeyStates (p1 <> p2) (u1 <> u2)

-- | Raw window component
data RawWindow = RawWindow
  { unRawWindow :: GLFW.Window,
    rawWindowKeyStates :: IORef KeyStates
  }

instance (Monad m) => Component m RawWindow

-- | Keys component
data Keys = Keys
  { keysPressed :: KeySet,
    keyStates :: KeyStates
  }
  deriving (Show, Eq)

instance Monoid Keys where
  mempty = Keys Set.empty mempty

instance Semigroup Keys where
  (Keys p1 ks1) <> (Keys p2 ks2) = Keys (p1 <> p2) (ks1 <> ks2)

instance (Monad m) => Component m Keys

keyPressed :: Key -> Keys -> Bool
keyPressed k ks = k `Set.member` keysPressed ks

keyJustPressed :: Key -> Keys -> Bool
keyJustPressed k ks = k `Set.member` (keysJustPressed . keyStates $ ks)

keyJustUnpressed :: Key -> Keys -> Bool
keyJustUnpressed k ks = k `Set.member` (keysJustUnpressed . keyStates $ ks)

-- | Cursor component
data Cursor = Cursor
  { cursorX :: Double,
    cursorY :: Double
  }
  deriving (Show, Eq)

instance (Monad m) => Component m Cursor

-- | Window component
data Window = Window
  { windowTitle :: String,
    windowWidth :: Int,
    windowHeight :: Int
  }
  deriving (Show, Eq)

instance (MonadIO m) => Component m Window where
  componentOnInsert e w = do
    insert e $ bundle (mempty @Keys) <> bundle (Cursor 0 0)
    res <- liftIO $ do
      _ <- GLFW.init
      res <- GLFW.createWindow (windowWidth w) (windowHeight w) (windowTitle w) Nothing Nothing
      case res of
        Nothing -> return Nothing
        Just raw -> do
          keyStatesRef <- newIORef $ KeyStates Set.empty Set.empty
          GLFW.setKeyCallback raw $ Just (go keyStatesRef)
          return . Just $ RawWindow raw keyStatesRef
    case res of
      Just raw -> insert e . bundle $ raw
      Nothing -> error "TODO"
    where
      go keyStatesRef _win key _scancode action _mods = do
        when (action == GLFW.KeyState'Pressed) $ do
          modifyIORef keyStatesRef (\ks -> ks {keysJustPressed = Set.insert key (keysJustPressed ks)})
        when (action == GLFW.KeyState'Released) $ do
          modifyIORef keyStatesRef (\ks -> ks {keysJustUnpressed = Set.insert key (keysJustUnpressed ks)})
  componentOnChange e w w' = do
    when (windowTitle w /= windowTitle w') $ do
      mws <- lookup e
      case mws of
        Just (RawWindow raw _) -> liftIO $ GLFW.setWindowTitle raw (windowTitle w')
        Nothing -> return ()
    when ((windowWidth w, windowHeight w) /= (windowWidth w', windowHeight w')) $ do
      mws <- lookup e
      case mws of
        Just (RawWindow raw _) -> liftIO $ GLFW.setWindowSize raw (windowWidth w') (windowHeight w')
        Nothing -> return ()
  componentOnRemove e _ = do
    mws <- lookup e
    case mws of
      Just (RawWindow raw _) -> liftIO $ GLFW.destroyWindow raw
      Nothing -> return ()

runAccessGLFW :: (MonadIO m) => Access m Bool -> Access m ()
runAccessGLFW a = do
  liftIO $ GLFW.pollEvents
  shouldClose <- a
  if shouldClose
    then return ()
    else do
      res <- system . runQuery . queryUntracked . queryMapWithAccumM go' $ queryMapWithAccumM go query
      unless (or $ fmap fst res) $ runAccessGLFW a
  where
    go (RawWindow rw keyStatesRef) cursor = liftIO $ do
      (x, y) <- GLFW.getCursorPos rw
      let cursor' = cursor {cursorX = x, cursorY = y}
      return (RawWindow rw keyStatesRef, cursor')
    go' (RawWindow rw keyStatesRef, _) keys = liftIO $ do
      ks <- readIORef keyStatesRef
      writeIORef keyStatesRef mempty

      let newPressed = (keysPressed keys `Set.union` keysJustPressed ks) `Set.difference` keysJustUnpressed ks
      let keys' =
            Keys
              { keysPressed = newPressed,
                keyStates = ks
              }

      shouldClose <- GLFW.windowShouldClose rw
      GLFW.swapBuffers rw
      return (shouldClose, keys')