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