import qualified SOEGraphics as G import qualified GraphicsUtils as GU import List data Direction = L | R | T | B | N deriving (Show,Eq) data Marker = Blank | Cross | Oh deriving (Show,Eq) type Conf =[[Marker]] data EvalResult = Inf | NInf | Win | Lose | Val Int deriving Show instance Eq EvalResult where Inf == Inf =True Inf == t = False t == Inf = False NInf == NInf = True NInf == t = False t == NInf = False Win == Win = True Win == t = False t == Win = False Lose == Lose = True Lose == t = False t == Lose = False (Val m) == (Val n) = m==n (Val m) == t = False t == (Val m) = False instance Ord EvalResult where compare Inf Inf=EQ compare Inf NInf =GT compare Inf Win = GT compare Inf Lose = GT compare Inf (Val n) = GT compare NInf NInf=EQ compare NInf Inf =LT compare NInf Win = LT compare NInf Lose = LT compare NInf (Val n) = LT compare Win Win = EQ compare Win (Val n) = GT compare Win Lose = GT compare Win Inf = LT compare Win NInf = GT compare (Val n) Win = LT compare (Val n) (Val m) = if n>m then GT else if n==m then EQ else LT compare (Val n) Lose = GT compare (Val n) Inf = LT compare (Val n) NInf = GT compare Lose Win = LT compare Lose (Val n) = LT compare Lose Lose = EQ compare Lose Inf = LT compare Lose NInf = GT testconf = [[Oh,Oh,Cross,Oh],[Oh,Oh,Cross,Oh],[Oh,Blank,Cross,Oh],[Blank,Blank,Cross,Blank]] --Empty board initLine 0 = [] initLine k = Blank :(initLine (k-1)) initConf _ 0 = [] initConf k s= (initLine k): initConf k (s-1) initBoard k = initConf k k --Given a current board configuration and the next move, generate the next board configuration newConf :: Conf -> Int -> Direction -> Marker -> Conf nextMove (row:cf) newcf 0 mark = newcf ++ [(push row mark)]++ cf nextMove (row:cf) newcf n mark = nextMove cf (newcf ++ [row]) (n-1) mark push row mark = filterBlank (mark:row) filterBlank (Blank:es) = es filterBlank (e: []) = [] filterBlank (e:es)= e:filterBlank es newConf cf n L mark = nextMove cf [] n mark newConf cf n R mark = let tmp1Conf = rTransf cf tmp2Conf = nextMove tmp1Conf [] n mark in rTransf tmp2Conf newConf cf n T mark = let tmp1Conf = tTransf cf tmp2Conf = nextMove tmp1Conf [] n mark in tTransf tmp2Conf newConf cf n B mark = let tmp1Conf = bTransf cf tmp2Conf = nextMove tmp1Conf [] n mark in bTransf2 tmp2Conf rTransf conf = map reverse conf tTransf conf = transpose conf bTransf conf = rTransf (tTransf conf) bTransf2 conf = tTransf (rTransf conf) --reverse the role of Cross and Oh in a board updown [] = [] updown (row:rs)=(updownrow row): updown rs updownrow [] = [] updownrow (Blank:es) = Blank:updownrow es updownrow (Oh:es) = Cross:updownrow es updownrow (Cross:es)= Oh:updownrow es --Evaluation function: straight count + piece count isStraight m [] = True isStraight m (e:es) = if m==e then isStraight m es else False rowStraightNum [] (m,n) = (m,n) rowStraightNum (row:cf) (m,n) = if(isStraight Cross row) then rowStraightNum cf (m+1,n) else if(isStraight Oh row) then rowStraightNum cf (m,n+1) else rowStraightNum cf (m,n) straightNum cf = let (m1,n1) = rowStraightNum cf (0,0) (m2,n2) = rowStraightNum (tTransf cf) (0,0) in (m1+m2,n1+n2) evalcf cf pasts= if (cf `elem` pasts) then Lose else let (m,n) = straightNum cf in if (m>n) then Win else if(mInt->Int rowPoint [] n = n rowPoint (Cross:es) n = rowPoint es (n+1) rowPoint (Blank:es) n = rowPoint es n rowPoint (Oh:es) n = rowPoint es (n-1) points:: Conf->Int->Int points [] n = n points (row:cf) n = points cf (rowPoint row n) --straight count rowStraight [] (m,n) = (m*m,n*n) rowStraight (Cross:es) (m,n) = rowStraight es (m+1,n) rowStraight (Blank:es) (m,n) = rowStraight es (m,n) rowStraight (Oh:es) (m,n) = rowStraight es (m,n+1) straightCount [] (m,n) = m-n straightCount (row:cf) (m,n)= let (c,o)=rowStraight row (0,0) in straightCount cf (m+c,n+o) branch1 _ (-1) _ _ cflist = cflist branch1 cf k dir mark cflist = branch1 cf (k-1) dir mark ((dir,k,(newConf cf k dir mark)):cflist) branch cf k mark = let cflistL=branch1 cf k L mark [] cflistR=branch1 cf k R mark [] cflistT=branch1 cf k T mark [] cflistB=branch1 cf k B mark [] in cflistL ++ cflistR ++ cflistT ++ cflistB --Alpha-Beta Minimax search search::Conf->Int->[Conf]->((Direction,Int),EvalResult) search cf k pasts = let childs = branch cf k Cross in maxenum k ((N,0),NInf) ((N,0),Inf) childs 4 pasts --Iterative Deepening Search!!! --search::Conf->Int->[Conf]->((Direction,Int),EvalResult)->Int->((Direction,Int),EvalResult) --search cf k pasts ((bestdir,bestn),bestv) depth = -- let childs = branch cf k Cross -- ((dir,n),v) = maxenum k ((N,0),NInf) ((N,0),Inf) childs depth pasts -- in if(v==Win) then ((dir,n),v) else -- if(depth>=4) -- then if(bestv if (ply==0) then ((dir,kn),val) else let childs = branch cf k Cross in maxenum k alpha beta childs ply (cf:pasts) v -> ((dir,kn),v) maxenum k (alphamv,alphan) (betamv,betan) [] ply _= (alphamv,alphan) maxenum k (alphamv,alphan) (betamv,betan) (c:cs) ply pasts = let (dir,kn,cf)=c (minmv,minn) = minVal c k (alphamv,alphan) (betamv,betan) (ply-1) pasts in if(minn > alphan) then if(minn>=betan) then (betamv ,betan) else maxenum k ((dir,kn),minn) (betamv,betan) cs ply pasts else if(alphan>=betan) then (betamv,betan) else maxenum k (alphamv,alphan) (betamv,betan) cs ply pasts minVal c k alpha beta ply pasts= let (dir,kn,cf)=c val = evalcf cf pasts in case val of Val n -> if (ply==0) then ((dir,kn),val) else let childs = branch cf k Oh in minenum k alpha beta childs ply (cf:pasts) v -> ((dir,kn),v) minenum k (alphamv,alphan) (betamv,betan) [] ply _= (betamv,betan) minenum k (alphamv,alphan) (betamv,betan) (c:cs) ply pasts = let (dir,kn,cf)=c (maxmv,maxn) = maxVal c k (alphamv,alphan) (betamv,betan) (ply-1) pasts in if(maxn < betan) then if(maxn<=alphan) then (alphamv ,alphan) else minenum k (alphamv,alphan) ((dir,kn),maxn) cs ply pasts else if(betan<=alphan) then (alphamv ,alphan) else minenum k (alphamv,alphan)(betamv,betan) cs ply pasts --The enty point for the game to start start = G.runGraphics $ do w <- G.openWindow "Pousse Tournament" (500,300) G.drawInWindow w (G.text (100,60) "Please Input Game Size && Game Mode") G.drawInWindow w (G.text (100,80) "1===>Machine Vs. Human") G.drawInWindow w (G.text (100,100) "2===>Machine Vs. Machine") G.drawInWindow w (G.text (100,120) "3===>Human Vs. Human") G.drawInWindow w (G.text (100,160) "Game Size, preferrably 3 to 7") G.drawInWindow w (G.text (100,230) "Game Mode") G.drawInWindow w (G.polygon [(100,180),(300,180),(300,210),(100,210)]) G.drawInWindow w (G.polygon [(100,250),(300,250),(300,280),(100,280)]) ns <- getK w "" 100 190 gm <- getK w "" 100 260 G.closeWindow w startGame ((read ns)::Int) ((read gm)::Int) getK w t xpos ypos = do G.drawInWindow w (G.withColor GU.Red (G.text (xpos,ypos) (t++"_"))) k <- G.getKey w if(ord k == 13) then (return t) else do G.drawInWindow w (G.withColor GU.Red (G.text (xpos,ypos) (t++[k]))) getK w (t++[k]) xpos ypos startGame k mode= case mode of 1 -> do w <- G.openWindow "Pousse Tournament" (150*k,150*k) drawBoard w 0 (initBoard k) G.drawInWindow w (G.text (30,70+100*k) "Machine's turn=>...press ENTER to see its move") playGame w (initBoard k) k [] G.closeWindow w return () 2 -> do w <- G.openWindow "Pousse Tournament" (150*k,150*k) drawBoard w 0 (initBoard k) G.drawInWindow w (G.text (30,70+100*k) "A's turn=>...press ENTER to see its move") G.getKey w mmplayGame w (initBoard k) k [] G.closeWindow w return () 3 -> do w <- G.openWindow "Pousse Tournament" (150*k,150*k) drawBoard w 0 (initBoard k) G.drawInWindow w (G.polygon [(100,100+100*k),(300,100+100*k),(300,100*k+130),(100,100*k+130)]) G.drawInWindow w (G.text (100,70+100*k) "A's turn=>...please Input Next Move") hhplayGame w (initBoard k) k [] G.closeWindow w return () drawBoard _ _ [] = return () drawBoard w r (e:es) = do drawRow w r 0 e drawBoard w (r+1) es drawRow _ _ _ [] = return () drawRow w r c (Blank:bs) = do G.drawInWindow w (G.withColor GU.Red (G.polyline [(50+100*(r),50+100*(c)),(50+100*(r+1),50+100*(c)),(50+100*(r+1),50+100*(c+1)),(50+100*(r),50+100*(c+1)),(50+100*(r),50+100*(c))])) drawRow w r (c+1) bs drawRow w r c (Cross:bs) = do G.drawInWindow w (G.withColor GU.Red (G.polyline [(50+100*(r),50+100*(c)),(50+100*(r+1),50+100*(c)),(50+100*(r+1),50+100*(c+1)),(50+100*(r),50+100*(c+1)),(50+100*(r),50+100*(c))])) G.drawInWindow w (G.withColor GU.Red (G.line (50+100*(c),50+100*(r)) (50+100*(c+1),50+100*(r+1)))) G.drawInWindow w (G.withColor GU.Red (G.line (50+100*(c+1),50+100*(r)) (50+100*(c),50+100*(r+1)))) drawRow w r (c+1) bs drawRow w r c (Oh:bs) = do G.drawInWindow w (G.withColor GU.Red (G.polyline [(50+100*(r),50+100*(c)),(50+100*(r+1),50+100*(c)),(50+100*(r+1),50+100*(c+1)),(50+100*(r),50+100*(c+1)),(50+100*(r),50+100*(c))])) G.drawInWindow w (G.withColor GU.Red (G.ellipse (50+100*(c),50+100*(r)) (50+100*(c+1),50+100*(r+1)))) drawRow w r (c+1) bs --Machine Vs. Human playgame playGame w cf k pasts = let ((dir,n),v) = search cf (k-1) pasts --((L,0),NInf) 1 newcf = newConf cf n dir Cross cv=evalcf newcf (cf:pasts) in case cv of Win -> do G.clearWindow w drawBoard w 0 newcf G.drawInWindow w (G.text (100,20) "HaHa, I WIN") G.getKey w G.closeWindow w Lose -> do G.clearWindow w drawBoard w 0 newcf G.drawInWindow w (G.text (100,20) "Congratulations, You WIN!") G.getKey w G.closeWindow w _ -> do G.getKey w G.clearWindow w drawBoard w 0 newcf G.drawInWindow w (G.polygon [(100,100+100*k),(300,100+100*k),(300,100*k+130),(100,100*k+130)]) G.drawInWindow w (G.text (100,70+100*k) "Please Input Next Move") nm<-getK w "" 110 (110+100*k) youMove w newcf k (cf:pasts) nm youMove w newcf k pasts nm = let (youdir,youn) = parseIn nm younewcf = newConf newcf youn youdir Oh youv=evalcf newcf pasts in case youv of Win -> do G.clearWindow w drawBoard w 0 younewcf G.drawInWindow w (G.text (100,20) "HaHa, I WIN") G.getKey w G.closeWindow w Lose -> do G.clearWindow w drawBoard w 0 younewcf G.drawInWindow w (G.text (100,20) "Congratulations, You WIN!") G.getKey w G.closeWindow w _ -> do G.clearWindow w G.drawInWindow w (G.text (30,70+100*k) "Machine's turn=>...press ENTER to see its move") drawBoard w 0 younewcf playGame w younewcf k (newcf:pasts) parseIn::String->(Direction, Int) parseIn [] = (L,0) parseIn (c:cs) = case c of 'L' -> (L,read cs) 'l' -> (L,read cs) 'T' -> (T,read cs) 't' -> (T,read cs) 'R' -> (R,read cs) 'r' -> (R,read cs) 'B' -> (B,read cs) 'b' -> (B,read cs) ch -> (L,read cs) --Machine vs. Machine playgame mmplayGame w cf k pasts = let ((dir,n),v) = search cf (k-1) pasts --((L,0),NInf) 1 newcf = newConf cf n dir Cross cv=evalcf newcf (cf:pasts) in case cv of Win -> do G.clearWindow w drawBoard w 0 newcf G.drawInWindow w (G.text (100,20) "HaHa, A WIN") G.getKey w G.closeWindow w Lose -> do G.clearWindow w drawBoard w 0 newcf G.drawInWindow w (G.text (100,20) "Congratulations, B WIN!") G.getKey w G.closeWindow w _ -> do G.clearWindow w G.drawInWindow w (G.text (30,70+100*k) "B's turn=>...press ENTER to see its move") drawBoard w 0 newcf G.getKey w mmyouMove w newcf k (cf:pasts) mmyouMove w newcf k pasts = let ((youdir,youn),v) = search (updown newcf) (k-1) (map updown pasts) --((L,0),NInf) 1 younewcf = newConf newcf youn youdir Oh youv=evalcf newcf pasts in case youv of Win -> do G.clearWindow w drawBoard w 0 younewcf G.drawInWindow w (G.text (100,20) "HaHa, A WIN") G.getKey w G.closeWindow w Lose -> do G.clearWindow w drawBoard w 0 younewcf G.drawInWindow w (G.text (100,20) "Congratulations, B WIN!") G.getKey w G.closeWindow w _ -> do G.clearWindow w G.drawInWindow w (G.text (30,70+100*k) "A's turn=>...press ENTER to see its move") drawBoard w 0 younewcf G.getKey w mmplayGame w younewcf k (newcf:pasts) --Human Vs. Human playgame hhplayGame w cf k pasts = do nm<-getK w "" 110 (110+100*k) myturn w cf k pasts nm myturn w cf k pasts nm= let (dir,n) = parseIn nm newcf = newConf cf n dir Cross cv=evalcf newcf (cf:pasts) in case cv of Win -> do G.clearWindow w drawBoard w 0 newcf G.drawInWindow w (G.text (100,20) "HaHa, A WIN") G.getKey w G.closeWindow w Lose -> do G.clearWindow w drawBoard w 0 newcf G.drawInWindow w (G.text (100,20) "Congratulations, B WIN!") G.getKey w G.closeWindow w _ -> do G.clearWindow w drawBoard w 0 newcf G.drawInWindow w (G.polygon [(100,100+100*k),(300,100+100*k),(300,100*k+130),(100,100*k+130)]) G.drawInWindow w (G.text (100,70+100*k) "B's turn=>...please Input Next Move") nm<-getK w "" 110 (110+100*k) hhyouMove w newcf k (cf:pasts) nm hhyouMove w newcf k pasts nm = let (youdir,youn) = parseIn nm younewcf = newConf newcf youn youdir Oh youv=evalcf newcf pasts in case youv of Win -> do G.clearWindow w drawBoard w 0 younewcf G.drawInWindow w (G.text (100,20) "HaHa A WIN") G.getKey w G.closeWindow w Lose -> do G.clearWindow w drawBoard w 0 younewcf G.drawInWindow w (G.text (100,20) "Congratulations, B WIN!") G.getKey w G.closeWindow w _ -> do G.clearWindow w G.drawInWindow w (G.polygon [(100,100+100*k),(300,100+100*k),(300,100*k+130),(100,100*k+130)]) G.drawInWindow w (G.text (100,70+100*k) "A's turn=>...please Input Next Move") drawBoard w 0 younewcf hhplayGame w younewcf k (newcf:pasts)