Move.hs

{-# Language FlexibleContexts #-}

module Screen.Move where

import Terminal.Game
import Lens.Micro.Platform

import Meeple.Operate
import Room
import Screen.Check
import Screen.Collision
import Screen.Primitives

import qualified Data.List  as L


-- moves, check for room and meeples collision <= one by one
moveCollideGeneral :: HasScreen s => s -> s
moveCollideGeneral s =
            let -- motion (non step) action
                s'   = s & meeples . each %~ applyGravity (s ^. room)
                         & meeples . each %~ limitSpeed
                -- steps
                s''  = exhaustSteps (generateAllSteps s')
                -- dead cleaning will be done in story,
                -- since messages are collected there
            in s''
    where
          -- step actions
          exhaustSteps :: HasScreen s => s -> s
          exhaustSteps sw =
              if any hasSteps (sw ^. meeples)
                then exhaustSteps (oneStep sw)
                else sw

          oneStep :: HasScreen s => s -> s
          oneStep sw = let ms = sw ^. meeples
                           ei = length ms - 1
                      in
                      L.foldl' stepCollide sw [0..ei]


------------
-- MOTION --
------------

-- *non* stepped stuff

gravity  :: Integer
gravity = 1

-- room:: jus for oob check
-- todo [refactor] refactor
applyGravity :: Room -> Meeple -> Meeple
applyGravity _ m@(MDead _)  = m
applyGravity _ m@(MBird _)  = m
applyGravity _ m@(MDumb _)  = m & speed . _1 +~ gravity
applyGravity _ m@(MKram _)  = m & speed . _1 +~ gravity
applyGravity _ m@(MLock _)  = m
applyGravity _ m@(MNettle _)  = m
applyGravity r m@(MPlayer p)
        | p ^. isClimbing = m
        | isOOBRoom r
            (p ^. position) = m -- do not apply in between room or we can't
                                -- high jump between rooms
        | otherwise       = m & speed . _1 +~ gravity
applyGravity _ m@(MSave _)  = m
applyGravity _ m@(MSmart _) = m & speed . _1 +~ gravity
applyGravity _ m@(MStar _)  = m
applyGravity _ m@(MSickle _) = m & speed . _1 +~ gravity
applyGravity _ m@(MStone _) = m & speed . _1 +~ gravity
applyGravity _ m@(MWin _)   = m
applyGravity _ m@(MWitch _)   = m

limitSpeed :: Meeple -> Meeple
limitSpeed m@(MDead _) = m
limitSpeed m     = m & speed . _1 %~ im (>=) 1
                     & speed . _2 %~ im (>=) 1
                     & speed . _2 %~ im (<=) (-1)
    where
          im :: (Integer -> Integer -> Bool) ->
                Integer -> Integer -> Integer
          im o t x = if x `o` t then t else x


-----------
-- STEPS --
-----------

generateAllSteps :: HasScreen s => s -> s
generateAllSteps s = s & meeples . each %~ generateSteps


-- single meeple, *one* step
stepCollide :: HasScreen s => s -> Index -> s
stepCollide s i = s & meeples . ix i %~ savePosition
                    & meeples . ix i %~ step s
                    & meeples . ix i %~ roomCollision s
                    & meeples        %~ meepleCollision i

savePosition :: Meeple -> Meeple
savePosition m@(MDead _) = m
savePosition m           = m & prevPos .~ m ^. position

-- this is a single step!
step :: HasScreen s => s -> Meeple -> Meeple
step _ m@(MDead _)   = m
step s m@(MBird _)   = simpleMove s m
step s m@(MDumb _)   = simpleMove s m
step s m@(MKram _)   = simpleMove s m
step _ m@(MLock _)   = m
step _ m@(MNettle _)  = m
step s m@(MPlayer _) = simpleMove s m
step _ m@(MSave _)   = m
step s m@(MSickle _)  = simpleMove s m
step s m@(MSmart _)  = simpleMove s m
step _ m@(MStar _)   = m
step s m@(MStone _)  = simpleMove s m
step s m@(MWin _)    = simpleMove s m
step s m@(MWitch _)    = everyMove s m


-----------------
-- ANCILLARIES --
-----------------

-- move everywhere, regardless of boundaries (spirit)
everyMove :: HasScreen s => s -> Meeple -> Meeple
everyMove _ m
        | not (hasSteps m) = m
        | otherwise        =
                let (sr, sc) = m ^. speed
                in m & position . _1 %~ (+sr)
                     & position . _2 %~ (+sc)
                     & id            %~ dropStep

-- try to move in a direction fallback to other solutions if possible
simpleMove :: (HasScreen s) => s -> Meeple -> Meeple
simpleMove s a
        | not (hasSteps a) = a
        | (fp:_) <- fps    = dropStep $ snd fp
        | otherwise        = dropStep $ a' & speed .~ (0, 0)
                               -- stuck? Just don't move
    where
          ps :: [(Coords, Meeple)]
          ps = map (uncurry $ makePosa a)
                   -- we first try the expected, the no vert, etc.
                   [(False, False),
                    (True, False),
                    (False, True),
                    (True, True)]

          fps :: [(Coords, Meeple)]
          fps = filter (\(c, _) -> canGoThere s a c) ps

          -- stop agi mov
          a' | (MPlayer p) <- a =
                  if p ^. amSlow . to not ||
                     (p ^. delay . to (ticks 2) . to fetchFrame)
                        -- todo [refactor] no idea why ticks 3
                    then MPlayer $ p & action .~ ANoAction
                    else MPlayer p
             | otherwise        = a

-- given Meeple we modify slightly its speed and obtain projected landing
-- places. Uper functions can check these are sensible (against walls etc.)
-- and pick the right move.
type VerticalOffset   = Bool
type HorizontalOffset = Bool
makePosa :: Meeple -> VerticalOffset -> VerticalOffset -> (Coords, Meeple)
makePosa m vo ho = (cs, m & vm & hm & position .~ cs)
    where
          pr = m ^. position . _1
          pc = m ^. position . _2

          stepSpeed = steps . to head

          sr | vo        = 0
             | otherwise = m ^. stepSpeed . _1

          sc | ho        = 0
             | otherwise = m ^. stepSpeed . _2

          cs = (pr + sr, pc + sc)

          vm | vo        = speed . _1 .~ 0
             | otherwise = id

          hm | ho        = \bm -> bm & speed . _2 .~ 0
                                     & id %~ pActStop
             | otherwise = id

          pActStop (MPlayer p) = MPlayer $ p & action .~ ANoAction
          pActStop wm          = wm