module Mischief.SDL.Window where

import Control.Monad.IO.Class
import Data.Bits ((.|.))
import Data.Default
import Data.Foldable (for_)
import Foreign.C
import Foreign.C.ConstPtr (ConstPtr (..))
import Mischief.ECS
import Mischief.ECS.App.Schedules (First)
import Mischief.ECS.Messages qualified as Messages
import Mischief.SDL.Events
import SDL3.Sys qualified as SDL3
import SDL3.Sys.Video

-- | A component that will create a new window when added to an entity, and destroy it when removed.
--
-- Windows can be configured by inserting a 'WindowSize', 'WindowTitle', 'WindowFlags' alongside this component.
data Window = Window

instance Component Window where
  onAdd :: [Hook Window]
onAdd = [(HookContext -> System ()) -> Hook Window
forall {k} (a :: k). (HookContext -> System ()) -> Hook a
hook HookContext -> System ()
handleNewWindow]
  onRemove :: [Hook Window]
onRemove = [(HookContext -> System ()) -> Hook Window
forall {k} (a :: k). (HookContext -> System ()) -> Hook a
hook HookContext -> System ()
handleWindowRemove]
  required :: Set DefaultComponentType
required = forall b. RequiredBundle b => Set DefaultComponentType
forall {k} (b :: k). RequiredBundle b => Set DefaultComponentType
require @(WindowSize, WindowTitle, WindowFlags)

-- | The size of a window in pixels.
data WindowSize = WindowSize {WindowSize -> Int
width :: Int, WindowSize -> Int
height :: Int} deriving (Typeable WindowSize
[HookRel WindowSize]
[Hook WindowSize]
Set DefaultComponentType
IsExclusive (IsExclusiveRel WindowSize)
(Typeable WindowSize, IsExclusive (IsExclusiveRel WindowSize)) =>
Set DefaultComponentType
-> [Hook WindowSize]
-> [Hook WindowSize]
-> [Hook WindowSize]
-> [HookRel WindowSize]
-> [HookRel WindowSize]
-> [HookRel WindowSize]
-> Component WindowSize
forall c.
(Typeable c, IsExclusive (IsExclusiveRel c)) =>
Set DefaultComponentType
-> [Hook c]
-> [Hook c]
-> [Hook c]
-> [HookRel c]
-> [HookRel c]
-> [HookRel c]
-> Component c
$crequired :: Set DefaultComponentType
required :: Set DefaultComponentType
$conAdd :: [Hook WindowSize]
onAdd :: [Hook WindowSize]
$conSet :: [Hook WindowSize]
onSet :: [Hook WindowSize]
$conRemove :: [Hook WindowSize]
onRemove :: [Hook WindowSize]
$conAddRel :: [HookRel WindowSize]
onAddRel :: [HookRel WindowSize]
$conSetRel :: [HookRel WindowSize]
onSetRel :: [HookRel WindowSize]
$conRemoveRel :: [HookRel WindowSize]
onRemoveRel :: [HookRel WindowSize]
Component)

instance Default WindowSize where
  def :: WindowSize
def = Int -> Int -> WindowSize
WindowSize Int
600 Int
400

-- | The displayed title (or name) of a window.
newtype WindowTitle = WindowTitle String deriving anyclass (Typeable WindowTitle
[HookRel WindowTitle]
[Hook WindowTitle]
Set DefaultComponentType
IsExclusive (IsExclusiveRel WindowTitle)
(Typeable WindowTitle, IsExclusive (IsExclusiveRel WindowTitle)) =>
Set DefaultComponentType
-> [Hook WindowTitle]
-> [Hook WindowTitle]
-> [Hook WindowTitle]
-> [HookRel WindowTitle]
-> [HookRel WindowTitle]
-> [HookRel WindowTitle]
-> Component WindowTitle
forall c.
(Typeable c, IsExclusive (IsExclusiveRel c)) =>
Set DefaultComponentType
-> [Hook c]
-> [Hook c]
-> [Hook c]
-> [HookRel c]
-> [HookRel c]
-> [HookRel c]
-> Component c
$crequired :: Set DefaultComponentType
required :: Set DefaultComponentType
$conAdd :: [Hook WindowTitle]
onAdd :: [Hook WindowTitle]
$conSet :: [Hook WindowTitle]
onSet :: [Hook WindowTitle]
$conRemove :: [Hook WindowTitle]
onRemove :: [Hook WindowTitle]
$conAddRel :: [HookRel WindowTitle]
onAddRel :: [HookRel WindowTitle]
$conSetRel :: [HookRel WindowTitle]
onSetRel :: [HookRel WindowTitle]
$conRemoveRel :: [HookRel WindowTitle]
onRemoveRel :: [HookRel WindowTitle]
Component)

instance Default WindowTitle where
  def :: WindowTitle
def = String -> WindowTitle
WindowTitle String
"Mischief Window"

handleNewWindow :: HookContext -> System ()
handleNewWindow :: HookContext -> System ()
handleNewWindow (HookContext Entity
entity) = do
  Just (WindowSize w h, WindowTitle title, flags) <- Query System (WindowSize, WindowTitle, WindowFlags)
-> System (Maybe (WindowSize, WindowTitle, WindowFlags))
forall w (m :: * -> *) out.
MonadSystem w m =>
Query m out -> m (Maybe out)
single [q|entity. WindowSize, WindowTitle, WindowFlags|]
  window <- liftIO $ withCString title $ \CString
title -> PtrConst CChar
-> Int32 -> Int32 -> SDL_WindowFlags -> IO (Ptr SDL_Window)
SDL3.createWindow (CString -> PtrConst CChar
forall a. Ptr a -> ConstPtr a
ConstPtr CString
title) (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w) (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h) (WindowFlags -> SDL_WindowFlags
flagsToBit WindowFlags
flags)
  insert (SDLWindow window) entity

handleWindowRemove :: HookContext -> System ()
handleWindowRemove :: HookContext -> System ()
handleWindowRemove (HookContext Entity
entity) = do
  Just (SDLWindow p) <- Query System SDLWindow -> System (Maybe SDLWindow)
forall w (m :: * -> *) out.
MonadSystem w m =>
Query m out -> m (Maybe out)
single [q|entity. SDLWindow|]
  liftIO $ SDL3.destroyWindow p

-- | These correspond to the [SDL3 Window Flags](https://wiki.libsdl.org/SDL3/SDL_WindowFlags).
--
-- The most important ones are 'WindowFullscreen' and 'WindowResizable'.
data WindowFlag
  = WindowFullscreen
  | WindowHidden
  | WindowBorderless
  | WindowResizable
  | WindowMinimized
  | WindowMaximized
  | WindowModal
  | WindowHighPixelDensity
  | WindowMouseRelativeMode
  | WindowAlwaysOnTop
  | WindowUtility
  | WindowTooltip
  | WindowPopupMenu
  | WindowTransparent
  | WindowNotFocuable
  | WindowMetal

flagToBit :: WindowFlag -> SDL_WindowFlags
flagToBit :: WindowFlag -> SDL_WindowFlags
flagToBit WindowFlag
WindowFullscreen = SDL_WindowFlags
SDL_WINDOW_FULLSCREEN
flagToBit WindowFlag
WindowHidden = SDL_WindowFlags
SDL_WINDOW_HIDDEN
flagToBit WindowFlag
WindowBorderless = SDL_WindowFlags
SDL_WINDOW_BORDERLESS
flagToBit WindowFlag
WindowResizable = SDL_WindowFlags
SDL_WINDOW_RESIZABLE
flagToBit WindowFlag
WindowMinimized = SDL_WindowFlags
SDL_WINDOW_MINIMIZED
flagToBit WindowFlag
WindowMaximized = SDL_WindowFlags
SDL_WINDOW_MAXIMIZED
flagToBit WindowFlag
WindowModal = SDL_WindowFlags
SDL_WINDOW_MODAL
flagToBit WindowFlag
WindowHighPixelDensity = SDL_WindowFlags
SDL_WINDOW_HIGH_PIXEL_DENSITY
flagToBit WindowFlag
WindowMouseRelativeMode = SDL_WindowFlags
SDL_WINDOW_MOUSE_RELATIVE_MODE
flagToBit WindowFlag
WindowAlwaysOnTop = SDL_WindowFlags
SDL_WINDOW_ALWAYS_ON_TOP
flagToBit WindowFlag
WindowUtility = SDL_WindowFlags
SDL_WINDOW_UTILITY
flagToBit WindowFlag
WindowTooltip = SDL_WindowFlags
SDL_WINDOW_TOOLTIP
flagToBit WindowFlag
WindowPopupMenu = SDL_WindowFlags
SDL_WINDOW_POPUP_MENU
flagToBit WindowFlag
WindowTransparent = SDL_WindowFlags
SDL_WINDOW_TRANSPARENT
flagToBit WindowFlag
WindowNotFocuable = SDL_WindowFlags
SDL_WINDOW_NOT_FOCUSABLE
flagToBit WindowFlag
WindowMetal = SDL_WindowFlags
SDL_WINDOW_METAL

-- | A list of 'WindowFlag's specifying various configurations for the window. The only one set by default is 'WindowResizable'.
newtype WindowFlags = WindowFlags [WindowFlag] deriving anyclass (Typeable WindowFlags
[HookRel WindowFlags]
[Hook WindowFlags]
Set DefaultComponentType
IsExclusive (IsExclusiveRel WindowFlags)
(Typeable WindowFlags, IsExclusive (IsExclusiveRel WindowFlags)) =>
Set DefaultComponentType
-> [Hook WindowFlags]
-> [Hook WindowFlags]
-> [Hook WindowFlags]
-> [HookRel WindowFlags]
-> [HookRel WindowFlags]
-> [HookRel WindowFlags]
-> Component WindowFlags
forall c.
(Typeable c, IsExclusive (IsExclusiveRel c)) =>
Set DefaultComponentType
-> [Hook c]
-> [Hook c]
-> [Hook c]
-> [HookRel c]
-> [HookRel c]
-> [HookRel c]
-> Component c
$crequired :: Set DefaultComponentType
required :: Set DefaultComponentType
$conAdd :: [Hook WindowFlags]
onAdd :: [Hook WindowFlags]
$conSet :: [Hook WindowFlags]
onSet :: [Hook WindowFlags]
$conRemove :: [Hook WindowFlags]
onRemove :: [Hook WindowFlags]
$conAddRel :: [HookRel WindowFlags]
onAddRel :: [HookRel WindowFlags]
$conSetRel :: [HookRel WindowFlags]
onSetRel :: [HookRel WindowFlags]
$conRemoveRel :: [HookRel WindowFlags]
onRemoveRel :: [HookRel WindowFlags]
Component)

instance Default WindowFlags where
  def :: WindowFlags
def = [WindowFlag] -> WindowFlags
WindowFlags [WindowFlag
WindowResizable]

flagsToBit :: WindowFlags -> SDL_WindowFlags
flagsToBit :: WindowFlags -> SDL_WindowFlags
flagsToBit (WindowFlags [WindowFlag]
a) = (WindowFlag -> SDL_WindowFlags -> SDL_WindowFlags)
-> SDL_WindowFlags -> [WindowFlag] -> SDL_WindowFlags
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\WindowFlag
a SDL_WindowFlags
b -> SDL_WindowFlags
b SDL_WindowFlags -> SDL_WindowFlags -> SDL_WindowFlags
forall a. Bits a => a -> a -> a
.|. WindowFlag -> SDL_WindowFlags
flagToBit WindowFlag
a) SDL_WindowFlags
0 [WindowFlag]
a

-- | Plugin adding windowing functionality.
data WindowPlugin

instance Plugin WindowPlugin where
  init :: System ()
init = do
    System () -> SystemConfig
forall a. ToSystems a => a -> SystemConfig
systems System ()
handleWindowEvents
      SystemConfig -> (SystemConfig -> SystemConfig) -> SystemConfig
forall a b. a -> (a -> b) -> b
& System () -> SystemConfig -> SystemConfig
forall a. ToSystems a => a -> SystemConfig -> SystemConfig
after System ()
handleEvents
      SystemConfig -> (SystemConfig -> System ()) -> System ()
forall a b. a -> (a -> b) -> b
& forall sc. Schedule sc => SystemConfig -> System ()
forall {k} (sc :: k). Schedule sc => SystemConfig -> System ()
schedule @First

handleWindowEvents :: System ()
handleWindowEvents :: System ()
handleWindowEvents = do
  messages <- forall m. Message m => System [m]
Messages.read @(SDLMessage SDL3.SDL_WindowEvent)
  for_ messages handleWindowEvent

handleWindowEvent :: SDLMessage SDL3.SDL_WindowEvent -> System ()
handleWindowEvent :: SDLMessage SDL_WindowEvent -> System ()
handleWindowEvent (SDLMessage SDL_EventType
SDL3.SDL_EVENT_WINDOW_RESIZED SDL_WindowEvent
w) = do
  let Int
width :: Int = Sint32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral SDL_WindowEvent
w.data1
  let Int
height :: Int = Sint32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral SDL_WindowEvent
w.data2

  window <- IO (Ptr SDL_Window) -> System (Ptr SDL_Window)
forall a. IO a -> System a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr SDL_Window) -> System (Ptr SDL_Window))
-> IO (Ptr SDL_Window) -> System (Ptr SDL_Window)
forall a b. (a -> b) -> a -> b
$ SDL_WindowID -> IO (Ptr SDL_Window)
SDL3.getWindowFromID SDL_WindowEvent
w.windowID

  [q|(Entity, SDLWindow) / With SDLWindow|]
    & qfilter (\(Entity
_, SDLWindow Ptr SDL_Window
p) -> Ptr SDL_Window
p Ptr SDL_Window -> Ptr SDL_Window -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr SDL_Window
window)
    & qinsert (const $ WindowSize width height)
    & query_
handleWindowEvent SDLMessage SDL_WindowEvent
_ = () -> System ()
forall a. a -> System a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()