Ada 95 :: x80_gam.ada

 --[pack_screen.ads] Specification
package Pack_screen is
  procedure screen_clear;                -- Home clear screen
  procedure screen_home;                 -- Home no clear screen
private
  ESC: CONSTANT Character := Character'Val(27);
end Pack_screen;

with Text_io; use Text_io;
package body Pack_screen is             -- Terminal dependent I/O
  procedure screen_clear is             -- Clear screen
  begin
    put( ESC & "[2J" );                 -- Escape sequence
  end screen_clear;
  procedure screen_home is              -- Home
  begin
    put( ESC & "[0;0H");                -- Escape sequence
  end screen_home;
end Pack_screen;

----------------------------------------------------------------------

package Class_counter is
  type Counter        is private;
  type Counter_colour is ( BLACK, WHITE );
  procedure set( the:in out Counter; rep:in Counter_colour );
  procedure display( the:in Counter );
  procedure display_none( the:in Counter );
  procedure flip( the:in out Counter );
  function  rep( the:in Counter ) return Counter_colour;
private
  type Counter is record
    colour: Counter_colour;         -- Colour of counter
  end record;
end Class_counter;

with Simple_io; use Simple_io;
package body Class_counter is
  procedure set( the:in out Counter; rep:in Counter_colour ) is
  begin
    the.colour := rep;
  end set;

  procedure display( the:in Counter ) is
  begin
    case the.colour is
      when BLACK  => put('X'); -- Representation of a black piece
      when WHITE  => put('O'); -- Representation of a white piece
    end case;
  end display;

  procedure display_none( the:in Counter ) is
  begin
    put(' ');                   -- Representation of NO piece
  end display_none;

  procedure flip( the:in out Counter ) is
  begin
    case the.colour is
      when BLACK  => the.colour := WHITE;     -- Flip to White
      when WHITE  => the.colour := BLACK;     -- Flip to Black
    end case;
  end flip;

  function  rep( the:in Counter ) return Counter_colour is
  begin
    return the.colour;  -- Representation of the counter colour
  end rep;
end Class_counter;

----------------------------------------------------------------------

with Class_counter;
use  Class_counter;
package Class_cell is
  type Cell is private;
  type Cell_holds is ( C_WHITE, C_BLACK, EMPTY );

  procedure initialize( the:in out Cell );
  function  holds( the:in Cell ) return Cell_holds;
  procedure add( the:in out Cell; players_counter:in Counter );
  procedure display( the:in Cell );
  procedure flip( the:in out Cell );
  function to_colour( c:in Cell_holds ) return Counter_colour;
private
  type Cell_is is ( EMPTY_CELL, not_EMPTY_CELL );
  type Cell is record
    contents: Cell_is := EMPTY_CELL;
    item    : Counter;                 -- The counter
  end record;
end Class_cell;

package body Class_cell is
  procedure initialize( the:in out Cell ) is
  begin
    the.contents := EMPTY_CELL;   -- Initialize cell to empty
  end initialize;

  function  holds( the:in Cell ) return Cell_holds is
  begin
    case the.contents is
      when EMPTY_CELL     =>             -- Empty
        return EMPTY;                    --  No counter
      when not_EMPTY_CELL =>             -- Counter
        case rep( the.item ) is
          when WHITE => return C_WHITE;  --  white counter
          when BLACK => return C_BLACK;  --  black counter
        end case;
    end case;
  end holds;

  procedure add(the:in out Cell; players_counter:in Counter) is
  begin
    the := (not_EMPTY_CELL,players_counter);
  end add;

  procedure display( the:in Cell ) is
  begin
    if the.contents = not_EMPTY_CELL then
      display( the.item );           -- Display the counter
    else
      display_none( the.item );      -- No counter
    end if;
  end display;

  procedure flip( the:in out Cell ) is
  begin
    flip( the.item );                -- Flip counter
  end flip;

  function to_colour(c:in Cell_holds) return Counter_colour is
  begin
    case c is                        -- Conversion of enum.
      when C_WHITE => return WHITE;
      when C_BLACK => return BLACK;
      when others  => raise Constraint_error;
    end case;
  end to_colour;

end Class_cell;

----------------------------------------------------------------------

with Class_counter, Class_cell;
use  Class_counter, Class_cell;
package Class_board is

  type Board         is private;
  type State_of_game is ( PLAY, WIN, DRAW, LOSE );
  type Move_status   is ( OK, INVALID, PASS );

  procedure set_up( the:in out Board );
  procedure add( the:in out Board; x,y:in Integer;
                 move_is:in Move_status );
  procedure now_playing( the:in out Board; c:in Counter_colour );
  procedure display( the:in Board );
  function  check_move( the:in Board; x,y:in Integer )
                        return Move_status;
  function  status( the:in Board ) return State_of_game;
  function  contents( the:in Board; x,y:in Integer )
                     return Cell_holds;

private
  SIZE: CONSTANT := 8;                            -- 8 * 8 Board
  subtype Board_index is Integer range 1 .. SIZE; --
  subtype Board_range is Board_index;             --

  type Board_array is array (Board_range, Board_range) of Cell;
  type Score_array is array (Counter_colour) of Natural;
  type Move_array  is array (Counter_colour) of Move_status;

  type Board is record
    sqrs     : Board_array;               -- Game board
    player   : Counter_colour;            -- Current Player
    opponent : Counter_colour;            -- Opponent
    score    : Score_array;               -- Running score
    last_move: Move_array;                -- Last move is
  end record;
end Class_board;

with Simple_io, Pack_screen;
use  Simple_io, Pack_screen;
package body Class_board is

  procedure next( the:in Board; x_co,y_co:in out Board_index;
                  dir:in Natural; res:out Boolean);
  function find_turned( the:in Board; x,y: in Board_index )
                        return Natural;
  procedure turn_counters(the: in out Board; x,y: in Board_index;
                          total: out Natural );
  function  no_turned(the:in Board; o_x,o_y:in Board_index;
                      dir:in Natural;
                      n:in Natural := 0 ) return Natural;
  procedure capture(the:in out Board; x_co, y_co:in Board_index;
                    dir:in Natural );

  procedure set_up( the:in out Board ) is
    black_counter: Counter;               -- A white counter
    white_counter: Counter;               -- A black counter
  begin
    set( black_counter, BLACK );          -- Set black
    set( white_counter, WHITE );          -- Set white
    for x in the.sqrs'Range(1) loop
      for y in the.sqrs'Range(2) loop
        initialize( the.sqrs(x,y) );      -- To empty
      end loop;
    end loop;
    add( the.sqrs( SIZE/2,   SIZE/2 ),   black_counter );
    add( the.sqrs( SIZE/2,   SIZE/2+1 ), white_counter );
    add( the.sqrs( SIZE/2+1, SIZE/2 ),   white_counter );
    add( the.sqrs( SIZE/2+1, SIZE/2+1 ), black_counter );
    the.score( BLACK ) := 2; the.score( WHITE ) := 2;
  end set_up;

  procedure add( the:in out Board; x,y:in Integer;
                 move_is:in Move_status ) is
    plays_with: Counter;          -- Current player's counter
    turned    : Natural;          -- Number counters turned
  begin
    set( plays_with, the.player );          -- Set current colour
    the.last_move( the.player ) := move_is; -- Last move is
    if move_is = OK then                    -- Not Pass
      turn_counters(the, x,y, turned);      -- and flip
      add( the.sqrs( x, y ), plays_with );  -- to board
      the.score( the.player ) :=
                 the.score( the.player ) + turned + 1;
      the.score( the.opponent ):=
                 the.score( the.opponent ) - turned;
    end if;
  end add;

  procedure now_playing(the:in out Board; c:in Counter_colour) is
  begin
    the.player   := c;                       -- Player
    case c is                                -- Opponent
       when WHITE => the.opponent := BLACK;
       when BLACK => the.opponent := WHITE;
    end case;
  end now_playing;

  procedure display( the:in Board ) is
    dashes: String( 1 .. the.sqrs'Length*4+1 ) := (others=>'-');
  begin
    screen_clear;                            -- Clear screen
    put( dashes ); new_line;                 -- Top
    for x in the.sqrs'Range(1) loop
      put("|");                              -- Cells on line
      for y in the.sqrs'Range(2) loop
        put(" "); display( the.sqrs(x,y) ); put(" |");
      end loop;
      new_line; put( dashes ); new_line;     -- Bottom lines
    end loop;
    new_line;
    put( "Player X has " );
    put( Integer(the.score(BLACK)), width=>2 );
    put( " counters" ); new_line;
    put( "Player O has " );
    put( Integer(the.score(WHITE)), width=>2 );
    put( " counters" ); new_line;
  end display;

  function check_move( the:in Board; x,y:in Integer )
                       return Move_status is
  begin
    if x = 0 and then y = 0 then
      return PASS;
    elsif x in Board_index and then y in Board_index then
      if holds( the.sqrs( x, y ) ) = EMPTY then
        if find_turned(the, x, y) > 0 then
          return OK; 
        end if;
      end if;
    end if;
    return INVALID;
  end check_move;

  function find_turned( the:in Board; x,y: in Board_index )
                        return Natural is
    sum     : Natural := 0;       -- Total stones turned
  begin
    if holds( the.sqrs( x, y ) ) = EMPTY then
      for dir in 1 .. 8 loop      -- The  8 possible directions
        sum := sum + no_turned( the, x, y, dir );
      end loop;
    end if;
    return sum;                   -- return total
  end find_turned;

  procedure turn_counters(the: in out Board; x,y: in Board_index;
                          total: out Natural ) is
    num_cap  : Natural := 0;
    captured : Natural;
  begin
    if holds( the.sqrs( x, y ) ) = EMPTY then
      for dir in 1 .. 8 loop
        captured := no_turned( the, x, y, dir );
        if captured > 0 then
          capture( the, x, y, dir );
          num_cap := num_cap + captured;
        end if;
      end loop;
    end if;
    total := num_cap;
  end turn_counters;

  function  no_turned(the:in Board; o_x,o_y:in Board_index;
                      dir:in Natural;
                      n:in Natural := 0 ) return Natural is
    ok : Boolean;                           -- Result from next
    nxt: Cell_holds;                        -- Next in line is
    col: Counter_colour;                    -- Counter colour
    x  : Board_index := o_x;                -- Local copy
    y  : Board_index := o_y;                -- Local copy
  begin
    next( the, x,y, dir, ok );              -- Next cell
    if ok then                              -- On the board
      nxt := holds( the.sqrs(x,y) );        -- Contents are
      if nxt = EMPTY then                   -- End of line
        return 0;
      else
        col := to_colour( nxt );            -- Colour
        if col = the.opponent then          -- Opponents counter
          return no_turned(the, x,y, dir, n+1); -- Try next cell
        elsif col = the.player then         -- End of counters
          return n;                         -- Counters turned
        end if;
      end if;
    else
      return 0;                             -- No line
    end if;
  end no_turned;

  procedure next( the:in Board; x_co,y_co:in out Board_index;
                  dir:in Natural; res:out Boolean) is
    x, y   : Natural;
  begin
    x := x_co; y := y_co;         -- May go outside Board_range
    case dir is
      when 1 =>         y:=y+1;   --  Direction to move
      when 2 => x:=x+1; y:=y+1;   --      8   1   2
      when 3 => x:=x+1;           --
      when 4 => x:=x+1; y:=y-1;   --      7   *   3
      when 5 =>         y:=y-1;   --
      when 6 => x:=x-1; y:=y-1;   --      6   5   4
      when 7 => x:=x-1;           --
      when 8 => x:=x-1; y:=y+1;   --
      when others => raise Constraint_error;
    end case;
    if x in Board_range and then y in Board_range then
      x_co :=  x; y_co :=  y;     --
      res := TRUE;                -- Found a next cell
    else
      res := FALSE;               -- No next cell
    end if;
  end next;

  procedure capture(the:in out Board; x_co, y_co:in Board_index;
             dir:in Natural ) is
    ok   : Boolean;                   -- There is a next cell
    x, y : Board_index;               -- Coordinates of cell
    nxt  : Cell_holds;                -- Next in line is
  begin
    x := x_co; y := y_co;
    next( the, x, y, dir, ok );       -- Calculate pos next cell
    if ok then                        -- Cell exists (Must)
      nxt := holds( the.sqrs(x,y) );
      if to_colour( nxt ) = the.opponent then
        flip( the.sqrs(x, y) );       -- Capture
        capture(the, x, y, dir );     -- Implement capture
      else
        return;                       -- End of line
      end if;
    else
      raise Constraint_error;         -- Will never occur
    end if;
  end capture;

  function  status ( the:in Board ) return State_of_game is
  begin
    if the.score( the.opponent ) = 0 then
      return WIN;
    end if;
    if (the.sqrs'Length(1) * the.sqrs'Length(2) =
        the.score(the.opponent)+the.score(the.player)) or
       (the.last_move(BLACK)=PASS and the.last_move(WHITE)=PASS)
    then
      if the.score(the.opponent) = the.score(the.player)
         then return DRAW;
      end if;
      if the.score(the.opponent) < the.score(the.player)
         then return WIN;
      else
        return LOSE;
      end if;
    end if;
    return PLAY;
  end;

  function contents( the:in Board; x,y:in Integer )
                     return Cell_holds is
  begin
      return holds( the.sqrs( x, y ) );
  end contents;

end Class_board;

----------------------------------------------------------------------

with Class_counter, Class_board;
use  Class_counter, Class_board;
package Class_player is
  type Player is private;

  procedure set( the:in out Player; c:in Counter_colour );
  procedure get_move(the:in Player; row,column:out Integer);
  function  my_counter( the:in Player ) return Counter;
  procedure announce( the:in Player; what:in State_of_game );
private
  type Player is record
    plays_with : Counter;        -- Player's counter
  end record;
end Class_player;

with Simple_io;
use  Simple_io;
package body Class_player is
  procedure set(the:in out Player; c:in Counter_colour ) is
    a_counter : Counter;
  begin
    set( a_counter, c );          -- Set colour
    the.plays_with := a_counter;  -- Player is playing with
  end set;

  procedure get_move(the:in Player; row,column:out Integer) is
    valid_move : Boolean := FALSE;
  begin
    while not valid_move loop
      begin
        put("Please enter move "); display( the.plays_with );
        put(" row column : "); get( row ); get( column );
        valid_move := TRUE;
      exception
        when Data_Error =>
          row := -1; column := -1; skip_line;
        when End_error =>
          row := 0; column := 0;
          return;
      end;
    end loop;
  end get_move;

  function  my_counter( the:in Player ) return Counter is
  begin
    return the.plays_with;
  end my_counter;

  procedure announce(the:in Player; what:in State_of_game) is
  begin
    case what is
      when Win    =>
        put("Player "); display( the.plays_with );
        put(" has won");
      when LOSE   =>
        put("Player "); display( the.plays_with );
        put(" has lost");
      when DRAW   =>
        put("It's a draw");
      when others =>
        raise Constraint_error;
    end case;
    new_line;
  end announce;

end Class_player;

----------------------------------------------------------------------

with Class_board, Class_player, Class_counter;
use  Class_board, Class_player, Class_counter;
procedure play is                            -- Reversi
  reversi       : Board;                     -- The playing board
  contestant    : array(Counter_colour) of Player;
  current_state : State_of_game;             -- State of game
  person        : Counter_colour;            -- Current player
  x, y          : Integer;                   -- Move
  move_is       : Move_status;               -- Last move is
begin
  set_up( reversi );                         -- Set up board
  set( contestant(BLACK), BLACK );           -- Set player black
  set( contestant(WHITE), WHITE );           -- Set player white

  current_state := PLAY;  person := BLACK;   -- Black starts

  display( reversi );                        -- Initial board

  while current_state = PLAY loop            -- Playable game
    now_playing( reversi, person );          -- set player

    loop                                     -- Get move
      get_move( contestant(person), x, y );
      move_is := check_move(reversi, x, y);  -- Validate
      exit when move_is=OK or move_is=PASS;  -- OK
    end loop;

    add( reversi, x, y, move_is );           -- Add move to board

    display( reversi );                      -- Display new board
    current_state := status( reversi );      -- State of play is

    if current_state = PLAY then             -- Is still playable
      case person is                         -- next player
        when BLACK  => person := WHITE;
        when WHITE  => person := BLACK;
      end case;
    end if;

  end loop;                                   -- Next move

  announce( contestant(person), current_state );  -- Result

end play;


© M.A.Smith University of Brighton. Created September 1995 last modified May 1997.
Comments, suggestions, etc. M.A.Smith@brighton.ac.uk * [Home page]