EditGameState.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 EditGameState (modTile, mergeTiles) where
  12
  13 import           Control.Applicative
  14 import           Control.Monad
  15 import           Data.Function       (on)
  16 import           Data.List
  17 import           Data.Map            (Map)
  18 import qualified Data.Map            as Map
  19 import           Data.Maybe
  20
  21 import           GameState
  22 import           GameStateTypes
  23 import           Hex
  24 --import Debug
  25
  26 modTile :: Maybe Tile -> HexPos -> HexPos -> Bool -> GameState -> GameState
  27 modTile tile pos lastPos painting st =
  28     let board = stateBoard st
  29         curOwnedTile = Map.lookup pos board
  30         (st',mowner) = case curOwnedTile of
  31             Nothing                     -> (st,Nothing)
  32             Just (owner,SpringTile _ _) -> (delConnectionsIn pos st, Just owner)
  33             Just (owner,_)              -> delPiecePos owner pos st -- XXX may invalidate board's indices to st
  34         board' = stateBoard st'
  35         addPiece p = addpp $ PlacedPiece pos p
  36         lastMOwner = do
  37             (o,_) <- Map.lookup lastPos board
  38             return o
  39         {-
  40         same = isJust $ do
  41                 t <- tile
  42                 (_,t') <- curOwnedTile
  43                 guard $ ((==) `on` tileType) t t'
  44                 return $ Just ()
  45         -}
  46         lastElem os = isJust $ do
  47                lastOwner <- lastMOwner
  48                guard $ lastOwner `elem` os
  49         lastWasDiff = isNothing $ do
  50                lastOwner <- lastMOwner
  51                owner <- mowner
  52                guard $ owner == lastOwner
  53         lastOK = painting || lastWasDiff
  54         validSpringRootTile ot = case snd ot of
  55             BlockTile _ -> True
  56             PivotTile _ -> True
  57             _           -> False
  58         -- |Find next adjacent, skipping over current entity.
  59         nextOfAdjacents adjs loop = listToMaybe $ fromMaybe adjs $ do
  60                 owner <- mowner
  61                 i <- elemIndex owner adjs
  62                 return $ dropWhile (== owner) (drop i adjs) ++
  63                     if loop && i > 0 then adjs else []
  64     in case mowner of
  65          Just o | protectedPiece o -> st
  66          _ -> (case tile of
  67            -- _ | same && (pos /= lastPos) -> id
  68            Just (BlockTile _) ->
  69                let adjacentBlocks = nub [ idx |
  70                        dir <- hexDirs
  71                        , Just (idx, BlockTile _) <- [Map.lookup (dir +^ pos) board']
  72                        , not $ protectedPiece idx ]
  73                    addToIdx = if lastOK && lastElem adjacentBlocks
  74                        then lastMOwner
  75                        else nextOfAdjacents adjacentBlocks False
  76                in case addToIdx of
  77                   Nothing -> addPiece $ Block [zero]
  78                   Just b  -> addBlockPos b pos
  79            Just (ArmTile armdir _) ->
  80                let adjacentPivots = [ idx |
  81                        dir <- if armdir == zero then hexDirs else [armdir, neg armdir]
  82                        , Just (idx, PivotTile _) <- [Map.lookup (dir +^ pos) board'] ]
  83                    addToIdx = if lastOK && lastElem adjacentPivots
  84                        then lastMOwner
  85                        else nextOfAdjacents adjacentPivots True
  86                in case addToIdx of
  87                       Nothing -> id
  88                       Just p  -> addPivotArm p pos
  89            Just (SpringTile _ _) ->
  90                let possibleSprings = [ Connection root end $ Spring sdir natLen |
  91                        sdir <- hexDirs
  92                        , let epos = sdir +^ pos
  93                        , Just (eidx, BlockTile _) <- [Map.lookup epos board']
  94                        , not $ protectedPiece eidx
  95                        , (ridx, rpos) <- maybeToList $ castRay (neg sdir +^ pos) (neg sdir) board'
  96                        , Just True == (validSpringRootTile <$> Map.lookup rpos board')
  97                        , let natLen = hexLen (rpos -^ epos) - 1
  98                        , natLen > 0
  99                        {-
 100                        , null [ conn |
 101                            conn@(Connection _ _ (Spring sdir' _)) <-
 102                                springsAtIdx st' eidx ++ springsEndAtIdx st' ridx
 103                            , not $ sdir' `elem` [sdir,neg sdir] ]
 104                        -}
 105                        , not $ connGraphPathExists st' eidx ridx
 106                        , let end = (eidx, epos -^ placedPos (getpp st' eidx))
 107                        , let root = (ridx, rpos -^ placedPos (getpp st' ridx))
 108                        ]
 109                    nextSpring = listToMaybe $ fromMaybe possibleSprings $ do
 110                        (_,SpringTile _ _) <- curOwnedTile -- XXX: therefore the indices of st are still valid
 111                        i <- findIndex (`elem` connections st) possibleSprings
 112                        return $ drop (i+1) possibleSprings
 113                in maybe id addConn nextSpring
 114            Just (PivotTile _) -> addPiece $ Pivot []
 115            Just (WrenchTile _) -> addPiece $ Wrench zero
 116            Just HookTile -> let arm = listToMaybe [ dir |
 117                                     dir <- hexDirs
 118                                     , isNothing $ Map.lookup (dir +^ pos) board' ]
 119                             in case arm of Just armdir -> addPiece $ Hook armdir NullHF
 120                                            _ -> id
 121            Just BallTile -> addPiece Ball
 122            _ -> id
 123            ) st'
 124
 125 -- | merge tile/piece with a neighbouring piece. If we merge a piece with
 126 -- connections, the connections are deleted: otherwise we'd need some fiddly
 127 -- conditions to ensure connection graph acyclicity.
 128 mergeTiles :: HexPos -> HexDir -> Bool -> GameState -> GameState
 129 mergeTiles pos dir mergePiece st = fromMaybe st $ do
 130     let board = stateBoard st
 131     (idx,tile) <- Map.lookup pos board
 132     (idx',tile') <- Map.lookup (dir+^pos) board
 133     guard $ idx /= idx'
 134     guard $ not (any protectedPiece [idx,idx'])
 135     case tile of
 136         BlockTile _ -> do
 137             BlockTile _ <- Just tile'
 138             let st' = if mergePiece
 139                           then delPiece idx st
 140                           else fst $ delPiecePos idx pos st
 141             (idx'',_) <- Map.lookup (dir+^pos) $ stateBoard st'
 142             return $ if mergePiece
 143                          then foldr (addBlockPos idx'') st'
 144                                 $ plPieceFootprint $ getpp st idx
 145                          else addBlockPos idx'' pos st'
 146         ArmTile _ _  -> do
 147             PivotTile _ <- Just tile'
 148             let st' = fst $ delPiecePos idx pos st
 149             (idx'',_) <- Map.lookup (dir+^pos) $ stateBoard st'
 150             return $ addPivotArm idx'' pos st'
 151         _ -> mzero