tracer/src/Interior.hs

module Interior where

import qualified Affection as A

import Data.Matrix as M
import qualified Data.Map.Strict as Map
import Data.List as L
import Data.Maybe (isNothing, isJust)

import Linear.V2

import System.Random

-- internal imports

import Navigation
import Util

import Types

placeInteriorIO
  :: Matrix TileState
  -> Matrix (Maybe ImgId)
  -> [ReachPoint]
  -> [Graph]
  -> IO (Matrix (Maybe ImgId), [ReachPoint])
placeInteriorIO imat imgmat irp graph =
  do
    rnd <- newStdGen
    let (_, matps) =
          foldl
            (traverseGraph imat)
            (rnd, (imgmat, irp))
            graph
    return matps

traverseGraph
  :: Matrix TileState
  -> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
  -> Graph
  -> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
traverseGraph imat acc (GHall sub) =
  foldl (traverseGraph imat) acc sub
traverseGraph imat (rng, putt) (GRoom _ bnds) =
  let applicable =
        L.sortBy (\b a -> size (a, (ph, pw)) `compare` size (b, (ph, pw))) (
          L.filter
            (\a -> roomType `elem` clusterRoom a && size (a, (ph, pw)) <= size bnds)
            [minBound .. maxBound] :: [Cluster])
      roomType = fst (L.minimumBy
        (\b a -> (snd a :: Int) `compare` (snd b :: Int)) $ Map.toList $ foldl
          (\acc a -> if a `Map.member` acc
            then Map.insert a (acc Map.! a + 1) acc
            else Map.insert a 1 acc
            )
          Map.empty
          (M.submatrix
            (fst $ matmin bnds) (fst $ matmax bnds)
            (snd $ matmin bnds) (snd $ matmax bnds)
            imat
            )
        )
      (ph, g1) = randomR (1, fst (matmax bnds) - fst (matmin bnds) + 1) rng
      (pw, g2) = randomR (1, snd (matmax bnds) - snd (matmin bnds) + 1) g1
  in
    foldl
      (\(orng, (omat, orp)) -> placeCluster imat orng bnds (ph, pw) 1 omat orp)
      (g2, putt)
      applicable

placeCluster
  :: Matrix TileState
  -> StdGen
  -> Boundaries Int
  -> (Int, Int)
  -> Int
  -> Matrix (Maybe ImgId)
  -> [ReachPoint]
  -> Cluster
  -> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
placeCluster imat rng bnds dim try mat rp appl =
  let (pr, g1) = randomR (fst (matmin bnds) - 1, fst (matmax bnds) - 1) rng
      (pc, g2) = randomR (snd (matmin bnds) - 1, snd (matmax bnds) - 1) g1
      (g2_1, g2_2) = split g2
      freeRoom = foldl
        (\acc a -> if isNothing  a then acc + 1 else acc)
        0
        (M.toList $ M.submatrix
          (fst $ matmin bnds) (fst $ matmax bnds)
          (snd $ matmin bnds) (snd $ matmax bnds)
          mat
          ) :: Int
      cmat = clusterMat appl dim g2_2
      newmat = insertMat cmat mat (pr, pc)
      exits = filter
        (\p -> pointType p == RoomExit && inBounds (pointCoord p) bnds)
        rp
      reaches = map (+ V2 (pr - 1) (pc - 1))
        (map pointCoord (clusterPoints appl dim))
      reachdirs = map pointDir (clusterPoints appl dim)
      reachtypes = map pointType (clusterPoints appl dim)
      oldreaches = foldl (\acc p ->
          if pointType p /= RoomExit && inBounds (pointCoord p) bnds
          then pointCoord p : acc
          else acc
          )
        []
        rp
      newrp = rp ++ map (\(a, b, c) -> ReachPoint a b c)
        (zip3 reachtypes reaches reachdirs)
  in
    if try >= 10 || fromIntegral freeRoom <= size (appl, dim)
    then (g2, (mat, rp))
    else
      if pr + nrows cmat - 1 > fst (matmax bnds) ||
        pc + ncols cmat - 1 > snd (matmax bnds)
      then A.log A.Debug ("no cluster placed") $
        placeCluster imat g2 bnds dim (try + 1) mat rp appl
      else if
        any (`notElem` clusterRoom appl)
          (M.toList (M.submatrix
            pr (pr + nrows cmat - 1)
            pc (pc + ncols cmat - 1)
            imat
            )) ||
        any isJust
          (M.toList (M.submatrix
            pr (pr + nrows cmat - 1)
            pc (pc + ncols cmat - 1)
            mat
            ))
        then A.log A.Debug ("no cluster placed") $
          placeCluster imat g2_1 bnds dim (try + 1) mat rp appl
        else if
          any (`elem` (oldreaches))
          (V2
            <$> [pr .. pr + nrows cmat - 1]
            <*> [pc .. pc + ncols cmat - 1])
          then A.log A.Debug ("no cluster placed") $
            placeCluster imat g2 bnds dim (try + 1) mat rp appl
          else if
            isReachable newmat [(V2 10 10, Boundaries (0, 1) (0, 1))] (oldreaches ++ reaches) exits
            then A.log A.Debug ("placed cluster" ++ show appl) $
              placeCluster imat g2_1 bnds dim (try + 1) newmat newrp appl
            else A.log A.Debug ("no cluster placed") $
              placeCluster imat g2_1 bnds dim (try + 1) mat rp appl

insertMat
  :: Matrix (Maybe a)
  -> Matrix (Maybe a)
  -> (Int, Int)
  -> Matrix (Maybe a)
insertMat i into (roffs, coffs) =
  if roffs + nrows i > nrows into || coffs + ncols i > ncols into
  then error "insertMat: matrix to be inserted does not fit!"
  else foldl
    (\mat (ir, ic) ->
      if isNothing (mat M.! (ir + roffs - 1, ic + coffs - 1))
      then M.setElem (i M.! (ir, ic)) (ir + roffs - 1, ic + coffs - 1) mat
      else mat
      )
    into
    ((,) <$> [1 .. nrows i] <*> [1 .. ncols i])