mainhsmines.hs

HTK系列的

                     destroy main
                     nuSize <- readTkVariable varSize
                     run htk nuSize)

    -- start the game
    start

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

buttons :: Container par=> par-> Button-> Event Int
                           -> (Int, Int)
                           -> IO [((Int, Int), Button)]

buttons par sb 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]]

     let bArr = array ((1,1), size) buttons
         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
                mapM_ (\b-> b # photo zeroImg >>= 
                                relief Raised) (elems bArr)
                sync (play m)

         play :: Mines-> Event ()
         play m 
           = do r <- choose leCl >>>= open bArr m
                case r of Nothing -> always gameLost 
                            >> gameOver
                          Just nu -> playOn nu
             +>
             do r<- choose riCl >>>= flag bArr 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 
                                        do always gameWon 
                                           gameOver
                          else play m

         gameLost :: IO ()
         gameLost = 
           do sb # photo smSadImg
              createAlertWin "*** BOOM!***\nYou lost." []
         gameWon :: IO ()
         gameWon = 
           do sb # photo smWinImg
              createMessageWin "You have won!" []


         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-> Mines-> (Int, Int)-> IO Mines
flag b m xy = 
  case m!xy of
    Cleared _ -> return m
    s@(Unexplored{flagged= f})-> 
        if f || (sum (map flags (elems m)) < 
                    sum (map mines (elems m)))
        then do b!xy # (if not f then photo flagImg 
                        else photo zeroImg)
                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