-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathEmulator.hs
141 lines (116 loc) · 4.69 KB
/
Emulator.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
import System.Environment (getArgs)
import System.IO
import System.Process
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.Error
import Data.Tuple (swap)
import Data.Maybe
import LTG
runL :: WriterT [String] (State LTG) a -> StateT LTG IO a
runL ma = do
((a, msgs), ltg) <- liftM (runState (runWriterT ma)) get
put ltg
mapM_ (liftIO . putStrLn) msgs
return a
-- xx: fix evil liftIO
oneStep :: Handle -> Maybe Handle -> StateT LTG IO ()
oneStep hIn mOut = do
playerNo <- liftM ltgPlayer get
liftIO . putStrLn $ "*** player " ++ show playerNo ++ "'s turn, with slots:"
runL $ printHBoard Prop
liftIO . putStrLn $ "(slots {10000,I} are omitted)"
runL zombieScan
order <- getOrder
-- xx: too complex? any simpler way?
(card, slot) <- case order of
LeftApp -> liftM2 (,) getCard getSlot
RightApp -> liftM swap $ liftM2 (,) getSlot getCard
(liftIO . putStrLn) $ showChoice playerNo order card slot
case mOut of
Just h -> do
liftIO . hPutStr h $ showChoice4Bot order card slot
liftIO $ hFlush h
runL $ applyCard order card slot
where getOrder = do
(liftIO . putStrLn) "(1) apply card to slot, or (2) apply slot to card?"
liftM (intToOrder . read) (liftIO $ hGetLine hIn)
getCard = do
(liftIO . putStrLn) "card name?"
liftM cLookup (liftIO $ hGetLine hIn)
getSlot = do
(liftIO . putStrLn) "slot no?"
liftM read (liftIO $ hGetLine hIn)
onOrder order a b = case order of LeftApp -> a; RightApp -> b
showChoice pn order card slot =
let p1 = ["player ", show pn, " applied "]
x = onOrder order id swap ("card " ++ show card, "slot " ++ show slot)
in concat $ p1 ++ [fst x, " to ", snd x]
showChoice4Bot order card slot =
let p1 = show $ orderToInt order
p2 = onOrder order id reverse [show card, show slot]
in unlines (p1:p2)
printTurn :: StateT LTG IO ()
printTurn = get >>= \ltg -> liftIO $ putStrLn $ "###### turn " ++ show(ltgTurn ltg)
orderToInt o = case o of LeftApp -> 1 ; RightApp -> 2
intToOrder i = case i of 1 -> LeftApp ; 2 -> RightApp
simpleStep :: StateT LTG IO ()
simpleStep = printTurn >> oneStep stdin Nothing
runOnly :: IO LTG
runOnly = execStateT (forever simpleStep) defaultLTG
runAlt :: IO LTG
runAlt = execStateT (forever helper) defaultLTG
where helper = do
printTurn
simpleStep ; runL swapPlayers
simpleStep ; runL swapPlayers
runL incrementTurn
runMatch :: [String] -> IO LTG
runMatch [prog0, prog1] = do
(Just in0, Just out0, _, _) <- cProc prog0 "0"
(Just in1, Just out1, _, _) <- cProc prog1 "1"
execStateT (helper in0 out0 in1 out1) defaultLTG
where
cProc prog i = createProcess (proc prog [i]) {std_in = CreatePipe,
std_out = CreatePipe}
-- xx: remove staircasing. Cont? Either?
helper :: Handle -> Handle -> Handle -> Handle -> StateT LTG IO LTG
helper in0 out0 in1 out1 = do
printTurn
oneStep out0 (Just in1)
eMsg <- checkEnd
runL swapPlayers
case eMsg of
Just m -> (liftIO . putStrLn) m >> get
Nothing -> do
oneStep out1 (Just in0)
eMsg <- checkEnd
runL swapPlayers
case eMsg of
Just m -> (liftIO . putStrLn) m >> get
Nothing -> runL incrementTurn >> helper in0 out0 in1 out1
checkEnd = do
(l0, l1) <- runL countAlive
turn <- liftM ltgTurn get
playerI <- liftM ltgPlayer get
let msg = compose l0 l1 turn
if (l0 == 0 || l1 == 0) || (turn == 100000 && playerI == 1)
then return (Just msg)
else return Nothing
where compose l0 l1 turn =
let msg2 = " by " ++ show l0 ++ ":" ++ show l1 ++
" after turn " ++ show turn
in case (l0 == l1, l0 > l1) of
(True, _) -> "!! draw" ++ msg2
(_, True) -> "!! player 0 wins" ++ msg2
(_, _ ) -> "!! player 1 wins" ++ msg2
--printActions h order card slot = do
main = do
args <- getArgs
when (null args) $ fail "Usage: ./xx only|alt|match [prog1] [prog2]"
case head args of
"only" -> runOnly
"alt" -> runAlt
"match" -> runMatch $ tail args
_ -> fail "Unknown command"
return 0