Primitives.hs

{-# Language RankNTypes #-}
{-# Language TemplateHaskell #-}
{-# Language ConstraintKinds #-}

module Meeple.Primitives where

-- NPC/PC/Objects primitives

import Input
import Lens.Micro.Platform
import Terminal.Game

import qualified Data.Function as F
import qualified Data.Char as C


-------------
-- CLASSES --
-------------

-- Classes:
-- - stationary
--     - moving
--         - delayed
--             - walker
-- - casual


data Stationary = Stationary { _position :: Coords,
                               _draw     :: Animation }
              deriving (Eq, Show)
makeClassy ''Stationary

defaultStationary :: Coords -> Animation -> Stationary
defaultStationary c a = Stationary c a

-- speed in row/column
type Speed = (Row, Column)
type Step  = Speed -- movement relative to last step

data Moving = Moving
        { _movingStationary :: Stationary,
          _speed            :: Speed,
          _steps            :: [Step],
          _prevPos          :: Coords  }
              deriving (Eq, Show)
makeClassy ''Moving
instance HasStationary Moving where stationary = movingStationary

defaultMoving :: Coords -> Animation -> Moving
defaultMoving c a = Moving (defaultStationary c a)
                           (0, 0) [] c

-- delayed moving (once every x frames)
data Delayed = Delayed
        { _delayedMoving :: Moving,
          _delay         :: Timed Bool }
                        -- will wait x cycles before acting
              deriving (Eq, Show)
makeClassy ''Delayed
instance HasMoving Delayed where moving = delayedMoving
instance HasStationary Delayed where
        stationary = delayedMoving . movingStationary

defaultDelayed :: Coords -> Animation -> Integer -> Delayed
defaultDelayed c a i = Delayed (defaultMoving c a) (creaBoolTimerLoop i)

data Walker = Walker
        { _walkerDelayed :: Delayed,
          _cardinal      :: Cardinal }
          deriving (Eq, Show)
makeClassy ''Walker
instance HasDelayed Walker where delayed = walkerDelayed
instance HasMoving Walker where moving = walkerDelayed . delayedMoving
instance HasStationary Walker where
        stationary = walkerDelayed . movingStationary

defaultWalker :: Coords -> Animation -> Integer -> Cardinal -> Walker
defaultWalker c a i k = Walker (defaultDelayed c a i) k


newtype Casual = Casual { _seed :: StdGen }
              deriving (Show)
makeClassy ''Casual

-- dirty way of setting up an rng
defaultCasual :: Coords -> Casual
defaultCasual (r, c) = Casual $ mkStdGen (fromIntegral $ r + c)

-- cosa vado a creare? Non posso usare Meeple direttamente, perché grouping
-- of TH non lascia spazio per def circolari.

data MeepRef = MRStone Coords
             | MRSickle Coords Speed
            deriving (Eq, Show)

data Generator = Generator
        { _generatorCasual :: Casual,
          _ready           :: Maybe MeepRef }
              deriving (Show)
makeClassy ''Generator
instance HasCasual Generator where casual = generatorCasual
instance Eq Generator where
    ga == gb = F.on (==) _ready ga gb

defaultGenerator :: Coords -> Generator
defaultGenerator cs = Generator (defaultCasual cs) Nothing


--------------------
-- ACTUAL MEEPLES --
--------------------

-- STATIONARY --

newtype Star = Star { _starStationary :: Stationary }
        deriving (Eq, Show)
makeLenses ''Star
instance HasStationary Star where stationary = starStationary
defaultStar :: Coords -> Star
defaultStar cs = Star $
            defaultStationary
                cs
                (creaStaticAnimation $ cell '*' # color Yellow Vivid)

data Lock = Lock { _lockStationary :: Stationary,
                   _origNumeral :: Integer,   -- stars to collect to open it
                   _currNumeral :: Integer }
        deriving (Eq, Show)
makeLenses ''Lock
instance HasStationary Lock where stationary = lockStationary

defaultLock :: Coords -> Integer -> Lock
defaultLock cs i = Lock sta i i
    where
          sta = defaultStationary
                  cs
                  (creaStaticAnimation $ cell 'L')

newtype Stone = Stone { _stoneMoving :: Moving }
        deriving (Eq, Show)
makeLenses ''Stone
instance HasMoving Stone where moving = stoneMoving
instance HasStationary Stone where
    stationary = stoneMoving . movingStationary

defaultStone :: Coords -> Stone
defaultStone cs = Stone $
            defaultMoving cs
                (creaStaticAnimation $ cell 'o' # color Cyan Vivid)

newtype Sickle = Sickle { _sickleMoving :: Moving }
        deriving (Eq, Show)
makeLenses ''Sickle
instance HasMoving Sickle where moving = sickleMoving
instance HasStationary Sickle where
    stationary = sickleMoving . movingStationary

defaultSickle :: Coords -> Speed -> Sickle
defaultSickle cs s = Sickle def
    where
          sickAni = creaLoopAnimation
                      [(1, cell '<' # color Cyan Vivid),
                       (1, cell '^' # color Cyan Vivid),
                       (1, cell '>' # color Cyan Vivid),
                       (1, cell 'v' # color Cyan Vivid)
                      ]

          def = (defaultMoving cs sickAni) { _speed = s }

data NetStatus = NNo | NWake | NYes
        deriving (Eq, Show)
newtype Nettle = Nettle { _nettleStationary :: Stationary }
        deriving (Eq, Show)
makeLenses ''Nettle
instance HasStationary Nettle where stationary = nettleStationary

defaultNettle :: Coords -> Nettle
defaultNettle c = Nettle (defaultStationary c ia)
    where
          ia = creaLoopAnimation
                    [(19, cell ',' # color Green Dull),
                     ( 5, cell ';' # color Green Dull),
                     (26, cell 'A' # color Green Dull),
                     ( 5, cell ';' # color Green Dull)]

-- MOVING --

newtype Dumb = Dumb { _dumbWalker :: Walker }
        deriving (Eq, Show)
makeLenses ''Dumb
instance HasWalker Dumb where walker = dumbWalker
instance HasDelayed Dumb where delayed = dumbWalker . walkerDelayed
instance HasMoving Dumb where moving = dumbWalker . delayedMoving
instance HasStationary Dumb where stationary = dumbWalker . movingStationary

defaultDumb :: Coords -> Cardinal -> Dumb
defaultDumb cs k = Dumb $
        defaultWalker
            cs
            (creaStaticAnimation $ cell 'd' # color Red Dull)
            2 k

newtype Smart = Smart { _smartWalker :: Walker }
        deriving (Eq, Show)
makeLenses ''Smart
instance HasWalker Smart where walker = smartWalker
instance HasDelayed Smart where delayed = smartWalker . walkerDelayed
instance HasMoving Smart where moving = smartWalker . delayedMoving
instance HasStationary Smart where stationary = smartWalker . movingStationary


defaultSmart :: Coords -> Cardinal -> Smart
defaultSmart cs k = Smart $
        defaultWalker
            cs
            (creaStaticAnimation $ cell 'd' # color Cyan Dull)
            2 k

data Krampus = Krampus { _krampusWalker  :: Walker,
                         _krampusGenerator :: Generator }
        deriving (Eq, Show)
makeLenses ''Krampus
instance HasWalker Krampus where walker = krampusWalker
instance HasDelayed Krampus where delayed = krampusWalker . walkerDelayed
instance HasMoving Krampus where moving = krampusWalker . delayedMoving
instance HasStationary Krampus where
    stationary = krampusWalker . movingStationary
instance HasGenerator Krampus where generator = krampusGenerator
instance HasCasual Krampus where casual = krampusGenerator . generatorCasual

defaultKrampus :: Coords -> Cardinal -> Krampus
defaultKrampus cs d = Krampus wlk gen
    where wlk = defaultWalker
                     cs
                     (creaStaticAnimation $ cell 'k' # color Blue Vivid # bold)
                     2 d
          gen = defaultGenerator cs


-- bird state is "where I spawned". Should be "read", not state, but it's ok.
data Bird = Bird { _birdDelayed   :: Delayed,
                   _birdGenerator :: Generator,
                   _spawnpoint    :: Coords }
        deriving (Eq, Show)
makeLenses ''Bird
instance HasDelayed Bird where delayed = birdDelayed
instance HasMoving Bird where moving = birdDelayed . delayedMoving
instance HasStationary Bird where stationary = birdDelayed . movingStationary
instance HasGenerator Bird where generator = birdGenerator
instance HasCasual Bird where casual = birdGenerator . generatorCasual
defaultBird :: Coords -> Bird
defaultBird cs = Bird del gen cs
    where del = defaultDelayed
                     cs
                     (creaStaticAnimation $ cell 'v' # color Magenta Vivid)
                     2
          gen = defaultGenerator cs

data Witch = Witch { _witchDelayed :: Delayed,
                     _witchCasual  :: Casual }
        deriving (Show)
makeLenses ''Witch
instance Eq Witch where
    ga == gb = F.on (==) _witchDelayed ga gb
instance HasDelayed Witch where delayed = witchDelayed
instance HasMoving Witch where moving = witchDelayed . moving
instance HasStationary Witch where stationary = witchDelayed . stationary
instance HasCasual Witch where casual = witchCasual
defaultWitch :: Coords -> Witch
defaultWitch cs = Witch del gen
    where del = defaultDelayed
                     cs
                     (creaStaticAnimation $ cell 'X' # color Yellow Dull # bold)
                     2
          gen = defaultCasual cs



data Win = Win { _winDelayed :: Delayed,
                 _floatino   :: Cardinal }
        deriving (Eq, Show)
makeLenses ''Win
instance HasDelayed Win where delayed = winDelayed
instance HasMoving Win where moving = winDelayed . delayedMoving
instance HasStationary Win where stationary = winDelayed . movingStationary
defaultWin :: Coords -> Win
defaultWin cs = Win del N
    where
          del = defaultDelayed
                    cs
                    (creaLoopAnimation
                       [(2, cell '+' # color Red Vivid),
                        (2, cell '*' # color Yellow Vivid),
                        (2, cell '+' # color Green Vivid),
                        (2, cell '*' # color Blue Vivid)])
                    30

newtype Save = Save { _saveStationary :: Stationary }
        deriving (Eq, Show)
makeLenses ''Save
instance HasStationary Save where stationary = saveStationary
defaultSave :: Coords -> Save
defaultSave cs = Save sta
    where
          sta = defaultStationary cs
                          (creaStaticAnimation $ cell '@' # color Blue Vivid )

-- PLAYER --

data PAction = ANoAction | AJumpL | AJumpR | AJumpX | AClimb | ADescend | AGoW | AGoE
        deriving (Eq, Show)

data Player = Player {
                _playerDelayed :: Delayed,
                _action       :: PAction,
                    -- AGI direction
                _IsClimbing :: Bool,
                _IsNew      :: Bool, -- no moves yet: True
                _AmSaving   :: Bool,

                    -- slow gimmick for orcolat
                _AmSlow :: Bool
             }
    deriving (Eq, Show)
makeLenses ''Player
instance HasDelayed Player where delayed = playerDelayed
instance HasMoving Player where moving = playerDelayed . moving
instance HasStationary Player where
    stationary = playerDelayed . movingStationary

defaultPlayer :: Coords -> Player
defaultPlayer cs = Player
        (defaultDelayed cs (creaStaticAnimation $ cell '@' # invert) 2)
                -- ricorda di modificare anche a' in simpleMove
        ANoAction
        False True False
        False


--------------
-- SUM TYPE --
--------------

-- If you add anything to this you must
-- 1) add the relevant data (see e.g. Bird)
-- 2) add a wrapper here (e.g. MBird)
-- 3) add the relevant parsing char to charMeeple
-- 4) then everything will be just fixing "non-exhaustive pattern matches"
--    (turn -WAll on for this)
-- 5) add collisions in Screen/Collision.hs collTable
data Meeple = MBird Bird
            | MDead Message
            | MDumb Dumb
            | MKram Krampus
            | MLock Lock
            | MNettle Nettle
            | MPlayer Player
            | MSave Save
            | MSmart Smart
            | MSickle Sickle
            | MStar Star
            | MStone Stone
            | MWin Win
            | MWitch Witch
        deriving (Eq, Show)

-- sort is needed when drawing, player should always come on top
instance Ord Meeple where
    compare (MPlayer _) _ = GT
    compare _ (MPlayer _) = LT
    compare _ _           = EQ

data Message = PlusStar Coords -- String: Name of the Room
             | NeutralStar Coords
             | Won
             | None
        deriving (Eq, Show)

-- parsing helper
charMeeple :: Char -> Coords -> Maybe Meeple
charMeeple '*' cs = Just . MStar $ defaultStar cs
charMeeple '+' cs = Just . MWin $ defaultWin cs
charMeeple 'd' cs = Just . MDumb $ defaultDumb cs W
charMeeple 'b' cs = Just . MDumb $ defaultDumb cs E
charMeeple 'f' cs = Just . MSmart $ defaultSmart cs W
charMeeple 'j' cs = Just . MSmart $ defaultSmart cs E
charMeeple 'v' cs = Just . MBird $ defaultBird cs
charMeeple 'o' cs = Just . MStone $ defaultStone cs
charMeeple 'k' cs = Just . MKram $ defaultKrampus cs E
charMeeple 'y' cs = Just . MKram $ defaultKrampus cs W
charMeeple '^' cs = Just . MSickle $ defaultSickle cs (2, 0)
charMeeple ',' cs = Just . MNettle $ defaultNettle cs
charMeeple '@' cs = Just . MSave $ defaultSave cs
charMeeple 'X' cs = Just . MWitch $ defaultWitch cs
charMeeple c   cs | C.isDigit c =
                      Just . MLock $ defaultLock cs (read [c])
charMeeple _   _  = Nothing


------------------------
-- SUM TYPE INSTANCES --
------------------------


-- "id setter, no getter" lens
els :: forall a s. String -> Lens' a s
els t = lens (error t) const

instance HasStationary Meeple where
    stationary f (MDead x)   = MDead <$> els "HasStationary on Dead" f x
    stationary f (MBird b)   = MBird <$> stationary f b
    stationary f (MDumb d)   = MDumb <$> stationary f d
    stationary f (MKram k)   = MKram <$> stationary f k
    stationary f (MLock l)   = MLock <$> stationary f l
    stationary f (MNettle n) = MNettle <$> stationary f n
    stationary f (MPlayer p) = MPlayer <$> stationary f p
    stationary f (MSave s)   = MSave <$> stationary f s
    stationary f (MSickle s) = MSickle <$> stationary f s
    stationary f (MSmart s)  = MSmart <$> stationary f s
    stationary f (MStar s)   = MStar <$> stationary f s
    stationary f (MStone s)  = MStone <$> stationary f s
    stationary f (MWin w)    = MWin <$> stationary f w
    stationary f (MWitch w)  = MWitch <$> stationary f w

instance HasMoving Meeple where
    moving f (MDead x)   = MDead <$> els "HasMoving on Dead" f x
    moving f (MBird d)   = MBird <$> moving f d
    moving f (MDumb d)   = MDumb <$> moving f d
    moving f (MKram k)   = MKram <$> moving f k
    moving f (MLock l)   = MLock <$> els "HasMoving on Lock" f l
    moving f (MNettle n) = MNettle <$> els "HasMoving on Nettle" f n
    moving f (MPlayer p) = MPlayer <$> moving f p
    moving f (MSave s)   = MSave <$> els "HasMoving on Save" f s
    moving f (MSmart s)  = MSmart <$> moving f s
    moving f (MSickle s) = MSickle <$> moving f s
    moving f (MStar s)   = MStar <$> els "HasMoving on Star" f s
    moving f (MStone s)  = MStone <$> moving f s
    moving f (MWin w)    = MWin <$> moving f w
    moving f (MWitch w)   = MWitch <$> moving f w

----------------
-- CATEGORIES --
----------------

data MCategory = Aether | Baddie | Bonus | Projectile | CPlayer | Static
               deriving (Show, Eq)

meepleCategory :: Meeple -> MCategory
meepleCategory (MDead _)   = Aether
meepleCategory (MBird _)   = Baddie
meepleCategory (MDumb _)   = Baddie
meepleCategory (MKram _)   = Baddie
meepleCategory (MLock _)   = Static
meepleCategory (MNettle _) = Baddie
meepleCategory (MPlayer _) = CPlayer
meepleCategory (MSave _)   = Bonus
meepleCategory (MSickle _) = Projectile
meepleCategory (MStar _)   = Bonus
meepleCategory (MSmart _)  = Baddie
meepleCategory (MStone _)  = Projectile
meepleCategory (MWin _)    = Bonus
meepleCategory (MWitch _)   = Baddie

class Meepeable a where
    a2m :: a -> Meeple

type Coo m = (HasStationary m, Meepeable m)

instance Meepeable Dumb where
    a2m = MDumb
instance Meepeable Krampus where
    a2m = MKram
instance Meepeable Smart where
    a2m = MSmart
instance Meepeable Meeple where
    a2m = id