GameState.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 {-# LANGUAGE FlexibleContexts #-}
  12 {-# LANGUAGE TupleSections    #-}
  13 module GameState where
  14
  15 import           Control.Applicative
  16 import           Control.Monad
  17 import           Control.Monad.State
  18 import           Data.Function       (on)
  19 import           Data.List
  20 import           Data.Map            (Map)
  21 import qualified Data.Map            as Map
  22 import           Data.Maybe
  23 import           Data.Set            (Set)
  24 import qualified Data.Set            as Set
  25 import           Data.Vector         (Vector, (!), (//))
  26 import qualified Data.Vector         as Vector
  27
  28 import           GameStateTypes
  29 import           Hex
  30 import           Util
  31 --import Debug
  32
  33 ppidxs :: GameState -> [PieceIdx]
  34 ppidxs = Vector.toList . Vector.findIndices (const True) . placedPieces
  35
  36 getpp :: GameState -> PieceIdx -> PlacedPiece
  37 getpp st idx = placedPieces st ! idx
  38
  39 setpp :: PieceIdx -> PlacedPiece -> GameState -> GameState
  40 setpp idx pp st@(GameState pps _) =
  41     let displacement = placedPos (getpp st idx) -^ placedPos pp
  42         updateConn conn@(Connection root@(ridx,rpos) end@(eidx,epos) link)
  43             | ridx == idx = Connection (ridx,rpos+^displacement) end link
  44             | eidx == idx = Connection root (eidx,epos+^displacement) link
  45             | otherwise = conn
  46     in st {placedPieces = pps // [(idx, pp)]
  47         , connections = updateConn <$> connections st }
  48
  49 addpp :: PlacedPiece -> GameState -> GameState
  50 addpp pp st@(GameState pps _) = st {placedPieces = Vector.snoc pps pp}
  51
  52 addConn :: Connection -> GameState -> GameState
  53 addConn conn st@(GameState _ conns) = st {connections = conn:conns}
  54
  55 type Component = (HexVec, Set HexVec)
  56 components :: Set HexVec -> [Component]
  57 components patt
  58     | Set.null patt = []
  59     | otherwise =
  60         let c = if zero `Set.member` patt then zero else head $ Set.toList patt
  61             (patt',comp) = floodfill c patt
  62         in ( (c, Set.map (+^ neg c) comp) : components patt' )
  63
  64 floodfill :: HexVec -> Set HexVec -> (Set HexVec, Set HexVec)
  65 floodfill start patt = floodfill' start `execState` (patt, Set.empty)
  66     where
  67         floodfill' :: HexVec -> State (Set HexVec, Set HexVec) ()
  68         floodfill' start = do
  69               (patt, dels) <- get
  70               let patt' = Set.delete start patt
  71               unless (Set.size patt' == Set.size patt) $ do
  72                   put (patt', Set.insert start dels)
  73                   sequence_ [ floodfill' (dir+^start) | dir <- hexDirs ]
  74
  75 delPiece :: PieceIdx -> GameState -> GameState
  76 delPiece idx (GameState pps conns) =
  77     GameState (Vector.concat [Vector.take idx pps, Vector.drop (idx+1) pps])
  78         [ Connection (ridx',rv) (eidx',ev) link |
  79             Connection (ridx,rv) (eidx,ev) link <- conns
  80             , ridx /= idx
  81             , eidx /= idx
  82             , let ridx' = if ridx > idx then ridx-1 else ridx
  83             , let eidx' = if eidx > idx then eidx-1 else eidx ]
  84
  85 delPieceIn :: HexPos -> GameState -> GameState
  86 delPieceIn pos st =
  87     case fst <$> Map.lookup pos (stateBoard st) of
  88         Just idx -> delPiece idx st
  89         _        -> st
  90
  91 setPiece :: PieceIdx -> Piece -> GameState -> GameState
  92 setPiece idx p st =
  93     setpp idx (PlacedPiece (placedPos $ getpp st idx) p) st
  94
  95 adjustPieces :: (Piece -> Piece) -> GameState -> GameState
  96 adjustPieces f st =
  97     st { placedPieces =
  98         (\pp -> pp { placedPiece = f $ placedPiece pp }) <$> placedPieces st }
  99
 100 addBlockPos :: PieceIdx -> HexPos -> GameState -> GameState
 101 addBlockPos b pos st =
 102     let PlacedPiece ppos (Block patt) = getpp st b
 103     in setPiece b (Block (pos -^ ppos:patt)) st
 104
 105 addPivotArm :: PieceIdx -> HexPos -> GameState -> GameState
 106 addPivotArm p pos st =
 107     let PlacedPiece ppos (Pivot arms) = getpp st p
 108     in setPiece p (Pivot (pos -^ ppos:arms)) st
 109
 110 locusPos :: GameState -> Locus -> HexPos
 111 locusPos s (idx,v) = v +^ placedPos (getpp s idx)
 112
 113 posLocus :: GameState -> HexPos -> Maybe Locus
 114 posLocus st pos = listToMaybe [ (idx,pos-^ppos) |
 115     (idx,pp@(PlacedPiece ppos _)) <- enumVec $ placedPieces st
 116     , pos `elem` plPieceFootprint pp ]
 117
 118 connectionLength :: GameState -> Connection -> Int
 119 connectionLength st (Connection root end _) =
 120     let rootPos = locusPos st root
 121         endPos = locusPos st end
 122     in hexLen (endPos -^ rootPos) - 1
 123
 124 springsAtIdx,springsEndAtIdx,springsRootAtIdx :: GameState -> PieceIdx -> [Connection]
 125 springsAtIdx st idx =
 126     [ c | c@(Connection (ridx,_) (eidx, _) (Spring _ _)) <- connections st
 127     , idx `elem` [ridx,eidx] ]
 128 springsAtIdxIgnoring st idx idx' =
 129     [ c | c@(Connection (ridx,_) (eidx, _) (Spring _ _)) <- connections st
 130     , idx `elem` [ridx,eidx], idx' `notElem` [ridx,eidx] ]
 131 springsEndAtIdx st idx =
 132     [ c | c@(Connection _ (eidx, _) (Spring _ _)) <- connections st
 133     , eidx==idx ]
 134 springsRootAtIdx st idx =
 135     [ c | c@(Connection (ridx, _) _ (Spring _ _)) <- connections st
 136     , ridx==idx ]
 137 connectionsBetween :: GameState -> PieceIdx -> PieceIdx -> [Connection]
 138 connectionsBetween st idx idx' =
 139     filter connIsBetween $ connections st
 140     where
 141         connIsBetween conn =
 142             isPerm (idx,idx') (fst $ connectionRoot conn, fst $ connectionEnd conn)
 143         isPerm = (==) `on` (\(x,y) -> Set.fromList [x,y])
 144
 145 connGraphPathExists :: GameState -> PieceIdx -> PieceIdx -> Bool
 146 connGraphPathExists st ridx eidx = (ridx == eidx) ||
 147         any ((connGraphPathExists st `flip` eidx) . fst .  connectionEnd)
 148             (springsRootAtIdx st ridx)
 149
 150 connGraphHeight :: GameState -> PieceIdx -> Int
 151 connGraphHeight st idx =
 152     maximum . (0:) $ (+1) . connGraphHeight st . fst . connectionRoot <$> springsEndAtIdx st idx
 153
 154 type Digraph a = Map a (Set a)
 155 checkConnGraphAcyclic :: GameState -> Bool
 156 checkConnGraphAcyclic st =
 157     let idxs = ppidxs st
 158         leaves dg = (fst <$>) . filter (Set.null . snd) $ Map.toList dg
 159         checkDigraphAcyclic :: Ord a => Digraph a -> Bool
 160         checkDigraphAcyclic dg = case listToMaybe $ leaves dg of
 161             Nothing -> Map.null dg
 162             Just leaf -> checkDigraphAcyclic $ Map.delete leaf $ Set.delete leaf <$> dg
 163     in checkDigraphAcyclic $ Map.fromList
 164         [ (idx, Set.fromList $ fst . connectionRoot <$> springsEndAtIdx st idx) | idx <- idxs ]
 165
 166 repossessConns :: GameState -> GameState -> GameState
 167 repossessConns st st' =
 168     st' {connections = [ Connection root' end' link |
 169         Connection root end link <- connections st
 170         , root' <- maybeToList $ posLocus st' $ locusPos st root
 171         , end' <- maybeToList $ posLocus st' $ locusPos st end ] }
 172
 173 delConnectionsIn :: HexPos -> GameState -> GameState
 174 delConnectionsIn pos st =
 175     st {connections = filter
 176         ((pos `notElem`) . connectionFootPrint st)
 177         $ connections st}
 178
 179 delPiecePos :: PieceIdx -> HexPos -> GameState -> (GameState, Maybe PieceIdx)
 180 -- ^ returns new state and the new index of what remains of the piece, if
 181 -- anything
 182 delPiecePos idx pos st =
 183     let PlacedPiece ppos p = getpp st idx
 184         v = pos -^ ppos
 185     in case p of
 186         Block patt ->
 187             let (st',midx) = componentify idx $ setpp idx (PlacedPiece ppos $ Block $ patt \\ [v]) st
 188             in (repossessConns st st', midx)
 189         Pivot arms -> if v == zero
 190            then (delPiece idx st, Nothing)
 191            else ((setPiece idx $ Pivot $ arms \\ [v]) st, Just idx)
 192         _ -> (delPiece idx st, Nothing)
 193 componentify :: PieceIdx -> GameState -> (GameState, Maybe PieceIdx)
 194 componentify idx st = let PlacedPiece ppos p = getpp st idx
 195     in case p of
 196         Block patt ->
 197             let comps = components $ Set.fromList patt
 198                 ppOfComp (v,patt) = PlacedPiece (v+^ppos) $ Block $ Set.toList patt
 199             in case comps of
 200                 [] -> (delPiece idx st, Nothing)
 201                 zeroComp:newComps ->
 202                     (setpp idx (ppOfComp zeroComp)
 203                         $ foldr (addpp . ppOfComp) st newComps, Just idx)
 204         _ -> (st,Nothing)
 205
 206 springExtended,springCompressed,springFullyExtended
 207     ,springFullyCompressed :: GameState -> Connection -> Bool
 208 springExtended st c@(Connection _ _ (Spring _ natLen)) =
 209     connectionLength st c > natLen
 210 springExtended _ _ = False
 211 springCompressed st c@(Connection _ _ (Spring _ natLen)) =
 212     connectionLength st c < natLen
 213 springCompressed _ _ = False
 214 springFullyExtended st c@(Connection _ _ (Spring _ natLen)) =
 215     connectionLength st c >= 2*natLen
 216 springFullyExtended _ _ = False
 217 springFullyCompressed st c@(Connection _ _ (Spring _ natLen)) =
 218     connectionLength st c <= (natLen+1)`div`2
 219 springFullyCompressed _ _ = False
 220 springExtensionValid st c@(Connection _ _ (Spring _ natLen)) =
 221     let l = connectionLength st c
 222     in l >= (natLen+1)`div`2 && l <= 2*natLen
 223 springExtensionValid _ _ = True
 224
 225 stateBoard :: GameState -> GameBoard
 226 stateBoard st@(GameState plPieces conns) =
 227     addConnAdjs st conns $
 228         Map.unions (plPieceBoard <$> enumVec plPieces) `Map.union`
 229         Map.unions (connectionBoard st <$> conns)
 230
 231 addConnAdjs :: GameState -> [Connection] -> GameBoard -> GameBoard
 232 addConnAdjs st = flip $ foldr addConnAdj
 233     where
 234         addConnAdj (Connection root end (Spring dir _)) board =
 235             addAdj (locusPos st root) dir $
 236             addAdj (locusPos st end) (neg dir) board
 237         addConnAdj _ board = board
 238         addAdj pos d =
 239             Map.adjust (\(o,tile) -> (o,case tile of
 240                     BlockTile adjs -> BlockTile (d:adjs)
 241                     _              -> tile))
 242                 pos
 243
 244 plPieceBoard :: (PieceIdx,PlacedPiece) -> GameBoard
 245 plPieceBoard (idx,pp) = (idx,) <$> plPieceMap pp
 246
 247 plPieceMap :: PlacedPiece -> Map HexPos Tile
 248 plPieceMap (PlacedPiece pos (Block patt)) =
 249     let pattSet = Set.fromList patt
 250     in Map.fromList [ (rel +^ pos, BlockTile adjs)
 251         | rel <- patt
 252         , let adjs = filter (\dir -> (rel +^ dir) `Set.member` pattSet) hexDirs ]
 253 plPieceMap (PlacedPiece pos (Pivot arms)) =
 254     let overarmed = length arms > 2 in
 255     Map.fromList $ (pos, PivotTile $ if overarmed then head arms else zero ) :
 256         [ (rel +^ pos, ArmTile rel main)
 257         | (rel,main) <- map (,False) arms ]
 258 plPieceMap (PlacedPiece pos (Hook arm _)) =
 259     Map.fromList $ (pos, HookTile) : [ (arm +^ pos, ArmTile arm True) ]
 260 plPieceMap (PlacedPiece pos (Wrench mom)) = Map.singleton pos $ WrenchTile mom
 261 plPieceMap (PlacedPiece pos Ball) = Map.singleton pos BallTile
 262
 263 plPieceFootprint :: PlacedPiece -> [HexPos]
 264 plPieceFootprint = Map.keys . plPieceMap
 265
 266 fullFootprint :: GameState -> PieceIdx -> [HexPos]
 267 -- ^footprint of piece and connections ending at it
 268 fullFootprint st idx = plPieceFootprint (getpp st idx) ++
 269     concatMap (connectionFootPrint st) (springsEndAtIdx st idx)
 270
 271 footprintAt :: GameState -> PieceIdx -> [HexPos]
 272 -- ^footprint of piece and any connections at it
 273 footprintAt st idx = plPieceFootprint (getpp st idx) ++
 274     concatMap (connectionFootPrint st) (springsAtIdx st idx)
 275
 276 footprintAtIgnoring :: GameState -> PieceIdx -> PieceIdx -> [HexPos]
 277 -- ^footprint of piece and any connections at it, except those with idx'
 278 footprintAtIgnoring st idx idx' = plPieceFootprint (getpp st idx) ++
 279     concatMap (connectionFootPrint st) (springsAtIdxIgnoring st idx idx')
 280
 281 collisions :: GameState -> PieceIdx -> PieceIdx -> [HexPos]
 282 -- ^intersections of two pieces and their connections, disregarding
 283 -- the connections which connect the two pieces
 284 collisions st idx idx' =
 285     intersect (footprintAt st idx) (footprintAt st idx') \\
 286         concatMap (connectionFootPrint st) (connectionsBetween st idx idx')
 287
 288 connectionBoard :: GameState -> Connection -> GameBoard
 289 connectionBoard st (Connection root end@(eidx,_) (Spring dir natLen)) =
 290     let rootPos = locusPos st root
 291         endPos = locusPos st end
 292         curLen = hexLen (endPos -^ rootPos) - 1
 293     in Map.fromList $
 294         [ ((d *^ dir) +^ rootPos, (eidx, SpringTile extension dir))
 295             | d <- [1..curLen],
 296             let extension | d <= natLen - curLen = Compressed
 297                           | curLen-d < 2*(curLen - natLen) = Stretched
 298                           | otherwise = Relaxed ]
 299 connectionBoard _ _ = Map.empty
 300
 301 connectionFootPrint :: GameState -> Connection -> [HexPos]
 302 connectionFootPrint s c = Map.keys $ connectionBoard s c
 303
 304 castRay :: HexPos -> HexDir -> GameBoard -> Maybe (PieceIdx, HexPos)
 305 castRay start dir board =
 306     castRay' 30 start
 307     where castRay' 0 _ = Nothing
 308           castRay' n pos =
 309               case Map.lookup pos board of
 310                   Nothing      -> castRay' (n-1) (dir+^pos)
 311                   Just (idx,_) -> Just (idx,pos)
 312
 313 validGameState :: GameState -> Bool
 314 validGameState st@(GameState pps conns) = and
 315     [ checkValidHex st
 316     , checkConnGraphAcyclic st
 317     , and [ null $ collisions st idx idx'
 318             | idx <- ppidxs st
 319             , idx' <- [0..idx-1] ]
 320     , and [ isHexDir dir
 321             && castRay (dir+^rpos) dir
 322                 (stateBoard $ GameState pps (conns \\ [c]))
 323                 == Just (eidx, epos)
 324             && springExtensionValid st c
 325             && validRoot st root
 326             && validEnd st end
 327             | c@(Connection root@(ridx,_) end@(eidx,_) (Spring dir _)) <- conns
 328             , let [rpos,epos] = locusPos st <$> [root,end] ]
 329     , and [ 1 == length (components $ Set.fromList patt)
 330             | Block patt <- placedPiece <$> Vector.toList pps ]
 331     ]
 332
 333 validRoot st (idx,v) = case placedPiece $ getpp st idx of
 334     (Block _) -> True
 335     (Pivot _) -> v==zero
 336     _         -> False
 337 validEnd st (idx,_) = case placedPiece $ getpp st idx of
 338     (Block _) -> True
 339     _         -> False
 340
 341 checkValidHex (GameState pps conns) = all validPP (Vector.toList pps) && all validConn conns
 342     where
 343         validVec (HexVec x y z) = x+y+z==0
 344         validPos (PHS v) = validVec v
 345         validDir v = validVec v && isHexDir v
 346         validPP (PlacedPiece pos piece) = validPos pos && validPiece piece
 347         validPiece (Block patt) = all validVec patt
 348         validPiece (Pivot arms) = all validDir arms
 349         validPiece (Hook dir _) = validDir dir
 350         validPiece _            = True
 351         validConn (Connection (_,rv) (_,ev) link) = all validVec [rv,ev] && validLink link
 352         validLink (Free v)       = validVec v
 353         validLink (Spring dir _) = validDir dir
 354
 355 protectedPiece :: PieceIdx -> Bool
 356 protectedPiece = isFrame
 357 isFrame :: PieceIdx -> Bool
 358 isFrame = (==0)