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
            (rnd, (imgmat, irp))
            graph
    return matps
  where
    traverseGraph
      :: (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
      -> Graph
      -> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
    traverseGraph acc (GHall sub) =
      foldl traverseGraph acc sub
    traverseGraph putt (GRoom _ bnds) =
      let applicable =
            L.sortBy (\b a -> size a `compare` size b) (
              L.filter
                (\a -> roomType `elem` clusterRoom a && size a <= 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
                )
            )
      in
        foldl
          (\(orng, (omat, orp)) -> placeCluster orng bnds 1 omat orp)
          putt
          applicable
    placeCluster
      :: StdGen
      -> Boundaries Int
      -> Int
      -> Matrix (Maybe ImgId)
      -> [ReachPoint]
      -> Cluster
      -> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
    placeCluster rng bnds 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
          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
          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))
          reachdirs = map pointDir (clusterPoints appl)
          reachtypes = map pointType (clusterPoints appl)
          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
        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 g2 bnds (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 g2 bnds (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 g2 bnds (try + 1) mat rp appl
              else if
                not (isReachable newmat [] (oldreaches ++ reaches) exits)
                then A.log A.Debug ("no cluster placed") $
                  placeCluster g2 bnds (try + 1) mat rp appl
                else A.log A.Debug ("placed cluster" ++ show appl) $
                  placeCluster g2 bnds (try + 1) newmat newrp 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])