tracer/src/Object/Door.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
module Object.Door where

import Affection as A

import Control.Monad (when)

import Data.Ecstasy
import Data.Maybe

import Linear

-- internal imports

import Types

import Object.ActionTime

doorObjectAction _ dt t@ObjDoor s@"open" ent = do
  emap (anEnt ent) $ do
    mtime <- queryMaybe objStateTime
    case mtime of
      Nothing -> do
        return unchanged
      Just ttl ->
        return unchanged
          { objStateTime = Set (ttl - dt)
          }
  trans <- efor (anEnt ent) $ do
    mttl <- queryMaybe objStateTime
    case mttl of
      Nothing -> return False
      Just ttl -> return (ttl < 0)
  when (head trans) (setEntity ent =<< doorObjectTransition t s False ent Nothing)

doorObjectAction allRelEnts dt t@ObjDoor s@"shut" ent = do
  permEnts <- efor (anEnt ent) $ do
    pos' <- query pos
    rot' <- query rot
    clvl <- query clearanceLvl
    let posEnts = filter
          (\(_, b, _, _) ->
            (fmap floor b `elem` deltaCoords || fmap floor b == floorPos) &&
            distance b pos' < 0.75)
          allRelEnts
        floorPos = fmap floor pos'
        deltas = case rot' of
          NW ->
            [ V2 (-1) 0
            , V2 1    0
            ]
          NE ->
            [ V2 0 (-1)
            , V2 0    1
            ]
        acceptedRots = case rot' of
          NW -> [NW, SE]
          NE -> [NE, SW]
        deltaCoords = map (floorPos +) deltas
        predicate (_, _, c, d) = c `elem` acceptedRots && d >= clvl
        ret = filter predicate posEnts
    return ret
  mapM_
    (\(e, _, _, _) -> setEntity ent =<< doorObjectTransition t s False ent (Just e))
    (head permEnts)

doorObjectAction _ _ _ _ _ = return ()

doorObjectTransition t@ObjDoor s@"shut" _ ent (Just aent) = do
  [clearance] <- efor (anEnt aent) (query clearanceLvl)
  e <- efor (anEnt ent) $ do
      dir <- query rot
      oclear <- query clearanceLvl
      liftIO $ A.logIO A.Verbose (show aent ++ " is attempting to open door " ++ show ent)
      liftIO $ A.logIO A.Verbose ("door clearance: " ++ show oclear ++ ", entity clearance: " ++ show clearance)
      if clearance >= oclear
      then do
        liftIO $ A.logIO A.Verbose ("door " ++ show oclear ++ " opens")
        let nstat = AnimState
              (AnimId AnimDoor0 "open" dir)
              0
              0
        return unchanged
          { objState     = Set "open"
          , objStateTime = Set (actionTime t ("open" :: String))
          , objUsedBy    = Set aent
          , anim         = Set nstat
          , obstacle     = Unset
          }
      else
        return unchanged
  return (head e)

doorObjectTransition ObjDoor "open" _ ent Nothing = do
  e <- efor (anEnt ent) $ do
    ttl <- query objStateTime
    orientation <- query rot
    if ttl < 0
    then do
      let nstat = AnimState
            (AnimId AnimDoor0 "shut" orientation)
            0
            0
      return unchanged
        { anim         = Set nstat
        , objState     = Set "shut"
        , objStateTime = Unset
        , objUsedBy    = Unset
        , obstacle     = Set $ case orientation of
          NW -> Boundaries (4/9, 0) (5/9, 1)
          NE -> Boundaries (0, 4/9) (1, 5/9)
          _  -> error "strange orientation for door"
        }
    else return unchanged
  return (head e)

doorObjectTransition _ _ _ _ _ = return unchanged