1votos

Juego del Go: Reglas en Haskell

por josejuan hace 3 años

Dado lo sencillo del tema se implementa con la maquinaria típica de un módulo representando un sencillo DSL dentro de una mónada. No se implementa el conteo final porque hay varios y todos ellos bastante ambiguos en la interpretación.

Implementar las reglas asociadas al juego: colocación de piedras, retirada de las capturadas y obtención de la puntuación.

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
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
{- 
    Se implementa como un sencillo DSL con las acciones 
 
        pass          el jugador actual pasa 
        set           el jugador actual pone ficha 
        get           mirar una celda 
        player        ver a quien le toca mover 
        stage         ver como anda el juego: Jugando, HanPasado, HaTerminado 
        render        dibujar el tablero actual 
        ioRender      dibujar el tablero actual directamente a stdout 
 
    Una simulación de un Ko (no permitido) sería 
 
        > checkKo 
        Black move to (3,1) 
        . . @ . . 
        . . . . . 
        . . . . . 
        . . . . . 
        . . . . . 
        White move to (2,1) 
        . O @ . . 
        . . . . . 
        . . . . . 
        . . . . . 
        . . . . . 
        Black move to (2,2) 
        . O @ . . 
        . @ . . . 
        . . . . . 
        . . . . . 
        . . . . . 
        White move to (1,2) 
        . O @ . . 
        O @ . . . 
        . . . . . 
        . . . . . 
        . . . . . 
        Black move to (4,2) 
        . O @ . . 
        O @ . @ . 
        . . . . . 
        . . . . . 
        . . . . . 
        White move to (2,3) 
        . O @ . . 
        O @ . @ . 
        . O . . . 
        . . . . . 
        . . . . . 
        Black move to (3,3) 
        . O @ . . 
        O @ . @ . 
        . O @ . . 
        . . . . . 
        . . . . . 
        White move to (3,2) 
        . O @ . . 
        O . O @ . 
        . O @ . . 
        . . . . . 
        . . . . . 
        Cannot move to (2,2) (cell in Ko) 
        . O @ . . 
        O . O @ . 
        . O @ . . 
        . . . . . 
        . . . . . 
 
-} 
--==== Main.hs ============================================================================== 
{-# LANGUAGE ConstraintKinds #-} 
{-# LANGUAGE FlexibleContexts #-} 
{-# LANGUAGE LambdaCase #-} 
module Main where 
 
import Go 
import System.Environment 
import Control.Monad 
import Data.Array.MArray 
import qualified Data.Array.IO as IOA 
 
-- one possible instance using IO for `tty` and `Array` (can be used any others) 
ioGo :: MArray IOA.IOArray Cell IO ⇒ Int → Go IOA.IOArray IO r → IO r 
ioGo n = runGo n putStrLn 
 
-- simple simulate playing for testing purposes 
simulate = ioGo 5 ∘ ↱_step 
  where step c = set c ↪ either (io ∘ putStrLn) (η ∘ const ()) 
               » ioRender 
 
-- can check result for multiple example games 
checkPassPassGameOver = ioGo 5 $ do 
  pass 
  pass 
  set (1, 1) 
  ioRender 
 
checkCannotSuicide    = simulate [(2, 1), (5, 5), (1, 2), (1, 1)] 
checkLooksLikeSuicide = simulate [(3, 1), (2, 1), (2, 2), (1, 2), (4, 2), (2, 3), (3, 3), (3, 2)] 
checkKo               = simulate [(3, 1), (2, 1), (2, 2), (1, 2), (4, 2), (2, 3), (3, 3), (3, 2), (2, 2)] 
 
-- one simple Go game user interface 
playGo :: Int → IO () 
playGo n = void $ ioGo n play 
  where play = do 
          render ↪ ↱_(io ∘ putStrLn) 
          p ← player 
          io $ putStr $ "Player `" ⧺ show p ⧺ "` move: " 
          io readLn ↪ (λcase 
            (0, 0) → pass 
            c      → set c) ↪ either (io ∘ putStrLn ∘ ("Illegal: " ⧺)) (η ∘ const ()) 
          stage ↪ flip when play ∘ (GameOver ≢) 
 
main :: IO () 
main = getArgs ↪ playGo ∘ read ∘ head 
 
 
 
--==== Go.hs ============================================================================== 
 
 
{-# LANGUAGE GeneralizedNewtypeDeriving #-} 
{-# LANGUAGE ConstraintKinds #-} 
{-# LANGUAGE FlexibleContexts #-} 
{-# LANGUAGE LambdaCase #-} 
module Go ( 
  Player (…)    -- Black & White 
, Coord         -- Into checkboard 
, Cell          -- Empty or player stone 
, Stage (…)     -- Game stage 
, Go            -- Go monad stack 
, runGo         -- Start one Go game 
 
-- DSL commands 
, pass          -- Player pass their turn 
, set           -- Player move stone 
, get           -- Read one coordinate state 
, player        -- Current player 
, stage         -- Current game stage 
, render        -- Simple game rendering 
, ioRender      -- To IO 
 
, io            -- for convenience 
) where 
 
import Data.Array.MArray 
import Control.Monad 
import Control.Monad.Trans 
import Control.Monad.Trans.Except 
import Control.Monad.Trans.Reader 
import qualified Control.Monad.Trans.State as S 
import Data.List (intersperse) 
 
data Player = Black | White deriving (Eq, Show) 
 
type Cell = 𝐌 Player 
 
type Coord = (Int, Int) 
 
data Stage = Playing | OnePass | GameOver deriving (Eq, Show) 
 
data State = State { _player :: Player 
                   , _stage  :: Stage 
                   , _ko     :: [Coord] } 
 
data Config a m = Config { _tty   :: 𝐒 → m () 
                         , _board :: a Coord Cell } 
 
newtype Go a m r = Go { runGo' :: ReaderT (Config a m) (S.StateT State m) r } 
                        deriving (Functor, Applicative, Monad, MonadIO) 
 
type EGo a m = ExceptT 𝐒 (Go a m) 
 
type MGo a m = MArray a Cell m 
 
runGo :: MGo a m ⇒ Int → (𝐒 → m ()) → Go a m r → m r 
runGo n tty k = newArray ((1, 1), (n, n)) 𝑁 ↪ flip S.evalStateT (State Black Playing []) 
                                            ∘ runReaderT (runGo' k) ∘ Config tty 
 
assert :: MGo a m ⇒ 𝐒 → EGo a m 𝔹 → EGo a m () 
assert message condition = condition ↪ λp → unless p (throwE message) 
 
board :: MGo a m ⇒ (a Coord Cell → m r) → EGo a m r 
board k = lift $ Go $ asks _board ↪ lift ∘ lift ∘ k 
 
tty :: MGo a m ⇒ 𝐒 → EGo a m () 
tty s = lift $ Go $ asks _tty ↪ λf → (lift ∘ lift ∘ f) s 
 
ret :: MGo a m ⇒ EGo a m r → Go a m r 
ret k = runExceptT k ↪ either (error ∘ ("BUG: unexpected exception, " ⧺)) η 
 
size' :: MGo a m ⇒ EGo a m Int 
size' = board $ ((fst ∘ snd) ↥) ∘ getBounds 
 
size :: MGo a m ⇒ Go a m Int 
size = ret size' 
 
inside :: MGo a m ⇒ Coord → EGo a m 𝔹 
inside (x, y) = (λs → 1 ≤ x ∧ x ≤ s ∧ 1 ≤ y ∧ y ≤ s) ↥ size' 
 
get' :: MGo a m ⇒ Coord → EGo a m Cell 
get' c = do assert "Only can access cells inside board" (inside c) 
            board (`readArray` c) 
 
get :: MGo a m ⇒ Coord → Go a m (𝐄 𝐒 Cell) 
get = runExceptT ∘ get' 
 
stateR :: MGo a m ⇒ EGo a m State 
stateR = lift $ Go $ lift S.get 
 
stateW :: MGo a m ⇒ (State → State) → EGo a m () 
stateW f = lift $ Go $ lift $ S.modify f 
 
player' :: MGo a m ⇒ EGo a m Player 
player' = _player ↥ stateR 
 
player :: MGo a m ⇒ Go a m Player 
player = ret player' 
 
stage :: MGo a m ⇒ Go a m Stage 
stage = ret (_stage ↥ stateR) 
 
stageW :: MGo a m ⇒ Stage → EGo a m () 
stageW g = stateW $ λs → s { _stage = g } 
 
nextPlayer :: MGo a m ⇒ EGo a m () 
nextPlayer = player' ↪ λp → stateW $ λs → s { _player = case p of { Black → White; White → Black } } 
 
inGame :: MGo a m ⇒ EGo a m () 
inGame = assert "The game is over!" ((GameOver ≢) ↥ (_stage ↥ stateR)) 
 
pass :: MGo a m ⇒ Go a m (𝐄 𝐒 ()) 
pass = runExceptT $ do 
  inGame 
  player' ↪ λp → tty $ "Player `" ⧺ show p ⧺ "` pass" 
  (_stage ↥ stateR) ↪ λcase 
    Playing → nextPlayer » stageW OnePass 
    OnePass → tty "Game over!" » stageW GameOver 
    _       → error "BUG: unexpected `stage` value" 
 
put :: MGo a m ⇒ Cell → Coord → EGo a m () 
put v c = board $ λa → writeArray a c v 
 
set :: MGo a m ⇒ Coord → Go a m (𝐄 𝐒 ()) 
set c = runExceptT $ do 
  inGame 
  assert ("Cannot move to " ⧺ show c ⧺ " (cell in Ko)") ((¬ ∘ elem c) ∘ _ko ↥ stateR) 
  assert ("Cell " ⧺ show c ⧺ " is not empty!") ((𝑁 ≡) ↥ get' c) 
  p ← player' 
  nextPlayer 
  p' ← player' 
  put (𝐽 p) c 
  tty $ show p ⧺ " move to " ⧺ show c 
  es ← ((map fst ∘ filter ((𝐽 p' ≡) ∘ snd)) ↥ board getAssocs) ↪ filterM (dead p') 
  stateW $ λs → s { _ko = es } 
  ↰_es (put 𝑁) 
  dead p c ↪ flip when (do 
          put 𝑁 c 
          ↰_es (put (𝐽 p')) 
          throwE $ "Cannot move to " ⧺ show c ⧺ " (cannot suicide)") 
 
dead :: MGo a m ⇒ Player → Coord → EGo a m 𝔹 
dead p c = fst ↥ open [] c 
  where open xs c@(x, y) = foldM check (𝑇,c:xs) [(x+dx,y+dy) | (dx,dy) ← [(1,0),(0,1),(-1,0),(0,-1)]] 
        check (𝐹,  _) _ = η (𝐹, []) 
        check (_, xs) c = if c ∈ xs then η (𝑇, xs) 
                            else inside c ↪ λcase 
                              𝐹 → η (𝑇, c:xs) 
                              𝑇 → get' c ↪ λcase 
                                    𝐽 p' → if p' ≡ p then open xs c else η (𝑇, c:xs) 
                                    𝑁    → η (𝐹, []) 
 
render :: MGo a m ⇒ Go a m [𝐒] 
render = ret $ do 
  s ← size' 
  let toChar v = c where 𝐽 c = lookup v $ zip [𝑁, 𝐽 Black, 𝐽 White] ".@O" 
  ↰[1…s] $ λi → intersperse ' ' ↥ (↰[1…s] $ λj → toChar ↥ get' (j, i)) 
 
ioRender :: (MonadIO m, MGo a m) ⇒ Go a m () 
ioRender = render ↪ ↱_(io ∘ putStrLn) 

Comenta la solución

Tienes que identificarte para poder publicar tu comentario.