{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}

module Terminal.Game.Layer.Object.Primitive where

import Terminal.Game.Plane

import qualified Control.Monad.Catch as MC
import qualified GHC.Generics as G
import qualified Data.ByteString as BS
import qualified Data.Serialize as Z
import qualified Data.Sequence as S
import qualified Test.QuickCheck as Q

-------------------------------------------------------------------------------
-- Assorted API types

-- | The number of 'Tick's fed each second to the logic function;
-- constant on every machine. /Frames/ per second might be lower
-- (depending on drawing function onerousness, terminal refresh rate,
-- etc.).
type TPS = Integer

-- | The number of frames blit to terminal per second. Frames might be
-- dropped, but game speed will remain constant. Check @balls@
-- (@cabal run -f examples balls@) to see how to display FPS.
-- For obvious reasons (blits would be wasted) @max FPS = TPS@.
type FPS = Integer

-- | An @Event@ is a 'Tick' (time passes) or a 'KeyPress'.
--
-- Note that all @Keypress@es are recorded and fed to your game-logic
-- function. This means you will not lose a single character, no matter
-- how fast your player is at typing or how low you set 'FPS' to be.
--
-- Example: in a game where you are controlling a hot-air baloon and have
-- @direction@ and @position@ variables, you most likely want @direction@
-- to change at every @KeyPress@, while having @position@ only change at
-- @Tick@s.
data Event = Tick
           | KeyPress Char
              -- ↑↓→← do not work on Windows (are handled by the app,
              -- not passed to the program) both on cmd.exe and
              -- PowerShell.
           deriving (Int -> Event -> ShowS
[Event] -> ShowS
Event -> String
(Int -> Event -> ShowS)
-> (Event -> String) -> ([Event] -> ShowS) -> Show Event
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Event -> ShowS
showsPrec :: Int -> Event -> ShowS
$cshow :: Event -> String
show :: Event -> String
$cshowList :: [Event] -> ShowS
showList :: [Event] -> ShowS
Show, Event -> Event -> Bool
(Event -> Event -> Bool) -> (Event -> Event -> Bool) -> Eq Event
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Event -> Event -> Bool
== :: Event -> Event -> Bool
$c/= :: Event -> Event -> Bool
/= :: Event -> Event -> Bool
Eq, (forall x. Event -> Rep Event x)
-> (forall x. Rep Event x -> Event) -> Generic Event
forall x. Rep Event x -> Event
forall x. Event -> Rep Event x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Event -> Rep Event x
from :: forall x. Event -> Rep Event x
$cto :: forall x. Rep Event x -> Event
to :: forall x. Rep Event x -> Event
G.Generic)
instance Z.Serialize Event where

instance Q.Arbitrary Event where
  arbitrary :: Gen Event
arbitrary = [Gen Event] -> Gen Event
forall a. [Gen a] -> Gen a
Q.oneof [ Event -> Gen Event
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Event
Tick,
                        Char -> Event
KeyPress (Char -> Event) -> Gen Char -> Gen Event
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Char
forall a. Arbitrary a => Gen a
Q.arbitrary ]

-- | Game environment with current terminal dimensions and current display
-- rate.
data GEnv = GEnv { GEnv -> Dimensions
eTermDims :: Dimensions,
                        -- ^ Current terminal dimensions.
                   GEnv -> FPS
eFPS :: FPS
                        -- ^ Current blitting rate.
                       }
    deriving (Int -> GEnv -> ShowS
[GEnv] -> ShowS
GEnv -> String
(Int -> GEnv -> ShowS)
-> (GEnv -> String) -> ([GEnv] -> ShowS) -> Show GEnv
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GEnv -> ShowS
showsPrec :: Int -> GEnv -> ShowS
$cshow :: GEnv -> String
show :: GEnv -> String
$cshowList :: [GEnv] -> ShowS
showList :: [GEnv] -> ShowS
Show, GEnv -> GEnv -> Bool
(GEnv -> GEnv -> Bool) -> (GEnv -> GEnv -> Bool) -> Eq GEnv
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GEnv -> GEnv -> Bool
== :: GEnv -> GEnv -> Bool
$c/= :: GEnv -> GEnv -> Bool
/= :: GEnv -> GEnv -> Bool
Eq)

-------------------------------------------------------------------------------
-- GRec record/replay game typs

-- | Opaque data type with recorded game input, for testing purposes.
data GRec = GRec { GRec -> Seq [Event]
aPolled :: S.Seq [Event],
                                -- Seq. of polled events
                   GRec -> Seq (Maybe Dimensions)
aTermSize :: S.Seq (Maybe Dimensions) }
                                -- Seq. of polled termdims
        deriving (Int -> GRec -> ShowS
[GRec] -> ShowS
GRec -> String
(Int -> GRec -> ShowS)
-> (GRec -> String) -> ([GRec] -> ShowS) -> Show GRec
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GRec -> ShowS
showsPrec :: Int -> GRec -> ShowS
$cshow :: GRec -> String
show :: GRec -> String
$cshowList :: [GRec] -> ShowS
showList :: [GRec] -> ShowS
Show, GRec -> GRec -> Bool
(GRec -> GRec -> Bool) -> (GRec -> GRec -> Bool) -> Eq GRec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GRec -> GRec -> Bool
== :: GRec -> GRec -> Bool
$c/= :: GRec -> GRec -> Bool
/= :: GRec -> GRec -> Bool
Eq, (forall x. GRec -> Rep GRec x)
-> (forall x. Rep GRec x -> GRec) -> Generic GRec
forall x. Rep GRec x -> GRec
forall x. GRec -> Rep GRec x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GRec -> Rep GRec x
from :: forall x. GRec -> Rep GRec x
$cto :: forall x. Rep GRec x -> GRec
to :: forall x. Rep GRec x -> GRec
G.Generic)
instance Z.Serialize GRec where

igrec :: GRec
igrec :: GRec
igrec = Seq [Event] -> Seq (Maybe Dimensions) -> GRec
GRec Seq [Event]
forall a. Seq a
S.Empty Seq (Maybe Dimensions)
forall a. Seq a
S.Empty

addDims :: Maybe Dimensions -> GRec -> GRec
addDims :: Maybe Dimensions -> GRec -> GRec
addDims Maybe Dimensions
mds (GRec Seq [Event]
p Seq (Maybe Dimensions)
s) = Seq [Event] -> Seq (Maybe Dimensions) -> GRec
GRec Seq [Event]
p (Maybe Dimensions
mds Maybe Dimensions
-> Seq (Maybe Dimensions) -> Seq (Maybe Dimensions)
forall a. a -> Seq a -> Seq a
S.<| Seq (Maybe Dimensions)
s)

getDims :: GRec -> (Maybe Dimensions, GRec)
getDims :: GRec -> (Maybe Dimensions, GRec)
getDims (GRec Seq [Event]
p (Seq (Maybe Dimensions)
ds S.:|> Maybe Dimensions
d)) = (Maybe Dimensions
d, Seq [Event] -> Seq (Maybe Dimensions) -> GRec
GRec Seq [Event]
p Seq (Maybe Dimensions)
ds)
getDims GRec
_ = String -> (Maybe Dimensions, GRec)
forall a. HasCallStack => String -> a
error String
"getDims: empty Seq"
    -- Have to use _ or “non exhaustive patterns” warning

addPolled :: [Event] -> GRec -> GRec
addPolled :: [Event] -> GRec -> GRec
addPolled [Event]
es (GRec Seq [Event]
p Seq (Maybe Dimensions)
s) = Seq [Event] -> Seq (Maybe Dimensions) -> GRec
GRec ([Event]
es [Event] -> Seq [Event] -> Seq [Event]
forall a. a -> Seq a -> Seq a
S.<| Seq [Event]
p) Seq (Maybe Dimensions)
s

getPolled :: GRec -> ([Event], GRec)
getPolled :: GRec -> ([Event], GRec)
getPolled (GRec (Seq [Event]
ps S.:|> [Event]
p) Seq (Maybe Dimensions)
d) = ([Event]
p, Seq [Event] -> Seq (Maybe Dimensions) -> GRec
GRec Seq [Event]
ps Seq (Maybe Dimensions)
d)
getPolled GRec
_ = String -> ([Event], GRec)
forall a. HasCallStack => String -> a
error String
"getPolled: empty Seq"

isOver :: GRec -> Bool
isOver :: GRec -> Bool
isOver (GRec Seq [Event]
S.Empty Seq (Maybe Dimensions)
_) = Bool
True
isOver GRec
_ = Bool
False

-- | Reads a file containing a recorded session. Throws
-- 'MalformedGRec' on failure.
readRecord :: FilePath -> IO GRec
readRecord :: String -> IO GRec
readRecord String
fp = ByteString -> Either String GRec
forall a. Serialize a => ByteString -> Either String a
Z.decode (ByteString -> Either String GRec)
-> IO ByteString -> IO (Either String GRec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile String
fp IO (Either String GRec)
-> (Either String GRec -> IO GRec) -> IO GRec
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Left String
e  -> ATGException -> IO GRec
forall e a. (HasCallStack, Exception e) => e -> IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
MC.throwM (String -> ATGException
MalformedGRec String
e)
                  Right GRec
r -> GRec -> IO GRec
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GRec
r

-- | Convenience function to create a 'GRec' from screen size (constant) plus a list of events. Useful with 'setupGame'.
createGRec :: Dimensions -> [Event] -> GRec
createGRec :: Dimensions -> [Event] -> GRec
createGRec Dimensions
ds [Event]
es = let l :: Int
l = [Event] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Event]
es Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 in
                   Seq [Event] -> Seq (Maybe Dimensions) -> GRec
GRec ([[Event]] -> Seq [Event]
forall a. [a] -> Seq a
S.fromList [[Event]
es])
                        ([Maybe Dimensions] -> Seq (Maybe Dimensions)
forall a. [a] -> Seq a
S.fromList ([Maybe Dimensions] -> Seq (Maybe Dimensions))
-> (Maybe Dimensions -> [Maybe Dimensions])
-> Maybe Dimensions
-> Seq (Maybe Dimensions)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Dimensions -> [Maybe Dimensions]
forall a. Int -> a -> [a]
replicate Int
l (Maybe Dimensions -> Seq (Maybe Dimensions))
-> Maybe Dimensions -> Seq (Maybe Dimensions)
forall a b. (a -> b) -> a -> b
$ Dimensions -> Maybe Dimensions
forall a. a -> Maybe a
Just Dimensions
ds)

-------------------------------------------------------------------------------
-- Exceptions

-- | @ATGException@s are thrown synchronously for easier catching.
data ATGException = CannotGetDisplaySize
                  | DisplayTooSmall Dimensions Dimensions
                        -- ^ Required and actual dimensions.
                  | MalformedGRec String
        deriving (ATGException -> ATGException -> Bool
(ATGException -> ATGException -> Bool)
-> (ATGException -> ATGException -> Bool) -> Eq ATGException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ATGException -> ATGException -> Bool
== :: ATGException -> ATGException -> Bool
$c/= :: ATGException -> ATGException -> Bool
/= :: ATGException -> ATGException -> Bool
Eq)

instance Show ATGException where
    show :: ATGException -> String
show ATGException
CannotGetDisplaySize = String
"CannotGetDisplaySize"
    show (DisplayTooSmall (Int
sw, Int
sh) Dimensions
tds) =
      let colS :: Int -> Bool
colS Int
ww = Int
ww Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
sw
          rowS :: Int -> Bool
rowS Int
wh = Int
wh Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
sh

          smallMsg :: Dimensions -> String
          smallMsg :: Dimensions -> String
smallMsg (Int
ww, Int
wh) =
                let cm :: String
cm = Int -> String
forall a. Show a => a -> String
show Int
ww String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" columns"
                    rm :: String
rm = Int -> String
forall a. Show a => a -> String
show Int
wh String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" rows"
                    em :: String
em | Int -> Bool
colS Int
ww Bool -> Bool -> Bool
&& Int -> Bool
rowS Int
wh = String
cm String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" and " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
rm
                       | Int -> Bool
colS Int
ww = String
cm
                       | Int -> Bool
rowS Int
wh = String
rm
                       | Bool
otherwise = String
"smallMsg: passed correct term size!"
                in
                  String
"This games requires a display of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
sw String -> ShowS
forall a. [a] -> [a] -> [a]
++
                  String
" columns and " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
sh String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" rows.\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                  String
"Yours only has " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
em String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"!\n\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                  String
"Please resize your terminal and restart the game.\n"
      in String
"DisplayTooSmall.\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Dimensions -> String
smallMsg Dimensions
tds
    show (MalformedGRec String
e) = String
"MalformedGRec: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e

instance MC.Exception ATGException where