{-# 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