::
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]