1 2(********************************************************************) 3(* *) 4(* ms.sd7 Mine sweeper game *) 5(* Copyright (C) 1993, 1994, 2004 Thomas Mertes *) 6(* *) 7(* This program is free software; you can redistribute it and/or *) 8(* modify it under the terms of the GNU General Public License as *) 9(* published by the Free Software Foundation; either version 2 of *) 10(* the License, or (at your option) any later version. *) 11(* *) 12(* This program is distributed in the hope that it will be useful, *) 13(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 15(* GNU General Public License for more details. *) 16(* *) 17(* You should have received a copy of the GNU General Public *) 18(* License along with this program; if not, write to the *) 19(* Free Software Foundation, Inc., 51 Franklin Street, *) 20(* Fifth Floor, Boston, MA 02110-1301, USA. *) 21(* *) 22(********************************************************************) 23 24 25$ include "seed7_05.s7i"; 26 include "stdio.s7i"; 27 include "console.s7i"; 28 include "window.s7i"; 29 include "keybd.s7i"; 30 31 32var text: scr is STD_NULL; 33var text: field is STD_NULL; 34var text: status is STD_NULL; 35var text: protocol is STD_NULL; 36 37const integer: STRETCH_FACTOR is 2; 38 39var integer: max_line is 0; 40var integer: max_column is 0; 41var integer: marked_mine_counter is 0; 42var integer: real_mine_counter is 0; 43var integer: explosion_counter is 0; 44 45var integer: round_lines is 8; 46var integer: round_columns is 8; 47var integer: round_mines is 10; 48 49var integer: line is 0; 50var integer: column is 0; 51var char: command is ' '; 52 53const type: field_place is new struct 54 var boolean: bomb is FALSE; 55 var integer: counter is 0; 56 var boolean: marked is FALSE; 57 var boolean: visited is FALSE; 58 end struct; 59 60const field_place: NULL_FIELD is field_place.value; 61 62 63const type: field_line is array field_place; 64var array field_line: area is 0 times 0 times NULL_FIELD; 65 66 67const proc: init_area (in integer: num_lines, in integer: num_columns) is func 68 begin 69 max_line := num_lines; 70 max_column := num_columns; 71 area := num_lines times num_columns times NULL_FIELD; 72 end func; 73 74 75const proc: display_place (in integer: line, in integer: column, ref field_place: place) is func 76 begin 77 setPos(field, line, STRETCH_FACTOR * pred(column) + 2); 78(* writeln(protocol, line <& " " <& column <& " " <& 79 str(place.marked)[1] <& str(place.visited)[1] <& 80 str(place.bomb)[1] <& place.counter); *) 81 if place.marked then 82 write(field, "X"); 83 elsif not place.visited then 84 write(field, "."); 85 elsif place.bomb then 86 write(field, "#"); 87 elsif place.counter = 0 then 88 write(field, " "); 89 else 90 write(field, place.counter); 91 end if; 92 end func; 93 94 95const proc: show_place (in integer: line, in integer: column) is func 96 begin 97 if not area[line][column].visited then 98 area[line][column].visited := TRUE; 99 display_place(line, column, area[line][column]); 100 end if; 101 end func; 102 103 104const proc: incr_place (in integer: line, in integer: column) is func 105 begin 106 if line >= 1 and line <= max_line and 107 column >= 1 and column <= max_column then 108 incr(area[line][column].counter); 109 end if; 110 end func; 111 112 113const proc: init_mines (in integer: num_mines) is func 114 local 115 var integer: number is 0; 116 var integer: line is 0; 117 var integer: column is 0; 118 begin 119 marked_mine_counter := num_mines; 120 real_mine_counter := num_mines; 121 for number range 1 to num_mines do 122 repeat 123 line := rand(1, max_line); 124 column := rand(1, max_column); 125(* 126 write(line); 127 write(" "); 128 write(column); 129 write(" "); 130 write(area[line][column].bomb); 131 writeln; 132 TRACE(area[line][column]); 133 writeln; 134 if getc(KEYBOARD) = '*' then 135 EXIT(PROGRAM); 136 end if; 137*) 138 until not area[line][column].bomb; 139 area[line][column].bomb := TRUE; 140 incr(area[line][column].counter); 141 incr_place(pred(line), pred(column)); 142 incr_place(pred(line), column ); 143 incr_place(pred(line), succ(column)); 144 incr_place( line , pred(column)); 145 incr_place( line , succ(column)); 146 incr_place(succ(line), pred(column)); 147 incr_place(succ(line), column ); 148 incr_place(succ(line), succ(column)); 149 end for; 150 end func; 151 152 153const func boolean: place_is_free (in integer: line, in integer: column) is func 154 result 155 var boolean: is_free is TRUE; 156 begin 157(* write(protocol, "RANGE " <& line <& " " <& column <& " "); *) 158 is_free := line >= 1 and line <= max_line and 159 column >= 1 and column <= max_column and 160 area[line][column].counter = 0 and 161 not (area[line][column].visited or 162 area[line][column].marked); 163 if is_free then 164 area[line][column].visited := TRUE; 165 display_place(line, column, area[line][column]); 166 end if; 167(* writeln(protocol, is_free); *) 168 end func; 169 170 171const proc: display_nonfree_place (in integer: line, in integer: column) is func 172 begin 173 if line >= 1 and line <= max_line and 174 column >= 1 and column <= max_column and 175 not area[line][column].marked then 176 show_place(line, column); 177 end if; 178 end func; 179 180 181(* 182const proc: show_free_area (in integer: line, in integer: column) is func 183 begin 184 if place_is_free(line, column) then 185 show_free_area( line , succ(column)); 186 show_free_area(pred(line), succ(column)); 187 show_free_area(pred(line), column ); 188 show_free_area(pred(line), pred(column)); 189 show_free_area( line , pred(column)); 190 show_free_area(succ(line), pred(column)); 191 show_free_area(succ(line), column ); 192 show_free_area(succ(line), succ(column)); 193 else 194 display_nonfree_place(line, column); 195 end if; 196 end func; 197*) 198 199 200const proc: show_free_NW (in integer: line, in integer: column) is forward; 201const proc: show_free_NE (in integer: line, in integer: column) is forward; 202const proc: show_free_SW (in integer: line, in integer: column) is forward; 203const proc: show_free_SE (in integer: line, in integer: column) is forward; 204 205 206const proc: show_free_N (in integer: line, in integer: column) is func 207 begin 208 if place_is_free(line, column) then 209 show_free_N (pred(line), column ); 210 show_free_NW(pred(line), succ(column)); 211 show_free_NE(pred(line), pred(column)); 212 else 213 display_nonfree_place(line, column); 214 end if; 215 end func; 216 217 218const proc: show_free_S (in integer: line, in integer: column) is func 219 begin 220 if place_is_free(line, column) then 221 show_free_S (succ(line), column ); 222 show_free_SE(succ(line), pred(column)); 223 show_free_SW(succ(line), succ(column)); 224 else 225 display_nonfree_place(line, column); 226 end if; 227 end func; 228 229 230const proc: show_free_W (in integer: line, in integer: column) is func 231 begin 232 if place_is_free(line, column) then 233 show_free_W ( line , succ(column)); 234 show_free_SW(succ(line), succ(column)); 235 show_free_NW(pred(line), succ(column)); 236 else 237 display_nonfree_place(line, column); 238 end if; 239 end func; 240 241 242const proc: show_free_E (in integer: line, in integer: column) is func 243 begin 244 if place_is_free(line, column) then 245 show_free_E ( line , pred(column)); 246 show_free_NE(pred(line), pred(column)); 247 show_free_SE(succ(line), pred(column)); 248 else 249 display_nonfree_place(line, column); 250 end if; 251 end func; 252 253 254const proc: show_free_NW (in integer: line, in integer: column) is func 255 begin 256 if place_is_free(line, column) then 257 show_free_NW(pred(line), succ(column)); 258 show_free_W ( line , succ(column)); 259 show_free_N (pred(line), column ); 260 show_free_SW(succ(line), succ(column)); 261 show_free_NE(pred(line), pred(column)); 262 else 263 display_nonfree_place(line, column); 264 end if; 265 end func; 266 267 268const proc: show_free_NE (in integer: line, in integer: column) is func 269 begin 270 if place_is_free(line, column) then 271 show_free_NE(pred(line), pred(column)); 272 show_free_N (pred(line), column ); 273 show_free_E ( line , pred(column)); 274 show_free_NW(pred(line), succ(column)); 275 show_free_SE(succ(line), pred(column)); 276 else 277 display_nonfree_place(line, column); 278 end if; 279 end func; 280 281 282const proc: show_free_SE (in integer: line, in integer: column) is func 283 begin 284 if place_is_free(line, column) then 285 show_free_SE(succ(line), pred(column)); 286 show_free_E ( line , pred(column)); 287 show_free_S (succ(line), column ); 288 show_free_NE(pred(line), pred(column)); 289 show_free_SW(succ(line), succ(column)); 290 else 291 display_nonfree_place(line, column); 292 end if; 293 end func; 294 295 296const proc: show_free_SW (in integer: line, in integer: column) is func 297 begin 298 if place_is_free(line, column) then 299 show_free_SW(succ(line), succ(column)); 300 show_free_S (succ(line), column ); 301 show_free_W ( line , succ(column)); 302 show_free_SE(succ(line), pred(column)); 303 show_free_NW(pred(line), succ(column)); 304 else 305 display_nonfree_place(line, column); 306 end if; 307 end func; 308 309 310const proc: show_free_area (in integer: line, in integer: column) is func 311 begin 312 if place_is_free(line, column) then 313 show_free_N (pred(line), column ); 314 show_free_NE(pred(line), pred(column)); 315 show_free_E ( line , pred(column)); 316 show_free_SE(succ(line), pred(column)); 317 show_free_S (succ(line), column ); 318 show_free_SW(succ(line), succ(column)); 319 show_free_W ( line , succ(column)); 320 show_free_NW(pred(line), succ(column)); 321 else 322 display_nonfree_place(line, column); 323 end if; 324 end func; 325 326 327const proc: show_explosion (in integer: line, in integer: column) is func 328 begin 329 show_place(line, column); 330 writeln(protocol, "MINE EXPLODED"); 331 decr(marked_mine_counter); 332 decr(real_mine_counter); 333 incr(explosion_counter); 334 setPos(status, 1, 2); 335 write(status, marked_mine_counter); 336 write(status, " "); 337 end func; 338 339 340const proc: show_wrong_mark (in integer: line, in integer: column) is func 341 begin 342 setPos(field, line, STRETCH_FACTOR * pred(column) + 2); 343 write(field, "F"); 344 end func; 345 346 347const proc: show_area_around (in integer: line, in integer: column) is func 348 local 349 var integer: lin is 0; 350 var integer: col is 0; 351 var integer: sum is 0; 352 var field_place: place is NULL_FIELD; 353 begin 354 for lin range -1 to 1 do 355 for col range -1 to 1 do 356 if (lin <> 0 or col <> 0) and 357 line + lin >= 1 and line + lin <= max_line and 358 column + col >= 1 and column + col <= max_column then 359 place := area[line + lin][column + col]; 360 if place.marked or (place.visited and place.bomb) then 361 incr(sum); 362 end if; 363 end if; 364 end for; 365 end for; 366 if area[line][column].counter = sum then 367 for lin range -1 to 1 do 368 for col range -1 to 1 do 369 if (lin <> 0 or col <> 0) and 370 line + lin >= 1 and line + lin <= max_line and 371 column + col >= 1 and column + col <= max_column then 372 place := area[line + lin][column + col]; 373 if not place.visited then 374 if place.bomb then 375 if not place.marked then 376 show_explosion(line + lin, column + col); 377 end if; 378 elsif place.marked then 379 show_wrong_mark(line + lin, column + col); 380 elsif place.counter = 0 then 381 show_free_area(line + lin, column + col); 382 else 383 show_place(line + lin, column + col); 384 end if; 385 end if; 386 end if; 387 end for; 388 end for; 389 end if; 390 end func; 391 392 393const proc: show_solution is func 394 local 395 var integer: line is 0; 396 var integer: column is 0; 397 var field_place: place is NULL_FIELD; 398 begin 399 for line range 1 to max_line do 400 for column range 1 to max_column do 401 place := area[line][column]; 402 place.marked := FALSE; 403 place.visited := TRUE; 404 display_place(line, column, place); 405 end for; 406 end for; 407 end func; 408 409 410const proc: read_command (in integer: line, in integer: column) is func 411 begin 412 setPos(field, line, STRETCH_FACTOR * pred(column) + 3); 413 write(field, ">"); 414 setPos(field, line, STRETCH_FACTOR * pred(column) + 1); 415 write(field, "<"); 416 command := getc(KEYBOARD); 417 setPos(field, line, STRETCH_FACTOR * pred(column) + 3); 418 write(field, " "); 419 setPos(field, line, STRETCH_FACTOR * pred(column) + 1); 420 write(field, " "); 421 end func; 422 423 424const proc: congratulation is func 425 begin 426 clear(protocol); 427 setPos(protocol, 1, 1); 428 writeln(protocol, "CONGRATULATION"); 429 writeln(protocol); 430 writeln(protocol, "The minefield"); 431 writeln(protocol, "is cleared."); 432 writeln(protocol); 433 if explosion_counter = 0 then 434 write(protocol, "no"); 435 else 436 write(protocol, explosion_counter); 437 end if; 438 if explosion_counter >= 2 then 439 write(protocol, " mines"); 440 else 441 write(protocol, " mine"); 442 end if; 443 writeln(protocol); 444 writeln(protocol, "exploded"); 445 writeln(protocol); 446 writeln(protocol, " Press RETURN"); 447 end func; 448 449 450const proc: select_round is func 451 begin 452 clear(protocol); 453 setPos(protocol, 1, 1); 454 writeln(protocol, "MINE SWEEPER"); 455 writeln(protocol); 456 writeln(protocol, "Keys:"); 457 writeln(protocol, "space test"); 458 writeln(protocol, "m mark"); 459 writeln(protocol, "n new game"); 460 writeln(protocol, "q quit"); 461 writeln(protocol); 462 writeln(protocol, "select game"); 463 writeln(protocol); 464 field := openWindow(scr, 5, 18, 5, 16); 465 box(field); 466 writeln(field, " NEW GAME"); 467 writeln(field); 468 writeln(field, " 1 Beginner"); 469 writeln(field, " 2 Advanced"); 470 write (field, " 3 Professional"); 471 command := getc(KEYBOARD); 472 if command = '3' then 473 round_lines := 16; 474 round_columns := 30; 475 round_mines := 99; 476 elsif command = '2' then 477 round_lines := 16; 478 round_columns := 16; 479 round_mines := 40; 480(* elsif command = '4' then 481 round_lines := 8; 482 round_columns := 8; 483 round_mines := 3; *) 484 else 485 round_lines := 8; 486 round_columns := 8; 487 round_mines := 10; 488 end if; 489 clear(field); 490 clear_box(field); 491 end func; 492 493 494const proc: init_round is func 495 local 496 var integer: lin is 0; 497 var string: stri is ""; 498 begin 499 init_area(round_lines, round_columns); 500 init_mines(round_mines); 501 explosion_counter := 0; 502 field := openWindow(scr, 5, 18, 503 round_lines, round_columns * STRETCH_FACTOR + 1); 504 box(field); 505 stri := ("." lpad STRETCH_FACTOR) mult round_columns; 506 for lin range 1 to round_lines do 507 setPos(field, lin, 1); 508 write(field, stri); 509 end for; 510 setPos(status, 1, 2); 511 write(status, round_mines); 512 write(status, " MINES LEFT"); 513 line := 1; 514 column := 1; 515 end func; 516 517 518const proc: shut_round is func 519 begin 520 clear(field); 521 clear_box(field); 522 clear(protocol); 523 setPos(protocol, 20, 1); 524 end func; 525 526 527const proc: init is func 528 begin 529 scr := open(CONSOLE); 530 status := openWindow(scr, 2, 18, 1, 33); 531 protocol := openWindow(scr, 3, 2, 20, 14); 532 box(status); 533 box(protocol); 534 setPos(protocol, 1, 1); 535 select_round; 536 end func; 537 538 539const proc: play_round is func 540 local 541 var field_place: place is NULL_FIELD; 542 begin 543 read_command(line, column); 544 while command <> 'q' and 545 command <> 'n' and 546 (marked_mine_counter <> 0 or real_mine_counter <> 0) do 547 if command = ' ' or command = '\n' then 548 place := area[line][column]; 549 if not place.marked then 550 if place.visited then 551 if not place.bomb then 552 show_area_around(line, column); 553 end if; 554 elsif place.bomb then 555 show_explosion(line, column); 556 elsif place.counter = 0 then 557 show_free_area(line, column); 558 else 559 show_place(line, column); 560 end if; 561 end if; 562 elsif command = '\t' or command = '+' or command = 'x' or command = 'm' then 563 place := area[line][column]; 564 if not place.visited then 565 place.marked := not place.marked; 566 area[line][column] := place; 567 display_place(line, column, place); 568 if place.marked then 569 decr(marked_mine_counter); 570 if place.bomb then 571 decr(real_mine_counter); 572 end if; 573 else 574 incr(marked_mine_counter); 575 if place.bomb then 576 incr(real_mine_counter); 577 end if; 578 end if; 579 setPos(status, 1, 2); 580 write(status, marked_mine_counter); 581 write(status, " "); 582 end if; 583 elsif command = 'j' or command = '2' or command = KEY_DOWN then 584 if line < max_line then 585 incr(line); 586 else 587 line := 1; 588 end if; 589 elsif command = 'k' or command = '8' or command = KEY_UP then 590 if line > 1 then 591 decr(line); 592 else 593 line := max_line; 594 end if; 595 elsif command = 'l' or command = '6' or command = KEY_RIGHT then 596 if column < max_column then 597 incr(column); 598 else 599 column := 1; 600 end if; 601 elsif command = 'h' or command = '4' or command = KEY_LEFT then 602 if column > 1 then 603 decr(column); 604 else 605 column := max_column; 606 end if; 607 elsif command = 's' then 608 show_solution; 609 else 610 write(protocol, "illegal "); 611 writeln(protocol, literal(command)); 612 end if; 613 if marked_mine_counter = 0 and real_mine_counter = 0 then 614 congratulation; 615 repeat 616 command := getc(KEYBOARD); 617 until command = 'q' or command = 'n' or command = KEY_NL; 618 else 619 read_command(line, column); 620 end if; 621 end while; 622 end func; 623 624 625const proc: main is func 626 begin 627 init; 628 PROT_OUTFILE := protocol; 629 while command <> 'q' do 630 init_round; 631 play_round; 632 shut_round; 633 if command = 'n' or 634 (marked_mine_counter = 0 and real_mine_counter = 0 and 635 command <> 'q') then 636 select_round; 637 end if; 638 end while; 639 setPos(scr, 24, 1); 640 end func; 641