{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}
-- | Breadth first search algorithms.
module Game.LambdaHack.Client.Bfs
  ( BfsDistance, MoveLegal(..), apartBfs
  , fillBfs, findPathBfs, accessBfs
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , minKnownBfs
#endif
  ) where

import Control.Exception.Assert.Sugar
import Data.Binary
import Data.Bits (Bits, complement, (.&.), (.|.))
import Data.List
import Data.Maybe

import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
import Game.LambdaHack.Common.Vector

-- | Weighted distance between points along shortest paths.
newtype BfsDistance = BfsDistance Word8
  deriving (Show, Eq, Ord, Enum, Bounded, Bits)

-- | State of legality of moves between adjacent points.
data MoveLegal = MoveBlocked | MoveToOpen | MoveToUnknown
  deriving Eq

-- | The minimal distance value assigned to paths that don't enter
-- any unknown tiles.
minKnownBfs :: BfsDistance
minKnownBfs = toEnum $ (1 + fromEnum (maxBound :: BfsDistance)) `div` 2

-- | The distance value that denote no legal path between points.
-- The next value is the minimal distance value assigned to paths
-- that don't enter any unknown tiles.
apartBfs :: BfsDistance
apartBfs = pred minKnownBfs

-- TODO: costly; use a ring buffer instead of the lists, don't call so often
-- | Fill out the given BFS array.
-- Unsafe @PointArray@ operations are OK here, because the intermediate
-- values of the vector don't leak anywhere outside nor are kept unevaluated
-- and so they can't be overwritten by the unsafe side-effect.
fillBfs :: (Point -> Point -> MoveLegal)  -- ^ is a move from known tile legal
        -> (Point -> Point -> Bool)       -- ^ is a move from unknown legal
        -> Point                          -- ^ starting position
        -> PointArray.Array BfsDistance   -- ^ initial array, with @apartBfs@
        -> PointArray.Array BfsDistance   -- ^ array with calculated distances
{-# INLINE fillBfs #-}
fillBfs isEnterable passUnknown origin aInitial =
  let maxKnownBfs = pred maxBound
      predMaxKnownBfs = pred maxKnownBfs
      bfs :: BfsDistance
          -> [Point]
          -> [Point]
          -> PointArray.Array BfsDistance
          -> PointArray.Array BfsDistance
      bfs distance predK predU a =
        let distCompl = distance .&. complement minKnownBfs
            processKnown (succK2, succU2, a2) pos =
              let fKnown (lK, lU) move =
                    let p = shift pos move
                        freshMv = a2 PointArray.! p == apartBfs
                        legality = isEnterable pos p
                        (notBlocked, enteredUnknown) = case legality of
                          MoveBlocked -> (False, undefined)
                          MoveToOpen -> (True, False)
                          MoveToUnknown -> (True, True)
                    in if freshMv && notBlocked
                       then if enteredUnknown
                            then (lK, p : lU)
                            else (p : lK, lU)
                       else (lK, lU)
                  (mvsK, mvsU) = foldl' fKnown ([], []) moves
                  upd = zip mvsK (repeat distance)
                        ++ zip mvsU (repeat distCompl)
                  !a3 = PointArray.unsafeUpdateA a2 upd
              in (mvsK ++ succK2, mvsU ++ succU2, a3)
            processUnknown (succU2, a2) pos =
              let fUnknown lU move =
                    let p = shift pos move
                        freshMv = a2 PointArray.! p == apartBfs
                        notBlocked = passUnknown pos p
                    in if freshMv && notBlocked
                       then p : lU
                       else lU
                  mvsU = foldl' fUnknown [] moves
                  upd = zip mvsU (repeat distCompl)
                  !a3 = PointArray.unsafeUpdateA a2 upd
              in (mvsU ++ succU2, a3)
            (succU4, !a4) = foldl' processUnknown ([], a) predU
            (succK6, succU6, !a6) = foldl' processKnown ([], succU4, a4) predK
        in if null succK6 && null succU6  -- no more dungeon positions to check
              || distance == predMaxKnownBfs  -- wasting one Known slot
           then a6  -- too far
           else bfs (succ distance) succK6 succU6 a6
  in bfs (succ minKnownBfs) [origin] []
         (PointArray.unsafeUpdateA aInitial [(origin, minKnownBfs)])

-- TODO: Use http://harablog.wordpress.com/2011/09/07/jump-point-search/
-- to determine a few really different paths and compare them,
-- e.g., how many closed doors they pass, open doors, unknown tiles
-- on the path or close enough to reveal them.
-- Also, check if JPS can somehow optimize BFS or pathBfs.
-- | Find a path, without the source position, with the smallest length.
-- The @eps@ coefficient determines which direction (or the closest
-- directions available) that path should prefer, where 0 means north-west
-- and 1 means north.
findPathBfs :: (Point -> Point -> MoveLegal)
            -> (Point -> Point -> Bool)
            -> Point -> Point -> Int -> PointArray.Array BfsDistance
            -> Maybe [Point]
{-# INLINE findPathBfs #-}
findPathBfs isEnterable passUnknown source target sepsRaw bfs =
  assert (bfs PointArray.! source == minKnownBfs) $
  let targetDist = bfs PointArray.! target
  in if targetDist == apartBfs
     then Nothing
     else
       let eps = sepsRaw `mod` 4
           (mc1, mc2) = splitAt eps movesCardinal
           (md1, md2) = splitAt eps movesDiagonal
           preferredMoves = mc1 ++ reverse mc2 ++ md2 ++ reverse md1  -- fuzz
           track :: Point -> BfsDistance -> [Point] -> [Point]
           track pos oldDist suffix | oldDist == minKnownBfs =
             assert (pos == source
                     `blame` (source, target, pos, suffix)) suffix
           track pos oldDist suffix | oldDist > minKnownBfs =
             let dist = pred oldDist
                 children = map (shift pos) preferredMoves
                 matchesDist p = bfs PointArray.! p == dist
                                 && isEnterable p pos == MoveToOpen
                 minP = fromMaybe (assert `failure` (pos, oldDist, children))
                                  (find matchesDist children)
             in track minP dist (pos : suffix)
           track pos oldDist suffix =
             let distUnknown = pred oldDist
                 distKnown = distUnknown .|. minKnownBfs
                 children = map (shift pos) preferredMoves
                 matchesDistUnknown p = bfs PointArray.! p == distUnknown
                                        && passUnknown p pos
                 matchesDistKnown p = bfs PointArray.! p == distKnown
                                      && isEnterable p pos == MoveToUnknown
                 (minP, dist) = case find matchesDistKnown children of
                   Just p -> (p, distKnown)
                   Nothing -> case find matchesDistUnknown children of
                     Just p -> (p, distUnknown)
                     Nothing -> assert `failure` (pos, oldDist, children)
             in track minP dist (pos : suffix)
       in Just $ track target targetDist []

-- | Access a BFS array and interpret the looked up distance value.
accessBfs :: PointArray.Array BfsDistance -> Point -> Maybe Int
{-# INLINE accessBfs #-}
accessBfs bfs target =
  let dist = bfs PointArray.! target
  in if dist == apartBfs
     then Nothing
     else Just $ fromEnum $ dist .&. complement minKnownBfs