Physics.hs

   1 -- This file is part of Intricacy
   2 -- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 module Physics where
  12
  13 import           Control.Monad.State
  14 import           Control.Monad.Writer
  15 import           Data.Foldable        (foldrM)
  16 import           Data.List
  17 import           Data.Monoid          (Any (Any, getAny))
  18 import           Data.Set             (Set)
  19 import qualified Data.Set             as Set
  20 import           Data.Vector          (Vector, (!), (//))
  21 import qualified Data.Vector          as Vector
  22
  23 import           GameState
  24 import           GameStateTypes
  25 import           Hex
  26 import           Util
  27
  28 -- | a list of forces to try in order:
  29 newtype ForceChoice = ForceChoice {getForceChoice :: [Force]}
  30
  31 type ForceChoices = Vector.Vector ForceChoice
  32
  33 forceIdx :: Force -> PieceIdx
  34 forceIdx force = case force of (Push idx _)   -> idx
  35                                (Torque idx _) -> idx
  36
  37 isPush,isTorque,forceIsNull :: Force -> Bool
  38 isPush (Push _ _) = True
  39 isPush _          = False
  40 isTorque = not . isPush
  41 forceIsNull (Push _ dir)   = dir == zero
  42 forceIsNull (Torque _ dir) = dir == 0
  43
  44 getForcedpp :: GameState -> Force -> PlacedPiece
  45 getForcedpp s f = getpp s (forceIdx f)
  46
  47 -- |PlayerMove: if not NullPM, the direction should be non-zero
  48 data PlayerMove = NullPM | HookPush HexDir | HookTorque TorqueDir | WrenchPush HexDir
  49     deriving (Eq, Ord, Show, Read)
  50
  51 toolForces :: GameState -> PlayerMove -> ForceChoices
  52 toolForces st pm = Vector.fromList $
  53     [ ForceChoice (wmom++wmove)
  54     | (widx, PlacedPiece _ (Wrench mom)) <- epps
  55     , let wmom = [Push widx mom | mom /= zero]
  56     , let wmove = case pm of {WrenchPush v -> [Push widx v]; _ -> []}
  57     , not $ null (wmom++wmove)
  58     ] ++ case pm of
  59         HookTorque ht -> [ ForceChoice [Torque hidx ht] | hidx <- hidxs ]
  60         HookPush hp   -> [ ForceChoice [Push hidx hp] | hidx <- hidxs ]
  61         _             -> []
  62     where
  63         epps = enumVec $ placedPieces st
  64         hidxs = [ hidx | (hidx, PlacedPiece _ (Hook _ _)) <- epps ]
  65
  66 -- |Dominance: a propagand of a source force F can not block any progagand of
  67 -- a source force which dominates F.
  68 -- F dominates F' iff F and F' are spring forces, and the end of F is an
  69 -- ancestor of the root of F'.
  70 -- Note that by acyclicity of the connection digraph, domination is
  71 -- antisymmetric.
  72 type Dominance = Int -> Int -> Bool
  73
  74 envForces :: GameState -> (ForceChoices, Dominance)
  75 envForces st@(GameState _ conns) =
  76     let rootedForces :: Vector (Maybe PieceIdx, Force)
  77         rootedForces = Vector.fromList [ (Just rootIdx, Push endIdx dir)
  78             | c@(Connection (rootIdx,_) (endIdx,_) (Spring outDir natLen)) <- conns
  79             , let curLen = connectionLength st c
  80             , natLen /= curLen
  81             , let dir = if natLen > curLen then outDir else neg outDir ]
  82
  83     in ( Vector.map (ForceChoice . replicate 1 . snd) rootedForces,
  84         \f1 f2 -> Just True == do
  85                 rootIdx <- fst $ rootedForces!f2
  86                 return $ connGraphPathExists st (forceIdx.snd $ rootedForces!f1) rootIdx )
  87
  88
  89 setTools :: PlayerMove -> GameState -> GameState
  90 setTools pm st =
  91     let hf = case pm of
  92             HookTorque dir -> TorqueHF dir
  93             HookPush v     -> PushHF v
  94             _              -> NullHF
  95     in adjustPieces (\p -> case p of
  96                 Hook arm _ -> Hook arm hf
  97                 _          -> p) st
  98
  99 physicsTick :: PlayerMove -> GameState -> Writer [Alert] GameState
 100 physicsTick pm st =
 101     let tfs = toolForces st pm
 102         (efs, dominates) = envForces st
 103     in do
 104         st' <- resolveForces tfs Vector.empty (\_ _->False) $ setTools pm st
 105         tell [AlertIntermediateState st']
 106         resolveForces Vector.empty efs dominates $ setTools NullPM st'
 107
 108 stepPhysics :: GameState -> GameState
 109 stepPhysics = fst.runWriter.physicsTick NullPM
 110
 111 type Source = Int
 112 data SourcedForce = SForce Source Force Bool Bool
 113     deriving (Eq, Ord, Show)
 114 resolveForces :: ForceChoices -> ForceChoices -> Dominance -> GameState -> Writer [Alert] GameState
 115 resolveForces plForces eForces eDominates st =
 116     let pln = Vector.length plForces
 117         dominates i j = case map (< pln) [i,j] of
 118                 [True,False]  -> True
 119                 [False,False] -> eDominates (i-pln) (j-pln)
 120                 _             -> False
 121         initGrps = (propagate st True <$> plForces) Vector.++
 122                 (propagate st False <$> eForces)
 123         blockInconsistent :: Int -> Int -> StateT (Vector (Writer Any [Force])) (Writer [Alert]) ()
 124         blockInconsistent i j = do
 125             grps <- mapM gets [(! i),(! j)]
 126             blocks <- lift $ checkInconsistent i j $ map (fst.runWriter) grps
 127             modify $ Vector.imap (\k -> if k `elem` blocks then (tell (Any True) >>) else id)
 128         checkInconsistent :: Int -> Int -> [[Force]] -> Writer [Alert] [Int]
 129         checkInconsistent i j fss =
 130             let st' = foldr applyForce st $ nub $ concat fss
 131                 (inconsistencies,cols) = runWriter $ sequence
 132                     [ tell cols >> return [f,f']
 133                     | [f,f'] <- sequence fss
 134                     , (True,cols) <- [
 135                             if forceIdx f == forceIdx f'
 136                             then (f /= f',[])
 137                             else let cols = collisions st' (forceIdx f) (forceIdx f')
 138                                 in (not $ null cols, cols) ]]
 139                 badConns = [ c | c <- connections st'
 140                     , not $ springExtensionValid st' c ]
 141             in do
 142                 tell $ map AlertBlockingForce $ concat inconsistencies
 143                 tell $ map AlertCollision cols
 144                 tell $ map AlertCollision $ concat
 145                     [ locusPos st' <$> [r, e]
 146                     | Connection r e _ <- badConns]
 147                 return $ if null inconsistencies && null badConns then []
 148                     else if i==j then [i]
 149                     else if dominates i j then [j]
 150                     else if dominates j i then [i]
 151                     else [i,j]
 152
 153         stopWrench idx = setPiece idx (Wrench zero)
 154         stopBlockedWrenches blocked unblocked st' = foldr stopWrench st' $
 155             forcedWrenches blocked \\ forcedWrenches unblocked
 156             where forcedWrenches fs = [ forceIdx f
 157                     | f <- fs, isWrench.placedPiece $ getForcedpp st' f ]
 158         divertedWrenches fs = [ idx
 159             | Push idx dir <- fs
 160             , Wrench mom <- [placedPiece $ getpp st idx]
 161             , mom `notElem` [zero,dir] ]
 162     in do
 163         let unresisted = [ s | (s, (_, Any False)) <- enumVec $ runWriter <$> initGrps ]
 164
 165         -- check for inconsistencies within, and between pairs of, forcegroups
 166         grps <- sequence [ blockInconsistent i j
 167                         | [i,j] <- sequence [unresisted,unresisted]
 168                         , i <= j ]
 169                     `execStateT` initGrps
 170
 171         let [blocked, unblocked] = map (nub.concatMap (fst.runWriter) . Vector.toList) $
 172                 (\(x,y) -> [x,y]) $ Vector.partition (getAny.snd.runWriter) grps
 173         tell $ map AlertBlockedForce blocked
 174         tell $ map AlertAppliedForce unblocked
 175         tell $ map AlertDivertedWrench $ divertedWrenches unblocked
 176         return $ stopBlockedWrenches blocked unblocked $ foldr applyForce st unblocked
 177
 178 resolveSinglePlForce :: Force -> GameState -> Writer [Alert] GameState
 179 resolveSinglePlForce force = resolveForces
 180     (Vector.singleton (ForceChoice [force])) Vector.empty
 181     (\_ _->False)
 182
 183 applyForce :: Force -> GameState -> GameState
 184 applyForce f s =
 185     let idx = forceIdx f
 186         pp' = applyForceTo (getpp s idx) f
 187         pp'' = case (placedPiece pp',f) of
 188                    ( Wrench _ , Push _ dir ) -> pp' {placedPiece = Wrench dir}
 189                    _                         -> pp'
 190         in
 191         s { placedPieces = placedPieces s // [(idx, pp'')] }
 192
 193 collisionsWithForce :: GameState -> Force -> PieceIdx -> [HexPos]
 194 collisionsWithForce st (Push idx dir) idx' =
 195     map (dir+^) (footprintAtIgnoring st idx idx') `intersect` footprintAtIgnoring st idx' idx
 196 collisionsWithForce st force idx' =
 197     collisions (applyForce force st) (forceIdx force) idx'
 198
 199 applyForceTo :: PlacedPiece -> Force -> PlacedPiece
 200 applyForceTo (PlacedPiece pos piece) (Push _ dir) =
 201     PlacedPiece (dir +^ pos) piece
 202 applyForceTo (PlacedPiece pos (Pivot arms)) (Torque _ dir) =
 203     PlacedPiece pos (Pivot $ map (rotate dir) arms)
 204 applyForceTo (PlacedPiece pos (Hook arm hf)) (Torque _ dir) =
 205     PlacedPiece pos (Hook (rotate dir arm) hf)
 206 applyForceTo pp _ = pp
 207
 208 -- A force on a piece which resists it is immediately blocked
 209 pieceResists :: GameState -> Force -> Bool
 210 pieceResists st force =
 211     let idx = forceIdx force
 212         PlacedPiece _ piece = getpp st idx
 213         springs = springsEndAtIdx st idx
 214         fixed = case piece of
 215                      (Pivot _) -> isPush force
 216                      (Block _) -> null springs
 217                      (Wrench mom) -> case force of
 218                             Push _ v -> v /= mom
 219                             _        -> True
 220                      (Hook _ hf) -> case force of
 221                             Push _ v     -> hf /= PushHF v
 222                             Torque _ dir -> hf /= TorqueHF dir
 223                      _ -> False
 224     in fixed
 225
 226 -- |transmittedForce: convert pushes into torques as appropriate
 227 transmittedForce :: GameState -> Source -> HexPos -> HexDir -> Force
 228 transmittedForce st idx cpos dir =
 229     let pp@(PlacedPiece _ piece) = getpp st idx
 230         rpos = cpos -^ placedPos pp
 231         armPush = case
 232                 (dir `hexDot` (rotate 1 rpos -^ rpos)) `compare`
 233                 (dir `hexDot` (rotate (-1) rpos -^ rpos)) of
 234             GT -> Torque idx 1
 235             LT -> Torque idx $ -1
 236             EQ -> Push idx dir
 237     in case piece of
 238             Pivot _             -> armPush
 239             Hook _ (TorqueHF _) -> armPush
 240             _                   -> Push idx dir
 241
 242 -- |propagateForce: return forces a force causes via bumps and fully
 243 -- compressed/extended springs
 244 propagateForce :: GameState -> Bool -> Force -> [ForceChoice]
 245 propagateForce st@(GameState _ conns) isPlSource force =
 246     bumps ++ springTransmissions
 247     where
 248         idx = forceIdx force
 249         bumps = [ ForceChoice $ map (transmittedForce st idx' cpos) dirs
 250             | idx' <- ppidxs st
 251             , idx' /= idx
 252             , cpos <- collisionsWithForce st force idx'
 253             , let dirs = case force of
 254                     Push _ dir -> [dir]
 255                     Torque _ dir -> [push,claw]
 256                         where push = arm -^ rotate (-dir) arm
 257                               claw = rotate dir arm -^ arm
 258                               arm = cpos -^ placedPos (getpp st idx) ]
 259         springTransmissions =
 260             case force of
 261                  Push _ dir -> [ ForceChoice [Push idx' dir]
 262                         | c@(Connection (ridx,_) (eidx,_) (Spring sdir _)) <- conns
 263                         , let root = idx == ridx
 264                         , let end = idx == eidx
 265                         , root || end
 266                         , let idx' = if root then eidx else ridx
 267                         , let pull = (root && dir == neg sdir) || (end && dir == sdir)
 268                         , let push = (root && dir == sdir) || (end && dir == neg sdir)
 269                         , (push && if isPlSource then springFullyCompressed st c else not $ springExtended st c) ||
 270                             (pull && if isPlSource then springFullyExtended st c else not $ springCompressed st c) ||
 271                             (not push && not pull) ]
 272                  _ -> []
 273
 274 -- |propagate: find forcegroup generated by a forcechoice, and note if the
 275 -- group is blocked due to resistance. If there are multiple forces in a
 276 -- forcechoice and the first results in a block due to resistance, try the
 277 -- next instead.
 278 propagate :: GameState -> Bool -> ForceChoice -> Writer Any [Force]
 279 propagate st isPlSource fch = Set.toList <$> propagate' isPlSource Set.empty fch where
 280     propagate' isPlForce ps (ForceChoice (f:backups)) =
 281         if f `Set.member` ps then return ps
 282         else
 283             let (ps', failed) = if pieceResists st f && not isPlForce
 284                     then (ps, Any True)
 285                     else runWriter $ foldrM
 286                             (flip $ propagate' False)
 287                             (f `Set.insert` ps)
 288                             $ propagateForce st isPlSource f
 289             in if getAny failed
 290                 then if null backups
 291                     then tell (Any True) >> return ps'
 292                     else propagate' isPlForce ps $ ForceChoice backups
 293                 else return ps'
 294     propagate' _ _ (ForceChoice []) = error "null ForceChoice"