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