module Game where

import qualified Board
import qualified Event
import qualified Observer
import qualified Opts
import qualified Pack
import qualified Robo
import IO
import Ix

import MArray
import IOExts
import List hiding (drop)
import Maybe (catMaybes)
import Monad(when,liftM2,filterM,unless)
import Prelude hiding (log,drop)
import Random (randomIO)
import Utils

import FiniteMap





--------------------------------------------------------------------------------
-- The game
--------------------------------------------------------------------------------


data Player     = Robo Robo.T | Obs Observer.T 
data PlayerType = Player | Observer | StartAt Int Int deriving (Read,Show)

-- should the list of packages be in here?
data T = New
  { board       :: Board.T 
  , packMap     :: IOArray Board.Pos [Pack.T]
  , players     :: Mutable [Player]
  , log         :: Opts.Verbosity -> String -> IO ()
  , over        :: IO ()
  , groundPacks :: Mutable (FiniteMap Board.Pos Int) 
                            -- how many packs on this square
    -- argh...
  , nextPackID  :: Mutable (Pack.ID)
  , timeout     :: Maybe Int
  }


create opts _players h = 
  do playersR  <- new _players
     packMapR  <- newArray (bounds _board) []
     groundPacksR <- new emptyFM
     nextPackIDR <- new (if null packs then 0 else maxPackID packs + 1)

     let logR wh msg = 
            do os <- getObservers g
               mapM_ (`Observer.sendStrLn` msg) os
               when (wh <= verb) (h `hPutStrLn` msg)

         g = New
          { board       = _board
          , players     = playersR
          , packMap     = packMapR
          , log         = logR
          , groundPacks = groundPacksR
          , nextPackID  = nextPackIDR
          , over        = hClose h
          , timeout     = Opts.timeout opts
          }

     g `addPackages` packs 

     -- don't use log as we don't want to send them to the observers
     unless (verb == Opts.Quiet) $ 
        do h `hPutStrLn` Board.toString _board
           h `hPutStrLn` show (packDests packs)
     return g
  where
  verb = Opts.verbosity opts
  packs = Opts.packFile opts
  _board = Opts.mapFile opts


g `addPackages` packs =
  do sequence_ [ updArray (packMap g) pos (ps++) | (pos,ps) <- packs ]
     (g `upd` groundPacks) addPs
  where
  addPs fm = addListToFM_C (+) fm (map (apSnd length) packs)

maxPackID = maximum . concatMap (map Pack.uid . snd) 


packDests :: [(Board.Pos,[Pack.T])] -> [Board.Pos]
packDests packs = nub [ Pack.dest p | (_,ps) <- packs, p <- ps ]

  
g `getPacksAt` p = readArray (packMap g) p
g `setPacksAt` p = writeArray (packMap g) p
  
classify :: [Player] -> ([Robo.T],[Observer.T])
classify [] = ([],[])
classify (Robo r : ps)  = (r:rs,os) where (rs,os) = classify ps
classify (Obs o : ps)   = (rs,o:os) where (rs,os) = classify ps

getObservers g  = snd . classify  #  g `get` players
getRobots g     = fst . classify  #  g `get` players
getAliveRobos g = filterM Robo.isAlive =<< getRobots g



roboAt p g = filterM atP =<< getAliveRobos g
  where
  atP r = (p ==) # (r `get` Robo.pos)

    
g `tileAt` p      = board g `Board.tileAt` p
p `onBoard` g     = inRange (Board.bounds (board g)) p
p `isPassable` g  = p `onBoard` g && g `tileAt` p /= Board.Impassable 
p `isLethal` g    = g `tileAt` p == Board.Lethal


atHomeBase :: T -> Robo.T -> IO Bool
g `atHomeBase` r  = do
  pos <- r `get` Robo.pos
  return (board g `Board.tileAt` pos == Board.Base)



-- remove dead robots, and remove their packs 
cleanUp g = do (robos,obs) <- classify # (g `get` players)
               (alive,dead) <- partitionM (Robo.isAlive) robos
               lost <- concat # mapM (`get` Robo.packs) dead
               aliveObs <- filterM (`get` Observer.alive) obs
               (g `set` players) (map Robo alive ++ map Obs aliveObs)


--------------------------------------------------------------------------------
-- Gameplay
--------------------------------------------------------------------------------

oneTurn :: T -> IO ()
oneTurn g = do
  robs <- getRobots g
  mapM_ sendPacks robs
  g `logPositions` robs
  logPackPositions g

  reps <- mapM (Robo.receive (timeout g)) robs
  good <- killBad (robs `zip` reps)
  g `logReplies` good
  mapM_ (roboPlay g) (orderRobos good)
  whenM (noPackages g) $ do (robos,obs) <- classify # (g `get` players)
		            mapM_ (Robo.kill "Game over") robos
		            mapM_ Observer.kill obs
  g `logEvents` robs
  
  cleanUp g
  logs <- mapM (`get` Robo.turnLog) robs -- !!! robs is all robots dead or alive
  surv <- getRobots g
  mapM_ (`Robo.endTurn` (mkRsp (map Robo.uid robs `zip` logs))) surv

  where 
  sendPacks r = 
    do pos <- r `get` Robo.pos
       packs <- g `getPacksAt` pos
       r `Robo.sendStrLn` unwords (concatMap formatPack packs)
       hFlush (Robo.talkTo r) `catch` \e -> Robo.kill "<Connection broke>" r

  formatPack p = [show (Pack.uid p), show x, show y, show (Pack.weight p)]
    where
    (x,y) = Pack.dest p


logPackPositions g = log g Opts.Chatty =<< thePacks
  where
  thePacks = show . fmToList # g `get` groundPacks
  
g `logPositions` rs = log g Opts.Chatty . show =<< mapM thePosition rs
  where
  thePosition r = do p <- (r `get` Robo.pos); return (Robo.uid r, p)

g `logEvents` rs = log g Opts.Normal . show =<< mapM theEvents rs
  where
  theEvents r = do ev <- r `get` Robo.turnLog
                   return (Robo.uid r, reverse ev)

g `logReplies` rs = log g Opts.Normal (show (map noRandom rs))
  where
  noRandom (r,((bid,_),cmd)) = (Robo.uid r,bid,cmd)


killBad [] = return []
killBad ((r,Left msg):rs) = Robo.kill ("Bad reply: " ++ msg) r >> killBad rs
killBad ((r,Right (bid,cmd)):rs) 
  | bid == 0  = Robo.kill "Bid 0" r >> killBad rs
  | otherwise =
    do bal <- r `get` Robo.money 
       let bid' = abs bid
       if bal < bid'   
          then Robo.kill "Bid too much" r >> killBad rs
          else do (r `set` Robo.money) (bal - bid')
                  good <- killBad rs
                  tiebreak <- randomIO :: IO Int
                  return ((r,((bid,tiebreak),cmd)):good)



mkRsp = unwords . map (unwords . formatRsp)
  where
  formatRsp (uid,acts) = ('#' : show uid) : map Event.showForPlayer (reverse acts)


--------------------------------------------------------------------------------
-- resolve in what order to execute commands
--------------------------------------------------------------------------------
orderRobos :: [(Robo.T,((Robo.Bid,Int),Robo.Cmd))] -> [(Robo.T,Robo.Cmd)]
orderRobos [] = []
orderRobos [(r,(bid,cmd))] = [(r,cmd)]
orderRobos xs = [ (r,cmd) | 
                    (r,(_,cmd)) <- sortBy (flip (compareBy (fst.snd))) xs ]

--------------------------------------------------------------------------------
-- Interpretation of commands
--------------------------------------------------------------------------------

roboPlay :: T -> (Robo.T,Robo.Cmd) -> IO ()
roboPlay g (r,cmd) = 
  do whenM (Robo.isAlive r `andM` notM (Robo.isRebooting r)) $
      case cmd of
        Robo.Move d   -> do move g r d; return ()
        Robo.Pick ps  -> mapM_ (pick g r) ps 
        Robo.Drop ps  -> mapM_ (drop g r) ps




drop g r p = do x <- r `Robo.dropPackage` p 
                case x of
                  Nothing -> return ()
                  Just (delivered, pack) 
                    | delivered -> return ()
                    | otherwise -> do pos <- r `get` Robo.pos 
                                      g `addPackages` [(pos,[pack])]

reboot g r = do Robo.wasPushed r
                (r `set` Robo.reboot) True


-- move a robot in a given direction
-- the result is if the robot moved
move :: Game.T -> Robo.T -> Board.Dir -> IO Bool
move g r d = do
  pos         <- r `get` Robo.pos 
  let newpos  = pos + Board.dir d 
      moveMe  = succMove g d r >> return True
  if newpos `isPassable` g 
    then do neighs <- roboAt newpos g
            case neighs of
              [] -> moveMe
              n:ns -> do moved <- push g d n
                         mapM_ (pushNoMove g) ns
                         if moved 
                          then do Robo.goodPush r 
                                  mapM_ (succMove g d) ns
                                  moveMe
                          else Robo.badPush r >> return False
    else return False

succMove g d r =
  do pos <- r `get` Robo.pos
     let newpos = pos + Board.dir d
     (r `set` Robo.pos) newpos
     when (newpos `isLethal` g) (Robo.kill "Stepped on lethal" r)
     r `Robo.moved` d


pushNoMove g r = 
  do reboot g r
     packs <- r `get` Robo.packs 
     case packs of 
      []      -> return ()
      pack:_  -> drop g r (Pack.uid pack)


push g d r = do pushNoMove g r 
                move g r d


-- pick a package if available & at home base & and not too heavy
pick :: Game.T -> Robo.T -> Pack.ID -> IO ()
pick g r pid = 
  do loc <- r `get` Robo.pos
     packs <- g `getPacksAt` loc
     case partition ((pid ==) . Pack.uid) packs of
       ([pack],otherPacks) -> 
          do picked <- r `Robo.addPackage` pack
             when picked $ 
                do (g `setPacksAt` loc) otherPacks
                   let change 
                        -- efficiency hack
                        | null otherPacks = (`delFromFM` loc)
                        | otherwise = \fm -> 
                          case lookupFM fm loc of
                            Nothing -> error "bug: groundMap is wrong"
                            -- to avoid leaking when not verbose
                            Just n  -> addToFM fm loc (subtract 1 $! n)
                   (g `upd` groundPacks) change
       ([],_) -> r `Robo.badPick` pid >> return ()

      -- hmm, should we crash here?
       _      -> error "Multiple packages with the same ID"


noRobots g    = null # getRobots g
noPackages g  = noPacksOnGround g `andM` noneCarried g

noneCarried g     = allM Robo.isEmpty =<< getAliveRobos g
noPacksOnGround g = isEmptyFM  #  g `get` groundPacks