Commit | Line | Data |
---|---|---|
7eeb782e AT |
1 | #!/usr/bin/perl -w |
2 | ||
3 | # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # | |
4 | # This program is distributed with GNU Go, a Go program. # | |
5 | # # | |
6 | # Write gnugo@gnu.org or see http://www.gnu.org/software/gnugo/ # | |
7 | # for more information. # | |
8 | # # | |
9 | # Copyright 1999, 2000, 2001 by the Free Software Foundation. # | |
10 | # # | |
11 | # This program is free software; you can redistribute it and/or # | |
12 | # modify it under the terms of the GNU General Public License # | |
13 | # as published by the Free Software Foundation - version 3, # | |
14 | # or (at your option) any later version. # | |
15 | # # | |
16 | # This program is distributed in the hope that it will be # | |
17 | # useful, but WITHOUT ANY WARRANTY; without even the implied # | |
18 | # warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR # | |
19 | # PURPOSE. See the GNU General Public License in file COPYING # | |
20 | # for more details. # | |
21 | # # | |
22 | # You should have received a copy of the GNU General Public # | |
23 | # License along with this program; if not, write to the Free # | |
24 | # Software Foundation, Inc., 51 Franklin Street, Fifth Floor, # | |
25 | # Boston, MA 02111, USA. # | |
26 | # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # | |
27 | ||
28 | use Tk; | |
29 | use ttgo; | |
30 | use FileHandle; | |
31 | use IPC::Open2; | |
32 | ||
33 | # use strict; | |
34 | ||
35 | $| = 1; | |
36 | ||
37 | my $boardsize = 11; | |
38 | ||
39 | my $autoplay = 1; | |
40 | ||
41 | my @program = (); | |
42 | my @cur_id = (); | |
43 | ||
44 | ||
45 | my $Aprg_in = new FileHandle; | |
46 | my $Aprg_out = new FileHandle; | |
47 | $program[0] = 'gnugo --mode gtp --quiet'; | |
48 | $cur_id[0] = 1; # starting id | |
49 | ||
50 | ||
51 | my $Bprg_in = new FileHandle; | |
52 | my $Bprg_out = new FileHandle; | |
53 | $program[1] = 'gnugo --mode gtp --score aftermath --capture-all-dead --chinese-rules --quiet'; | |
54 | $cur_id[1] = 1; # starting id | |
55 | ||
56 | ||
57 | my $state = 'start'; # first initialization state | |
58 | ||
59 | open2($Aprg_out, $Aprg_in, $program[0]); | |
60 | $flags = | |
61 | fcntl( $Aprg_out, F_GETFL, 0) | |
62 | or die "Error with fcntl\n"; | |
63 | $flags = | |
64 | fcntl( $Aprg_out, F_SETFL, $flags | O_NOBLOCK) | |
65 | or die "Error with fcntl\n"; | |
66 | ||
67 | ||
68 | open2($Bprg_out, $Bprg_in, $program[1]); | |
69 | $flags = | |
70 | fcntl( $Bprg_out, F_GETFL, 0) | |
71 | or die "Error with fcntl\n"; | |
72 | $flags = | |
73 | fcntl( $Bprg_out, F_SETFL, $flags | O_NOBLOCK) | |
74 | or die "Error with fcntl\n"; | |
75 | ||
76 | ||
77 | ||
78 | my $flags = 0; | |
79 | my $consecutive_passes = 0; | |
80 | my $ctm = 'B'; # who's turn to move? | |
81 | my $cc = 'W'; # computers color | |
82 | ||
83 | ||
84 | my $msgstr = ''; | |
85 | ||
86 | ||
87 | # This handles up to 25 size boards | |
88 | # ================================= | |
89 | my @letter = qw ( A B C D E F G H J K L M N O P Q R S T U V W X Y Z ); | |
90 | ||
91 | ||
92 | # color definitions | |
93 | # ================= | |
94 | my %cstr = ( 'b' => '#604040', 'B' => '#604040', | |
95 | 'w' => '#ffffff', 'W' => '#ffffff' | |
96 | ); | |
97 | ||
98 | my $bkc = '#eeeeee'; | |
99 | ||
100 | ||
101 | ||
102 | ||
103 | # get command line arguments start with defaults | |
104 | # ============================================== | |
105 | my $sqwh = 26; | |
106 | my $sqwh2 = 12; # 1/2 of sqwh | |
107 | ||
108 | ||
109 | ||
110 | ||
111 | my %toix = (); | |
112 | foreach my $ix (0 .. $#letter) { | |
113 | $toix{ $letter[$ix] } = $ix; | |
114 | } | |
115 | ||
116 | ||
117 | ||
118 | ||
119 | # initialize graphics and such | |
120 | # ---------------------------- | |
121 | my $top = MainWindow->new; | |
122 | $top->title("ptkgo.pl"); | |
123 | $top->resizable(0,0); | |
124 | my $geox = ($boardsize-1) * $sqwh + 80; | |
125 | my $geoy = ($boardsize-1) * $sqwh + 140; | |
126 | ||
127 | $top->geometry( $geox . 'x' . $geoy ); | |
128 | $top->configure( background => $bkc ); | |
129 | ||
130 | ||
131 | ||
132 | # build the background go board | |
133 | ||
134 | my $backing = $top->Canvas( | |
135 | -width => $sqwh * $boardsize + 80, | |
136 | -height => $sqwh * $boardsize + 80, | |
137 | -background => $bkc | |
138 | )->place( | |
139 | -x => 0, | |
140 | -y => 0, | |
141 | ); | |
142 | ||
143 | ||
144 | foreach my $x ( 0 .. $boardsize-1 ) { | |
145 | ||
146 | $backing->createText( 40 + $x * $sqwh, | |
147 | 25, | |
148 | -text => $letter[$x], | |
149 | -fill => 'black', | |
150 | -justify => 'center', | |
151 | -font => '-b&h-*-bold-r-*-*-11-*-*-*-*-*-*-*' | |
152 | ); | |
153 | ||
154 | $backing->createText( 40 + $x * $sqwh, | |
155 | ($boardsize-1)*$sqwh + 55, | |
156 | -text => $letter[$x], | |
157 | -fill => 'black', | |
158 | -justify => 'center', | |
159 | -font => '-b&h-*-bold-r-*-*-11-*-*-*-*-*-*-*' | |
160 | ); | |
161 | ||
162 | ||
163 | $backing->createLine( $x*$sqwh + 40, | |
164 | 40, | |
165 | $x*$sqwh+40, | |
166 | ($boardsize-1)*$sqwh + 40, | |
167 | -fill => 'black', | |
168 | -width => 1 ); | |
169 | } | |
170 | ||
171 | ||
172 | ||
173 | ||
174 | foreach my $y ( 0 .. $boardsize-1 ) { | |
175 | ||
176 | $backing->createText( 25, | |
177 | $y * $sqwh + 40, | |
178 | -text => $boardsize - $y, | |
179 | -fill => 'black', | |
180 | -justify => 'center', | |
181 | -font => '-b&h-*-bold-r-*-*-11-*-*-*-*-*-*-*' | |
182 | ); | |
183 | ||
184 | $backing->createText( ($boardsize-1) * $sqwh + 55, | |
185 | $y * $sqwh + 40, | |
186 | -text => $boardsize - $y, | |
187 | -fill => 'black', | |
188 | -justify => 'center', | |
189 | -font => '-b&h-*-bold-r-*-*-11-*-*-*-*-*-*-*' | |
190 | ); | |
191 | ||
192 | ||
193 | $backing->createLine( 40, | |
194 | $y*$sqwh+40, | |
195 | ($boardsize-1)*$sqwh+40, | |
196 | $y*$sqwh + 40, | |
197 | -fill => 'black', | |
198 | -width => 1 ); | |
199 | } | |
200 | ||
201 | ||
202 | ttNewGame($boardsize); | |
203 | ttShowBoard(); | |
204 | ||
205 | ||
206 | ||
207 | ||
208 | # pass button | |
209 | # ----------- | |
210 | my $pass = $top->Button( | |
211 | -text => 'Pass', | |
212 | -command => sub { }, | |
213 | -width => 2, | |
214 | -height => 1, | |
215 | -font => '5x7', | |
216 | -borderwidth => 1, | |
217 | -highlightcolor => 'black', | |
218 | -highlightthickness => 1, | |
219 | -highlightbackground => 'black', | |
220 | -relief => 'flat' | |
221 | )->place( | |
222 | -x => 40 + 0 * 40, | |
223 | -y => ($boardsize + 2) * $sqwh, | |
224 | ); | |
225 | ||
226 | ||
227 | ||
228 | # undo button | |
229 | # ----------- | |
230 | my $undo = $top->Button( | |
231 | -text => 'Undo', | |
232 | -command => sub { }, | |
233 | -width => 2, | |
234 | -height => 1, | |
235 | -font => '5x7', | |
236 | -borderwidth => 1, | |
237 | -highlightcolor => 'black', | |
238 | -highlightthickness => 1, | |
239 | -highlightbackground => 'black', | |
240 | -relief => 'flat' | |
241 | )->place( | |
242 | -x => 40 + 1 * 40, | |
243 | -y => ($boardsize + 2) * $sqwh, | |
244 | ); | |
245 | ||
246 | ||
247 | ||
248 | ||
249 | $top->bind( "<Button-1>", [ \&drop_stone, Ev('x'), Ev('y') ] ); | |
250 | ||
251 | ||
252 | $top->fileevent( $Aprg_out, 'readable', [ \&getmessage, 0] ); | |
253 | $top->fileevent( $Bprg_out, 'readable', [ \&getmessage, 1] ); | |
254 | ||
255 | ||
256 | $state = 'start'; # first initialization state | |
257 | control(); | |
258 | ||
259 | ||
260 | MainLoop(); | |
261 | ||
262 | ||
263 | ||
264 | ||
265 | my $tmpstr; | |
266 | ||
267 | sub getmessage | |
268 | { | |
269 | my ($pi) = @_; | |
270 | ||
271 | ||
272 | if ($pi == 0) { | |
273 | $tmpstr = <$Aprg_out>; | |
274 | } else { | |
275 | $tmpstr = <$Bprg_out>; | |
276 | } | |
277 | ||
278 | if (defined $tmpstr) { | |
279 | chomp($tmpstr); | |
280 | ||
281 | if ($tmpstr eq '') { # eat the line, update id | |
282 | $cur_id[$pi] ++; | |
283 | control( $msgstr ); | |
284 | } else { | |
285 | $msgstr = $tmpstr; | |
286 | print "Came up with $msgstr\n"; | |
287 | } | |
288 | ||
289 | } | |
290 | } | |
291 | ||
292 | ||
293 | ||
294 | ||
295 | sub xputstone | |
296 | { | |
297 | my ($color, $x, $y) = @_; | |
298 | ||
299 | ||
300 | my $xx = $x * $sqwh + 40; | |
301 | my $yy = $y * $sqwh + 40; | |
302 | ||
303 | $backing->createOval( $xx-$sqwh2, $yy-$sqwh2, | |
304 | $xx+$sqwh2, $yy+$sqwh2, | |
305 | -tags => $x . '_' . $y, | |
306 | -outline => 'black', | |
307 | -fill => $cstr{$color} ); | |
308 | } | |
309 | ||
310 | ||
311 | # This routine clears all empty squares, it does | |
312 | # not actually draw board | |
313 | sub xfixboard | |
314 | { | |
315 | my @vis = ttGetBoard(); | |
316 | my $st; | |
317 | ||
318 | foreach my $y (0 .. $boardsize -1) { | |
319 | foreach my $x (0 .. $boardsize -1) { | |
320 | ||
321 | $st = shift @vis; | |
322 | ||
323 | if ($st eq '+') { | |
324 | $backing->delete( $x . '_' . $y ); | |
325 | } | |
326 | } | |
327 | } | |
328 | } | |
329 | ||
330 | ||
331 | sub pass | |
332 | { | |
333 | ||
334 | ||
335 | } | |
336 | ||
337 | ||
338 | sub drop_stone | |
339 | { | |
340 | my ( $w, $x, $y) = @_; | |
341 | ||
342 | $x = -1 + int(($x-3) / 26); | |
343 | $y = -1 + int(($y-3) / 26); | |
344 | ||
345 | if ($x < 0) { return 1; } | |
346 | if ($y < 0) { return 1; } | |
347 | if ($x >= $boardsize) { return 1; } | |
348 | if ($y >= $boardsize) { return 1; } | |
349 | ||
350 | ||
351 | my $gn = $letter[$x] . ($boardsize - $y); | |
352 | ||
353 | if ( !ttPlaceStone( $ctm, $gn ) ) { | |
354 | xputstone( $ctm, $x, $y ); | |
355 | xfixboard(); | |
356 | ttShowBoard(); | |
357 | } else { return 1; } | |
358 | ||
359 | ||
360 | if ($ctm eq 'W') { | |
361 | $state = 'white'; | |
362 | } else { | |
363 | $state = 'black'; | |
364 | } | |
365 | ||
366 | swap_ctm(); | |
367 | ||
368 | } | |
369 | ||
370 | ||
371 | ||
372 | ||
373 | # This routine is called after each message is recieved | |
374 | # ----------------------------------------------------- | |
375 | ||
376 | # How the control loop works: | |
377 | # | |
378 | # the '$state' variable determines where to jump in. | |
379 | # control is called when a program responds to a message | |
380 | ||
381 | sub control | |
382 | { | |
383 | my ($msg) = @_; | |
384 | ||
385 | ||
386 | # send boardsize 0 (prgA) | |
387 | # send boardsize 1 (prgB) | |
388 | # xxx | |
389 | # send genmove_black (prgA); | |
390 | # send black (prgB); | |
391 | # send genmove_white (prgB); | |
392 | # white (prgA) | |
393 | # goto xxx | |
394 | ||
395 | ||
396 | if (defined $msg) { | |
397 | print STDERR "state/msg = $state $msg\n"; | |
398 | } else { print STDERR "state/msg = $state NULL\n"; } | |
399 | ||
400 | if ($state eq 'start') { | |
401 | snd( 0, "$cur_id[0] boardsize $boardsize" ); | |
402 | $state = 'startb'; | |
403 | return; | |
404 | } | |
405 | ||
406 | if ($state eq 'startb') { | |
407 | snd( 1, "$cur_id[1] boardsize $boardsize" ); | |
408 | $state = 'genmove_black'; | |
409 | return; | |
410 | } | |
411 | ||
412 | if ( $state eq 'genmove_black' ) { | |
413 | snd( 0, "$cur_id[0] genmove_black" ); | |
414 | $state = 'black'; | |
415 | return; | |
416 | } | |
417 | ||
418 | if ( $state eq 'black' ) { | |
419 | my $y; | |
420 | my $x; | |
421 | my $gn; | |
422 | ||
423 | print "msg ---> $msg\n"; | |
424 | ||
425 | $msg =~ /^=\d+\s+(.)(.*)/; # parse out move components | |
426 | ||
427 | if ( $msg =~ /PASS/ ) { | |
428 | $consecutive_passes++; | |
429 | $gn = 'PASS'; | |
430 | } else { | |
431 | $consecutive_passes = 0; | |
432 | $y = $boardsize - $2; | |
433 | $x = $toix{$1}; | |
434 | $gn = $letter[$x] . ($boardsize - $y); | |
435 | } | |
436 | ||
437 | ||
438 | # show blacks move to the interface | |
439 | # --------------------------------- | |
440 | if ( !ttPlaceStone( $ctm, $gn ) ) { | |
441 | xputstone( $ctm, $x, $y ) if $gn ne 'PASS'; | |
442 | xfixboard(); | |
443 | ttShowBoard(); | |
444 | swap_ctm(); | |
445 | } else { return 1; } | |
446 | ||
447 | # send the move along to WHITE | |
448 | # ---------------------------- | |
449 | snd( 1, "$cur_id[1] black $gn" ); | |
450 | $state = 'genmove_white'; | |
451 | ||
452 | if ($consecutive_passes == 2) { | |
453 | $state = 'gameover'; | |
454 | } | |
455 | ||
456 | return; | |
457 | } | |
458 | ||
459 | ||
460 | if ( $state eq 'genmove_white' ) { | |
461 | snd( 1, "$cur_id[1] genmove_white" ); | |
462 | $state = 'white'; | |
463 | return; | |
464 | } | |
465 | ||
466 | ||
467 | if ( $state eq 'white' ) { | |
468 | my $y; | |
469 | my $x; | |
470 | my $gn; | |
471 | ||
472 | print "msg ---> $msg\n"; | |
473 | ||
474 | $msg =~ /^=\d+\s+(.)(.*)/; # parse out move components | |
475 | ||
476 | if ( $msg =~ /PASS/ ) { | |
477 | $consecutive_passes++; | |
478 | $gn = 'PASS'; | |
479 | } else { | |
480 | $consecutive_passes = 0; | |
481 | $y = $boardsize - $2; | |
482 | $x = $toix{$1}; | |
483 | $gn = $letter[$x] . ($boardsize - $y); | |
484 | } | |
485 | ||
486 | ||
487 | # show blacks move to the interface | |
488 | # --------------------------------- | |
489 | if ( !ttPlaceStone( $ctm, $gn ) ) { | |
490 | xputstone( $ctm, $x, $y ) if $gn ne 'PASS'; | |
491 | xfixboard(); | |
492 | ttShowBoard(); | |
493 | swap_ctm(); | |
494 | } else { return 1; } | |
495 | ||
496 | # send the move along to BLACK | |
497 | # ---------------------------- | |
498 | snd( 0, "$cur_id[0] white $gn" ); | |
499 | $state = 'genmove_black'; | |
500 | ||
501 | if ($consecutive_passes == 2) { | |
502 | $state = 'gameover'; | |
503 | } | |
504 | ||
505 | return; | |
506 | } | |
507 | ||
508 | ||
509 | if ( $state eq 'gameover' ) { | |
510 | print "Game Over\n"; | |
511 | ttScore(); | |
512 | ||
513 | } | |
514 | ||
515 | ||
516 | ||
517 | ||
518 | ||
519 | ||
520 | } | |
521 | ||
522 | ||
523 | ||
524 | ||
525 | ||
526 | sub snd | |
527 | { | |
528 | my ($who, $str) = @_; | |
529 | ||
530 | if ($who == 0) { | |
531 | print $Aprg_in "$str\n"; | |
532 | } else { | |
533 | print $Bprg_in "$str\n"; | |
534 | } | |
535 | ||
536 | print STDERR "----> $str\n"; | |
537 | ||
538 | } | |
539 | ||
540 | ||
541 | sub swap_ctm | |
542 | { | |
543 | if ( $ctm eq 'B' ) { | |
544 | $ctm = 'W'; | |
545 | } else { | |
546 | $ctm = 'B'; | |
547 | } | |
548 | ||
549 | } |