module Main where

import Random -- (randomRIO)
import Array
import Time 
import Control.Concurrent (ThreadId, killThread, threadDelay, forkIO)
import List (union, nub)
import System
import Monad (foldM)

import HTk hiding (State)
import DialogWin (createAlertWin,createMessageWin)

import Clock
import MinesImages

-- The state of a single field.
data State = Cleared Int 
           | Unexplored { flagged :: Bool,
                          mine    :: Bool }

-- A field is still untouched if it is neither cleared nor flagged
untouched :: State-> Bool
untouched (Cleared _) = False
untouched (Unexplored{flagged = f}) = not f

-- Counts the number of mines on a field
mines :: State-> Int
mines (Unexplored{mine= True}) = 1
mines _                        = 0

-- Similary, the number of flags
flags :: State-> Int
flags (Unexplored{flagged= True}) = 1
flags _                           = 0

-- Our playing field: an array of states, and the button handlers for 
-- them. (We keep them separate, since the state will change,
-- and the button handlers don't.)
type Mines   = Array (Int, Int) State
type Buttons = Array (Int, Int) Button

-- The field sizes. We need to type them explicitly, so we might as
-- well write them all down here
tinySize, weeSize, normalSize, bigSize, hugeSize :: (Int, Int)
tinySize = (6, 6)
weeSize  = (10, 10)
normalSize = (15, 15)
bigSize    = (20, 20)
hugeSize   = (25, 25)

-- get list of all adjacents to a given position
adjacents :: Mines-> (Int, Int)-> [(Int, Int)]
adjacents p (x, y) = 
  filter (inRange (bounds p))
         [(x-1, y-1), (x, y-1), (x+1, y-1),
          (x-1, y),             (x+1, y),
          (x-1, y+1), (x, y+1), (x+1, y+1)]

-- Get a non-repeating infite list of valid positions.
rndPos :: Mines-> IO [(Int, Int)]
rndPos p = 
   do s1<- newStdGen
      s2<- newStdGen
      return (nub (zip (randomRs (lox, hix) s1) 
                       (randomRs (loy, hiy) s2))) where
        ((lox, loy), (hix, hiy))= bounds p
 
-- Create all mines
createMines :: (Int, Int) -> Int 
                          -> IO Mines
createMines (w, h) d = 
  do -- We first get the positions for all the mines, and then put
     -- them on an empty pitch.
     minePos <- rndPos mt
     return (mt // zip (take numMines minePos) (repeat mine)) where
         mt= listArray ((1, 1), (w, h)) (repeat nomine)
         numMines = (w*h) `div` d
         mine   = Unexplored{mine= True, flagged= False}
         nomine = Unexplored{mine= False, flagged= False}
  

main :: IO ()
main = 
 do htk<- initHTk [withdrawMainWin]
    run htk normalSize 

run :: HTk-> (Int, Int)-> IO ()
run htk currentSize = 
 do main <- createToplevel [text "hsMines"]

    menubar <- createMenu main False []
    main # menu menubar

    fm <- createPulldownMenu menubar [text "File"]

    restb <- createMenuCommand fm [text "Restart"]
    quitb <- createMenuCommand fm [text "Quit"]

    pm <- createPulldownMenu menubar [text "Preferences"]
   
    pmc1 <- createMenuCascade pm [text "Size"]
    pmc1m <- createMenu main False []
    pmc1 # menu pmc1m
        
    pmc2 <- createMenuCascade pm [text "Difficulty"]
    pmc2m <- createMenu main False []
    pmc2 # menu pmc2m

    varSize <- createTkVariable currentSize
    sr1 <- createMenuRadioButton pmc1m 
            [text "tiny (6x6)", value tinySize, 
             variable varSize]
    sr2 <- createMenuRadioButton pmc1m 
            [text "small (10x10)", value weeSize,
             variable varSize]
    sr3 <- createMenuRadioButton pmc1m 
            [text "normal (15x15)", value normalSize,
             variable varSize]
    sr4 <- createMenuRadioButton pmc1m 
            [text "large (20x20)", value bigSize,
             variable varSize]
    sr5 <- createMenuRadioButton pmc1m 
            [text "huge (25x25)", value hugeSize,
             variable varSize]

    varDiff <- createTkVariable (6:: Int)
    dr1 <- createMenuRadioButton pmc2m 
            [text "easy", value (8::Int),
             variable varDiff]
    dr2 <- createMenuRadioButton pmc2m 
            [text "normal", value (6::Int),
             variable varDiff]
    dr3 <- createMenuRadioButton pmc2m 
            [text "hard", value (4::Int),
             variable varDiff]
    dr4 <- createMenuRadioButton pmc2m 
            [text "nuts", value (3::Int),
             variable varDiff]

    restartClick <- clicked restb
    quitClick <- clicked quitb

    csr1 <- clicked sr1
    csr2 <- clicked sr2
    csr3 <- clicked sr3
    csr4 <- clicked sr4
    csr5 <- clicked sr5

    sm <- newButton main [photo smSmileImg]
    startClick <- clicked sm

    pack sm [Side AtTop, PadY 20, PadX 20] 

    restartCh <- newChannel

    bfr <- newFrame main [width (cm 10)]

    pack bfr [Side AtTop, PadX 15] 

    flags <- newLabel main [text (formFlags 0 0), font (Lucida, 12::Int)]
    time  <- newLabel main [text (formTime 0), font (Lucida, 12::Int)] 
    pack flags [Side AtLeft,  PadX 5, PadY 5]
    pack time  [Side AtRight, PadX 5, PadY 5]

    size <- readTkVariable varSize
    allbuttons <- createButtons bfr sm flags time (receive restartCh) size
    delayWish $ mapM_ (\(xy, b)-> grid b 
          [GridPos xy, GridPadX 1, GridPadY 1]) allbuttons

    -- sync (never) -- stop execution for a screen shot 

    let start :: IO () 
        start = do diff <- readTkVariable varDiff
                   sendIO restartCh diff
                   
    -- start the menu handler
    stopmh<- spawnEvent (forever
          (startClick >>> start
        +> quitClick >>> destroy htk
        +> choose [csr1, csr2, csr3, csr4, csr5] >>> 
             createMessageWin "Changes come into effect after \"Restart\"." []))

    -- the restart handler (note no forever!)
    spawnEvent (restartClick >>> 
                  do stopmh
                     destroy main
                     nuSize <- readTkVariable varSize
                     run htk nuSize)

    -- start the game
    start

    -- wait for game to stop, then clear up the mess
    finishHTk

createButtons :: Container par=> par-> Button-> Label-> Label-> Event Int
                           -> (Int, Int)
                           -> IO [((Int, Int), Button)]
createButtons par sb fl tl startEv (size@(xmax, ymax)) =
  do buttons <- mapM (\xy-> 
       do b<- newButton par [photo starImg, relief Raised]
          return (xy, b)) [(x, y) | x <- [1.. xmax],
                                    y <- [1.. ymax]]
     cl <- newClock 1000 
                    (\td-> do tl # text (formTime (tdSec td)))
     let bArr = array ((1,1), size) buttons
         getButtonRelease :: Button-> Int-> a-> IO (Event a)
         getButtonRelease b n xy = 
            do (click, _) <- bindSimple b 
                              (ButtonRelease (Just n))
               return (click >> return xy)
     leCl <- mapM (\(xy, b)-> getButtonRelease b 1 xy) 
                                 buttons
     riCl <- mapM (\(xy, b)-> getButtonRelease b 3 xy) 
                                 buttons
     press <- mapM (\(_, b)-> 
       do (cl, _)<- bindSimple b (ButtonPress Nothing)
          return cl) buttons

     let start :: Event ()
         start = 
           startEv >>>= \d-> 
             do m <- createMines (snd (bounds bArr)) d
                sb # photo smSmileImg
		fl # text (formFlags 0 (sum (map mines (elems m))))
                mapM_ (\b-> b # photo zeroImg >>= 
                                   relief Raised) (elems bArr)
                sync (do Clock.start cl
                         play m)

         play :: Mines-> Event ()
         play m 
           = do r <- choose leCl >>>= open bArr m
                case r of Nothing -> gameLost m
                          Just nu -> playOn nu
             +>
             do r<- choose riCl >>>= flag bArr fl m
                playOn r
             +>
             do choose press 
                always (sb # photo smWorriedImg >> done) 
                play m
             +>
	     start

         playOn :: Mines-> Event ()
         playOn m = do always (sb # photo smCoolImg)
                       if all (not.untouched) (elems m) 
                           then gameWon
                           else play m

         gameLost :: Mines-> Event ()
         gameLost m = 
           do stop cl
	      always (do sb # photo smSadImg
                         uncover bArr m
		         createAlertWin "*** BOOM!***\nYou lost." [])
              gameOver

         gameWon :: Event ()
         gameWon = 
           do stop cl
	      always (do sb # photo smWinImg
                         createMessageWin "You have won!" [])
              gameOver

         gameOver :: Event ()
         gameOver = start 
                    +> (choose (leCl++ riCl) >> gameOver) 
                    +> (choose press >> gameOver)

     spawnEvent start
     return buttons

-- drop or retrieve a flag (mouse right-click)
flag :: Buttons-> Label-> Mines-> (Int, Int)-> IO Mines
flag b fl m xy = 
  let numflags = sum (map flags (elems m))
      nummines = sum (map mines (elems m))
  in case m!xy of
      Cleared _ -> return m
      s@(Unexplored{flagged= f})-> 
        if f || (numflags < nummines)
        then do b!xy # (if not f then photo flagImg
                        else photo zeroImg)
                fl # text (formFlags (numflags+ (if f then -1 else 1))
		                      nummines)
                return (m // [(xy, s{flagged= not f})])
        else return m 

-- open up a field (mouse left-click)
-- returns Nothing, if we click on a hidden mine, the input if we 
-- click on a flagged field (without a mine), and peeks at the field
-- otherwise

-- Crimson: I switched the order of Flag and Mine because it sucks to 
-- accidently click a Flag and get killed... 
-- I also put the Cleared _ expression on top because I think this saves 
-- computation time. 

open :: Buttons-> Mines-> (Int, Int)-> IO (Maybe Mines)
open b m xy = 
  case m!xy of 
    Cleared _                  -> return (Just m)
    Unexplored {flagged= True} -> return (Just m)
    Unexplored {mine= True}    -> return Nothing
    _ -> peek b m [xy] >>= return. Just

-- Peek at a list of fields, and count the number of
-- adjacent mines. If there are none, we recursively peek at all the
-- adjacent fields, which are
-- a. not already cleared, and
-- b. not on our list of fields to peek at
-- Precondition: all fields in the list are untouched.

peek :: Buttons-> Mines-> [(Int, Int)]-> IO Mines
peek b m [] = return m
peek b m (xy:rest) =
   let adjMines :: Int
       adjMines = sum (map (mines. (m !)) (adjacents m xy))
       nu       = m // [(xy, Cleared adjMines)]
   in do (b!xy)# photo (getImg adjMines) >>= relief Flat
         if adjMines == 0 then 
            peek b nu (rest `union` 
                      (filter (untouched. (m !))
                              (adjacents m xy)))
            else peek b nu rest

-- uncover all fields after game has ended
-- we uncover flags where there is no mine, and mines which have not
-- been detected 
uncover :: Buttons-> Mines-> IO ()
uncover b m =
  let uncoverOne(xy, Unexplored{flagged= True, mine= False}) = 
                                     b!xy # photo noMineImg >> done
      uncoverOne(xy, Unexplored{flagged= False, mine= True}) =
                                     b!xy # photo mineImg >> done
      uncoverOne _ = done
  in  mapM_ uncoverOne (assocs m)

-- utility function: format a number digit intro a string with leading 0's
format :: Num a=> Int-> a-> String
format m n = reverse (take m (reverse (show n) ++ repeat '0'))

-- format the number of flags and mines
formFlags :: Int-> Int-> String
formFlags f m = format 2 f ++ "/" ++ format 2 m

-- format the time field (input in seconds)
formTime :: Int-> String
formTime sec = format 2 m ++ ":" ++ format 2 s where
                 (m, s) = sec `quotRem` 60