Skip to content

Commit a17783e

Browse files
skruppyskruppy
committed
Print final result
1 parent 98a38b8 commit a17783e

File tree

4 files changed

+96
-99
lines changed

4 files changed

+96
-99
lines changed

‎Sm.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,6 @@
44
-- day, and you think this stuff is worth it, you can buy me a beer in return.
55
-- -- Albatrouss and Skruppy
66

7-
module Sm (StepResult(..),Cfg(..),GameData(..),PlayerItem(..),smCreate,smStep) where
7+
module Sm (StepResult(..),Cfg(..),GameData(..),PlayerItem(..),Board,smCreate,smStep) where
88

99
import Sm.Internal

‎Sm/Internal.hs‎

Lines changed: 17 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,7 @@ import Data.Version
1717

1818
data StepResult
1919
= SmOk QuallifiedState [String]
20-
| SmEnd GameData (Maybe Int)
20+
| SmEnd GameData (Maybe Int) (Array (Int, Int) String)
2121
| SmError String
2222
deriving (Eq, Show)
2323

@@ -33,6 +33,7 @@ type GameType = String
3333
type GameName = String
3434
type MoveTime = Int
3535
type WinnerId = Int
36+
type Board = (Array (Int, Int) String)
3637

3738
data BoardTransReason
3839
= Winner Int
@@ -51,19 +52,19 @@ data State
5152
| PlayerEndState Major Minor GameType GameName (Array Int (Maybe PlayerItem))
5253
| IdleState GameData
5354
| FieldStartState GameData BoardTransReason
54-
| FieldLineState GameData BoardTransReason Int Int Int [[String]]
55-
| FieldEndState GameData BoardTransReason Int Int [[String]]
56-
| ThinkingState GameData MoveTime (Array (Int, Int) String)
55+
| FieldLineState GameData BoardTransReason Int Int Int [[String]]
56+
| FieldEndState GameData BoardTransReason Int Int [[String]]
57+
| ThinkingState GameData MoveTime Board
5758
| MoveState GameData
58-
| QuitState GameData (Maybe WinnerId)
59-
| EndState GameData (Maybe WinnerId)
59+
| QuitState GameData (Maybe WinnerId) Board
60+
| EndState GameData (Maybe WinnerId) Board
6061
| ErrorState String
6162
deriving (Eq, Show)
6263

6364
data Cfg = Cfg
6465
{ gameId :: String
6566
, player :: Maybe Int
66-
, ai :: GameData -> Array (Int, Int) String -> Int -> ( String , IO () )
67+
, ai :: GameData -> Board -> Int -> ( String , IO () )
6768
}
6869

6970
instance Show Cfg where
@@ -241,9 +242,9 @@ parseInput (FieldLineState gameData boardTransReason x y curY field) cfg input =
241242
parseInput (FieldEndState gameData boardTransReason x y field) cfg input =
242243
if input == "+ ENDFIELD" then
243244
case boardTransReason of
244-
Move time -> (ThinkingState gameData time f, ["THINKING"], return ())
245-
Winner winner -> (QuitState gameData (Just winner), [], return ())
246-
Draw -> (QuitState gameData (Nothing), [], return ())
245+
Move time -> (ThinkingState gameData time f , ["THINKING"] , return ())
246+
Winner winner -> (QuitState gameData (Just winner) f , [] , return ())
247+
Draw -> (QuitState gameData (Nothing) f , [] , return ())
247248
else unexpectedInput "end of board" input
248249
where
249250
f = listArray ((1,1), (x,y)) (concat $ transpose field)
@@ -263,13 +264,13 @@ parseInput (MoveState gameData) cfg input =
263264
else unexpectedInput "acceptance of our move" input
264265

265266

266-
parseInput (QuitState gameData winner) cfg input =
267+
parseInput (QuitState gameData winner field) cfg input =
267268
if input == "+ QUIT"
268-
then (EndState gameData winner, [], return ())
269+
then (EndState gameData winner field, [], return ())
269270
else unexpectedInput "quit" input
270271

271272

272-
parseInput (EndState _ _) cfg input = error ("No input line should ever be parsed in the end state, but we still got \""++input++"\"")
273+
parseInput (EndState _ _ _) cfg input = error ("No input line should ever be parsed in the end state, but we still got \""++input++"\"")
273274

274275

275276
parseInput (ErrorState _) cfg input = error ("No input line should ever be parsed in the error state, but we still got \""++input++"\"")
@@ -281,6 +282,6 @@ smCreate cfg = SmOk (QuallifiedState StartState cfg) []
281282

282283
smStep (QuallifiedState s c) input =
283284
case parseInput s c input of
284-
(ErrorState msg , _ , _ ) -> ( SmError msg , return () )
285-
(EndState gameData winner , _ , _ ) -> ( SmEnd gameData winner , return () )
286-
(s' , output , io) -> ( SmOk (QuallifiedState s' c) output , io )
285+
(ErrorState msg , _ , _ ) -> ( SmError msg , return () )
286+
(EndState gameData winner field , _ , _ ) -> ( SmEnd gameData winner field , return () )
287+
(s' , output , io) -> ( SmOk (QuallifiedState s' c) output , io )

‎Sm/Test.hs‎

Lines changed: 31 additions & 65 deletions
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,7 @@ import Test.Hspec
1010
import Sm.Internal
1111
import Data.Array
1212

13-
testAi gameData field time = ("test" , Nothing)
13+
testAi gameData field time = ("test" , return ())
1414
cfg = Cfg {gameId = "GameId", player = Just 1, ai = testAi}
1515

1616
testPlayers = array (0, 1) [
@@ -45,9 +45,7 @@ testStep result [] = result
4545
testStep result _ = result
4646

4747

48-
sm (x:xs) cfg = testStep s xs
49-
where
50-
(s, _) = smStep (smCreate cfg) x
48+
sm xs cfg = testStep (smCreate cfg) xs
5149

5250

5351
main :: IO ()
@@ -381,13 +379,13 @@ main = hspec $ do
381379
parseInput (
382380
FieldEndState gameData Draw 3 2
383381
([["7","11","13"],["2","3","5"]]) )
384-
cfg "+ ENDFIELD" `stateShouldBe` (QuitState gameData Nothing, [])
382+
cfg "+ ENDFIELD" `stateShouldBe` (QuitState gameData Nothing field, [])
385383

386384
it "Valid input (quit)" $ do
387385
parseInput (
388386
FieldEndState gameData (Winner 0) 3 2
389387
([["7","11","13"],["2","3","5"]]) )
390-
cfg "+ ENDFIELD" `stateShouldBe` (QuitState gameData (Just 0), [])
388+
cfg "+ ENDFIELD" `stateShouldBe` (QuitState gameData (Just 0) field, [])
391389

392390
it "Invalid input" $ do
393391
parseInput (FieldEndState gameData (Move 3000) 3 2 [["7","11","13"],["2","3","5"]]) cfg "+ asd" `stateShouldBe` (ErrorState "Protocoll error: Expected end of board, but got \"+ asd\"", [])
@@ -411,10 +409,10 @@ main = hspec $ do
411409

412410
describe "Parsing in player end state (+ QUIT)" $ do
413411
it "Valid input" $ do
414-
parseInput (QuitState gameData (Just 0)) cfg "+ QUIT" `stateShouldBe` (EndState gameData (Just 0), [])
412+
parseInput (QuitState gameData (Just 0) field) cfg "+ QUIT" `stateShouldBe` (EndState gameData (Just 0) field, [])
415413

416414
it "Invalid input" $ do
417-
parseInput (QuitState gameData (Just 0)) cfg "+ asd" `stateShouldBe` (ErrorState "Protocoll error: Expected quit, but got \"+ asd\"", [])
415+
parseInput (QuitState gameData (Just 0) field) cfg "+ asd" `stateShouldBe` (ErrorState "Protocoll error: Expected quit, but got \"+ asd\"", [])
418416

419417

420418

@@ -433,40 +431,20 @@ main = hspec $ do
433431
"+ WAIT", -- OKWAIT
434432
"+ WAIT", -- OKWAIT
435433
"+ MOVE 3000",
436-
"+ FIELD 12,12",
437-
"+ 12 * * * * * * * * * * * *",
438-
"+ 11 * * * * * * * * * * * *",
439-
"+ 10 * * * * * * * * * * * *",
440-
"+ 9 * * * * * * * * * * * *",
441-
"+ 8 * * * * * * * * * * * *",
442-
"+ 7 * * * * * W B * * * * *",
443-
"+ 6 * * * * * B W * * * * *",
444-
"+ 5 * * * * * * * * * * * *",
445-
"+ 4 * * * * * * * * * * * *",
446-
"+ 3 * * * * * * * * * * * *",
447-
"+ 2 * * * * * * * * * * * *",
448-
"+ 1 * * * * * * * * * * * *",
434+
"+ FIELD 3,2",
435+
"+ 2 2 3 5",
436+
"+ 1 7 11 13",
449437
"+ ENDFIELD", -- THINKING
450438
"+ OKTHINK", -- PLAY ...
451439
"+ MOVEOK",
452440
"+ WAIT", -- OKWAIT
453441
"+ WAIT", -- OKWAIT
454442
"+ GAMEOVER 0 Hans Peter",
455-
"+ FIELD 12,12",
456-
"+ 12 * * * * * * * * * * * *",
457-
"+ 11 * * * * * * * * * * * *",
458-
"+ 10 * * * * * * * * * * * *",
459-
"+ 9 * * * * * * * * * * * *",
460-
"+ 8 * * * * * * * * * * * *",
461-
"+ 7 * * * * * W B * * * * *",
462-
"+ 6 * * * * * B W * * * * *",
463-
"+ 5 * * * * * * * * * * * *",
464-
"+ 4 * * * * * * * * * * * *",
465-
"+ 3 * * * * * * * * * * * *",
466-
"+ 2 * * * * * * * * * * * *",
467-
"+ 1 * * * * * * * * * * * *",
443+
"+ FIELD 3,2",
444+
"+ 2 2 3 5",
445+
"+ 1 7 11 13",
468446
"+ ENDFIELD",
469-
"+ QUIT"] cfg `shouldBe` SmEnd gameData (Just 1)
447+
"+ QUIT"] cfg `shouldBe` SmEnd gameData (Just 1) field
470448

471449
it "Valid input (instant gameover)" $ do
472450
sm [
@@ -479,13 +457,11 @@ main = hspec $ do
479457
"+ 1 Horst 1",
480458
"+ ENDPLAYERS",
481459
"+ GAMEOVER 0 Hans Peter",
482-
"+ FIELD 4,4",
483-
"+ 4 a b c d",
484-
"+ 3 e f g h",
485-
"+ 2 i j k l",
486-
"+ 1 m n o p",
460+
"+ FIELD 3,2",
461+
"+ 2 2 3 5",
462+
"+ 1 7 11 13",
487463
"+ ENDFIELD",
488-
"+ QUIT"] cfg `shouldBe` SmEnd gameData (Just 1)
464+
"+ QUIT"] cfg `shouldBe` SmEnd gameData (Just 1) field
489465

490466
it "Invalid input (missing last field)" $ do
491467
sm [
@@ -498,10 +474,8 @@ main = hspec $ do
498474
"+ 1 Horst 1",
499475
"+ ENDPLAYERS",
500476
"+ GAMEOVER 0 Hans Peter",
501-
"+ FIELD 4,4",
502-
"+ 4 a b c d",
503-
"+ 3 e f g h",
504-
"+ 2 i j k l",
477+
"+ FIELD 3,2",
478+
"+ 2 2 3 5",
505479
"+ ENDFIELD",
506480
"+ QUIT"] cfg `shouldBe` SmError "Protocoll error: Expected board row, but got \"+ ENDFIELD\""
507481

@@ -516,12 +490,10 @@ main = hspec $ do
516490
"+ 1 Horst 1",
517491
"+ ENDPLAYERS",
518492
"+ GAMEOVER 0 Hans Peter",
519-
"+ FIELD 4,4",
520-
"+ 3 e f g h",
521-
"+ 2 i j k l",
522-
"+ 1 m n o p",
493+
"+ FIELD 3,2",
494+
"+ 1 7 11 13",
523495
"+ ENDFIELD",
524-
"+ QUIT"] cfg `shouldBe` SmError "Unexpected row number. Caussed by \"+ 3 e f g h\""
496+
"+ QUIT"] cfg `shouldBe` SmError "Unexpected row number. Caussed by \"+ 1 7 11 13\""
525497

526498
it "Invalid input (missing other players)" $ do
527499
sm [
@@ -533,11 +505,9 @@ main = hspec $ do
533505
"+ TOTAL 2",
534506
"+ ENDPLAYERS",
535507
"+ GAMEOVER 0 Hans Peter",
536-
"+ FIELD 4,4",
537-
"+ 4 a b c d",
538-
"+ 3 e f g h",
539-
"+ 2 i j k l",
540-
"+ 1 m n o p",
508+
"+ FIELD 3,2",
509+
"+ 2 2 3 5",
510+
"+ 1 7 11 13",
541511
"+ ENDFIELD",
542512
"+ QUIT"] cfg `shouldBe` SmError "Protocoll error: Expected oponent info, but got \"+ ENDPLAYERS\""
543513

@@ -553,11 +523,9 @@ main = hspec $ do
553523
"+ 1 Horst 1",
554524
"+ ENDPLAYERS",
555525
"+ GAMEOVER 0 Hans Peter",
556-
"+ FIELD 4,4",
557-
"+ 4 a b c d",
558-
"+ 3 e f g h",
559-
"+ 2 i j k l",
560-
"+ 1 m n o p",
526+
"+ FIELD 3,2",
527+
"+ 2 2 3 5",
528+
"+ 1 7 11 13",
561529
"+ ENDFIELD",
562530
"+ QUIT"] cfg `shouldBe` SmError "Player already defined. Caussed by \"+ 1 Horst 1\""
563531

@@ -573,10 +541,8 @@ main = hspec $ do
573541
"+ 2 Player 1 1",
574542
"+ ENDPLAYERS",
575543
"+ GAMEOVER 0 Hans Peter",
576-
"+ FIELD 4,4",
577-
"+ 4 a b c d",
578-
"+ 3 e f g h",
579-
"+ 2 i j k l",
580-
"+ 1 m n o p",
544+
"+ FIELD 3,2",
545+
"+ 2 2 3 5",
546+
"+ 1 7 11 13",
581547
"+ ENDFIELD",
582548
"+ QUIT"] cfg `shouldBe` SmError "Protocoll error: Expected end of oponent list, but got \"+ 2 Player 1 1\""

‎funthello.hs‎

Lines changed: 47 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -6,31 +6,34 @@
66

77
module Main where
88

9-
import Sm as S
10-
import Net
119
import AI as AI
12-
import Network.Socket as NS
13-
import System.IO
1410
import Conf as C
1511
import Conf.Args as CA
1612
import Conf.Gui as CG
13+
import Control.Concurrent
14+
import Control.Concurrent.MVar
1715
import Data.String.Utils
18-
import System.Environment
19-
import Util
16+
import Data.Version (showVersion)
2017
import GameGUI as GG
21-
import Control.Concurrent.MVar
22-
import Control.Concurrent
18+
import Graphics.UI.Gtk
19+
import Graphics.UI.Gtk.Windows.MessageDialog
20+
import Net
21+
import Network.Socket as NS
2322
import PP as PP
2423
import Paths_funthello (version)
25-
import Data.Version (showVersion)
24+
import Sm as S
2625
import System.Console.ANSI
26+
import System.Environment
2727
import System.Exit
28+
import System.IO
29+
import Util
30+
2831

2932
-- The name speaks for it self. Here you are looking at the beautiful main-l↺↺p.
30-
(↺) :: Handle -> StepResult -> IO (Either String (GameData, Maybe Int))
31-
(↺) hdl (SmEnd gameData winner) = return $ Right (gameData, winner)
32-
(↺) hdl (SmError msg) = return $ Left msg
33-
(↺) hdl (SmOk s o) = do
33+
(↺) :: Handle -> StepResult -> IO (Either String (GameData, Maybe Int, Board))
34+
(↺) hdl (SmEnd gameData winner board) = return $ Right (gameData, winner, board)
35+
(↺) hdl (SmError msg) = return $ Left msg
36+
(↺) hdl (SmOk s o) = do
3437
i <- converse hdl o
3538
let (s', io) = smStep s i
3639
io
@@ -54,7 +57,7 @@ play gameId' player' ai socket = do
5457
return res
5558

5659

57-
finalizeCfg :: IntermediateCfg -> IO (Either String (String, Maybe Int, Socket))
60+
finalizeCfg :: IntermediateCfg -> IO (Either String (String, Maybe Int, NS.Socket))
5861
finalizeCfg IntermediateCfg { C.host = Nothing } = return $ Left "Missing hostname"
5962
finalizeCfg IntermediateCfg { C.port = Nothing } = return $ Left "Missing port"
6063
finalizeCfg IntermediateCfg { C.gameId = Nothing } = return $ Left "Missing game ID"
@@ -71,7 +74,7 @@ finalizeCfg IntermediateCfg
7174
Left msg -> return $ Left msg
7275

7376

74-
getGuiCfg :: Gui -> String -> IO (String, Maybe Int, Socket)
77+
getGuiCfg :: Gui -> String -> IO (String, Maybe Int, NS.Socket)
7578
getGuiCfg gui msg = do
7679
-- Get config from GUI
7780
cfg <- CG.getCfg gui msg
@@ -101,8 +104,35 @@ guiMode cfg = do
101104

102105
res <- play gameId' player' ai socket
103106
case res of
104-
Right _ -> return True
105-
Left _ -> return False
107+
Right (gameData, winner, board) -> do
108+
tryPutMVar mVarField board
109+
tryPutMVar mVarGameData gameData
110+
PP.prettyPrint board
111+
112+
window <- messageDialogNew
113+
Nothing
114+
[]
115+
MessageError
116+
ButtonsOk
117+
"Game over"
118+
119+
dialogRun window
120+
widgetDestroy window
121+
122+
return True
123+
124+
Left msg -> do
125+
window <- messageDialogNew
126+
Nothing
127+
[]
128+
MessageError
129+
ButtonsOk
130+
msg
131+
132+
dialogRun window
133+
widgetDestroy window
134+
135+
return False
106136

107137

108138
consoleMode cfg = do

0 commit comments

Comments
 (0)