
(********************************************************************)
(*                                                                  *)
(*  ms.sd7        Mine sweeper game                                 *)
(*  Copyright (C) 1993, 1994, 2004  Thomas Mertes                   *)
(*                                                                  *)
(*  This program is free software; you can redistribute it and/or   *)
(*  modify it under the terms of the GNU General Public License as  *)
(*  published by the Free Software Foundation; either version 2 of  *)
(*  the License, or (at your option) any later version.             *)
(*                                                                  *)
(*  This program is distributed in the hope that it will be useful, *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of  *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the   *)
(*  GNU General Public License for more details.                    *)
(*                                                                  *)
(*  You should have received a copy of the GNU General Public       *)
(*  License along with this program; if not, write to the           *)
(*  Free Software Foundation, Inc., 51 Franklin Street,             *)
(*  Fifth Floor, Boston, MA  02110-1301, USA.                       *)
(*                                                                  *)
(********************************************************************)


$ include "seed7_05.s7i";
  include "screen.s7i";
  include "window.s7i";
  include "keybd.s7i";


var text: scr is STD_NULL;
var text: field is STD_NULL;
var text: status is STD_NULL;
var text: protocol is STD_NULL;

const integer: STRETCH_FACTOR is 2;

var integer: max_line is 0;
var integer: max_column is 0;
var integer: marked_mine_counter is 0;
var integer: real_mine_counter is 0;
var integer: explosion_counter is 0;

var integer: round_lines is 8;
var integer: round_columns is 8;
var integer: round_mines is 10;

var integer: line is 0;
var integer: column is 0;
var char: command is ' ';

const type: field_place is new struct
    var boolean: bomb is FALSE;
    var integer: counter is 0;
    var boolean: marked is FALSE;
    var boolean: visited is FALSE;
  end struct;

const field_place: NULL_FIELD is field_place.value;


const type: field_line is array field_place;
var array field_line: area is 0 times 0 times NULL_FIELD;


const proc: init_area (in integer: num_lines, in integer: num_columns) is func
  begin
    max_line := num_lines;
    max_column := num_columns;
    area := num_lines times num_columns times NULL_FIELD;
  end func;


const proc: display_place (in integer: line, in integer: column, ref field_place: place) is func
  begin
    setPos(field, line, STRETCH_FACTOR * pred(column) + 2);
(*  writeln(protocol, line <& " " <& column <& " " <&
        str(place.marked)[1] <& str(place.visited)[1] <&
        str(place.bomb)[1] <& place.counter); *)
    if place.marked then
      write(field, "X");
    elsif not place.visited then
      write(field, ".");
    elsif place.bomb then
      write(field, "#");
    elsif place.counter = 0 then
      write(field, " ");
    else
      write(field, place.counter);
    end if;
  end func;


const proc: show_place (in integer: line, in integer: column) is func
  begin
    if not area[line][column].visited then
      area[line][column].visited := TRUE;
      display_place(line, column, area[line][column]);
    end if;
  end func;


const proc: incr_place (in integer: line, in integer: column) is func
  begin
    if line >= 1 and line <= max_line and
        column >= 1 and column <= max_column then
      incr(area[line][column].counter);
    end if;
  end func;


const proc: init_mines (in integer: num_mines) is func
  local
    var integer: number is 0;
    var integer: line is 0;
    var integer: column is 0;
  begin
    marked_mine_counter := num_mines;
    real_mine_counter := num_mines;
    for number range 1 to num_mines do
      repeat
        line := rand(1, max_line);
        column := rand(1, max_column);
(*
        write(line);
        write(" ");
        write(column);
        write(" ");
        write(area[line][column].bomb);
        writeln;
        TRACE(area[line][column]);
        writeln;
        if getc(KEYBOARD) = '*' then
          EXIT(PROGRAM);
        end if;
*)
      until not area[line][column].bomb;
      area[line][column].bomb := TRUE;
      incr(area[line][column].counter);
      incr_place(pred(line), pred(column));
      incr_place(pred(line),      column );
      incr_place(pred(line), succ(column));
      incr_place(     line , pred(column));
      incr_place(     line , succ(column));
      incr_place(succ(line), pred(column));
      incr_place(succ(line),      column );
      incr_place(succ(line), succ(column));
    end for;
  end func;


const func boolean: place_is_free (in integer: line, in integer: column) is func
  result
    var boolean: result is TRUE;
  begin
(*  write(protocol, "RANGE " <& line <& " " <& column <& " "); *)
    result := line >= 1 and line <= max_line and
        column >= 1 and column <= max_column and
        area[line][column].counter = 0 and
        not (area[line][column].visited or
            area[line][column].marked);
    if result then
      area[line][column].visited := TRUE;
      display_place(line, column, area[line][column]);
    end if;
(*  writeln(protocol, result); *)
  end func;


const proc: display_nonfree_place (in integer: line, in integer: column) is func
  begin
    if line >= 1 and line <= max_line and
        column >= 1 and column <= max_column and
        not area[line][column].marked then
      show_place(line, column);
    end if;
  end func;


(*
const proc: show_free_area (in integer: line, in integer: column) is func
  begin
    if place_is_free(line, column) then
      show_free_area(     line , succ(column));
      show_free_area(pred(line), succ(column));
      show_free_area(pred(line),      column );
      show_free_area(pred(line), pred(column));
      show_free_area(     line , pred(column));
      show_free_area(succ(line), pred(column));
      show_free_area(succ(line),      column );
      show_free_area(succ(line), succ(column));
    else
      display_nonfree_place(line, column);
    end if;
  end func;
*)


const proc: show_free_NW (in integer param, in integer param) is forward;
const proc: show_free_NE (in integer param, in integer param) is forward;
const proc: show_free_SW (in integer param, in integer param) is forward;
const proc: show_free_SE (in integer param, in integer param) is forward;


const proc: show_free_N (in integer: line, in integer: column) is func
  begin
    if place_is_free(line, column) then
      show_free_N (pred(line),      column );
      show_free_NW(pred(line), succ(column));
      show_free_NE(pred(line), pred(column));
    else
      display_nonfree_place(line, column);
    end if;
  end func;


const proc: show_free_S (in integer: line, in integer: column) is func
  begin
    if place_is_free(line, column) then
      show_free_S (succ(line),      column );
      show_free_SE(succ(line), pred(column));
      show_free_SW(succ(line), succ(column));
    else
      display_nonfree_place(line, column);
    end if;
  end func;


const proc: show_free_W (in integer: line, in integer: column) is func
  begin
    if place_is_free(line, column) then
      show_free_W (     line , succ(column));
      show_free_SW(succ(line), succ(column));
      show_free_NW(pred(line), succ(column));
    else
      display_nonfree_place(line, column);
    end if;
  end func;


const proc: show_free_E (in integer: line, in integer: column) is func
  begin
    if place_is_free(line, column) then
      show_free_E (     line , pred(column));
      show_free_NE(pred(line), pred(column));
      show_free_SE(succ(line), pred(column));
    else
      display_nonfree_place(line, column);
    end if;
  end func;


const proc: show_free_NW (in integer: line, in integer: column) is func
  begin
    if place_is_free(line, column) then
      show_free_NW(pred(line), succ(column));
      show_free_W (     line , succ(column));
      show_free_N (pred(line),      column );
      show_free_SW(succ(line), succ(column));
      show_free_NE(pred(line), pred(column));
    else
      display_nonfree_place(line, column);
    end if;
  end func;


const proc: show_free_NE (in integer: line, in integer: column) is func
  begin
    if place_is_free(line, column) then
      show_free_NE(pred(line), pred(column));
      show_free_N (pred(line),      column );
      show_free_E (     line , pred(column));
      show_free_NW(pred(line), succ(column));
      show_free_SE(succ(line), pred(column));
    else
      display_nonfree_place(line, column);
    end if;
  end func;


const proc: show_free_SE (in integer: line, in integer: column) is func
  begin
    if place_is_free(line, column) then
      show_free_SE(succ(line), pred(column));
      show_free_E (     line , pred(column));
      show_free_S (succ(line),      column );
      show_free_NE(pred(line), pred(column));
      show_free_SW(succ(line), succ(column));
    else
      display_nonfree_place(line, column);
    end if;
  end func;


const proc: show_free_SW (in integer: line, in integer: column) is func
  begin
    if place_is_free(line, column) then
      show_free_SW(succ(line), succ(column));
      show_free_S (succ(line),      column );
      show_free_W (     line , succ(column));
      show_free_SE(succ(line), pred(column));
      show_free_NW(pred(line), succ(column));
    else
      display_nonfree_place(line, column);
    end if;
  end func;


const proc: show_free_area (in integer: line, in integer: column) is func
  begin
    if place_is_free(line, column) then
      show_free_N (pred(line),      column );
      show_free_NE(pred(line), pred(column));
      show_free_E (     line , pred(column));
      show_free_SE(succ(line), pred(column));
      show_free_S (succ(line),      column );
      show_free_SW(succ(line), succ(column));
      show_free_W (     line , succ(column));
      show_free_NW(pred(line), succ(column));
    else
      display_nonfree_place(line, column);
    end if;
  end func;


const proc: show_explosion (in integer: line, in integer: column) is func
  begin
    show_place(line, column);
    writeln(protocol, "MINE EXPLODED");
    decr(marked_mine_counter);
    decr(real_mine_counter);
    incr(explosion_counter);
    setPos(status, 1, 2);
    write(status, marked_mine_counter);
    write(status, " ");
  end func;


const proc: show_wrong_mark (in integer: line, in integer: column) is func
  begin
    setPos(field, line, STRETCH_FACTOR * pred(column) + 2);
    write(field, "F");
  end func;


const proc: show_area_around (in integer: line, in integer: column) is func
  local
    var integer: lin is 0;
    var integer: col is 0;
    var integer: sum is 0;
    var field_place: place is NULL_FIELD;
  begin
    for lin range -1 to 1 do
      for col range -1 to 1 do
        if (lin <> 0 or col <> 0) and
            line + lin >= 1 and line + lin <= max_line and
            column + col >= 1 and column + col <= max_column then
          place := area[line + lin][column + col];
          if place.marked or (place.visited and place.bomb) then
            incr(sum);
          end if;
        end if;
      end for;
    end for;
    if area[line][column].counter = sum then
      for lin range -1 to 1 do
        for col range -1 to 1 do
          if (lin <> 0 or col <> 0) and
              line + lin >= 1 and line + lin <= max_line and
              column + col >= 1 and column + col <= max_column then
            place := area[line + lin][column + col];
            if not place.visited then
              if place.bomb then
                if not place.marked then
                  show_explosion(line + lin, column + col);
                end if;
              elsif place.marked then
                show_wrong_mark(line + lin, column + col);
              elsif place.counter = 0 then
                show_free_area(line + lin, column + col);
              else
                show_place(line + lin, column + col);
              end if;
            end if;
          end if;
        end for;
      end for;
    end if;
  end func;


const proc: show_solution is func
  local
    var integer: line is 0;
    var integer: column is 0;
    var field_place: place is NULL_FIELD;
  begin
    for line range 1 to max_line do
      for column range 1 to max_column do
        place := area[line][column];
        place.marked := FALSE;
        place.visited := TRUE;
        display_place(line, column, place);
      end for;
    end for;
  end func;


const proc: read_command (in integer: line, in integer: column) is func
  begin
    setPos(field, line, STRETCH_FACTOR * pred(column) + 3);
    write(field, ">");
    setPos(field, line, STRETCH_FACTOR * pred(column) + 1);
    write(field, "<");
    command := getc(KEYBOARD);
    setPos(field, line, STRETCH_FACTOR * pred(column) + 3);
    write(field, " ");
    setPos(field, line, STRETCH_FACTOR * pred(column) + 1);
    write(field, " ");
  end func;


const proc: congratulation is func
  begin
    clear(protocol);
    setPos(protocol, 1, 1);
    writeln(protocol, "CONGRATULATION");
    writeln(protocol);
    writeln(protocol, "The minefield");
    writeln(protocol, "is cleared.");
    writeln(protocol);
    if explosion_counter = 0 then
      write(protocol, "no");
    else
      write(protocol, explosion_counter);
    end if;
    if explosion_counter >= 2 then
      write(protocol, " mines");
    else
      write(protocol, " mine");
    end if;
    writeln(protocol);
    writeln(protocol, "exploded");
    writeln(protocol);
    writeln(protocol, " Press RETURN");
  end func;


const proc: select_round is func
  begin
    clear(protocol);
    setPos(protocol, 1, 1);
    writeln(protocol, "MINE SWEEPER");
    writeln(protocol);
    writeln(protocol, "Keys:");
    writeln(protocol, "space test");
    writeln(protocol, "m     mark");
    writeln(protocol, "n     new game");
    writeln(protocol, "q     quit");
    writeln(protocol);
    writeln(protocol, "select game");
    writeln(protocol);
    field := open_window(scr, 5, 18, 5, 16);
    box(field);
    writeln(field, " NEW GAME");
    writeln(field);
    writeln(field, " 1 Beginner");
    writeln(field, " 2 Advanced");
    write  (field, " 3 Professional");
    command := getc(KEYBOARD);
    if command = '3' then
      round_lines := 16;
      round_columns := 30;
      round_mines := 99;
    elsif command = '2' then
      round_lines := 16;
      round_columns := 16;
      round_mines := 40;
(*  elsif command = '4' then
      round_lines := 8;
      round_columns := 8;
      round_mines := 3; *)
    else
      round_lines := 8;
      round_columns := 8;
      round_mines := 10;
    end if;
    clear(field);
    clear_box(field);
  end func;


const proc: init_round is func
  local
    var integer: lin is 0;
    var string: stri is "";
  begin
    init_area(round_lines, round_columns);
    init_mines(round_mines);
    explosion_counter := 0;
    field := open_window(scr, 5, 18,
        round_lines, round_columns * STRETCH_FACTOR + 1);
    box(field);
    stri := ("." lpad STRETCH_FACTOR) mult round_columns;
    for lin range 1 to round_lines do
      setPos(field, lin, 1);
      write(field, stri);
    end for;
    setPos(status, 1, 2);
    write(status, round_mines);
    write(status, "  MINES LEFT");
    line := 1;
    column := 1;
  end func;


const proc: shut_round is func
  begin
    clear(field);
    clear_box(field);
    clear(protocol);
    setPos(protocol, 20, 1);
  end func;


const proc: init is func
  begin
    scr := open(SCREEN);
    status := open_window(scr, 2, 18, 1, 33);
    protocol := open_window(scr, 3, 2, 20, 14);
    box(status);
    box(protocol);
    setPos(protocol, 1, 1);
    select_round;
  end func;


const proc: play_round is func
  local
    var field_place: place is NULL_FIELD;
  begin
    read_command(line, column);
    while command <> 'q' and
        command <> 'n' and
        (marked_mine_counter <> 0 or real_mine_counter <> 0) do
      if command = ' ' or command = '\n' then
        place := area[line][column];
        if not place.marked then
          if place.visited then
            if not place.bomb then
              show_area_around(line, column);
            end if;
          elsif place.bomb then
            show_explosion(line, column);
          elsif place.counter = 0 then
            show_free_area(line, column);
          else
            show_place(line, column);
          end if;
        end if;
      elsif command = '\t' or command = '+' or command = 'x' or command = 'm' then
        place := area[line][column];
        if not place.visited then
          place.marked := not place.marked;
          area[line][column] := place;
          display_place(line, column, place);
          if place.marked then
            decr(marked_mine_counter);
            if place.bomb then
              decr(real_mine_counter);
            end if;
          else
            incr(marked_mine_counter);
            if place.bomb then
              incr(real_mine_counter);
            end if;
          end if;
          setPos(status, 1, 2);
          write(status, marked_mine_counter);
          write(status, " ");
        end if;
      elsif command = 'j' or command = '2' or command = KEY_DOWN then
        if line < max_line then
          incr(line);
        else
          line := 1;
        end if;
      elsif command = 'k' or command = '8' or command = KEY_UP then
        if line > 1 then
          decr(line);
        else
          line := max_line;
        end if;
      elsif command = 'l' or command = '6' or command = KEY_RIGHT then
        if column < max_column then
          incr(column);
        else
          column := 1;
        end if;
      elsif command = 'h' or command = '4' or command = KEY_LEFT then
        if column > 1 then
          decr(column);
        else
          column := max_column;
        end if;
      elsif command = 's' then
        show_solution;
      else
        write(protocol, "illegal ");
        writeln(protocol, literal(command));
      end if;
      if marked_mine_counter = 0 and real_mine_counter = 0 then
        congratulation;
        repeat
          command := getc(KEYBOARD);
        until command = 'q' or command = 'n' or command = KEY_NL;
      else
        read_command(line, column);
      end if;
    end while;
  end func;


const proc: main is func
  begin
    init;
    PROT_OUTFILE := protocol;
    while command <> 'q' do
      init_round;
      play_round;
      shut_round;
      if command = 'n' or
          (marked_mine_counter = 0 and real_mine_counter = 0 and
          command <> 'q') then
        select_round;
      end if;
    end while;
    setPos(scr, 24, 1);
  end func;
