Description
Connect Four has been contributed by Professors Barry Fagin and Martin Carlisle of the US Air Force Academy for the JVM-GNAT version and has been adapted to GNOGA by Pascal Pignard. JVM-GNAT code has been left as comments in order to show the translation to Gnoga.
You can play the game by using your mouse to click on the column where you want to make your move. After some thinking the program will respond with its own move. You win if you can align 4 circles in a straight line (vertically, horizontally, or diagonally). When a winning position is reached you can restart the game by clicking on the mouse.
This application uses Zanyblue. Before running connect four, set the language variable for Zanyblue, for instance: (replace fr_FR by your own local language) unix like: export LANG=fr_FR.UTF-8.
Source code
connectfour.ads
--------------------------------------------------------------
-- Connect Four (TM) GNAPPLET
--
-- By: Barry Fagin and Martin Carlisle
-- US Air Force Academy, Department of Computer Science
-- mailto:carlislem@acm.org
--
-- 20150511 Adapted from JVM-GNAT to GNOGA by Pascal Pignard
-- http://blady.pagesperso-orange.fr
--
-- This is free software; you can redistribute it and/or
-- modify without restriction. We do ask that you please keep
-- the original author information, and clearly indicate if the
-- software has been modified.
--
-- This software 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.
--------------------------------------------------------------
-- with Java.Awt.Event.Mouselistener;
-- with Java.Awt.Event.MouseEvent;
-- with Java.Awt.Image;
-- with Java.Awt.Image.ImageObserver;
-- with Java.Awt.Graphics;
-- with Java.Applet.Applet;
-- with Java.Lang.String;
-- with Java.IO.Serializable;
-- with Java.Awt.MenuContainer;
-- with Javax.Accessibility.Accessible;
with Gnoga.Gui.View;
with Gnoga.Gui.Base; use Gnoga.Gui.Base;
with Gnoga.Gui.Element.Canvas.Context_2D;
with Gnoga.Gui.Window;
with ZanyBlue.Text.Locales;
package ConnectFour is
Num_Rows : constant Integer := 6;
Num_Columns : constant Integer := 7;
-- Constants for the board size
type Player_Kind is (None, Computer, User);
-- None means that neither the computer, nor the user have selected that
-- circle, Computer indicates that the circle has been selected by the
-- computer and User means that the circle has been selected by the user.
-- data type for the Connect Four board
type Board_Array_Type is array (1 .. Num_Rows, 1 .. Num_Columns) of Player_Kind;
-- Adding these discriminants to a type is the magic way of
-- telling JVM-GNAT that you are implementing these interfaces.
type Typ
-- (I_Serializable : java.io.Serializable.Ref;
-- I_MenuContainer : java.awt.MenuContainer.Ref;
-- I_ImageObserver : java.awt.image.ImageObserver.Ref;
-- I_MouseListener : Java.Awt.Event.Mouselistener.Ref;
-- I_Accessible : Javax.Accessibility.Accessible.Ref)
is new Gnoga.Gui.View.View_Type with record
User_Turn : Boolean;
The_Canvas : Gnoga.Gui.Element.Canvas.Canvas_Type;
Main_Window : Gnoga.Gui.Window.Window_Access;
-- state
Board : Board_Array_Type; -- the current board
-- Is the game over, and if so who won?
Computer_Won : Boolean := False;
User_Won : Boolean := False;
Tie : Boolean := False;
-- if user clicks in full column, computer should not take a turn
-- Also computer should not take turn if user wins or tie.
Ignore_Turn : Boolean := False;
Locale : ZanyBlue.Text.Locales.Locale_Type;
end record;
type Ref is access all Typ'Class;
-- pragma Convention (Java, Typ);
-- The following are the specifications for the overridden
-- methods from the Applet and MouseListener interfaces
function GetAppletInfo
(This : access Typ)
return Gnoga.String;
procedure Init (This : access Typ);
procedure Paint
(This : access Typ;
G1 : access Gnoga.Gui.Element.Canvas.Context_2D.Context_2D_Type);
-- procedure Update
-- (This : access Typ;
-- G : access Java.Awt.Graphics.Typ'Class);
procedure mouseReleased
(This : in out Base_Type'Class;
E : in Mouse_Event_Record);
-- pragma Convention (Java, MouseReleased);
-- procedure mouseClicked (This : access Typ;
-- P1 : access java.awt.event.MouseEvent.Typ'Class);
-- pragma Convention (Java, MouseClicked);
--
-- procedure mouseEntered (This : access Typ;
-- P1 : access java.awt.event.MouseEvent.Typ'Class);
-- pragma Convention (Java, MouseEntered);
--
-- procedure mouseExited (This : access Typ;
-- P1 : access java.awt.event.MouseEvent.Typ'Class);
-- pragma Convention (Java, MouseExited);
procedure mousePressed
(This : in out Base_Type'Class;
E : in Mouse_Event_Record);
-- pragma Convention (Java, MousePressed);
end ConnectFour;adablog-controller.ads
with Gnoga.Gui.Window;
with Gnoga.Application.Multi_Connect;
package AdaBlog.Controller is
procedure Index
(Main_Window : in out Gnoga.Gui.Window.Window_Type'Class;
Connection : access Gnoga.Application.Multi_Connect.Connection_Holder_Type);
procedure New_Entry
(Main_Window : in out Gnoga.Gui.Window.Window_Type'Class;
Connection : access Gnoga.Application.Multi_Connect.Connection_Holder_Type);
procedure Log_Out
(Main_Window : in out Gnoga.Gui.Window.Window_Type'Class;
Connection : access Gnoga.Application.Multi_Connect.Connection_Holder_Type);
end AdaBlog.Controller;adablog-controller.adb
with Ada.Calendar;
with Gnoga.Types;
with Gnoga.Gui.Base;
with Gnoga.Gui.Element;
with Gnoga.Gui.Element.Common;
with Gnoga.Gui.Element.Form;
with AdaBlog.View;
with AdaBlog.Model;
package body AdaBlog.Controller is
procedure On_Create_User (Object : in out Gnoga.Gui.Base.Base_Type'Class);
-- The create user button was clicked
procedure On_User_Login (Object : in out Gnoga.Gui.Base.Base_Type'Class);
-- User clicked the submit button for his user name and password
procedure On_Submit_Entry (Object : in out Gnoga.Gui.Base.Base_Type'Class);
-- User clicked the submit button to an a blog entry.
procedure On_Create_User (Object : in out Gnoga.Gui.Base.Base_Type'Class) is
Main_Window : aliased Gui.Window.Window_Type;
Message_Area : Gui.Element.Common.DIV_Type;
User_Login : Gui.Element.Common.Button_Type;
username : Gui.Element.Form.Text_Type;
password : Gui.Element.Form.Text_Type;
pass2 : Gui.Element.Form.Text_Type;
verify : Gui.Element.Common.DIV_Type;
User : AdaBlog.Model.Users.Active_Record;
begin
Main_Window.Attach (Object.Connection_ID);
Message_Area.Attach_Using_Parent (Main_Window, "message");
User_Login.Attach_Using_Parent (Main_Window, "login-button");
User_Login.Disabled;
username.Attach_Using_Parent (Main_Window, "username");
password.Attach_Using_Parent (Main_Window, "pass");
pass2.Attach_Using_Parent (Main_Window, "pass2");
verify.Attach_Using_Parent (Main_Window, "verify-pass");
verify.Display ("inline");
if Gnoga.String'(password.Value) /= Gnoga.String'(pass2.Value) or pass2.Value = "" then
Message_Area.Text ("Please verify password.");
return;
end if;
if username.Value = "" then
Message_Area.Text ("Username is required.");
return;
end if;
User.Find_Where ("username='" & username.Value & "'");
if User.Value ("id") /= "" then
Message_Area.Text ("Username is already taken.");
return;
end if;
User.Value ("username", Value => username.Value);
User.Value ("pass", Value => password.Value);
User.Value ("last_session", Value => Main_Window.Gnoga_Session_ID);
User.Save;
Main_Window.Location.URL ("/");
end On_Create_User;
procedure On_User_Login (Object : in out Gnoga.Gui.Base.Base_Type'Class) is
Main_Window : aliased Gui.Window.Window_Type;
Message_Area : Gui.Element.Common.DIV_Type;
username : Gui.Element.Form.Text_Type;
password : Gui.Element.Form.Text_Type;
User : AdaBlog.Model.Users.Active_Record;
begin
Main_Window.Attach (Object.Connection_ID);
Message_Area.Attach_Using_Parent (Main_Window, "message");
username.Attach_Using_Parent (Main_Window, "username");
password.Attach_Using_Parent (Main_Window, "pass");
User.Find_Where
(Where => "username ='" & username.Value & "'" & " AND " & "pass ='" & password.Value & "'",
Create_New => False);
User.Value ("last_session", Value => Main_Window.Gnoga_Session_ID);
User.Save;
Main_Window.Location.URL ("/");
exception
when others =>
Message_Area.Text ("Invalid Login");
end On_User_Login;
procedure On_Submit_Entry (Object : in out Gnoga.Gui.Base.Base_Type'Class) is
User : AdaBlog.Model.Users.Active_Record;
Entries : AdaBlog.Model.Blog_Entries.Active_Record;
Main_Window : aliased Gui.Window.Window_Type;
Text : Gnoga.Gui.Element.Form.Text_Area_Type;
begin
Main_Window.Attach (Object.Connection_ID);
Text.Attach_Using_Parent (Main_Window, "entry_text");
User.Find_Where ("last_session ='" & Main_Window.Gnoga_Session_ID & "'");
Entries.Value ("user_id", Value => User.Value ("id"));
Entries.Value ("entry_date", Date_Value => Ada.Calendar.Clock);
Entries.Value ("entry_text", Value => Text.Value);
Entries.Save;
Main_Window.Location.URL ("/");
end On_Submit_Entry;
procedure Index
(Main_Window : in out Gnoga.Gui.Window.Window_Type'Class;
Connection : access Gnoga.Application.Multi_Connect.Connection_Holder_Type)
is
Content_Area : Gui.Element.Common.DIV_Type;
Left_Area : Gui.Element.Common.DIV_Type;
User_Login : Gui.Element.Common.Button_Type;
Create_User : Gui.Element.Common.Button_Type;
User : AdaBlog.Model.Users.Active_Record;
procedure Display_Row (Row : Gnoga.Types.Data_Map_Type);
procedure Display_Row (Row : Gnoga.Types.Data_Map_Type) is
begin
AdaBlog.View.Display_Blog_Entry (Content_Area, Row);
end Display_Row;
begin
User.Find_Where ("last_session ='" & Main_Window.Gnoga_Session_ID & "'");
Main_Window.Disable_Auto_Set_View;
Content_Area.Create (Parent => Main_Window, ID => "main-body");
AdaBlog.Connection.Iterate
(SQL =>
"select username, entry_date, entry_text " & "from users, blog_entries " &
"where users.id=blog_entries.user_id",
Process => Display_Row'Unrestricted_Access);
View.User_Panel (Main_Window => Main_Window, Panel => Left_Area, User_Record => User.Values);
View.Template (Main_Window => Main_Window, Content => Content_Area, Left_Panel => Left_Area);
User_Login.Attach_Using_Parent (Main_Window, "login-button");
User_Login.On_Click_Handler (On_User_Login'Access);
Create_User.Attach_Using_Parent (Main_Window, "create-button");
Create_User.On_Click_Handler (On_Create_User'Access);
Connection.Hold;
end Index;
procedure New_Entry
(Main_Window : in out Gnoga.Gui.Window.Window_Type'Class;
Connection : access Gnoga.Application.Multi_Connect.Connection_Holder_Type)
is
User : AdaBlog.Model.Users.Active_Record;
Content_Area : Gui.Element.Common.DIV_Type;
Left_Area : Gui.Element.Common.DIV_Type;
Submit : Gui.Element.Common.Button_Type;
begin
User.Find_Where ("last_session ='" & Main_Window.Gnoga_Session_ID & "'");
if User.Value ("id") = "" then
Main_Window.Location.URL ("/");
return;
end if;
Main_Window.Disable_Auto_Set_View;
View.New_Entry_Form (Main_Window => Main_Window, Content => Content_Area);
View.User_Panel (Main_Window => Main_Window, Panel => Left_Area, User_Record => User.Values);
View.Template (Main_Window => Main_Window, Content => Content_Area, Left_Panel => Left_Area);
Submit.Attach_Using_Parent (Main_Window, "submit_entry");
Submit.On_Click_Handler (On_Submit_Entry'Access);
Connection.Hold;
end New_Entry;
procedure Log_Out
(Main_Window : in out Gnoga.Gui.Window.Window_Type'Class;
Connection : access Gnoga.Application.Multi_Connect.Connection_Holder_Type)
is
pragma Unreferenced (Connection);
User : AdaBlog.Model.Users.Active_Record;
begin
User.Find_Where ("last_session ='" & Main_Window.Gnoga_Session_ID & "'");
if User.Value ("id") /= "" then
User.Value ("last_session", "");
User.Save;
end if;
Main_Window.Location.URL ("/");
end Log_Out;
begin
Application.Multi_Connect.On_Connect_Handler (Controller.Index'Unrestricted_Access, "default");
Application.Multi_Connect.On_Connect_Handler (Controller.Index'Unrestricted_Access, "main");
Application.Multi_Connect.On_Connect_Handler (New_Entry'Unrestricted_Access, "new_entry");
Application.Multi_Connect.On_Connect_Handler (Log_Out'Unrestricted_Access, "logout");
end AdaBlog.Controller;connectfour.adb
--------------------------------------------------------------
-- Connect Four (TM) GNAPPLET
--
-- By: Barry Fagin and Martin Carlisle
-- US Air Force Academy, Department of Computer Science
-- mailto:carlislem@acm.org
--
-- 20150613 Adapted from JVM-GNAT to GNOGA by Pascal Pignard
-- http://blady.pagesperso-orange.fr
--
-- This is free software; you can redistribute it and/or
-- modify without restriction. We do ask that you please keep
-- the original author information, and clearly indicate if the
-- software has been modified.
--
-- This software 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.
--------------------------------------------------------------
-- with Java.Lang.String; use Java.Lang.String;
-- with Java; use Java;
-- with Java.Applet.Applet; use Java.Applet.Applet;
-- with Java.Awt.Color;
-- with Java.Awt.Dimension;
-- with Java.Awt.Graphics; use Java.Awt.Graphics;
-- with Java.Net.Url;
-- with Java.Awt.Component;
-- The following comments are adapted from the JGNAT Tic-Tac-Toe
-- example program (C) Ada Core Technologies
--
-- * In the Init function of your applet, you need to call
-- Adainit subprogram to elaborate your program. In the
-- case of this applet it's ada_connectfour.adainit.
--
-- To execute the applet, you need to run the Java appletviewer
-- or a Java-capable browser on an html file such as the following:
--
-- <html>
-- <head>
-- <title>Connect Four (TM) Game, written in Ada</title>
-- </head>
--
-- <body>
--
-- <h1>Built using JVM-GNAT, The Ada 2005 to JVM compiler </h1>
--
-- <P ALIGN=center>
--
-- <APPLET CODEBASE="."
-- CODE="connectfour$typ.class"
-- ARCHIVE="connectfour.jar"
-- WIDTH=500 HEIGHT=300>
-- Sorry, can't show the applet</APPLET>
--
-- </P>
--
-- <hr>
-- </body>
-- </html>
--
-- See the Makefile provided in the directory for this demo
-- for specific details on how to create and run the applet.
with Gnoga.Types.Colors;
with connectfour_messages.connectfour_Strings; use connectfour_messages.connectfour_Strings;
package body ConnectFour is
use all type Gnoga.String;
subtype String is Gnoga.String;
------------------------
-- Local Types & Data --
------------------------
-- Num_Rows : constant Integer := 6;
-- Num_Columns : constant Integer := 7;
-- Constants for the board size
-- type Player_Kind is (None, Computer, User);
-- None means that neither the computer, nor the user have selected that
-- circle, Computer indicates that the circle has been selected by the
-- computer and User means that the circle has been selected by the user.
-- data type for the Connect Four board
-- type Board_Array_Type is array (1 .. Num_Rows, 1 .. Num_Columns)
-- of Player_Kind;
-- This image is used for double-buffering. See the update
-- method.
-- Off_Screen_Buffer : access Java.Awt.Image.Typ'Class;
-- use type Java.Awt.Image.Ref;
-- globals that maintain state -> put in Typ record for concurrency
-- Board : Board_Array_Type; -- the current board
-- Is the game over, and if so who won?
-- Computer_Won : Boolean := False;
-- User_Won : Boolean := False;
-- Tie : Boolean := False;
-- if user clicks in full column, computer should not take a turn
-- Also computer should not take turn if user wins or tie.
-- Ignore_Turn : Boolean := False;
-- The following constants are used to define the layout of the
-- board. They define the horizontal and vertical spacing of the
-- circles drawn on the screen.
Ytop : constant := 20; -- highest pos on screen
Ybottom : constant := 279; -- lowest pos on screen
Xleft : constant := 0; -- leftmost pos on screen
Xright : constant := 499; -- rightmost pos on screen
Title_Offset : constant := 4; -- left move from center of column
Title_Height : constant := 12; -- height of column numbers
-- Both horizontally and vertically, there are circles and intervals
-- (or spaces) between the circles.
-- If there is half an interval on the left and right ends, then
-- there are 7 full intervals (because there are 6 full intervals
-- not counting the ends) horizontally
-- Now, assuming the intervals are 1/4th as wide as the circles
-- (The 1/4th is completely arbitrary),
-- then we need 7 + 7/4 (8 3/4) circles worth of space across the
-- screen.
Circle_Width : constant Float := Float (Xright - Xleft + 1) / 8.75;
X_Space : constant Float := Float (Xright - Xleft + 1) / 7.0;
-- the horizontal space between circle centers
X_First : constant Integer := Xleft + Integer (0.625 * Circle_Width);
-- the first x coordinate is to the middle of the first circle,
-- which is 1/8 circle size + 1/2 circle size (5/8)
-- Similarly, vertically there will be 6 full intervals, and again
-- assuming an interval is 1/4 as tall as the space for the circle,
-- we get 6 + 6/4 (7 1/2) circles vertically on the screen
Circle_Height : constant Float := Float (Ybottom - Ytop + 1) / 7.5;
Y_Space : constant Float := Float (Ybottom - Ytop + 1) / 6.0;
Y_First : constant Integer := Ytop + Integer (0.625 * Circle_Height);
-- column_breaks holds the x coordinates where the transition from
-- one column to the next occurs
-- That is, column_breaks(1) is the rightmost x coordinate where
-- you can click and still be in column 1
type Column_Breaks_Array_Type is array (1 .. Num_Columns) of Integer;
Column_Breaks : constant Column_Breaks_Array_Type :=
(Integer (1.25 * Circle_Width), Integer (2.5 * Circle_Width), Integer (3.75 * Circle_Width),
Integer (5.00 * Circle_Width), Integer (6.25 * Circle_Width), Integer (7.5 * Circle_Width),
Integer (8.75 * Circle_Width));
----------------------
-- Initialize_Board --
----------------------
-- Initializes board to all none
procedure Initialize_Board (Board : out Board_Array_Type);
procedure Initialize_Board (Board : out Board_Array_Type) is
begin
Board := (others => (others => None));
end Initialize_Board;
------------------------------------------------------------------------
--
-- Name : Place_Disk
-- Description : Determines the row in the given column at which
-- who's disk should be placed (in the lowest empty
-- row, where a lower row has a higher index). Puts
-- who at that row/column in the board, then calls
-- Draw_Position to update the screen.
--
------------------------------------------------------------------------
procedure Place_Disk
(Board : in out Board_Array_Type;
Column : in Integer;
Row : out Integer;
Who : in Player_Kind);
procedure Place_Disk
(Board : in out Board_Array_Type;
Column : in Integer;
Row : out Integer;
Who : in Player_Kind)
is
begin
Row := 1;
-- starting at the top, loop until you find an non-empty row
-- in this column
while (Row <= Num_Rows) and then (Board (Row, Column) = None) loop
Row := Row + 1;
end loop;
-- the new disk will be placed just above the first non-empty row
Row := Row - 1;
-- place the disk
Board (Row, Column) := Who;
end Place_Disk;
---------------
-- Check_Won --
---------------
-- Checks to see if Who won
procedure Check_Won
(Board : in Board_Array_Type;
Who : in Player_Kind;
Won : out Boolean);
procedure Check_Won
(Board : in Board_Array_Type;
Who : in Player_Kind;
Won : out Boolean)
is
begin
-- Set Won to false
Won := False;
-- Loop through all rows
for Row in Board'Range (1) loop
-- Loop through all columns
for Column in Board'Range (2) loop
-- (checking row to the right)
-- If column <= Num_Columns - 3
if (Column <= Num_Columns - 3) then
-- If current location and row, column+1;
-- row, column+2; and
-- row, column+3 belong to who
if (Board (Row, Column) = Who) and (Board (Row, Column + 1) = Who) and
(Board (Row, Column + 2) = Who) and (Board (Row, Column + 3) = Who)
then
-- Set Won to true
Won := True;
end if;
end if;
-- (checking column down)
-- If row <= Num_Rows - 3
if (Row <= Num_Rows - 3) then
-- If current location and row+1, column;
-- row+2, column; and
-- row+3, column belong to who
if (Board (Row, Column) = Who) and (Board (Row + 1, Column) = Who) and
(Board (Row + 2, Column) = Who) and (Board (Row + 3, Column) = Who)
then
-- Set Won to true
Won := True;
end if;
end if;
-- (checking diagonal up to right)
-- If row >= 4 and column <= Num_Columns - 3
if (Row >= 4) and (Column <= Num_Columns - 3) then
-- If current location and row-1, column+1;
-- row-2, column+2;
-- and row-3,column+3 belong to who
if (Board (Row, Column) = Who) and (Board (Row - 1, Column + 1) = Who) and
(Board (Row - 2, Column + 2) = Who) and (Board (Row - 3, Column + 3) = Who)
then
-- Set Won to true
Won := True;
end if;
end if;
-- (checking diagonal down to right)
-- If row <= Num_Rows - 3 and column <= Num_Columns - 3
if (Row <= Num_Rows - 3) and (Column <= Num_Columns - 3) then
-- If current location and row+1, column+1;
-- row+2, column+2;
-- and row+3,column+3 belong to who
if (Board (Row, Column) = Who) and (Board (Row + 1, Column + 1) = Who) and
(Board (Row + 2, Column + 2) = Who) and (Board (Row + 3, Column + 3) = Who)
then
-- Set Won to true
Won := True;
end if;
end if;
end loop;
end loop;
end Check_Won;
---------------
-- Check_Tie --
---------------
-- Checks to see if the game has ended in a tie (all columns are full)
procedure Check_Tie
(Board : in Board_Array_Type;
Is_Tie : out Boolean);
procedure Check_Tie
(Board : in Board_Array_Type;
Is_Tie : out Boolean)
is
begin
-- Set Is_Tie to True
Is_Tie := True;
-- If we find any row with top column empty, then
-- it is NOT a tie.
for Index in Board'Range (2) loop
if (Board (1, Index) = None) then
Is_Tie := False;
end if;
end loop;
end Check_Tie;
-------------------
-- Computer_Turn --
-------------------
-- Uses lookahead and live tuple heuristic
procedure Computer_Turn
(Board : in Board_Array_Type;
Column : out Integer);
procedure Computer_Turn
(Board : in Board_Array_Type;
Column : out Integer)
is
Lookahead_Depth : constant Integer := 5;
type Column_Breaks_Array_Type is array (1 .. Num_Columns) of Integer;
type Value_Type is -- need two ties for symmetry
(Illegal, Win_For_User, Tie_For_User, Unknown, Tie_For_Computer, Win_For_Computer);
type Value_Array_Type is array (1 .. Num_Columns) of Value_Type;
--------------------
-- Make_New_Board --
--------------------
procedure Make_New_Board
(New_Board : out Board_Array_Type;
Board : in Board_Array_Type;
Who : Player_Kind;
Column : Integer);
procedure Make_New_Board
(New_Board : out Board_Array_Type;
Board : in Board_Array_Type;
Who : Player_Kind;
Column : Integer)
is
Dummy_Row : Integer;
begin
New_Board := Board;
Place_Disk (New_Board, Column, Dummy_Row, Who);
end Make_New_Board;
----------------------
-- Find_Best_Result --
----------------------
function Find_Best_Result
(Evaluations : in Value_Array_Type;
Who : Player_Kind)
return Value_Type;
function Find_Best_Result
(Evaluations : in Value_Array_Type;
Who : Player_Kind)
return Value_Type
is
Best_Result : Value_Type;
begin
if Who = Computer then
-- find "largest" move
Best_Result := Win_For_User;
for I in Evaluations'Range loop
if Evaluations (I) > Best_Result and Evaluations (I) /= Illegal then
Best_Result := Evaluations (I);
end if;
end loop;
else
-- Who = User, find "smallest" move
Best_Result := Win_For_Computer;
for I in Evaluations'Range loop
if Evaluations (I) < Best_Result and Evaluations (I) /= Illegal then
Best_Result := Evaluations (I);
end if;
end loop;
end if;
return Best_Result;
end Find_Best_Result;
------------------------
-- Weighting_Function --
------------------------
function Weighting_Function
(Arg : in Integer)
return Integer;
function Weighting_Function
(Arg : in Integer)
return Integer
is
begin
return (Arg * Arg * Arg);
-- use cubic for now
end Weighting_Function;
----------------------------
-- Evaluate_Unknown_Board --
----------------------------
function Evaluate_Unknown_Board
(Board : in Board_Array_Type)
return Integer;
function Evaluate_Unknown_Board
(Board : in Board_Array_Type)
return Integer
is
Owner : Player_Kind;
Cell : Player_Kind;
User_Count, Computer_Count, Board_Value : Integer;
Dead : Boolean;
begin
Board_Value := 0;
for Row in Board'Range (1) loop
for Column in Board'Range (2) loop
-- (checking horizontal tuples)
if (Column <= Num_Columns - 3) then
Owner := None;
User_Count := 0;
Computer_Count := 0;
Dead := False;
for I in 0 .. 3 loop
Cell := Board (Row, Column + I);
if Owner = None and Cell /= None then
Owner := Cell;
end if;
if (Cell = User and Owner = Computer) or (Cell = Computer and Owner = User) then
User_Count := 0;
Computer_Count := 0;
Dead := True;
end if;
if Cell = User and not Dead then
User_Count := User_Count + 1;
elsif Cell = Computer and not Dead then
Computer_Count := Computer_Count + 1;
end if;
end loop;
-- Computer count is positive, User count is negative so
-- that larger values are better for computer
Board_Value := Board_Value + Weighting_Function (Computer_Count) - Weighting_Function (User_Count);
end if;
-- (checking vertical tuples)
if (Row <= Num_Rows - 3) then
Owner := None;
User_Count := 0;
Computer_Count := 0;
Dead := False;
for I in 0 .. 3 loop
Cell := Board (Row + I, Column);
if Owner = None and Cell /= None then
Owner := Cell;
end if;
if (Cell = User and Owner = Computer) or (Cell = Computer and Owner = User) then
User_Count := 0;
Computer_Count := 0;
Dead := True;
end if;
if Cell = User and not Dead then
User_Count := User_Count + 1;
elsif Cell = Computer and not Dead then
Computer_Count := Computer_Count + 1;
end if;
end loop;
Board_Value := Board_Value + Weighting_Function (Computer_Count) - Weighting_Function (User_Count);
end if;
-- (checking diagonal tuples up to right)
if (Row >= Num_Rows / 2 + 1 and Column <= Num_Columns - 3) then
Owner := None;
User_Count := 0;
Computer_Count := 0;
Dead := False;
for I in 0 .. 3 loop
Cell := Board (Row - I, Column + I);
if Owner = None and Cell /= None then
Owner := Cell;
end if;
if (Cell = User and Owner = Computer) or (Cell = Computer and Owner = User) then
User_Count := 0;
Computer_Count := 0;
Dead := True;
end if;
if Cell = User and not Dead then
User_Count := User_Count + 1;
elsif Cell = Computer and not Dead then
Computer_Count := Computer_Count + 1;
end if;
end loop;
Board_Value := Board_Value + Weighting_Function (Computer_Count) - Weighting_Function (User_Count);
end if;
-- (checking diagonal tuples down to right)
if (Row <= Num_Rows - 3) and (Column <= Num_Columns - 3) then
Owner := None;
User_Count := 0;
Computer_Count := 0;
Dead := False;
for I in 0 .. 3 loop
Cell := Board (Row + I, Column + I);
if Owner = None and Cell /= None then
Owner := Cell;
end if;
if (Cell = User and Owner = Computer) or (Cell = Computer and Owner = User) then
User_Count := 0;
Computer_Count := 0;
Dead := True;
end if;
if Cell = User and not Dead then
User_Count := User_Count + 1;
elsif Cell = Computer and not Dead then
Computer_Count := Computer_Count + 1;
end if;
end loop;
Board_Value := Board_Value + Weighting_Function (Computer_Count) - Weighting_Function (User_Count);
end if;
end loop;
end loop;
return Board_Value;
end Evaluate_Unknown_Board;
--------------------
-- Evaluate_Board --
--------------------
function Evaluate_Board
(Board : in Board_Array_Type;
Who_Just_Moved : in Player_Kind;
Current_Depth : in Integer)
return Value_Type;
function Evaluate_Board
(Board : in Board_Array_Type;
Who_Just_Moved : in Player_Kind;
Current_Depth : in Integer)
return Value_Type
is
Computer_Won, User_Won, Is_Tie : Boolean;
Value : Value_Type;
Who_Moves_Next : Player_Kind;
New_Board : Board_Array_Type;
Evaluations : Value_Array_Type;
begin
Check_Won (Board => Board, Who => Computer, Won => Computer_Won);
if not Computer_Won then
Check_Won (Board => Board, Who => User, Won => User_Won);
if not User_Won then
Check_Tie (Board, Is_Tie);
end if;
end if;
if Computer_Won then
Value := Win_For_Computer;
elsif User_Won then
Value := Win_For_User;
elsif Is_Tie and Who_Just_Moved = User then
Value := Tie_For_User;
elsif Is_Tie and Who_Just_Moved = Computer then
Value := Tie_For_Computer;
elsif Current_Depth = 1 then
Value := Unknown;
else
-- Not a terminal node or end of lookahead, so recurse
if Who_Just_Moved = Computer then
Who_Moves_Next := User;
else
Who_Moves_Next := Computer;
end if;
for Col in Evaluations'Range loop
Evaluations (Col) := Illegal;
end loop;
for Col in Board'Range (2) loop
if Board (1, Col) = None then
Make_New_Board (New_Board, Board, Who_Moves_Next, Col);
Evaluations (Col) := Evaluate_Board (New_Board, Who_Moves_Next, Current_Depth - 1);
-- a/b pruning
exit when Evaluations (Col) = Win_For_Computer and Who_Moves_Next = Computer;
exit when Evaluations (Col) = Win_For_User and Who_Moves_Next = User;
else
Evaluations (Col) := Illegal;
end if;
end loop;
Value := Find_Best_Result (Evaluations, Who_Moves_Next);
end if;
return Value;
end Evaluate_Board;
--------------------
-- Find_Best_Move --
--------------------
function Find_Best_Move
(Evaluations : in Value_Array_Type;
Who : Player_Kind)
return Integer;
function Find_Best_Move
(Evaluations : in Value_Array_Type;
Who : Player_Kind)
return Integer
is
Best_Move : Integer;
Best_Result : Value_Type;
begin
if Who = Computer then
-- find "largest" move
Best_Result := Win_For_User;
for I in Evaluations'Range loop
if Evaluations (I) > Best_Result and Evaluations (I) /= Illegal then
Best_Result := Evaluations (I);
Best_Move := I;
end if;
end loop;
else
-- Who = User, find "smallest" move
Best_Result := Win_For_Computer;
for I in Evaluations'Range loop
if Evaluations (I) < Best_Result and Evaluations (I) /= Illegal then
Best_Result := Evaluations (I);
Best_Move := I;
end if;
end loop;
end if;
return Best_Move;
end Find_Best_Move;
-----------------------
-- Find_All_Unknowns --
-----------------------
procedure Find_All_Unknowns
(Evaluations : in Value_Array_Type;
Moves : out Column_Breaks_Array_Type;
Count : out Integer);
procedure Find_All_Unknowns
(Evaluations : in Value_Array_Type;
Moves : out Column_Breaks_Array_Type;
Count : out Integer)
is
begin
Count := 0;
for I in Evaluations'Range loop
if Evaluations (I) = Unknown then
Count := Count + 1;
Moves (Count) := I;
end if;
end loop;
end Find_All_Unknowns;
-- variables and body for "Computer_Turn"
New_Board : Board_Array_Type;
Evaluations : Value_Array_Type;
Moves_To_Unknown : Column_Breaks_Array_Type;
Count_Unknowns : Integer;
Value, Max_Value, Best_Move : Integer;
begin
Evaluations := (others => Illegal);
for Col in Board'Range (2) loop
if Board (1, Col) = None then
Make_New_Board (New_Board, Board, Computer, Col);
Evaluations (Col) := Evaluate_Board (New_Board, Computer, Lookahead_Depth);
-- a/b pruning
exit when Evaluations (Col) = Win_For_Computer;
else
Evaluations (Col) := Illegal;
end if;
end loop;
Column := Find_Best_Move (Evaluations, Computer);
-- Check if trapped, if so take best move at shallower depth
-- and hope for a mistake
if Evaluations (Column) = Win_For_User then
for Col in Board'Range (2) loop
if Board (1, Col) = None then
Make_New_Board (New_Board, Board, Computer, Col);
Evaluations (Col) := Evaluate_Board (New_Board, Computer, 2);
else
Evaluations (Col) := Illegal;
end if;
end loop;
Column := Find_Best_Move (Evaluations, Computer);
elsif Evaluations (Column) = Unknown then
-- If choosing from multiple unknown boards, apply heuristics. This
-- is where most of the strategy is.
Find_All_Unknowns (Evaluations, Moves_To_Unknown, Count_Unknowns);
Max_Value := -1_000;
for I in 1 .. Count_Unknowns loop
Make_New_Board (New_Board, Board, Computer, Moves_To_Unknown (I));
Value := Evaluate_Unknown_Board (New_Board);
if Value > Max_Value then
Max_Value := Value;
Best_Move := Moves_To_Unknown (I);
end if;
end loop;
-- unknown boards
Column := Best_Move;
end if;
-- picking from multiple unknown boards
exception
when others =>
Column := 1;
loop
exit when Board (1, Column) = None;
Column := Column + 1;
end loop;
end Computer_Turn;
----------
-- Init --
----------
procedure Repaint (This : access Typ);
procedure Init (This : access Typ) is
-- procedure Adainit;
-- pragma Import (Ada, Adainit, "ada_connectfour.adainit");
begin
-- Adainit;
-- The above call is needed for elaboration
-- Addmouselistener (This, This.I_Mouselistener);
This.The_Canvas.Create (This.all, 500, 350);
This.On_Mouse_Down_Handler (mousePressed'Access);
This.On_Mouse_Up_Handler (mouseReleased'Access);
Initialize_Board (Board => This.Board);
This.Computer_Won := False;
This.User_Won := False;
This.Tie := False;
This.Ignore_Turn := False;
This.User_Turn := True;
Gnoga.Gui.Window.Browser_Status_Bar (This.Main_Window.all, Format_CPYR (This.Locale));
Repaint (This);
This.Put_Line (Format_DEVP (This.Locale));
This.Put_Line (Format_INFO (This.Locale));
This.Put_Line (Format_ADPT (This.Locale));
end Init;
-----------
-- Paint --
-----------
procedure Paint
(This : access Typ;
G1 : access Gnoga.Gui.Element.Canvas.Context_2D.Context_2D_Type)
is
-- D : access Java.Awt.Dimension.Typ'Class := Getsize (This);
-- Xoff : Int := D.Width / 3;
-- Yoff : Int := D.Height / 3;
--------------------------------------------------------------
-- procedure Display_Text
--
-- display text in black at the given coordinates
--------------------------------------------------------------
procedure Display_Text
(X : in Integer;
Y : in Integer;
Text : in String);
procedure Display_Text
(X : in Integer;
Y : in Integer;
Text : in String)
is
begin
-- Setcolor(G1,Java.Awt.Color.Black);
G1.Stroke_Color (Gnoga.Types.Colors.Black);
G1.Fill_Color (Gnoga.Types.Colors.Black);
-- Drawstring(G1,+Text,X,Y);
G1.Stroke_Text (Text, X, Y);
end Display_Text;
--------------------------------------------------------------
-- procedure Draw_Line
--
-- display line in given color at the given coordinates
--------------------------------------------------------------
procedure Draw_Line
(X1 : in Integer;
Y1 : in Integer;
X2 : in Integer;
Y2 : in Integer;
Hue : Gnoga.Types.Colors.Color_Enumeration);
procedure Draw_Line
(X1 : in Integer;
Y1 : in Integer;
X2 : in Integer;
Y2 : in Integer;
Hue : Gnoga.Types.Colors.Color_Enumeration)
is
begin
-- Setcolor(G1,Hue);
G1.Stroke_Color (Hue);
-- Drawline(G1,X1,Y1,X2,Y2);
G1.Begin_Path;
G1.Move_To (X1, Y1);
G1.Line_To (X2, Y2);
G1.Stroke;
end Draw_Line;
--------------------------------------------------------------
-- procedure Draw_Circle
--
-- Draw a circle of the given color with given center
-- and radius. Will be filled based on filled parameter
--------------------------------------------------------------
procedure Draw_Circle
(X : in Integer;
Y : in Integer;
Radius : in Integer;
Hue : Gnoga.Types.Colors.Color_Enumeration;
Filled : in Boolean);
procedure Draw_Circle
(X : in Integer;
Y : in Integer;
Radius : in Integer;
Hue : Gnoga.Types.Colors.Color_Enumeration;
Filled : in Boolean)
is
begin
-- Setcolor(G1,Hue);
G1.Stroke_Color (Hue);
G1.Begin_Path;
if Filled then
G1.Fill_Color (Hue);
-- Filloval(G1,X-Radius,Y-Radius,2*Radius,2*Radius);
G1.Arc_Degrees (X, Y, Radius, 0.0, 360.0);
G1.Fill;
else
-- Drawoval(G1,X-Radius,Y-Radius,2*Radius,2*Radius);
G1.Arc_Degrees (X, Y, Radius, 0.0, 360.0);
end if;
G1.Stroke;
end Draw_Circle;
--------------------------------------------------------------
-- procedure Draw_Box
--
-- display rectangle in given color at the given coordinates
-- will be filled (vs. outline only) based on filled parameter
--------------------------------------------------------------
procedure Draw_Box
(X1 : in Integer;
Y1 : in Integer;
X2 : in Integer;
Y2 : in Integer;
Hue : Gnoga.Types.Colors.Color_Enumeration;
Filled : in Boolean);
procedure Draw_Box
(X1 : in Integer;
Y1 : in Integer;
X2 : in Integer;
Y2 : in Integer;
Hue : Gnoga.Types.Colors.Color_Enumeration;
Filled : in Boolean)
is
begin
-- Setcolor(G1,Hue);
G1.Stroke_Color (Hue);
if Filled then
G1.Fill_Color (Hue);
-- Fillrect(G1,X1,Y1,X2-X1,Y2-Y1);
G1.Fill_Rectangle ((X1, Y1, X2 - X1, Y2 - Y1));
else
-- Drawrect(G1,X1,Y1,X2-X1,Y2-Y1);
G1.Rectangle ((X1, Y1, X2 - X1, Y2 - Y1));
end if;
end Draw_Box;
------------------------------------------------------------------------
--
-- Name : Draw_Position
-- Description : Draws a disk with the appropriate color for the
-- given player at the given row and column
--
------------------------------------------------------------------------
procedure Draw_Position
(Who : in Player_Kind;
Row : in Integer;
Column : in Integer);
procedure Draw_Position
(Who : in Player_Kind;
Row : in Integer;
Column : in Integer)
is
-- for later
Color : Gnoga.Types.Colors.Color_Enumeration;
-- color of disk
Circle_Radius : Integer;
-- radius of disk
begin
-- Determine radius based on minimum of possible height/width
if Circle_Width < Circle_Height then
Circle_Radius := Integer (Circle_Width * 0.5);
else
Circle_Radius := Integer (Circle_Height * 0.5);
end if;
-- Determine color of disk
case Who is
when None =>
Color := Gnoga.Types.Colors.White;
when Computer =>
Color := Gnoga.Types.Colors.Red;
when User =>
Color := Gnoga.Types.Colors.Blue;
end case;
Draw_Circle
(X => X_First + Integer (Float (Column - 1) * X_Space), Y => Y_First + Integer (Float (Row - 1) * Y_Space),
Radius => Circle_Radius, Hue => Color, Filled => True);
end Draw_Position;
------------------------------------------------------------------------
--
-- Name : Print_Board
-- Description : Prints the board for the start of the game. This
-- procedure should NOT be called repeatedly. Rather,
-- this procedure is called once to draw the game board,
-- then draw_position is used to add player's disks as
-- the game progresses.
--
------------------------------------------------------------------------
procedure Print_Board (Board : in Board_Array_Type);
procedure Print_Board (Board : in Board_Array_Type) is
begin
-- change the screen color if the game is over.
if This.User_Won or This.Tie then
Draw_Box (X1 => 0, Y1 => 0, X2 => 499, Y2 => 299, Hue => Gnoga.Types.Colors.Pink, Filled => True);
elsif This.Computer_Won then
Draw_Box (X1 => 0, Y1 => 0, X2 => 499, Y2 => 299, Hue => Gnoga.Types.Colors.Gray, Filled => True);
else
Draw_Box (X1 => 0, Y1 => 0, X2 => 499, Y2 => 299, Hue => Gnoga.Types.Colors.Light_Gray, Filled => True);
end if;
-- Print column numbers
for Column in 1 .. Num_Columns loop
Display_Text
(X => X_First + Integer (Float (Column - 1) * X_Space) - Title_Offset, Y => Title_Height,
Text => From_ASCII (Character'Val (Column + 48)));
-- Draw vertical line between columns
if Column < Num_Columns then
Draw_Line
(X1 => Column_Breaks (Column), Y1 => Ytop, X2 => Column_Breaks (Column), Y2 => Ybottom,
Hue => Gnoga.Types.Colors.Black);
end if;
for Row in 1 .. Num_Rows loop
Draw_Position (Who => Board (Row, Column), Row => Row, Column => Column);
end loop;
end loop;
-- Print message if the game is over
if This.Computer_Won then
Display_Text (X => 0, Y => 285, Text => Format_IWIN (This.Locale));
elsif This.User_Won then
Display_Text (X => 0, Y => 285, Text => Format_YWIN (This.Locale));
elsif This.Tie then
Display_Text (X => 0, Y => 285, Text => Format_TIEG (This.Locale));
end if;
end Print_Board;
begin
Print_Board (This.Board);
end Paint;
-------------------------------------
-- procedure Update
--
-- uses an off screen image to double
-- buffer, thus smoothing drawing.
-------------------------------------
-- procedure Update (
-- This : access Typ;
-- G : access Java.Awt.Graphics.Typ'Class ) is
-- Gr : access Java.Awt.Graphics.Typ'Class;
-- Ignore : Java.Boolean;
-- begin
-- -- need to allocate Off_Screen_Buffer only once
-- if Off_Screen_Buffer = null then
-- Off_Screen_Buffer := CreateImage(This,500,300);
-- end if;
--
-- -- draw into the offscreen buffer
-- Gr := Java.Awt.Image.GetGraphics(Off_Screen_Buffer);
-- Paint (This, Gr);
--
-- -- copy offscreen buffer onto applet window
-- Ignore := Java.Awt.Graphics.DrawImage(
-- G,
-- Off_Screen_Buffer,
-- 0,
-- 0,
-- This.I_ImageObserver);
-- end Update;
-------------
-- Repaint --
-------------
procedure Repaint (This : access Typ) is
Context : aliased Gnoga.Gui.Element.Canvas.Context_2D.Context_2D_Type;
begin
Context.Get_Drawing_Context_2D (This.The_Canvas);
Paint (This, Context'Access);
end Repaint;
-------------------
-- GetAppletInfo --
-------------------
function GetAppletInfo
(This : access Typ)
return String
is
begin
return Format_INFO (This.Locale);
end GetAppletInfo;
-------------------
-- mouseReleased --
-------------------
procedure mouseReleased
(This : in out Base_Type'Class;
E : in Mouse_Event_Record)
is
pragma Unreferenced (E);
-- X : Integer := E.X;
-- Y : Integer := E.Y;
-- D : access Java.Awt.Dimension.Typ'Class := Getsize (This);
Column, Dummy_Row : Integer;
Self : constant access Typ := Typ (This)'Access;
begin
-- need to do this before checking won, since we use
-- this for user won.
if Self.Ignore_Turn then
return;
end if;
if Self.User_Won or Self.Computer_Won or Self.Tie then
Initialize_Board (Board => Self.Board);
Self.Computer_Won := False;
Self.User_Won := False;
Self.Tie := False;
Self.Ignore_Turn := False;
if Self.User_Turn then
Self.User_Turn := False;
Gnoga.Gui.Window.Browser_Status_Bar (Self.Main_Window.all, Format_IAMT (Self.Locale));
-- Let computer take turn
Computer_Turn (Board => Self.Board, Column => Column);
-- Place computer disk in the column
Place_Disk (Board => Self.Board, Column => Column, Who => Computer, Row => Dummy_Row);
else
Self.User_Turn := True;
end if;
Repaint (Self);
Gnoga.Gui.Window.Browser_Status_Bar (Self.Main_Window.all, Format_CPYR (Self.Locale));
return;
end if;
Gnoga.Gui.Window.Browser_Status_Bar (Self.Main_Window.all, Format_IAMT (Self.Locale));
-- Let computer take turn
Computer_Turn (Board => Self.Board, Column => Column);
-- Place computer disk in the column
Place_Disk (Board => Self.Board, Column => Column, Who => Computer, Row => Dummy_Row);
-- Check if computer won
Check_Won (Board => Self.Board, Who => Computer, Won => Self.Computer_Won);
-- Check for a Tie
Check_Tie (Board => Self.Board, Is_Tie => Self.Tie);
Repaint (Self);
Gnoga.Gui.Window.Browser_Status_Bar (Self.Main_Window.all, Format_CPYR (Self.Locale));
end mouseReleased;
------------------
-- mousePressed --
------------------
procedure mousePressed
(This : in out Base_Type'Class;
E : in Mouse_Event_Record)
is
X : constant Integer := E.X;
-- Y : Integer := E.Y;
-- D : access Java.Awt.Dimension.Typ'Class := Getsize (This);
Column, Dummy_Row : Integer;
Self : constant access Typ := Typ (This)'Access;
begin
-- don't place disk if game over
if Self.User_Won or Self.Computer_Won or Self.Tie then
Self.Ignore_Turn := False;
return;
end if;
-- look to see if this is a valid click location
-- if not, just ignore this click.
Column := -1;
for I in Self.Board'Range (2) loop
if X <= Column_Breaks (I) then
if Self.Board (1, I) = None then
Column := I;
end if;
exit;
end if;
end loop;
if Column <= 0 then
Self.Ignore_Turn := True;
return;
else
Self.Ignore_Turn := False;
end if;
-- Place user disk in the column
Place_Disk (Board => Self.Board, Column => Column, Who => User, Row => Dummy_Row);
-- Check if user won
Check_Won (Board => Self.Board, Who => User, Won => Self.User_Won);
Check_Tie (Board => Self.Board, Is_Tie => Self.Tie);
if Self.User_Won or Self.Tie then
Self.Ignore_Turn := True;
else
Gnoga.Gui.Window.Browser_Status_Bar (Self.Main_Window.all, Format_IAMT (Self.Locale));
end if;
Repaint (Self);
end mousePressed;
-- The functions below do nothing, but are required to override the ones
-- defined in the interface we are implementing (when they abstract).
-- Otherwise, the JVM would complain.
------------------
-- mouseClicked --
------------------
-- procedure Mouseclicked (
-- This : access Typ;
-- P1 : access Java.Awt.Event.Mouseevent.Typ'Class ) is
-- begin
-- null;
-- end Mouseclicked;
------------------
-- mouseEntered --
------------------
-- procedure Mouseentered (
-- This : access Typ;
-- P1 : access Java.Awt.Event.Mouseevent.Typ'Class ) is
-- begin
-- null;
-- end Mouseentered;
-----------------
-- mouseExited --
-----------------
-- procedure Mouseexited (
-- This : access Typ;
-- P1 : access Java.Awt.Event.Mouseevent.Typ'Class ) is
-- begin
-- null;
-- end Mouseexited;
end ConnectFour;connectfour_messages.ads
-- -*- coding: utf-8 -*-
--
-- Ada specification generated by ZBMCompile, V1.4.0 (r3199).
-- This is a generated file and should not be edited.
--
with ZanyBlue.Text.Catalogs;
with ZanyBlue.Text.Formatting;
with UXStrings;
package connectfour_messages is
use UXStrings;
subtype String is UXString;
-- Since the body calls the Initialize procedure, this package need
-- only be with'ed. Suppress any compiler warnings about an unused
-- with'ed package.
pragma Warnings (Off, connectfour_messages);
function Standard_Catalog return ZanyBlue.Text.Catalogs.Catalog_Type
renames ZanyBlue.Text.Formatting.Standard_Catalog;
function Facility (Index : Positive) return String;
-- The name of the Index'th Facility item compiled.
-- This routine is normally only used by generated accessor code.
function Facility_Count return Natural;
-- Numnber of Facility items compiled.
-- This routine is normally only used by generated accessor code.
function Key (Index : Positive) return String;
-- The name of the Index'th Key item compiled.
-- This routine is normally only used by generated accessor code.
function Key_Count return Natural;
-- Numnber of Key items compiled.
-- This routine is normally only used by generated accessor code.
procedure Initialize (
Catalog : ZanyBlue.Text.Catalogs.Catalog_Type := Standard_Catalog);
-- The catalog initialization routine: load the compiled messages into
-- a catalog.
end connectfour_messages;connectfour_messages.adb
-- -*- coding: utf-8 -*-
--
-- Ada implementation generated by ZBMCompile, V1.4.0 (r3199).
-- This is a generated file and should not be edited.
--
package body connectfour_messages is
package ZT renames ZanyBlue.Text;
package ZTC renames ZanyBlue.Text.Catalogs;
subtype Z is ZTC.ZBMCompile_Definition;
Facility_1 : aliased constant String := ""
& "connectfour"
& "";
Facilities : constant ZT.Constant_String_List (1 .. 1) := (
1 => Facility_1'Access);
Key_1 : aliased constant String := ""
& "ADPT"
& "";
Key_2 : aliased constant String := ""
& "APPE"
& "";
Key_3 : aliased constant String := ""
& "CPYR"
& "";
Key_4 : aliased constant String := ""
& "DEVP"
& "";
Key_5 : aliased constant String := ""
& "IAMT"
& "";
Key_6 : aliased constant String := ""
& "INFO"
& "";
Key_7 : aliased constant String := ""
& "IWIN"
& "";
Key_8 : aliased constant String := ""
& "TIEG"
& "";
Key_9 : aliased constant String := ""
& "YWIN"
& "";
Key_10 : aliased constant String := ""
& "TITL"
& "";
Keys : constant ZT.Constant_String_List (1 .. 10) := (
Key_1'Access,
Key_2'Access,
Key_3'Access,
Key_4'Access,
Key_5'Access,
Key_6'Access,
Key_7'Access,
Key_8'Access,
Key_9'Access,
Key_10'Access);
Locale_1 : aliased constant String := ""
& "";
Locale_2 : aliased constant String := ""
& "fr"
& "";
Locales : constant ZT.Constant_String_List (1 .. 2) := (
Locale_1'Access,
Locale_2'Access);
Pool_Data_1 : aliased constant String := ""
& "Adapted for GNOGA by Pascal Pignard (20150613).Application "
& "ended.Connect Four (TM) by Barry Fagin and Martin CarlisleD"
& "eveloped by Barry Fagin and Martin Carlisle, US Air Force A"
& "cademy.I am thinking...This Connect Four (TM) game was init"
& "ially coded in Ada 2005 and compiled with the JVM-GNAT comp"
& "iler.I win! - Press left mouse buttonTie Game! - Press Left"
& " Mouse ButtonYou win! - Press left mouse buttonAdapté pour "
& "GNOGA par Pascal Pignard (20150613).Application terminée.Pu"
& "issance 4 (TM) - Connect Four (TM) par Barry Fagin et Marti"
& "n CarlisleDéveloppé par Barry Fagin et Martin Carlisle, US "
& "Air Force Academy.Je réfléchis..."
& Unicode_Character'Val (16#000A#)
& "Ce jeu de Puissance 4 (TM) a été codé initialement en Ada 2"
& "005 et compilé avec le compilateur JVM-GNAT.J''ai gagné ! -"
& " Appuyez sur le bouton gauche de la sourisPartie nulle ! - "
& "Appuyez sur le bouton gauche de la sourisVous avez gagné ! "
& "- Appuyez sur le bouton gauche de la souris"
& "";
Pool : constant ZT.Static_Message_Pool_Type := Pool_Data_1'Access;
Messages : constant ZTC.ZBMCompile_List (1 .. 20) := (
Z'(First => 471, Last => 486,
Facility_Index => 1, Key_Index => 10,
Locale_Index => 2, Source_Locale_Index => 2),
-- ↦Puissance 4 (TM)
Z'(First => 542, Last => 608,
Facility_Index => 1, Key_Index => 4,
Locale_Index => 2, Source_Locale_Index => 2),
-- ↦Développé par Barry Fagin et Martin Carlisle, US Air Fo⤶
-- ↦rce Academy.
Z'(First => 66, Last => 82,
Facility_Index => 1, Key_Index => 10,
Locale_Index => 1, Source_Locale_Index => 1),
-- ↦Connect Four (TM)
Z'(First => 843, Last => 903,
Facility_Index => 1, Key_Index => 9,
Locale_Index => 2, Source_Locale_Index => 2),
-- ↦Vous avez gagné ! - Appuyez sur le bouton gauche de la ⤶
-- ↦souris
Z'(First => 368, Last => 401,
Facility_Index => 1, Key_Index => 9,
Locale_Index => 1, Source_Locale_Index => 1),
-- ↦You win! - Press left mouse button
Z'(First => 333, Last => 367,
Facility_Index => 1, Key_Index => 8,
Locale_Index => 1, Source_Locale_Index => 1),
-- ↦Tie Game! - Press Left Mouse Button
Z'(First => 785, Last => 842,
Facility_Index => 1, Key_Index => 8,
Locale_Index => 2, Source_Locale_Index => 2),
-- ↦Partie nulle ! - Appuyez sur le bouton gauche de la sou⤶
-- ↦ris
Z'(First => 450, Last => 470,
Facility_Index => 1, Key_Index => 2,
Locale_Index => 2, Source_Locale_Index => 2),
-- ↦Application terminée.
Z'(First => 66, Last => 117,
Facility_Index => 1, Key_Index => 3,
Locale_Index => 1, Source_Locale_Index => 1),
-- ↦Connect Four (TM) by Barry Fagin and Martin Carlisle
Z'(First => 48, Last => 65,
Facility_Index => 1, Key_Index => 2,
Locale_Index => 1, Source_Locale_Index => 1),
-- ↦Application ended.
Z'(First => 471, Last => 541,
Facility_Index => 1, Key_Index => 3,
Locale_Index => 2, Source_Locale_Index => 2),
-- ↦Puissance 4 (TM) - Connect Four (TM) par Barry Fagin et⤶
-- ↦ Martin Carlisle
Z'(First => 402, Last => 449,
Facility_Index => 1, Key_Index => 1,
Locale_Index => 2, Source_Locale_Index => 2),
-- ↦Adapté pour GNOGA par Pascal Pignard (20150613).
Z'(First => 1, Last => 47,
Facility_Index => 1, Key_Index => 1,
Locale_Index => 1, Source_Locale_Index => 1),
-- ↦Adapted for GNOGA by Pascal Pignard (20150613).
Z'(First => 625, Last => 727,
Facility_Index => 1, Key_Index => 6,
Locale_Index => 2, Source_Locale_Index => 2),
-- ↦Ce jeu de Puissance 4 (TM) a été codé initialement en A⤶
-- ↦da 2005 et compilé avec le compilateur JVM-GNAT.
Z'(First => 301, Last => 332,
Facility_Index => 1, Key_Index => 7,
Locale_Index => 1, Source_Locale_Index => 1),
-- ↦I win! - Press left mouse button
Z'(First => 201, Last => 300,
Facility_Index => 1, Key_Index => 6,
Locale_Index => 1, Source_Locale_Index => 1),
-- ↦This Connect Four (TM) game was initially coded in Ada ⤶
-- ↦2005 and compiled with the JVM-GNAT compiler.
Z'(First => 728, Last => 784,
Facility_Index => 1, Key_Index => 7,
Locale_Index => 2, Source_Locale_Index => 2),
-- ↦J''ai gagné ! - Appuyez sur le bouton gauche de la sour⤶
-- ↦is
Z'(First => 609, Last => 624,
Facility_Index => 1, Key_Index => 5,
Locale_Index => 2, Source_Locale_Index => 2),
-- ↦Je réfléchis...⏎
Z'(First => 185, Last => 200,
Facility_Index => 1, Key_Index => 5,
Locale_Index => 1, Source_Locale_Index => 1),
-- ↦I am thinking...
Z'(First => 118, Last => 184,
Facility_Index => 1, Key_Index => 4,
Locale_Index => 1, Source_Locale_Index => 1));
-- ↦Developed by Barry Fagin and Martin Carlisle, US Air Fo⤶
-- ↦rce Academy.
---------------
--- Facility --
---------------
function Facility (Index : Positive) return String is
begin
return Facilities (Index).all;
end Facility;
---------------------
--- Facility_Count --
---------------------
function Facility_Count return Natural is
begin
return Facilities'Length;
end Facility_Count;
----------------
-- Initialize --
----------------
procedure Initialize (Catalog : ZTC.Catalog_Type := Standard_Catalog) is
begin
ZTC.Initialize (Catalog, Messages, Pool, Facilities, Keys, Locales,
"connectfour_messages",
Pool_Data_1.Length, 903);
end Initialize;
----------
--- Key --
----------
function Key (Index : Positive) return String is
begin
return Keys (Index).all;
end Key;
----------------
--- Key_Count --
----------------
function Key_Count return Natural is
begin
return Keys'Length;
end Key_Count;
begin -- connectfour_messages
Initialize;
end connectfour_messages;connectfour_messages-connectfour_strings.ads
-- -*- coding: utf-8 -*-
--
-- Ada specification generated by ZBMCompile, V1.4.0 (r3199).
-- This is a generated file and should not be edited.
--
with ZanyBlue.Text.Catalogs;
with ZanyBlue.Text.Locales;
package connectfour_messages.connectfour_Strings is
use ZanyBlue.Text.Catalogs;
use ZanyBlue.Text.Locales;
function Format_ADPT (
Locale : Locale_Type := Current_Locale;
Catalog : Catalog_Type := Standard_Catalog) return String;
-- ↦Adapted for GNOGA by Pascal Pignard (20150613).
function Format_APPE (
Locale : Locale_Type := Current_Locale;
Catalog : Catalog_Type := Standard_Catalog) return String;
-- ↦Application ended.
function Format_CPYR (
Locale : Locale_Type := Current_Locale;
Catalog : Catalog_Type := Standard_Catalog) return String;
-- ↦Connect Four (TM) by Barry Fagin and Martin Carlisle
function Format_DEVP (
Locale : Locale_Type := Current_Locale;
Catalog : Catalog_Type := Standard_Catalog) return String;
-- ↦Developed by Barry Fagin and Martin Carlisle, US Air Fo⤶
-- ↦rce Academy.
function Format_IAMT (
Locale : Locale_Type := Current_Locale;
Catalog : Catalog_Type := Standard_Catalog) return String;
-- ↦I am thinking...
function Format_INFO (
Locale : Locale_Type := Current_Locale;
Catalog : Catalog_Type := Standard_Catalog) return String;
-- ↦This Connect Four (TM) game was initially coded in Ada ⤶
-- ↦2005 and compiled with the JVM-GNAT compiler.
function Format_IWIN (
Locale : Locale_Type := Current_Locale;
Catalog : Catalog_Type := Standard_Catalog) return String;
-- ↦I win! - Press left mouse button
function Format_TIEG (
Locale : Locale_Type := Current_Locale;
Catalog : Catalog_Type := Standard_Catalog) return String;
-- ↦Tie Game! - Press Left Mouse Button
function Format_TITL (
Locale : Locale_Type := Current_Locale;
Catalog : Catalog_Type := Standard_Catalog) return String;
-- ↦Connect Four (TM)
function Format_YWIN (
Locale : Locale_Type := Current_Locale;
Catalog : Catalog_Type := Standard_Catalog) return String;
-- ↦You win! - Press left mouse button
end connectfour_messages.connectfour_Strings;connectfour_messages-connectfour_strings.adb
-- -*- coding: utf-8 -*-
--
-- Ada implementation generated by ZBMCompile, V1.4.0 (r3199).
-- This is a generated file and should not be edited.
--
with ZanyBlue.Text.Arguments;
with ZanyBlue.Text.Formatting;
package body connectfour_messages.connectfour_Strings is
use ZanyBlue.Text.Arguments;
use ZanyBlue.Text.Formatting;
-----------------
-- Format_ADPT --
-----------------
function Format_ADPT (
Locale : Locale_Type := Current_Locale;
Catalog : Catalog_Type := Standard_Catalog) return String
is
begin
return Format (Facility (1), Key (1),
Empty_Argument_List, Locale, Catalog);
end Format_ADPT;
-----------------
-- Format_APPE --
-----------------
function Format_APPE (
Locale : Locale_Type := Current_Locale;
Catalog : Catalog_Type := Standard_Catalog) return String
is
begin
return Format (Facility (1), Key (2),
Empty_Argument_List, Locale, Catalog);
end Format_APPE;
-----------------
-- Format_CPYR --
-----------------
function Format_CPYR (
Locale : Locale_Type := Current_Locale;
Catalog : Catalog_Type := Standard_Catalog) return String
is
begin
return Format (Facility (1), Key (3),
Empty_Argument_List, Locale, Catalog);
end Format_CPYR;
-----------------
-- Format_DEVP --
-----------------
function Format_DEVP (
Locale : Locale_Type := Current_Locale;
Catalog : Catalog_Type := Standard_Catalog) return String
is
begin
return Format (Facility (1), Key (4),
Empty_Argument_List, Locale, Catalog);
end Format_DEVP;
-----------------
-- Format_IAMT --
-----------------
function Format_IAMT (
Locale : Locale_Type := Current_Locale;
Catalog : Catalog_Type := Standard_Catalog) return String
is
begin
return Format (Facility (1), Key (5),
Empty_Argument_List, Locale, Catalog);
end Format_IAMT;
-----------------
-- Format_INFO --
-----------------
function Format_INFO (
Locale : Locale_Type := Current_Locale;
Catalog : Catalog_Type := Standard_Catalog) return String
is
begin
return Format (Facility (1), Key (6),
Empty_Argument_List, Locale, Catalog);
end Format_INFO;
-----------------
-- Format_IWIN --
-----------------
function Format_IWIN (
Locale : Locale_Type := Current_Locale;
Catalog : Catalog_Type := Standard_Catalog) return String
is
begin
return Format (Facility (1), Key (7),
Empty_Argument_List, Locale, Catalog);
end Format_IWIN;
-----------------
-- Format_TIEG --
-----------------
function Format_TIEG (
Locale : Locale_Type := Current_Locale;
Catalog : Catalog_Type := Standard_Catalog) return String
is
begin
return Format (Facility (1), Key (8),
Empty_Argument_List, Locale, Catalog);
end Format_TIEG;
-----------------
-- Format_TITL --
-----------------
function Format_TITL (
Locale : Locale_Type := Current_Locale;
Catalog : Catalog_Type := Standard_Catalog) return String
is
begin
return Format (Facility (1), Key (10),
Empty_Argument_List, Locale, Catalog);
end Format_TITL;
-----------------
-- Format_YWIN --
-----------------
function Format_YWIN (
Locale : Locale_Type := Current_Locale;
Catalog : Catalog_Type := Standard_Catalog) return String
is
begin
return Format (Facility (1), Key (9),
Empty_Argument_List, Locale, Catalog);
end Format_YWIN;
end connectfour_messages.connectfour_Strings;connectfour.properties
#Connect Four en
ADPT=Adapted for GNOGA by Pascal Pignard (20150613).
APPE=Application ended.
CPYR=Connect Four (TM) by Barry Fagin and Martin Carlisle
DEVP=Developed by Barry Fagin and Martin Carlisle, US Air Force Academy.
IAMT=I am thinking...
INFO=This Connect Four (TM) game was initially coded in Ada 2005 and compiled with the JVM-GNAT compiler.
IWIN=I win\! - Press left mouse button
TIEG=Tie Game\! - Press Left Mouse Button
YWIN=You win\! - Press left mouse button
TITL=Connect Four (TM)connect_four.adb
-------------------------------------------------------------------------------
-- Main procedure for Connect Four web server
-- COPYRIGHT : 20150511 by Pascal Pignard
-- LICENCE : CeCILL V2.1 (http://www.cecill.info)
-- CONTACT : http://blady.pagesperso-orange.fr
-------------------------------------------------------------------------------
with Gnoga.Application;
with Gnoga.Application.Multi_Connect;
with Gnoga.Gui.Window;
with ConnectFour; use ConnectFour;
with connectfour_messages.connectfour_Strings; use connectfour_messages.connectfour_Strings;
with ZanyBlue.Text.Locales;
with Gnoga.Gui.Navigator;
with Gnoga.Server.Connection;
procedure Connect_Four is
use all type Gnoga.String;
procedure On_Connect
(Main_Window : in out Gnoga.Gui.Window.Window_Type'Class;
Connection : access Gnoga.Application.Multi_Connect.Connection_Holder_Type);
procedure On_Connect
(Main_Window : in out Gnoga.Gui.Window.Window_Type'Class;
Connection : access Gnoga.Application.Multi_Connect.Connection_Holder_Type)
is
Page : aliased Typ;
begin
Page.Create (Main_Window);
Page.Main_Window := Gnoga.Gui.Window.Window_Type (Main_Window)'Unchecked_Access;
Page.Locale :=
ZanyBlue.Text.Locales.Make_Locale_Narrow (Gnoga.Gui.Navigator.Language (Main_Window) & ".ISO8859-1");
Main_Window.Document.Title (Format_TITL (Page.Locale));
Gnoga.Server.Connection.HTML_On_Close (Main_Window.Connection_ID, Format_APPE (Page.Locale));
Init (Page'Access);
Connection.Hold;
end On_Connect;
begin
Gnoga.Application.Multi_Connect.Initialize;
Gnoga.Application.Multi_Connect.On_Connect_Handler (Event => On_Connect'Unrestricted_Access);
Gnoga.Application.Multi_Connect.Message_Loop;
end Connect_Four;Project file
with "settings.gpr";
with "gnoga.gpr";
with "zanyblue.gpr";
project Connect_Four is
for Object_Dir use Settings.Obj_Dir;
for Exec_Dir use Settings.Exe_Dir;
for Main use ("connect_four.adb");
for Create_Missing_Dirs use Settings'Create_Missing_Dirs;
package Compiler is
for Default_Switches ("Ada") use Settings.Compiler'Default_Switches ("Ada") & "-gnatyN";
end Compiler;
package Binder renames Settings.Binder;
package Linker renames Settings.Linker;
package Pretty_Printer renames Settings.Pretty_Printer;
end Connect_Four;