module Lambency.GameObject (
  wireFrom, contWireFrom, liftWire, liftWireRCW,
  bracketResource, withResource, joinResources, withDefault,
  transformedContext, transformedResourceContext,
  clippedContext, clippedResourceContext,
  withSubResource,
  mkContWire, stepContWire,
  doOnce, doOnceWithInput, everyFrame,
  quitWire,
  mkObject,
  staticObject,
  withVelocity,
  pulseSound
) where

--------------------------------------------------------------------------------
import Control.Arrow
import Control.Monad
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Wire

import Data.Maybe
import Data.Either (isLeft)
import Data.Foldable
import Data.Semigroup ()

import Lambency.Renderer
import Lambency.Sound
import Lambency.Transform
import Lambency.Types

import Prelude hiding ((.), id)

import qualified Graphics.UI.GLFW as GLFW
import FRP.Netwire.Input

import Linear.Vector
--------------------------------------------------------------------------------

wireFrom :: GameMonad a -> (a -> GameWire b c) -> GameWire b c
wireFrom prg fn = mkGen $ \dt val -> do
  seed <- prg
  stepWire (fn seed) dt (Right val)

contWireFrom :: GameMonad a -> (a -> ContWire b c) -> ContWire b c
contWireFrom prg fn = mkContWire $ \dt val -> do
  seed <- prg
  stepContWire (fn seed) dt val

doOnce :: GameMonad () -> GameWire a a
doOnce pgm = wireFrom pgm $ const Control.Wire.id

doOnceWithInput :: (a -> GameMonad ()) -> GameWire a a
doOnceWithInput fn = mkGenN $ \x -> fn x >> return (Right x, mkId)

everyFrame :: (a -> GameMonad b) -> ContWire a b
everyFrame fn = CW $ mkGen_ $ \x -> Right <$> (fn x)

mkObject :: RenderObject -> GameWire a Transform -> GameWire a a
mkObject ro xfw = mkGen $ \dt val -> do
  (xform, nextWire) <- stepWire xfw dt (Right val)
  case xform of
    Right xf -> addRenderAction xf ro >> return (Right val, mkObject ro nextWire)
    Left i -> return (Left i, mkObject ro nextWire)

staticObject :: RenderObject -> Transform -> GameWire a a
staticObject ro = mkObject ro . mkConst . Right

-- | `transformedContext a b` runs b as if all actions within it were rendered
-- with the transform produced by a
transformedContext :: GameWire a Transform -> GameWire a b -> GameWire a b
transformedContext xfw w = mkGen $ \dt x -> do
  (xfResult, xfw') <- stepWire xfw dt (Right x)
  case xfResult of
    Right xf ->
      addTransformedRenderAction xf $
      second (transformedContext xfw') <$> stepWire w dt (Right x)
    Left i -> return (Left i, transformedContext xfw' w)

clippedContext :: GameWire a b -> GameWire b c -> GameWire a c
clippedContext cw w = mkGen $ \dt x ->
  addClippedRenderAction (stepWire cw dt (Right x)) $ \(clipResult, cw') ->
  case clipResult of
    Right clip -> second (clippedContext cw') <$> stepWire w dt (Right clip)
    Left i -> return (Left i, clippedContext cw' w)

withVelocity :: (Monad m, Semigroup s, Monoid s) =>
                Transform -> Wire (Timed Float s) e m a Vec3f ->
                Wire (Timed Float s) e m a Transform
withVelocity initial velWire = velWire >>> (moveXForm initial)
  where moveXForm :: (Monad m, Semigroup s, Monoid s) =>
                     Transform -> Wire (Timed Float s) e m Vec3f Transform
        moveXForm xf = mkPure $ \t vel -> let
          newxform = translate (dtime t *^ vel) xf
          in (Right newxform, moveXForm newxform)

pulseSound :: Sound -> GameWire a a
pulseSound = doOnce . startSound

loadResources :: ResourceLoader a -> GameMonad (a, IO ())
loadResources (ResourceLoader loadPrg) = GameMonad $ do
  rr <- renderer <$> ask
  liftIO $ runWriterT (runReaderT loadPrg rr)

-- | Runs the initial loading program and uses the resource until the generated
-- wire inhibits, at which point it unloads the resource. Once the resource is
-- freed, the resulting wire returns Nothing indefinitely. The resulting wire
-- also takes a signal to terminate from its input.
bracketResource :: ResourceLoader r
                -> ResourceContextWire r a b
                -> ContWire (a, Bool) (Maybe b)
bracketResource load (RCW rcw) = CW $ mkGen $ \dt x -> do
  -- TODO: Maybe should restrict this to certain types of resources?
  (resource, unload) <- loadResources load
  stepWire (go unload resource rcw) dt (Right x)
    where
      go unload res w = mkGen $ \dt (x, quitSignal) ->
        let quit = GameMonad $ do
              _ <- liftIO unload
              return (Right Nothing, pure Nothing)
        in if quitSignal then quit else do
          (result, w') <- runReaderT (stepWire w dt (Right x)) res
          if isLeft result then quit else return (Just <$> result, go unload res w')

liftWireRCW :: GameWire a b -> ResourceContextWire r a b
liftWireRCW = RCW . liftWire

liftWire :: (Monad m, MonadTrans t, Monad (t m))
          => Wire s e m a b -> Wire s e (t m) a b
liftWire = mapWire lift

withResource :: (r -> GameWire a b) -> ResourceContextWire r a b
withResource wireGen = RCW $ mkGen $ \dt x -> do
  (r, w) <- second liftWire <$>
                (ReaderT $ \r -> stepWire (wireGen r) dt (Right x))
  return (r, w)

withinContext :: r -> ResourceContextWire r a b -> GameWire a b
withinContext res (RCW w) =
  mkGen $ \dt x ->
  second (withinContext res . RCW) <$> runReaderT (stepWire w dt (Right x)) res

transformedResourceContext :: ResourceContextWire r a Transform
                           -> ResourceContextWire r a b
                           -> ResourceContextWire r a b
transformedResourceContext xf w = RCW $ mkGen $ \dt x ->
  second liftWire <$>
  (ReaderT $ \r ->
    let xf' = withinContext r xf
        w' = withinContext r w
        xfw = transformedContext xf' w'
     in stepWire xfw dt (Right x))

clippedResourceContext :: ResourceContextWire r a b
                       -> ResourceContextWire r b c
                       -> ResourceContextWire r a c
clippedResourceContext cw w = RCW $ mkGen $ \dt x ->
  second liftWire <$>
  (ReaderT $ \r ->
    let cw' = withinContext r cw
        w' = withinContext r w
        xfw = clippedContext cw' w'
     in stepWire xfw dt (Right x))

joinResources :: Monoid b
              => [ContWire (a, Bool) (Maybe b)]
              -> ContWire (a, Bool) (Maybe b)
joinResources = mkWire . fmap msequence . sequenceA
  where
    mkWire (CW w) = CW $ mkGen $ \dt (x, quit) -> do
      (Right result, w') <- stepWire w dt (Right (x, quit))
      if not quit && isNothing result
        then stepWire w' dt (Right (undefined, True))
        else return (Right result, getContinuousWire . mkWire $ CW w')

    msequence :: (MonadPlus m, Monoid b) => [m b] -> m b
    msequence [] = mzero
    msequence (v : vs) = foldr (\x y -> x >>= ((<$> y) . mappend)) v vs

withDefault :: GameWire a b -> ContWire a b -> ContWire a b
withDefault w (CW m) = CW $ w <|> m

withSubResource :: (r' -> r)
                -> ResourceContextWire r a b
                -> ResourceContextWire r' a b
withSubResource f (RCW w) = RCW $ mkGen $ \dt x -> do
  (r, w') <- withReaderT f $ stepWire w dt (Right x)
  return (r, getResourceWire $ withSubResource f (RCW w'))

mkContWire :: (TimeStep -> a -> GameMonad (b, ContWire a b)) -> ContWire a b
mkContWire f = CW $ mkGen $ \dt x -> do
  (r, CW w') <- f dt x
  return (Right r, w')

stepContWire :: ContWire a b -> TimeStep -> a -> GameMonad (b, ContWire a b)
stepContWire (CW w) dt x = do
  (Right r, w') <- stepWire w dt (Right x)
  return (r, CW w')

-- Wire that behaves like the identity wire until the given key
-- is pressed, then inhibits forever.
quitWire :: GLFW.Key -> GameWire a a
quitWire key =
  rSwitch mkId . (mkId &&& (now . pure mkEmpty . keyPressed key <|> never))
