MineField.hs

module MineField(MInput(..),MOutput(..),Symbol(..),Coord(..),play,playSP,initMineCount,mineFieldSize) where
--import RandomHBC(randomInts)
import System.Random(StdGen,randomRs,split)
import Data.List(union, intersect)
import Fudgets(getSP,putsSP) -- SP operations
import Data.Array
import Data.List((\\),nub)

type Coord = (Int,Int)			-- mine field coordinate
type RandInt = Int
type MineCount = Int
type MineField = Array (Int,Int) Bool 	-- number of mines and the array representing the mine field
data Moves = Moves Coord [Coord] [Coord] -- current pos, places, border
	     deriving (Eq, Ord{-, Text-})

mineFieldSizeX, mineFieldSizeY :: Int
mineFieldSizeX = 12
mineFieldSizeY = 12
mineFieldSize :: Coord
mineFieldSize = (mineFieldSizeX, mineFieldSizeY)

newField :: StdGen -> MineCount -> MineField			-- random numbers gives a new field
newField g n =
  let (nx, ny) = mineFieldSize
    --rs = newRands r
    --xs = map (`rem` nx) (everyOther rs)
    --ys = map (`rem` ny) (everyOther (tail rs))
      (g1,g2) = split g
      ps = randomRs (1,nx) g1 `zip` randomRs (1,ny) g2
      xys = take ((n `min` (nx * ny)) `max` 0) $
            nub (ps \\ [(1,1),mineFieldSize])
      b = ((0,0),(nx+1,ny+1))
  in  array b [(p, p `elem` xys) | p<-range b]



--newRands r = randomInts ((r `max` 1) `min` 2147483562) (((r+123457) `max` 1) `min` 2147483398)
--everyOther (x:_:xs) = x:everyOther xs

initMoves = Moves (1,1) [(1,1)] [(1,2), (2,1), (2,2)]

moveTo :: Moves -> Coord -> Maybe Moves
moveTo (Moves _ visited border) xy | xy `elem` border =
        let visited' = xy:visited
	in  Just (Moves xy visited' (union border (neighbours xy) \\ visited'))
moveTo (Moves _ visited border) xy | xy `elem` visited =
	Just (Moves xy visited border)
moveTo _ _ = Nothing
	
neighbours :: Coord -> [Coord]
neighbours (x,y) = 
	let (xm,ym) = mineFieldSize
	in  [(xi,yi) | xi<-[x-1..x+1], xi>0 && xi<=xm, yi<-[y-1..y+1], yi>0 && yi<=ym]

data Symbol = SBlank | SNumber Int | SCurrent Int | SFree | SBomb | SBombX | SBombDone deriving (Eq, Ord, Show)
data MInput = Move Coord | Bomb Coord | Free Coord | Hint | New | SetSize Int | Noop deriving (Eq, Ord{-, Text-})
data MOutput = Repaint [(Coord, Symbol)] | Msg String | Status String deriving (Eq, Ord{-, Text-})
type Counters = (Int,Int) -- moves, hints
type Bombs = [Coord]
data State = Go StdGen MineCount MineField Moves Counters Bombs Bombs
           | Stop StdGen MineCount
           --deriving (Eq, Ord{-, Text-})

initMineCount :: MineCount
initMineCount = 26
newState :: StdGen -> MineCount -> State
newState g n = Go g1 n (newField g2 n) initMoves (0, 0) [] []
  where (g1,g2) = split g
doMove :: State -> MInput -> (State, [MOutput])
doMove s@(Go rs n mf ms c@(i,j) bs fs) (Move xy) =
    if xy `elem` bs then
	(s, [])
    else
	case moveTo ms xy of
	   Nothing -> (s, [])
	   Just ms' -> 
	        let c' = (i+1,j) in
		if mf ! xy then
		    let as = allBombs mf in
		    (Stop rs n, [Msg "You just exploded!", stat c' bs fs, Repaint [paintBomb bs a | a<-as], Repaint [(xy,SBombX) | xy<-bs, xy `notElem` as]])
		else 
		    if xy == mineFieldSize then
		        (Stop rs n, [Msg "You honestly made it!", stat c' bs fs, Repaint (map (paint mf ms' bs) (changes ms ms'))])
		    else
		        (Go rs n mf ms' c' bs fs, [Msg (mineMsg mf xy), stat c' bs fs, Repaint (map (paint mf ms' bs) (changes ms ms'))])
doMove s@(Go rs n mf ms@(Moves _ vis _) c bs fs) (Bomb xy) =
        if xy `elem` vis then
	    (s, [])
	else if xy `elem` bs then
	    let bs' = bs \\ [xy] in (Go rs n mf ms c bs' fs,          [stat c bs' fs, Repaint [(xy, SBlank)]])
	else
	    let bs' = xy:bs
                fs' = fs \\ [xy]
            in  (Go rs n mf ms c bs' fs', [stat c bs' fs', Repaint [(xy, SBomb)]])
doMove s@(Go rs n mf ms@(Moves _ vis _) c bs fs) (Free xy) =
        if xy `elem` vis then
	    (s, [])
	else if xy `elem` fs then
	    let fs' = fs \\ [xy] in (Go rs n mf ms c bs fs',          [stat c bs fs', Repaint [(xy, SBlank)]])
	else
	    let fs' = xy:fs
                bs' = bs \\ [xy]
            in  (Go rs n mf ms c bs' fs', [stat c bs' fs', Repaint [(xy, SFree)]])
doMove (Go rs n _ _ _ _ _) New = doMove (Stop rs n) New
doMove (Stop rs n) New =
	let (s@(Go _ _ a _ _ _ _), os) = doMove (newState rs n) (Move (1,1))
	in  (s, Repaint [((x,y), SBlank) | x<-[1..mineFieldSizeX], y<-[1..mineFieldSizeY]] : Repaint [((1,1), SCurrent (countBombs a (1,1)))] : stat (0,0) [] []:os)
doMove (Go rs _ mf ms c bs fs) (SetSize n) = (Go rs n mf ms c bs fs, [])
doMove (Go rs n mf ms@(Moves _ _ ps) (i,j) bs fs) Hint = 
        let m = case filter (\xy->not (mf ! xy)) ps of
                  [] -> Msg "Impossible"
		  xy:_ -> Repaint [(xy, SFree)]
            c' = (i,j+1)
        in  (Go rs n mf ms c' bs fs, [stat c' bs fs, m])
doMove (Stop rs _) (SetSize n) = (Stop rs n, [])
doMove s _ = (s, [])

stat :: Counters -> Bombs -> Bombs -> MOutput
stat (i, j) bs fs = Status ("Moves: "++show i++"   Hints: "++show j++"   Safes: "++show (length fs)++"   Mines: "++show (length bs))

mineMsg a xy =
	case countBombs a xy of
	   0 -> "No mines nearby."
	   1 -> "1 mine nearby."
	   n -> shows n " mines nearby."

changes :: Moves -> Moves -> [Coord]
changes (Moves cur vis bor) (Moves cur' vis' bor') =
	let chg l l' = union l l' \\ intersect l l'
	in  nub (chg [cur] [cur'] ++ chg vis vis' ++ chg bor bor')

paint :: MineField -> Moves -> Bombs -> Coord -> (Coord, Symbol)
paint a (Moves cur vis _) bs xy =
	(xy, 
	if xy == cur then
	    SCurrent (countBombs a xy)
	else if xy `elem` vis then
	    SNumber (countBombs a xy)
	else if xy `elem` bs then
	    SBomb
	else
	    SBlank)

countBombs a = length . filter id . map (a!) . neighbours

allBombs a = [(x,y) | x<-[1..mineFieldSizeX], y<-[1..mineFieldSizeY], a!(x,y)]

paintBomb bs xy =
	(xy,
	if xy `elem` bs then
		SBomb
	else
		SBombDone)

firstState :: StdGen -> (State, [MOutput])
firstState g =
	{-let r = truncate d
	in-}  doMove (newState g initMineCount) New

stripR = filter f where f (Repaint []) = False
                        f _ = True

doMoves :: State -> [MInput] -> [[MOutput]]
doMoves s [] = []
doMoves s (i:is) =
	let (s', os) = doMove s i
	in  stripR os : doMoves s' is

play :: StdGen -> [MInput] -> [[MOutput]]
play d is =
	let (s, os) = firstState d
	in  stripR os : doMoves s is


-- Stream Processor version of play & doMoves (hallgren 930525):

--doMovesSP :: State -> SP MInput MOutput
doMovesSP s =
	getSP $ \i ->
	let (s', os) = doMove s i
	in  putsSP (stripR os) $ doMovesSP s'

--playSP :: Double -> SP MInput MOutput
playSP d =
	let (s, os) = firstState d
	in  putsSP (stripR os) $ doMovesSP s