intricacy-0.4.1: EditGameState.hs

-- This file is part of Intricacy
-- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation, or any later version.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see http://www.gnu.org/licenses/.

module EditGameState (modTile, mergeTiles) where

import Control.Applicative hiding ((<*>))
import Data.Function (on)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe
import Control.Monad
import Data.List

import Hex
import GameState
import GameStateTypes
--import Debug

modTile :: Maybe Tile -> HexPos -> HexPos -> Bool -> GameState -> GameState
modTile tile pos lastPos painting st =
    let board = stateBoard st
	curOwnedTile = Map.lookup pos board
	(st',mowner) = case curOwnedTile of
	    Nothing -> (st,Nothing)
	    Just (owner,SpringTile _ _) -> (delConnectionsIn pos st, Just owner)
	    Just (owner,_) -> delPiecePos owner pos st -- XXX may invalidate board's indices to st
	board' = stateBoard st'
	addPiece p = addpp $ PlacedPiece pos p
	lastMOwner = do
	    (o,_) <- Map.lookup lastPos board
	    return o
	{-
	same = isJust $ do
		t <- tile
		(_,t') <- curOwnedTile
		guard $ ((==) `on` tileType) t t'
		return $ Just ()
	-}
	lastElem os = isJust $ do
	       lastOwner <- lastMOwner
	       guard $ lastOwner `elem` os
	lastWasDiff = isNothing $ do
	       lastOwner <- lastMOwner
	       owner <- mowner
	       guard $ owner == lastOwner
	lastOK = painting || lastWasDiff
	validSpringRootTile ot = case snd ot of
	    BlockTile _ -> True
	    PivotTile _ -> True
	    _ -> False
	-- |Find next adjacent, skipping over current entity.
	-- XXX: Note this doesn't work when the entity is adjacent in multiple
	-- non-contiguous directions.
	nextOfAdjacents adjs loop = listToMaybe $ fromMaybe adjs $ do
		owner <- mowner
		i <- elemIndex owner adjs
		return $ (dropWhile (== owner) $ drop i adjs) ++
		    if loop && i > 0 then adjs else []
    in case mowner of
	 Just o | protectedPiece o -> st
	 _ -> (case tile of
	   -- _ | same && (pos /= lastPos) -> id
	   Just (BlockTile _) ->
	       let adjacentBlocks = [ idx |
		       dir <- hexDirs
		       , Just (idx, BlockTile _) <- [Map.lookup (dir <+> pos) board']
		       , not $ protectedPiece idx ]
		   addToIdx = if lastOK && lastElem adjacentBlocks
		       then lastMOwner
		       else nextOfAdjacents adjacentBlocks False
	       in case addToIdx of
		  Nothing -> addPiece $ Block [zero]
		  Just b -> addBlockPos b pos
	   Just (ArmTile armdir _) ->
	       let adjacentPivots = [ idx |
		       dir <- if armdir == zero then hexDirs else [armdir, neg armdir]
		       , Just (idx, PivotTile _) <- [Map.lookup (dir <+> pos) board'] ]
		   addToIdx = if lastOK && lastElem adjacentPivots
		       then lastMOwner
		       else nextOfAdjacents adjacentPivots True
	       in case addToIdx of
		      Nothing -> id
		      Just p -> addPivotArm p pos
	   Just (SpringTile _ _) ->
	       let possibleSprings = [ Connection root end $ Spring sdir natLen |
		       sdir <- hexDirs
		       , let epos = sdir <+> pos
		       , Just (eidx, BlockTile _) <- [Map.lookup epos board']
		       , not $ protectedPiece eidx
		       , (ridx, rpos) <- maybeToList $ castRay (neg sdir <+> pos) (neg sdir) board'
		       , Just True == (validSpringRootTile `liftM` Map.lookup rpos board')
		       , let natLen = hexLen (rpos <-> epos) - 1
		       , natLen > 0
		       {-
		       , null [ conn |
			   conn@(Connection _ _ (Spring sdir' _)) <-
			       springsAtIdx st' eidx ++ springsEndAtIdx st' ridx
			   , not $ sdir' `elem` [sdir,neg sdir] ]
		       -}
		       , not $ connGraphPathExists st' eidx ridx
		       , let end = (eidx, epos <-> (placedPos $ getpp st' eidx))
		       , let root = (ridx, rpos <-> (placedPos $ getpp st' ridx))
		       ]
		   nextSpring = listToMaybe $ fromMaybe possibleSprings $ do
		       (_,SpringTile _ _) <- curOwnedTile -- XXX: therefore the indices of st are still valid
		       i <- findIndex (`elem` connections st) possibleSprings
		       return $ drop (i+1) possibleSprings
	       in case nextSpring of
		      Nothing -> id
		      Just conn -> addConn conn
	   Just (PivotTile _) -> addPiece $ Pivot []
	   Just (WrenchTile _) -> addPiece $ Wrench zero
	   Just HookTile -> let arm = listToMaybe [ dir |
				    dir <- hexDirs
				    , isNothing $ Map.lookup (dir <+> pos) board' ]
			    in case arm of Just armdir -> addPiece $ Hook armdir NullHF
					   _ -> id
	   Just (BallTile) -> addPiece Ball
	   _ -> id
	   ) st'

-- | merge tile/piece with a neighbouring piece. If we merge a piece with
-- connections, the connections are deleted: otherwise we'd need some fiddly
-- conditions to ensure connection graph acyclicity.
mergeTiles :: HexPos -> HexDir -> Bool -> GameState -> GameState
mergeTiles pos dir mergePiece st = fromMaybe st $ do
    let board = stateBoard st
    (idx,tile) <- Map.lookup pos board
    (idx',tile') <- Map.lookup (dir<+>pos) board
    guard $ idx /= idx'
    guard $ all (not . protectedPiece) [idx,idx']
    case tile of
	BlockTile _ -> do
	    BlockTile _ <- Just tile'
	    let st' = if mergePiece
			  then delPiece idx st
			  else fst $ delPiecePos idx pos st
	    (idx'',_) <- Map.lookup (dir<+>pos) $ stateBoard st'
	    return $ if mergePiece
			 then foldr (addBlockPos idx'') st'
				$ plPieceFootprint $ getpp st idx
			 else addBlockPos idx'' pos st'
	ArmTile _ _  -> do
	    PivotTile _ <- Just tile'
	    let st' = fst $ delPiecePos idx pos st
	    (idx'',_) <- Map.lookup (dir<+>pos) $ stateBoard st'
	    return $ addPivotArm idx'' pos st'
	_ -> mzero