SDL.hs

module Interpreter.Lib.SDL where

import Control.Monad.IO.Class
import Control.Monad.Loops
import Control.Monad.State.Strict
import qualified Data.ByteString as BS
import System.Process (createPipe)
import Data.Coerce
import Data.IORef
import Data.Int (Int32)
import qualified Data.List as DL
import qualified Data.Map as M
import Data.Maybe
import Data.WAVE
import qualified Data.Vector as V
import qualified Data.Vector.Storable as VS
import Data.Word
import Foreign.C.Types
import SDL hiding (Keycode, Scancode, get)
import qualified SDL
import SDL.Mixer as SDLM

import Interpreter.Common
import Interpreter.Interpreter

makeSinWaveChunk :: Double -> BS.ByteString
makeSinWaveChunk freq = BS.pack $
  fmap (\n ->
         let t = fromIntegral n / 22050 :: Double
         in round $ 127 + (127 * sin (2 * pi * freq * t)))
      [0 :: Int32 .. 22050]

createGraphicsWindow :: BuiltInFnWithDoc ['("width", Int), '("height", Int), '("accelerated", Maybe Bool)]
createGraphicsWindow ((coerce -> w) :> (coerce -> h) :> (coerce -> maccelerated) :>_) =
  initGraphics (Just (w, h)) (fromMaybe False maccelerated)

createGraphicsFullscreen :: BuiltInFnWithDoc '[ '("accelerated", Maybe Bool)]
createGraphicsFullscreen ((coerce -> maccelerated) :>_) =
  initGraphics Nothing (fromMaybe False maccelerated)

initGraphics :: Maybe (Int, Int) -> Bool -> InterpretM (Maybe Value)
initGraphics md acc = do
  let windowName = "S.P.A.D.E Program"
  (renderer, window) <- liftIO $ do
    SDL.initialize [SDL.InitVideo, SDL.InitAudio, SDL.InitEvents, SDL.InitTimer]
    SDLM.openAudio SDLM.defaultAudio 256
    window <- case md of
      Just (w, h) -> SDL.createWindow windowName (windowConfig w h)
      Nothing     -> SDL.createWindow windowName fullscreenConfig
    renderer <- case acc of
      True -> SDL.createRenderer window (-1) SDL.defaultRenderer
      _ -> SDL.createRenderer window (-1) $ SDL.defaultRenderer { rendererType = SoftwareRenderer }
    pure (renderer, window)
  sdlWindowRefs <- isSDLWindows <$> get
  liftIO $ modifyIORef sdlWindowRefs (\l -> (window : l))
  modify (\x -> x
    { isDefaultWindow = Just window
    , isDefaultRenderer = Just renderer
    , isAccelerated = Just acc
    })
  pure $ Just $ SDLValue $ Renderer renderer

fullscreenConfig :: SDL.WindowConfig
fullscreenConfig = SDL.defaultWindow
  { windowHighDPI = False
  , windowMode = FullscreenDesktop
  }

windowConfig :: Int -> Int -> SDL.WindowConfig
windowConfig w h = SDL.defaultWindow
  { windowHighDPI = False
  , windowInitialSize = (SDL.V2 (fromIntegral w) (fromIntegral h))
  , windowMode = Windowed
  }

setLogicalSize :: BuiltInFnWithDoc ['("x", CInt), '("y", CInt)]
setLogicalSize ((coerce -> (lx :: CInt)) :> (coerce -> (ly :: CInt)) :> _) =
  isDefaultRenderer <$> get >>= \case
    Just renderer  -> do
      SDL.V2 x y <- getWindowSize'
      SDL.rendererScale renderer SDL.$= (SDL.V2 (realToFrac x/realToFrac lx) (realToFrac y/realToFrac ly))
      pure Nothing
    Nothing -> throwErr $ SDLError "Graphics not Initialized"

getDefaultWindow :: InterpretM SDL.Window
getDefaultWindow = isDefaultWindow <$> get >>= \case
  Just x  -> pure x
  Nothing -> throwErr $ SDLError "Graphics not Initialized"

getDefaultRenderer :: InterpretM SDL.Renderer
getDefaultRenderer = isDefaultRenderer <$> get >>= \case
  Just x  -> pure x
  Nothing -> throwErr $ SDLError "Graphics not Initialized"

draw :: BuiltInFnWithDoc '[]
draw _ = do
  draw'
  pure Nothing

draw' :: InterpretM ()
draw' = getDefaultRenderer >>= SDL.present

drawIfNotAccelerated :: InterpretM ()
drawIfNotAccelerated = (isAccelerated <$> get) >>= \case
  (Just False) -> draw'
  _            -> pure ()

setDrawColor :: BuiltInFnWithDoc ['("red_component", Word8), '("green_component", Word8), '("blue_component", Word8)]
setDrawColor ((coerce -> r) :> (coerce -> g) :> (coerce -> b) :> _) = do
  getDefaultRenderer >>= \renderer -> do
    SDL.rendererDrawColor renderer $= V4 r g b 0
  pure Nothing

clear :: BuiltInFnWithDoc '[]
clear _ = do
  getDefaultRenderer >>= SDL.clear
  pure Nothing

drawPoint :: BuiltInFnWithDoc ['("x", CInt), '("y", CInt)]
drawPoint ((coerce -> x) :> (coerce -> y) :> _) = do
  renderer <- getDefaultRenderer
  SDL.drawPoint renderer (mkPoint x y)
  drawIfNotAccelerated
  pure Nothing

drawPoints :: BuiltInFnWithDoc '[ '("points", VS.Vector (SDL.Point V2 CInt))]
drawPoints ((coerce -> v) :> _) = do
  renderer <- getDefaultRenderer
  SDL.drawPoints renderer v
  drawIfNotAccelerated
  pure Nothing

drawLines :: BuiltInFnWithDoc '[ '("points", VS.Vector (SDL.Point V2 CInt))]
drawLines ((coerce -> v) :> _) = do
  renderer <- getDefaultRenderer
  SDL.drawLines renderer v
  if VS.length v > 0 then do
    let last' = VS.last v
    SDL.drawPoint renderer last'
    SDL.drawPoint renderer last'
  else pure ()
  drawIfNotAccelerated
  pure Nothing

drawLine :: BuiltInFnWithDoc ['("start_x", CInt), '("start_y", CInt), '("end_x", CInt), '("end_y", CInt)]
drawLine ((coerce -> x) :> (coerce -> y) :> (coerce -> xEnd) :> (coerce -> yEnd) :>_) = do
  renderer <- getDefaultRenderer
  let endpoint = mkPoint xEnd yEnd
  SDL.drawLine renderer (mkPoint x y) endpoint
  SDL.drawPoint renderer endpoint
  SDL.drawPoint renderer endpoint
    -- Due to some bug in SDL, without these extra call
    -- the next draw item appear to have a stray pixel with the same color
    -- that was used to draw this one.
  drawIfNotAccelerated
  pure Nothing

drawBox :: BuiltInFnWithDoc ['("start_x", CInt), '("start_y", CInt), '("width", CInt), '("height", CInt), '("fill", Maybe Bool)]
drawBox ((coerce -> x) :> (coerce -> y) :> (coerce -> width) :> (coerce -> height) :> (coerce -> fill) :> _) = do
  renderer <- getDefaultRenderer
  let
    f = case fill of
      Just b -> b
      Nothing -> False
  if f
    then SDL.fillRect renderer $ Just $ SDL.Rectangle (mkPoint x y) (SDL.V2 width height)
    else SDL.drawRect renderer $ Just $ SDL.Rectangle (mkPoint x y) (SDL.V2 width height)
  drawIfNotAccelerated
  pure Nothing

drawCircle :: BuiltInFnWithDoc ['("center_x", Double), '("center_y", Double), '("radius", Double)]
drawCircle ((coerce -> x) :> (coerce -> y) :> (coerce -> radius) :> _) = do
  renderer <- getDefaultRenderer
  let fullCircle = 2.0 * pi
  let segments = 50
  let (oneSegment :: Double) = fullCircle/segments
  let points = VS.fromList $ (\a -> mkPoint (round $ x + cos (oneSegment * a) * radius) (round $ y + sin (oneSegment * a) * radius)) <$> [0..segments]
  SDL.drawLines renderer points
  let last' = VS.last points
  SDL.drawPoint renderer last'
  SDL.drawPoint renderer last'
  drawIfNotAccelerated
  pure Nothing

waitForSDLKey :: BuiltInFnWithDoc '[]
waitForSDLKey _ = do
  void $ iterateWhile id $ do
    events <- pollEvents
    pure $ ((length $ filter filterEvent events) == 0)
  pure Nothing
  where
    filterEvent :: Event -> Bool
    filterEvent event =
      case eventPayload event of
        KeyboardEvent keyboardEvent ->
          (keyboardEventKeyMotion keyboardEvent == Pressed)
        _ -> False

getWindowSize' :: InterpretM (SDL.V2 CInt)
getWindowSize' = do
  window <- getDefaultWindow
  liftIO $ SDL.get (windowSize window)

getWindowSize :: BuiltInFnWithDoc '[]
getWindowSize _ = do
  (SDL.V2 x y) <- getWindowSize'
  pure $ Just $ ObjectValue $ M.fromList [("width", NumberValue $ NumberInt $ fromIntegral x), ("height", NumberValue $ NumberInt $ fromIntegral y)]

getKeyboardState :: BuiltInFnWithDoc '[]
getKeyboardState _ = do
  SDL.pumpEvents
  fn <- SDL.getKeyboardState
  pure $ Just $ SDLValue $ KeyboardState $ SDLKeyboardStateCallback fn

wasKeyDownIn :: BuiltInFnWithDoc '[ '("keyboard_state", SDLKeyboardStateCallback), '("key", SDL.Scancode) ]
wasKeyDownIn ((coerce -> (SDLKeyboardStateCallback cb)) :> (coerce -> scancode ) :> _) =
  pure $ Just $ BoolValue $ cb scancode

getKeys :: BuiltInFnWithDoc '[]
getKeys _ = do
  events <- pollEvents
  pure $ Just $ ArrayValue $ DL.foldl' convertEvent V.empty events
  where
    convertEvent :: V.Vector Value -> Event -> V.Vector Value
    convertEvent inp event =
      case eventPayload event of
        KeyboardEvent keyboardEvent ->
            V.cons (SDLValue $ Keycode ((keysymKeycode (keyboardEventKeysym keyboardEvent)))) inp
        _ -> inp

builtInSetSampleVolume :: BuiltInFnWithDoc '[ '("channel", Channel), '("volume", Int)]
builtInSetSampleVolume ((coerce -> (channel :: Channel)) :> (coerce -> volume) :> _) = do
  SDLM.setVolume volume channel
  pure Nothing

builtInSetSampleLRVolume :: BuiltInFnWithDoc '[ '("sample", Channel), '("volume_left", Int), '("volume_right", Int)]
builtInSetSampleLRVolume ((coerce -> (channel :: Channel)) :> (coerce -> volumel) :> (coerce -> volumer) :> _) = do
  void $ SDLM.effectPan channel volumel volumer
  pure Nothing

builtInPlaySoundSample :: BuiltInFnWithDoc '[ '("sample", Sample), '("channel", Int)]
builtInPlaySoundSample ((coerce -> sample) :> (coerce -> (channel :: Int)) :> _) = do
  void $ SDLM.playOn (fromIntegral channel) SDLM.Forever sample
  pure Nothing

makeSound :: (Int, [WAVESample]) -> InterpretM Value
makeSound (sampleCount, samplesRaw) = do
  (rEnd, wEnd) <- liftIO createPipe
  let waveData = WAVE (WAVEHeader 1 44100 16 $ Just sampleCount) [samplesRaw]
  waveEncodedData <- liftIO $ do
    hPutWAVE wEnd waveData
    BS.hGetContents rEnd
  chunk <- liftIO $ SDLM.decode waveEncodedData
  pure $ SDLValue $ SoundSample chunk

builtInMakeTone :: BuiltInFnWithDoc '[ '("freq", Double) ]
builtInMakeTone ((coerce -> freq) :> _) = do
  let samplesInOneCycle = 44100 / freq
  let multiplier = (2 * pi)/samplesInOneCycle
  let samplesRaw = [doubleToSample $ sin (realToFrac x * multiplier) | x <- [0 .. (round samplesInOneCycle - 1)]]
  Just <$> makeSound (round samplesInOneCycle, samplesRaw)

builtInMakeSoundSample :: BuiltInFnWithDoc '[ '("samplecount", Int), '("callback", Callback)]
builtInMakeSoundSample ((coerce -> sampleCount) :> (coerce -> (cb :: Callback)) :> _) = do
  samplesRaw <- getSamples sampleCount
  Just <$> makeSound (sampleCount , samplesRaw)
  where
    getSamples :: Int -> InterpretM [WAVESample]
    getSamples sc = mapM (\x -> mapFn x) [1..(fromIntegral sc)]

    mapFn :: Integer -> InterpretM WAVESample
    mapFn si = (doubleToSample . (fromValue @Double) . fromMaybe (throwErr MissingProcedureReturn)) <$>
      evaluateCallback cb [NumberValue $ NumberInt si]

builtInMakeSoundSampleFromFile :: BuiltInFnWithDoc '[ '("filepath", FilePath)]
builtInMakeSoundSampleFromFile ((coerce -> filePath) :> _) = do
  chunk <- liftIO $ SDLM.load filePath
  pure $ Just $ SDLValue $ SoundSample chunk

cleanupSDL :: InterpretM ()
cleanupSDL = do
  sdlWindowRefs <- isSDLWindows <$> get
  windows <- liftIO $ readIORef sdlWindowRefs
  mapM_ (liftIO . SDL.destroyWindow) windows
  modify (\x -> x { isDefaultRenderer = Nothing })
  modify (\x -> x { isDefaultWindow = Nothing })
  SDLM.closeAudio
  SDL.quit

keycodes :: Value
keycodes = ObjectValue $ M.fromList
  [ ("up", SDLValue $ Keycode KeycodeUp)
  , ("down", SDLValue $ Keycode KeycodeDown)
  , ("left", SDLValue $ Keycode KeycodeLeft)
  , ("right", SDLValue $ Keycode KeycodeRight)
  , ("a", SDLValue $ Keycode KeycodeA)
  , ("b", SDLValue $ Keycode KeycodeB)
  , ("c", SDLValue $ Keycode KeycodeC)
  , ("q", SDLValue $ Keycode KeycodeQ)
  , ("s", SDLValue $ Keycode KeycodeS)
  ]

scancodes :: Value
scancodes = ObjectValue $ M.fromList
  [ ("up", SDLValue $ Scancode ScancodeUp)
  , ("down", SDLValue $ Scancode ScancodeDown)
  , ("left", SDLValue $ Scancode ScancodeLeft)
  , ("right", SDLValue $ Scancode ScancodeRight)
  , ("q", SDLValue $ Scancode ScancodeQ)
  ]