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 module GameState where
  13
  14 import Control.Applicative
  15 import Data.Function (on)
  16 import qualified Data.Map as Map
  17 import Data.Map (Map)
  18 import qualified Data.Set as Set
  19 import Data.Set (Set)
  20 import qualified Data.Vector as Vector
  21 import Data.Maybe
  22 import Control.Monad
  23 import Control.Monad.State
  24 import Data.List
  25 import Data.Vector (Vector, (!), (//))
  26
  27 import Hex
  28 import Util
  29 import GameStateTypes
  30 --import Debug
  31
  32 ppidxs :: GameState -> [PieceIdx]
  33 ppidxs = Vector.toList . (Vector.findIndices $ const True) . placedPieces
  34
  35 getpp :: GameState -> PieceIdx -> PlacedPiece
  36 getpp st idx = (placedPieces st) ! idx
  37
  38 setpp :: PieceIdx -> PlacedPiece -> GameState -> GameState
  39 setpp idx pp st@(GameState pps _) =
  40     let displacement = (placedPos $ getpp st idx) -^ placedPos pp
  41         updateConn conn@(Connection root@(ridx,rpos) end@(eidx,epos) link)
  42             | ridx == idx = Connection (ridx,rpos+^displacement) end link
  43             | eidx == idx = Connection root (eidx,epos+^displacement) link
  44             | otherwise = conn
  45     in st {placedPieces = pps // [(idx, pp)]
  46         , connections = map updateConn $ connections st }
  47
  48 addpp :: PlacedPiece -> GameState -> GameState
  49 addpp pp st@(GameState pps _) = st {placedPieces = Vector.snoc pps pp}
  50
  51 addConn :: Connection -> GameState -> GameState
  52 addConn conn st@(GameState _ conns) = st {connections = conn:conns}
  53
  54 type Component = (HexVec, Set HexVec)
  55 components :: Set HexVec -> [Component]
  56 components patt
  57     | Set.null patt = []
  58     | otherwise =
  59         let c = if zero `Set.member` patt then zero else head $ Set.toList patt
  60             (patt',comp) = floodfill c patt
  61         in ( (c, Set.map (+^ neg c) comp) : components patt' )
  62
  63 floodfill :: HexVec -> Set HexVec -> (Set HexVec, Set HexVec)
  64 floodfill start patt = floodfill' start `execState` (patt, Set.empty)
  65     where
  66         floodfill' :: HexVec -> State (Set HexVec, Set HexVec) ()
  67         floodfill' start = do
  68               (patt, dels) <- get
  69               let patt' = Set.delete start patt
  70               unless (Set.size patt' == Set.size patt) $ do
  71                   put (patt', Set.insert start dels)
  72                   sequence_ [ floodfill' (dir+^start) | dir <- hexDirs ]
  73
  74 delPiece :: PieceIdx -> GameState -> GameState
  75 delPiece idx (GameState pps conns) =
  76     GameState (Vector.concat [Vector.take idx pps, Vector.drop (idx+1) pps])
  77         [ Connection (ridx',rv) (eidx',ev) link |
  78             Connection (ridx,rv) (eidx,ev) link <- conns
  79             , ridx /= idx
  80             , eidx /= idx
  81             , let ridx' = if ridx > idx then ridx-1 else ridx
  82             , let eidx' = if eidx > idx then eidx-1 else eidx ]
  83
  84 delPieceIn :: HexPos -> GameState -> GameState
  85 delPieceIn pos st =
  86     case liftM fst $ Map.lookup pos $ stateBoard st of
  87         Just idx -> delPiece idx st
  88         _ -> st
  89
  90 setPiece :: PieceIdx -> Piece -> GameState -> GameState
  91 setPiece idx p st =
  92     setpp idx (PlacedPiece (placedPos $ getpp st idx) p) st
  93
  94 adjustPieces :: (Piece -> Piece) -> GameState -> GameState
  95 adjustPieces f st =
  96     st { placedPieces = fmap
  97         (\pp -> pp { placedPiece = f $ placedPiece pp })
  98        $ 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 : map ((+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 = map 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 $ fmap (Set.delete leaf) dg
 163     in checkDigraphAcyclic $ Map.fromList
 164         [ (idx, Set.fromList $ map (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 $ map plPieceBoard $ enumVec plPieces) `Map.union`
 229         (Map.unions $ map (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) = fmap (\x -> (idx,x)) $ plPieceMap pp
 246
 247 plPieceMap :: PlacedPiece -> Map HexPos Tile
 248 plPieceMap (PlacedPiece pos (Block pattern)) =
 249     let pattSet = Set.fromList pattern
 250     in Map.fromList [ (rel +^ pos, BlockTile adjs)
 251         | rel <- pattern
 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) <- zip arms $ repeat False ]
 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     (concat $ map (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     (concat $ map (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     (concat $ map (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         (concat $ map (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] = map (locusPos st) [root,end] ]
 329     , and [ 1 == length (components $ Set.fromList patt)
 330             | Block patt <- map 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) = and
 342     [ all validPP $ Vector.toList pps
 343     , all validConn conns ]
 344     where
 345         validVec (HexVec x y z) = x+y+z==0
 346         validPos (PHS v) = validVec v
 347         validDir v = validVec v && isHexDir v
 348         validPP (PlacedPiece pos piece) = validPos pos && validPiece piece
 349         validPiece (Block patt) = all validVec patt
 350         validPiece (Pivot arms) = all validDir arms
 351         validPiece (Hook dir _) = validDir dir
 352         validPiece _ = True
 353         validConn (Connection (_,rv) (_,ev) link) = all validVec [rv,ev] && validLink link
 354         validLink (Free v) = validVec v
 355         validLink (Spring dir _) = validDir dir
 356
 357 protectedPiece :: PieceIdx -> Bool
 358 protectedPiece = isFrame
 359 isFrame :: PieceIdx -> Bool
 360 isFrame = (==0)