content: {-# LANGUAGE ConstraintKinds            #-}
  {-# LANGUAGE DataKinds                  #-}
  {-# LANGUAGE FlexibleContexts           #-}
  {-# LANGUAGE FlexibleInstances          #-}
  {-# LANGUAGE GADTs                      #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE PolyKinds                  #-}
  {-# LANGUAGE RankNTypes                 #-}
  {-# LANGUAGE RebindableSyntax           #-}
  {-# LANGUAGE StandaloneDeriving         #-}
  {-# LANGUAGE TemplateHaskell            #-}
  {-# LANGUAGE TypeFamilies               #-}
  {-# LANGUAGE TypeOperators              #-}
  module Motor.FSMSpec.Game where
  
  import           Prelude                hiding (log, (>>))
  
  import           Control.Monad.Indexed
  import           Control.Monad.IO.Class
  import           Data.Row.Records
  
  import           Motor.FSM
  import           Motor.FSM.Logging
  
  -- * Game Protocol/Machine
  
  data Standing
  data Jumping
  
  class MonadFSM m => Game (m :: Row * -> Row * -> * -> *) where
    type State m :: * -> *
    spawn
      :: KnownSymbol n
      => Name n
      -> Actions m '[n !+ State m Standing] r ()
    jump
      :: KnownSymbol n
      => Name n
      -> Actions m '[n := State m Standing !--> State m Jumping] r ()
    land
      :: KnownSymbol n
      => Name n
      -> Actions m '[n := State m Jumping !--> State m Standing] r ()
    perish
      :: KnownSymbol n
      => Name n
      -> Actions m '[n !- State m Standing] r ()
  
  -- * Game Implemention
  
  newtype GameImpl m (i :: Row *) (o :: Row *) a =
    GameImpl { runGameImpl :: FSM m i o a }
    deriving (IxFunctor, IxPointed, IxApplicative, IxMonad, MonadFSM)
  
  deriving instance Monad m => Functor (GameImpl m i i)
  
  deriving instance Monad m => Applicative (GameImpl m i i)
  
  deriving instance Monad m => Monad (GameImpl m i i)
  
  instance (MonadIO m) => MonadIO (GameImpl m i i) where
    liftIO = GameImpl . liftIO
  
  data GameState s where
    Standing :: GameState Standing
    Jumping :: GameState Jumping
  
  instance (MonadIO m, Monad m) => Game (GameImpl m) where
    type State (GameImpl m) = GameState
    spawn n =
      log n "Spawning player."
      >>>= const (new n Standing)
    jump n =
      log n "Huuuhhh!"
      >>>= const (enter n Jumping)
    land n =
      log n "Back on safe ground."
      >>>= const (enter n Standing)
    perish n =
      log n "Aaaaarhhh..."
      >>>= const (delete n)
  
  hero1 :: Name "hero1"
  hero1 = Name
  
  hero2 :: Name "hero2"
  hero2 = Name
  
  testTwoAdds ::
       Game m
    => Actions m '[ "hero1" !+ State m Standing
                 , "hero2" !+ State m Standing
                 ] r ()
  testTwoAdds =
    spawn hero1 >>>= \_ -> spawn hero2
  
  testTwoDeletes ::
       Game m
    => Actions m '[ "hero1" !- State m Standing
                 , "hero2" !- State m Standing
                 ] r ()
  testTwoDeletes =
    perish hero1 >>>= \_ -> perish hero2
  
  testTwoAddDeletes ::
       Game m
    => Actions m '[ "hero1" !+ State m Standing
                  , "hero2" !+ State m Standing
                  , "hero1" !- State m Standing
                  , "hero2" !- State m Standing
                  ] r ()
  testTwoAddDeletes = do
    spawn hero1
    spawn hero2
    perish hero1
    perish hero2
    where
      (>>) a = (>>>=) a . const
  
  testGame :: Game m => OnlyActions m '[] ()
  testGame = testTwoAdds >> testTwoDeletes >> testTwoAddDeletes
    where
      (>>) a = (>>>=) a . const
  
  
  runIO :: IO ()
  runIO = runFSM (runGameImpl testGame)
  