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 Data.Function (on)
  15 import qualified Data.Map as Map
  16 import Data.Map (Map)
  17 import Data.Maybe
  18 import Control.Monad
  19 import Data.List
  20
  21 import Hex
  22 import GameState
  23 import GameStateTypes
  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 `liftM` 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 case nextSpring of
 114                       Nothing -> id
 115                       Just conn -> addConn conn
 116            Just (PivotTile _) -> addPiece $ Pivot []
 117            Just (WrenchTile _) -> addPiece $ Wrench zero
 118            Just HookTile -> let arm = listToMaybe [ dir |
 119                                     dir <- hexDirs
 120                                     , isNothing $ Map.lookup (dir +^ pos) board' ]
 121                             in case arm of Just armdir -> addPiece $ Hook armdir NullHF
 122                                            _ -> id
 123            Just (BallTile) -> addPiece Ball
 124            _ -> id
 125            ) st'
 126
 127 -- | merge tile/piece with a neighbouring piece. If we merge a piece with
 128 -- connections, the connections are deleted: otherwise we'd need some fiddly
 129 -- conditions to ensure connection graph acyclicity.
 130 mergeTiles :: HexPos -> HexDir -> Bool -> GameState -> GameState
 131 mergeTiles pos dir mergePiece st = fromMaybe st $ do
 132     let board = stateBoard st
 133     (idx,tile) <- Map.lookup pos board
 134     (idx',tile') <- Map.lookup (dir+^pos) board
 135     guard $ idx /= idx'
 136     guard $ all (not . protectedPiece) [idx,idx']
 137     case tile of
 138         BlockTile _ -> do
 139             BlockTile _ <- Just tile'
 140             let st' = if mergePiece
 141                           then delPiece idx st
 142                           else fst $ delPiecePos idx pos st
 143             (idx'',_) <- Map.lookup (dir+^pos) $ stateBoard st'
 144             return $ if mergePiece
 145                          then foldr (addBlockPos idx'') st'
 146                                 $ plPieceFootprint $ getpp st idx
 147                          else addBlockPos idx'' pos st'
 148         ArmTile _ _  -> do
 149             PivotTile _ <- Just tile'
 150             let st' = fst $ delPiecePos idx pos st
 151             (idx'',_) <- Map.lookup (dir+^pos) $ stateBoard st'
 152             return $ addPivotArm idx'' pos st'
 153         _ -> mzero