"Крестики нолики" на haskell

                                                                                                                                                                                                                                                                 
-- Основной файл
 
-- подключем библиотеку графики:
import Graphics.UI.WX
-- для обработки исключений:
import Control.Concurrent
-- для связи между потоками:
import Control.Concurrent.Chan
-- созданые нами модули
import Netmoduleimport DialogCF      
main = do
-- создаём чаны для обещия между потоками  
 chanD <- newChan   
 chanN <- newChan
-- и запускаем поток с сетью   
 netFork <- forkOS $ mainNet chanD chanN
-- а так же диалоговое окно   
 firstD chanD chanN
-- по завершению надо убить поток для сети   
 killThread netFork
 
-- Gui
 
module DialogCF where
import Graphics.UI.WX
import Graphics.UI.WXCore
import Control.Concurrent
import Control.Concurrent.Chan
import Data.List
import Text.Regex.Posix ((=~))
 
 
setSize xs s  = [ take s x | x <- take s xs ] 
 
 
firstD chanD chanN = do
 start $ do
  f      <- frame  [text := "Game"]
  p      <- panel  f []
  ip <- textEntry p [text := "", alignment := AlignRight]
  let clabels = ["3","4","5","20"]
  sizeField   <- choice p [tooltip := "unsorted choices", sorted  := False, items := clabels, selection := 0]
 
  mp <- panel f []
  status <- staticText f [ text := "" ]
  set f [ layout := container mp $ margin 10 $ column 1 [ widget status ] ]
  set mp [ visible := False ]
 
  mainp <- panel f []
  let sizeL = 20
  bList <- buttonList mainp (sizeL * sizeL)
  let grL = groupM sizeL bList
  butList <- varCreate grL
  gameStatus <- staticText mainp [ text := "Start!" ]
  mapM_ ((x, y) -> set x [ on command := do 
             txt <- get x text
             case txt of 
              "" -> do 
                 forkOS $ do
 
                    set x [ text := "X" ]
                    bl <- varGet butList
                    resCheck <- check bl
                    case resCheck of
                     "Full" -> do 
                         writeChan chanD $ "f" ++ show y
                         infoDialog f "Info" "Draw"
                         mapM_ (mapM_ (x -> set x [ text := ""])) bl
                     "True" -> do
                         writeChan chanD $ "w" ++ show y
                         infoDialog f "Info" "You win"
                         mapM_ (mapM_ (x -> set x [ text := ""])) bl
                     "False" -> do
                         writeChan chanD $ show y
 
                    set gameStatus [ text := "Waiting..." ]
                    messageChan <- readChan chanN
                    case head messageChan of
                     'f' -> do
                        set (bList !! (-1 + read (tail messageChan) :: Int)) [ text := "O" ]
                        infoDialog f "Info" "Draw"
                        mapM_ (mapM_ (x -> set x [ text := ""])) bl 
                     'w' -> do
                        set (bList !! (-1 + read (tail messageChan) :: Int)) [ text := "O" ]
                        infoDialog f "Info" "You lose"
                        mapM_ (mapM_ (x -> set x [ text := ""])) bl
                     'd' -> do
                        infoDialog f "Info" "Opponent disconnected"
                        close f
                     _ -> do
                        set (bList !! (-1 + read messageChan :: Int)) [ text := "O" ]
                    set mainp [ enabled := True ]
                    set gameStatus [ text := "Your move" ]
                 set mainp [ enabled := False ]
              "X" -> infoDialog f "Info" "Here is already coming, nselect another cell"
              "O" -> infoDialog f "Info" "Here is already coming, nselect another cell"
        ]) (zip bList [1..(sizeL*sizeL)])
 
 
 
  set mainp [ visible := False ]
 
  connect <- button p [text := "Connect", on command := do
                 message <- get ip text
                 if (1 /= length (message =~ "[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}" :: [[String]]))
                  then infoDialog f "Info" "Invalid IP"
                  else do 
                    set status [ text := ("Connect to " ++ message) ]
                    set p [ visible := False ]
                    set status [ visible := True ]
                    forkOS $ do
                       message <- readChan chanN 
                       set status [ visible := False ]
                       if ("discon" == message)
                        then do 
                          set p [ visible := True ]
                          infoDialog f "Info" "Connection failed"
                        else do 
                          let sizeM = read message :: Int
                          let bListAtSize = take (sizeM * sizeM) bList
                          varSet butList $ groupM sizeM bListAtSize
                          mapM_ (x -> set x [ visible := True ]) bListAtSize
                          let gr = groupM sizeM $ map widget bListAtSize
                          set gameStatus [ text := "Your move" ]
                          set f  [layout := container mainp $ margin 10 $ column 1 [ (grid 5 5 gr)
                                         ,hfill $ minsize (sz 20 80) $ widget gameStatus]]
                          set mainp [ visible := True ]
                          set f [ clientSize := sz (20 + sizeM * 20) (20 + sizeM * 20)]
                    writeChan chanD $ "c" ++ message
 
                  ]
  run    <- button p [text := "Run server", on command := do
                 message <- get sizeField text
                 set status [ text := "Awaiting connection." ]
                 set p [ visible := False ]
                 set status [ visible := True ]
                 forkOS $ do
                    message <- readChan chanN
                    set status [ visible := False ]
                    let sizeM = read message :: Int
                    let bListAtSize = take (sizeM * sizeM) bList
                    mapM_ (x -> set x [ visible := True ]) bListAtSize
                    varSet butList $ groupM sizeM bListAtSize
                    let gr = groupM sizeM $ map widget bListAtSize
                    set gameStatus [ text := "Waiting..." ]
 
                    set f [layout := container mainp $ margin 10 $ column 1 [ (grid 5 5 gr)
                                          ,hfill $ minsize (sz 20 80) $ widget gameStatus]]
                    set mainp [ visible := True, enabled := False ]
                    set f [ clientSize := sz (20 + sizeM * 20) (20 + sizeM * 20)]
                    messageChan <- readChan chanN
 
                    if ("discon" == messageChan)
                     then do
                       infoDialog f "Info" "Opponent disconnected"
                       close f
                     else do  
                       set gameStatus [ text := "Your move" ]
                       set (bList !! (-1 + read messageChan :: Int)) [ text := "O" ]
                       set mainp [ enabled := True ]
                 writeChan chanD $ "r" ++ message
 
                  ]
 
  set f  [ layout :=  container p $
       margin 10 $
       column 5 [ boxed "Client" (grid 5 5 [ [label "Server ip:", hfill $ widget ip]
                 ,[widget connect]])
          ,boxed "Server" (grid 5 5 [ [label "Field size:", hfill $ widget sizeField]
                 ,[widget run]])]
   ]
 
 
groupM _ [] = []
groupM y xs = (take y xs):(groupM y $ drop y xs)
 
-- textAtButton::[Button ()]-> IO [Bool]
textAtButton []  = return []
textAtButton (x:xs) = do
       t <- get x text
       nextList <- textAtButton xs
       return $ t:nextList
-- textAtButtonM::[[Button ()]]-> IO [[Bool]]
textAtButtonM []   = return []       
textAtButtonM (x:xs)  = do
        t <- textAtButton x
        nextList <- textAtButtonM xs
        return $ t:nextList
 
check''' [] a@(x:xs) = if (3 > length x)
       then False
       else check''' (map tail a) (map tail a)     
check''' (("X":a):(_:"X":b):(_:_:"X":c):xs) _ = True
check''' ((_:_:"X":a):(_:"X":b):("X":c):xs) _ = True
check''' (("X":a):("X":b):("X":c):xs) _ = True
check''' (("X":"X":"X":a):xs) _ = True
check''' (x:xs) a = check''' xs a    
 
checkOfFull (x:xs) = not $ elem True (map (elem "") xs)
 
 
check xs = do
    t <- textAtButtonM xs
    if (checkOfFull t)
     then return "Full"
     else if (check''' t t)
       then return "True"
       else return "False"
 
 
buttonList _ 0 = return []
buttonList p a = do
     b <- button p [ text := "", clientSize := sz 15 15, visible := False ]         
     nextList <- buttonList p $ a - 1
     return $ b : nextList 
 
 
--и net-модуль взят из интернета немного переделан
 
module Netmodule where 
import Network
import System.IO (hGetLine,hClose,hPutStrLn,hSetBuffering,BufferMode(..),Handle,stdout)
import Control.Concurrent
import Control.Concurrent.Chan
 
port = 8001 
 
mainNet chanD chanN = withSocketsDo $ do
  input <- readChan chanD
  case head input of
   'r' -> server chanD chanN input
      `catch` (const $ writeChan chanN "discon" >> mainNet chanD chanN) 
   'c' -> do
      client chanD chanN input
       `catch` (const $ writeChan chanN "discon" >> mainNet chanD chanN)
   _ -> putStrLn "game net fork: stop"     
 
 
while2 x y = ifM x (return ()) $ ifM y (return ()) $ while2 x y 
 
ifM p t f  = p >>= (p' -> if p' then t else f)
 
client chanD chanN input = do
 h <- connectTo (tail input) (PortNumber port)
 hSetBuffering h LineBuffering
 while2 (receive h chanN) (send h chanD)
 hClose h
 
server chanD chanN input = do
 sock <- listenOn (PortNumber port)
 (h,host,port) <- accept sock
 hSetBuffering h LineBuffering
 hPutStrLn h $ tail input
 writeChan chanN $ tail input
 while2 (receive h chanN) (send h chanD)
 hClose h
 sClose sock

Комментарии

Популярные сообщения из этого блога

Google Chrome - видео в отдельном окне

Bitrix: кнопка добавить в корзину

Google chrome размытое изображение