-- | Operations on the 'Area' type that involve random numbers.
module Game.LambdaHack.Server.DungeonGen.AreaRnd
  ( -- * Picking points inside areas
    mkFixed, pointInArea, findPointInArea, mkVoidRoom, mkRoom
    -- * Choosing connections
  , connectGrid, randomConnection
    -- * Plotting corridors
  , HV(..), Corridor, connectPlaces
  , SpecialArea(..), grid
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , connectGrid', sortPoint, mkCorridor, borderPlace
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import           Data.Functor.Identity (runIdentity)
import qualified Data.IntSet as IS

import Game.LambdaHack.Common.Area
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.Vector
import Game.LambdaHack.Content.PlaceKind
import Game.LambdaHack.Core.Random
import Game.LambdaHack.Definition.Defs

-- Doesn't respect minimum sizes, because staircases are specified verbatim,
-- so can't be arbitrarily scaled up.
-- The size may be one more than what maximal size hint requests,
-- but this is safe (limited by area size) and makes up for the rigidity
-- of the fixed room sizes (e.g., that the size is always odd).
mkFixed :: (X, Y)    -- ^ maximum size
        -> Area      -- ^ the containing area, not the room itself
        -> Point     -- ^ the center point
        -> Area
mkFixed (xMax, yMax) area p@Point{..} =
  let (x0, y0, x1, y1) = fromArea area
      xradius = min ((xMax + 1) `div` 2) $ min (px - x0) (x1 - px)
      yradius = min ((yMax + 1) `div` 2) $ min (py - y0) (y1 - py)
      a = (px - xradius, py - yradius, px + xradius, py + yradius)
  in fromMaybe (error $ "" `showFailure` (a, xMax, yMax, area, p)) $ toArea a

-- | Pick a random point within an area.
pointInArea :: Area -> Rnd Point
pointInArea area = do
  let (Point x0 y0, xspan, yspan) = spanArea area
  pxy <- randomR0 (xspan * yspan - 1)
  let Point{..} = punindex xspan pxy
  return $! Point (x0 + px) (y0 + py)

-- | Find a suitable position in the area, based on random points
-- and a preference predicate and fallback acceptability predicate.
findPointInArea :: Area -> (Point -> Maybe Point)
                -> Int -> (Point -> Maybe Point)
                -> Rnd (Maybe Point)
findPointInArea area g gnumTries f =
  let (Point x0 y0, xspan, yspan) = spanArea area
      checkPoint :: Applicative m
                 => (Point -> Maybe Point) -> m (Maybe Point) -> Int
                 -> m (Maybe Point)
      {-# INLINE checkPoint #-}
      checkPoint check fallback pxyRelative =
        let Point{..} = punindex xspan pxyRelative
            pos = Point (x0 + px) (y0 + py)
        in case check pos of
          Just p -> pure $ Just p
          Nothing -> fallback
      gsearch 0 = fsearch (xspan * yspan * 10)
      gsearch count = do
        pxy <- randomR0 (xspan * yspan - 1)
        checkPoint g (gsearch (count - 1)) pxy
      fsearch 0 = return $! runIdentity $ searchAll (xspan * yspan - 1)
      fsearch count = do
        pxy <- randomR0 (xspan * yspan - 1)
        checkPoint f (fsearch (count - 1)) pxy
      searchAll (-1) = pure Nothing
      searchAll pxyRelative =
        checkPoint f (searchAll (pxyRelative - 1)) pxyRelative
  in gsearch gnumTries

-- | Create a void room, i.e., a single point area within the designated area.
mkVoidRoom :: Area -> Rnd Area
mkVoidRoom area = do
  -- Pass corridors closer to the middle of the grid area, if possible.
  let core = fromMaybe area $ shrink area
  pxy <- pointInArea core
  return $! trivialArea pxy

-- | Create a random room according to given parameters.
mkRoom :: (X, Y)    -- ^ minimum size
       -> (X, Y)    -- ^ maximum size
       -> Area      -- ^ the containing area, not the room itself
       -> Rnd Area
mkRoom (xm, ym) (xM, yM) area = do
  let (x0, y0, x1, y1) = fromArea area
      xspan = x1 - x0 + 1
      yspan = y1 - y0 + 1
      aW = (min xm xspan, min ym yspan, min xM xspan, min yM yspan)
      areaW = fromMaybe (error $ "" `showFailure` aW) $ toArea aW
  Point xW yW <- pointInArea areaW  -- roll size
  let a1 = (x0, y0, max x0 (x1 - xW + 1), max y0 (y1 - yW + 1))
      area1 = fromMaybe (error $ "" `showFailure` a1) $ toArea a1
  Point rx1 ry1 <- pointInArea area1  -- roll top-left corner
  let a3 = (rx1, ry1, rx1 + xW - 1, ry1 + yW - 1)
      area3 = fromMaybe (error $ "" `showFailure` a3) $ toArea a3
  return $! area3

-- Choosing connections between areas in a grid

-- | Pick a subset of connections between adjacent areas within a grid until
-- there is only one connected component in the graph of all areas.
connectGrid :: ES.EnumSet Point -> (X, Y) -> Rnd [(Point, Point)]
connectGrid voidPlaces (nx, ny) = do
  let unconnected = ES.fromDistinctAscList [ Point x y
                                           | y <- [0..ny-1], x <- [0..nx-1] ]
  -- Candidates are neighbours that are still unconnected. We start with
  -- a random choice.
  p <- oneOf $ ES.elems $ unconnected ES.\\ voidPlaces
  let candidates = ES.singleton p
  connectGrid' voidPlaces (nx, ny) unconnected candidates []

connectGrid' :: ES.EnumSet Point -> (X, Y)
             -> ES.EnumSet Point -> ES.EnumSet Point
             -> [(Point, Point)]
             -> Rnd [(Point, Point)]
connectGrid' voidPlaces (nx, ny) unconnected candidates !acc
  | unconnected `ES.isSubsetOf` voidPlaces = return acc
  | otherwise = do
      let candidatesBest = candidates ES.\\ voidPlaces
      c <- oneOf $ ES.elems $ if ES.null candidatesBest
                               then candidates
                               else candidatesBest
      -- potential new candidates:
      let ns = ES.fromList $ vicinityCardinal nx ny c
          nu = ES.delete c unconnected  -- new unconnected
          -- (new candidates, potential connections):
          (nc, ds) = ES.partition (`ES.member` nu) ns
      new <- if ES.null ds
             then return id
             else do
               d <- oneOf (ES.elems ds)
               return (sortPoint (c, d) :)
      connectGrid' voidPlaces (nx, ny) nu
        (ES.delete c (candidates `ES.union` nc)) (new acc)

-- | Sort the sequence of two points, in the derived lexicographic order.
sortPoint :: (Point, Point) -> (Point, Point)
sortPoint (a, b) | a <= b    = (a, b)
                 | otherwise = (b, a)

-- | Pick a single random connection between adjacent areas within a grid.
randomConnection :: (X, Y) -> Rnd (Point, Point)
randomConnection (nx, ny) =
  assert (nx > 1 && ny > 0 || nx > 0 && ny > 1 `blame` (nx, ny)) $ do
  rb <- oneOf [False, True]
  if rb && nx > 1 || ny <= 1
  then do
    rx <- randomR0 (nx - 2)
    ry <- randomR0 (ny - 1)
    return (Point rx ry, Point (rx+1) ry)
  else do
    rx <- randomR0 (nx - 1)
    ry <- randomR0 (ny - 2)
    return (Point rx ry, Point rx (ry+1))

-- Plotting individual corridors between two areas

-- | The choice of horizontal and vertical orientation.
data HV = Horiz | Vert
  deriving Eq

-- | The coordinates of consecutive fields of a corridor.
type Corridor = (Point, Point, Point, Point)

-- | Create a corridor, either horizontal or vertical, with
-- a possible intermediate part that is in the opposite direction.
-- There might not always exist a good intermediate point
-- if the places are allowed to be close together
-- and then we let the intermediate part degenerate.
mkCorridor :: HV            -- ^ orientation of the starting section
           -> Point         -- ^ starting point
           -> Bool          -- ^ starting is inside @FGround@ or @FFloor@
           -> Point         -- ^ ending point
           -> Bool          -- ^ ending is inside @FGround@ or @FFloor@
           -> Area          -- ^ the area containing the intermediate point
           -> Rnd Corridor  -- ^ straight sections of the corridor
mkCorridor hv (Point x0 y0) p0floor (Point x1 y1) p1floor area = do
  Point rxRaw ryRaw <- pointInArea area
  let (sx0, sy0, sx1, sy1) = fromArea area
      -- Avoid corridors that run along @FGround@ or @FFloor@ fence,
      -- unless not possible.
      rx = if | rxRaw == sx0 + 1 && p0floor -> sx0
              | rxRaw == sx1 - 1 && p1floor -> sx1
              | otherwise -> rxRaw
      ry = if | ryRaw == sy0 + 1 && p0floor -> sy0
              | ryRaw == sy1 - 1 && p1floor -> sy1
              | otherwise -> ryRaw
  return $! case hv of
    Horiz -> (Point x0 y0, Point rx y0, Point rx y1, Point x1 y1)
    Vert  -> (Point x0 y0, Point x0 ry, Point x1 ry, Point x1 y1)

-- | Try to connect two interiors of places with a corridor.
-- Choose entrances some steps away from the edges, if the place
-- is big enough. Note that with @pfence == FNone@, the inner area considered
-- is the strict interior of the place, without the outermost tiles.
--
-- The corridor connects (touches) the inner areas and the turning point
-- of the corridor (if any) is outside of the outer areas
-- and inside the grid areas.
connectPlaces :: (Area, Fence, Area) -> (Area, Fence, Area)
              -> Rnd (Maybe Corridor)
connectPlaces (_, _, sg) (_, _, tg) | sg == tg = return Nothing
connectPlaces s3@(sqarea, spfence, sg) t3@(tqarea, tpfence, tg) = do
  let (sa, so, stiny) = borderPlace sqarea spfence
      (ta, to, ttiny) = borderPlace tqarea tpfence
      trim area =
        let (x0, y0, x1, y1) = fromArea area
            dx = case (x1 - x0) `div` 2 of
              0 -> 0
              1 -> 1
              2 -> 1
              3 -> 1
              _ -> 3
            dy = case (y1 - y0) `div` 2 of
              0 -> 0
              1 -> 1
              2 -> 1
              3 -> 1
              _ -> 3
        in fromMaybe (error $ "" `showFailure` (area, s3, t3))
           $ toArea (x0 + dx, y0 + dy, x1 - dx, y1 - dy)
  Point sx sy <- pointInArea $ trim sa
  Point tx ty <- pointInArea $ trim ta
  -- If the place (e.g., void place) is slim (at most 2-tile wide, no fence),
  -- overwrite it with corridor. The place may not even be built (e.g., void)
  -- and the overwrite ensures connections through it are not broken.
  let (_, _, sax1Raw, say1Raw) = fromArea sa  -- inner area
      sslim = stiny && spfence == FNone
      (sax1, say1) = if sslim
                     then (sax1Raw - 1, say1Raw - 1)
                     else (sax1Raw, say1Raw)
      (tax0Raw, tay0Raw, _, _) = fromArea ta
      tslim = ttiny && tpfence == FNone
      (tax0, tay0) = if tslim
                     then (tax0Raw + 1, tay0Raw + 1)
                     else (tax0Raw, tay0Raw)
      (_, _, sox1, soy1) = fromArea so  -- outer area
      (tox0, toy0, _, _) = fromArea to
      (sgx0, sgy0, sgx1, sgy1) = fromArea sg  -- grid area
      (tgx0, tgy0, tgx1, tgy1) = fromArea tg
      (hv, area, p0, p1)
        | sgx1 == tgx0 =
          let x0 = if sgy0 <= ty && ty <= sgy1 then sox1 + 1 else sgx1
              x1 = if tgy0 <= sy && sy <= tgy1 then tox0 - 1 else sgx1
          in case toArea (x0, min sy ty, x1, max sy ty) of
            Just a -> (Horiz, a, Point (sax1 + 1) sy, Point (tax0 - 1) ty)
            Nothing -> error $ "" `showFailure` (sx, sy, tx, ty, s3, t3)
        | otherwise = assert (sgy1 == tgy0) $
          let y0 = if sgx0 <= tx && tx <= sgx1 then soy1 + 1 else sgy1
              y1 = if tgx0 <= sx && sx <= tgx1 then toy0 - 1 else sgy1
          in case toArea (min sx tx, y0, max sx tx, y1) of
            Just a -> (Vert, a, Point sx (say1 + 1), Point tx (tay0 - 1))
            Nothing -> error $ "" `showFailure` (sx, sy, tx, ty, s3, t3)
      nin p = not $ inside sa p || inside ta p
      !_A = assert (sslim || tslim
                    || allB nin [p0, p1] `blame` (sx, sy, tx, ty, s3, t3)) ()
  cor@(c1, c2, c3, c4) <- mkCorridor hv p0 (sa == so) p1 (ta == to) area
  let !_A2 = assert (sslim || tslim || allB nin [c1, c2, c3, c4]
                     `blame` (cor, sx, sy, tx, ty, s3, t3)) ()
  return $ Just cor

borderPlace :: Area -> Fence -> (Area, Area, Bool)
borderPlace qarea pfence = case pfence of
  FWall -> (qarea, expand qarea, False)
  FFloor  -> (qarea, qarea, False)
  FGround -> (qarea, qarea, False)
  FNone -> case shrink qarea of
    Nothing -> (qarea, qarea, True)
    Just sr -> (sr, qarea, False)

data SpecialArea =
    SpecialArea Area
  | SpecialFixed Point (Freqs PlaceKind) Area
  | SpecialMerged SpecialArea Point
  deriving Show

-- | Divide uniformly a larger area into the given number of smaller areas
-- overlapping at the edges.
--
-- The list of fixed centers (some important points inside)
-- of (non-overlapping) areas is given. Incorporate those,
-- with as little disruption, as possible.
-- Assume each of four boundaries of the cave are covered by a fixed centre.
grid :: EM.EnumMap Point (Freqs PlaceKind) -> [Point] -> Area -> (X, Y)
     -> ((X, Y), EM.EnumMap Point SpecialArea)
grid fixedCenters boot area cellSize =
  let (x0, y0, x1, y1) = fromArea area
      f zsize z1 n prev (c1 : c2 : rest) =
        let len = c2 - c1
            cn = len * n `div` zsize
        in -- traceShow ( zsize, z1, n, prev, len, cn
           --           , len `div` max 1 (2 * cn) ) $
           if cn < 2
           then let mid1 = (c1 + c2) `div` 2
                    mid2 = (c1 + c2) `divUp` 2
                    mid = if mid1 - prev > 4 then mid1 else mid2
                in (prev, mid, Just c1) : f zsize z1 n mid (c2 : rest)
           else (prev, c1 + len `div` (2 * cn), Just c1)
                : [ ( c1 + len * (2 * z - 1) `div` (2 * cn)
                    , c1 + len * (2 * z + 1) `div` (2 * cn)
                    , Nothing )
                  | z <- [1 .. cn - 1] ]
                ++ f zsize z1 n (c1 + len * (2 * cn - 1) `div` (2 * cn))
                     (c2 : rest)
      f _ z1 _ prev [c1] = [(prev, z1, Just c1)]
      f _ _ _ _ [] = error $ "empty list of centers" `showFailure` fixedCenters
      (xCenters, yCenters) = IS.fromList *** IS.fromList
                             $ unzip $ map (px &&& py) $ EM.keys fixedCenters
      distFromIS is z =
        - minimum (maxBound : map (\i -> abs (i - z)) (IS.toList is))
      xboot = nub $ sortOn (distFromIS xCenters)
              $ filter (`IS.notMember` xCenters) $ map px boot
      yboot = nub $ sortOn (distFromIS yCenters)
              $ filter (`IS.notMember` yCenters) $ map py boot
      -- Don't let boots ignore cell size too much, esp. in small caves.
      xcellsInArea = (x1 - x0 + 1) `div` fst cellSize
      ycellsInArea = (y1 - y0 + 1) `div` snd cellSize
      xbootN = assert (xcellsInArea > 0) $ xcellsInArea - IS.size xCenters
      ybootN = assert (ycellsInArea > 0) $ ycellsInArea - IS.size yCenters
      xset = xCenters `IS.union` IS.fromList (take xbootN xboot)
      yset = yCenters `IS.union` IS.fromList (take ybootN yboot)
      xsize = IS.findMax xset - IS.findMin xset
      ysize = IS.findMax yset - IS.findMin yset
      -- This is precisely how the cave will be divided among places,
      -- if there are no fixed centres except at boot coordinates.
      -- In any case, places, except for at boot points and fixed centres,
      -- are guaranteed at least the rolled minimal size of their
      -- enclosing cell (with one shared fence). Fixed centres are guaranteed
      -- a size between the cave cell size and the one implied by their
      -- placement wrt to cave fence and other fixed centers.
      lgrid = ( xsize `div` fst cellSize
              , ysize `div` snd cellSize )
      xallSegments = zip [0..] $ f xsize x1 (fst lgrid) x0 $ IS.toList xset
      yallSegments = zip [0..] $ f ysize y1 (snd lgrid) y0 $ IS.toList yset
  in -- traceShow (xallSegments, yallSegments) $
     ( (length xallSegments, length yallSegments)
     , EM.fromDistinctAscList
         [ ( Point x y
           , case (mcx, mcy) of
               (Just cx, Just cy) ->
                 case EM.lookup (Point cx cy) fixedCenters of
                   Nothing -> SpecialArea sarea
                   Just placeFreq -> SpecialFixed (Point cx cy) placeFreq sarea
               _ -> SpecialArea sarea )
         | (y, (cy0, cy1, mcy)) <- yallSegments
         , (x, (cx0, cx1, mcx)) <- xallSegments
         , let sarea = fromMaybe (error $ "" `showFailure` (x, y))
                       $ toArea (cx0, cy0, cx1, cy1) ] )
