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 qualified Data.Set as Set
  14 import Data.Set (Set)
  15 import qualified Data.Vector as Vector
  16 import Control.Monad.State
  17 import Control.Monad.Writer
  18 import Data.Foldable (foldrM)
  19 import Data.List
  20 import Data.Vector (Vector, (!), (//))
  21
  22 import Hex
  23 import Util
  24 import GameState
  25 import GameStateTypes
  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 = if mom == zero then [] else [Push widx mom]
  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 = fmap (propagate st True) plForces Vector.++
 121                 fmap (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             in do
 139                 tell $ map AlertBlockingForce $ concat inconsistencies
 140                 tell $ map AlertCollision cols
 141                 return $ if null inconsistencies then []
 142                     else if i==j then [i]
 143                     else if dominates i j then [j]
 144                     else if dominates j i then [i]
 145                     else [i,j]
 146
 147         stopWrench idx = setPiece idx (Wrench zero)
 148         stopBlockedWrenches blocked unblocked st' = foldr stopWrench st' $
 149             forcedWrenches blocked \\ forcedWrenches unblocked
 150             where forcedWrenches fs = [ forceIdx f
 151                     | f <- fs, isWrench.placedPiece $ getForcedpp st' f ]
 152         divertedWrenches fs = [ idx
 153             | Push idx dir <- fs
 154             , Wrench mom <- [placedPiece $ getpp st idx]
 155             , mom `notElem` [zero,dir] ]
 156     in do
 157         let unresisted = [ s | (s, (_, Any False)) <- enumVec $ fmap runWriter initGrps ]
 158
 159         -- check for inconsistencies within, and between pairs of, forcegroups
 160         grps <- sequence [ blockInconsistent i j
 161                         | [i,j] <- sequence [unresisted,unresisted]
 162                         , i <= j ]
 163                     `execStateT` initGrps
 164
 165         let [blocked, unblocked] = map (nub.concat.(map (fst.runWriter)).Vector.toList) $
 166                 (\(x,y) -> [x,y]) $ Vector.partition (getAny.snd.runWriter) grps
 167         tell $ map AlertBlockedForce blocked
 168         tell $ map AlertAppliedForce unblocked
 169         tell $ map AlertDivertedWrench $ divertedWrenches unblocked
 170         return $ stopBlockedWrenches blocked unblocked $ foldr applyForce st unblocked
 171
 172 resolveSinglePlForce :: Force -> GameState -> Writer [Alert] GameState
 173 resolveSinglePlForce force st = resolveForces
 174     (Vector.singleton (ForceChoice [force])) Vector.empty
 175     (\_ _->False) st
 176
 177 applyForce :: Force -> GameState -> GameState
 178 applyForce f s =
 179     let idx = forceIdx f
 180         pp' = applyForceTo (getpp s idx) f
 181         pp'' = case (placedPiece pp',f) of
 182                    ( Wrench _ , Push _ dir ) -> pp' {placedPiece = Wrench dir}
 183                    _ -> pp'
 184         in
 185         s { placedPieces = (placedPieces s) // [(idx, pp'')] }
 186
 187 collisionsWithForce :: GameState -> Force -> PieceIdx -> [HexPos]
 188 collisionsWithForce st (Push idx dir) idx' =
 189     intersect (map (dir+^) $ footprintAtIgnoring st idx idx') (footprintAtIgnoring st idx' idx)
 190 collisionsWithForce st force idx' =
 191     collisions (applyForce force st) (forceIdx force) idx'
 192
 193 applyForceTo :: PlacedPiece -> Force -> PlacedPiece
 194 applyForceTo (PlacedPiece pos piece) (Push _ dir) =
 195     PlacedPiece (dir +^ pos) piece
 196 applyForceTo (PlacedPiece pos (Pivot arms)) (Torque _ dir) =
 197     PlacedPiece pos (Pivot $ map (rotate dir) arms)
 198 applyForceTo (PlacedPiece pos (Hook arm hf)) (Torque _ dir) =
 199     PlacedPiece pos (Hook (rotate dir arm) hf)
 200 applyForceTo pp _ = pp
 201
 202 -- A force on a piece which resists it is immediately blocked
 203 pieceResists :: GameState -> Force -> Bool
 204 pieceResists st force =
 205     let idx = forceIdx force
 206         PlacedPiece _ piece = getpp st idx
 207         springs = springsEndAtIdx st idx
 208         fixed = case piece of
 209                      (Pivot _) -> isPush force
 210                      (Block _) -> null springs
 211                      (Wrench mom) -> case force of
 212                             Push _ v -> v /= mom
 213                             _ -> True
 214                      (Hook _ hf) -> case force of
 215                             Push _ v -> hf /= PushHF v
 216                             Torque _ dir -> hf /= TorqueHF dir
 217                      _ -> False
 218     in fixed
 219
 220 -- |transmittedForce: convert pushes into torques as appropriate
 221 transmittedForce :: GameState -> Source -> HexPos -> HexDir -> Force
 222 transmittedForce st idx cpos dir =
 223     let pp@(PlacedPiece _ piece) = getpp st idx
 224         rpos = cpos -^ placedPos pp
 225         armPush = case
 226                 (dir `hexDot` ((rotate 1 rpos) -^ rpos)) `compare`
 227                 (dir `hexDot` ((rotate (-1) rpos) -^ rpos)) of
 228             GT -> Torque idx 1
 229             LT -> Torque idx $ -1
 230             EQ -> Push idx dir
 231     in case piece of
 232             Pivot _ -> armPush
 233             Hook _ (TorqueHF _) -> armPush
 234             _ -> (Push idx dir)
 235
 236 -- |propagateForce: return forces a force causes via bumps and fully
 237 -- compressed/extended springs
 238 propagateForce :: GameState -> Bool -> Force -> [ForceChoice]
 239 propagateForce st@(GameState _ conns) isPlSource force =
 240     bumps ++ springTransmissions
 241     where
 242         idx = forceIdx force
 243         bumps = [ ForceChoice $ map (transmittedForce st idx' cpos) dirs |
 244             idx' <- ppidxs st
 245             , idx' /= idx
 246             , cpos <- collisionsWithForce st force idx'
 247             , let dirs = case force of
 248                     Push _ dir -> [dir]
 249                     Torque _ dir -> [push,claw]
 250                         where push = arm -^ rotate (-dir) arm
 251                               claw = rotate dir arm -^ arm
 252                               arm = cpos -^ placedPos (getpp st idx) ]
 253         springTransmissions =
 254             case force of
 255                  Push _ dir -> [ ForceChoice [Push idx' dir] |
 256                         c@(Connection (ridx,_) (eidx,_) (Spring sdir _)) <- conns
 257                         , let root = idx == ridx
 258                         , let end = idx == eidx
 259                         , root || end
 260                         , let idx' = if root then eidx else ridx
 261                         , let pull = (root && dir == neg sdir) || (end && dir == sdir)
 262                         , let push = (root && dir == sdir) || (end && dir == neg sdir)
 263                         , (push && if isPlSource then springFullyCompressed st c else not $ springExtended st c) ||
 264                             (pull && if isPlSource then springFullyExtended st c else not $ springCompressed st c) ||
 265                             (not push && not pull) ]
 266                  _ -> []
 267
 268 -- |propagate: find forcegroup generated by a forcechoice, and note if the
 269 -- group is blocked due to resistance. If there are multiple forces in a
 270 -- forcechoice and the first results in a block due to resistance, try the
 271 -- next instead.
 272 propagate :: GameState -> Bool -> ForceChoice -> Writer Any [Force]
 273 propagate st isPlSource fch = Set.toList `liftM` propagate' isPlSource Set.empty fch where
 274     propagate' isPlForce ps (ForceChoice (f:backups)) =
 275         if f `Set.member` ps then return ps
 276         else
 277             let (ps', failed) = if pieceResists st f && (not isPlForce)
 278                     then (ps, Any True)
 279                     else runWriter $ foldrM
 280                             (flip $ propagate' False)
 281                             (f `Set.insert` ps)
 282                             $ propagateForce st isPlSource f
 283             in if getAny failed
 284                 then if null backups
 285                     then tell (Any True) >> return ps'
 286                     else propagate' isPlForce ps $ ForceChoice backups
 287                 else return ps'
 288     propagate' _ _ (ForceChoice []) = error "null ForceChoice"