|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - downloadIndex: B T
Length: 37638 (0x9306)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦306851c02⟧
└─⟦this⟧
with Calendar;
with Text_Io;
with Button;
use Button;
with Draw;
use Draw;
with Main;
use Main;
with Ran1_Package;
use Ran1_Package;
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
with Xlbt_Basic;
use Xlbt_Basic;
with Xlbp_Graphics;
use Xlbp_Graphics;
with Xlbp_Keyboard_Control;
use Xlbp_Keyboard_Control;
package body Board is
------------------------------------------------------------------------------
-- Dragon - a version of Mah-Jongg for X Windows
--
-- Author: Gary E. Barnes March 1989
--
-- Board - Deals with the Mah-Jongg board. Setup and execution.
------------------------------------------------------------------------------
-- 05/30/90 GEB - Translate to Ada
------------------------------------------------------------------------------
Ran_Data : Ran1_Data;
--\f
procedure Write_Game (File : Text_Io.File_Type) is
------------------------------------------------------------------------------
-- file - Specifies a file open for write
--
-- Called to write out the current game context for later rereading.
------------------------------------------------------------------------------
Bp : Board_Position;
begin
S_Long_Io.Put (File, Score, Width => 0);
Text_Io.New_Line (File);
for Row in Board_Tiles'Range (1) loop
for Col in Board_Tiles'Range (2) loop
Bp := Board_Tiles (Row, Col);
for I in Bp.Tiles'Range loop
S_Long_Io.Put (File, S_Long (Bp.Tiles (0)), Width => 0);
Text_Io.Put (File, ' ');
end loop;
S_Long_Io.Put (File, S_Long (Bp.Level), Width => 0);
Text_Io.Put (File, ' ');
S_Long_Io.Put (File, S_Long (Bp.X), Width => 0);
Text_Io.Put (File, ' ');
S_Long_Io.Put (File, S_Long (Bp.Y), Width => 0);
Text_Io.New_Line (File);
end loop;
end loop;
end Write_Game;
--\f
procedure Read_Game (File : Text_Io.File_Type) is
------------------------------------------------------------------------------
-- file - Specifies a file open for reading
--
-- Called to read in a new current game context.
------------------------------------------------------------------------------
Bp : Board_Position;
begin
Click1 := null;
Click2 := null;
S_Long_Io.Get (File, Score);
Text_Io.Skip_Line (File);
for Row in Board_Tiles'Range (1) loop
for Col in Board_Tiles'Range (2) loop
Bp := Board_Tiles (Row, Col);
for I in Bp.Tiles'Range loop
S_Long_Io.Get (File, S_Long (Bp.Tiles (0)), Width => 0);
end loop;
Bp.Draw := True;
S_Long_Io.Get (File, S_Long (Bp.Level), Width => 0);
S_Long_Io.Get (File, S_Long (Bp.X), Width => 0);
S_Long_Io.Get (File, S_Long (Bp.Y), Width => 0);
Text_Io.Skip_Line (File);
end loop;
end loop;
end Read_Game;
--\f
procedure Pick_Tile (Avail : in out U_Char_Array; Pick : out U_Char) is
------------------------------------------------------------------------------
-- Avail - Specifies an [NTILES] array of available tiles. Unavailable
-- slots contain NO_TILE.
--
-- Called to pick a random tile from the Available tiles.
------------------------------------------------------------------------------
T : U_Char;
K : S_Long;
begin
----Pick a random starting place.
K := S_Long (Ran1 (Ran_Data) * Float (S_Long'Last / 2)) rem N_Tiles;
----Search until we find a non-NO_TILE slot.
while (Avail (K) = No_Tile) loop
K := K + 1;
if K = N_Tiles then
K := 0;
end if;
end loop;
----Return the tile we found and zap the slot.
T := Avail (K);
Avail (K) := No_Tile;
Pick := T;
end Pick_Tile;
--\f
procedure Set_Tile_Controls is
------------------------------------------------------------------------------
-- Called whenever the board has been reset or resized. We recalculate all of
-- the drawing controls for the tiles.
------------------------------------------------------------------------------
begin
----Now set up the control information for all of the tiles. The special
-- tiles are easy.
if Board_Tiles (Spec4_Row, Spec4_Col).Level > 0 then
Board_Tiles (Spec4_Row, Spec4_Col).X :=
Board_Tile0_X + 6 * (Tile_Width + 1) +
(Tile_Width + 1) / 2 + 4 * Side_X;
Board_Tiles (Spec4_Row, Spec4_Col).Y :=
Board_Tile0_Y + 3 * (Tile_Height + 1) +
(Tile_Height + 1) / 2 - 3 * Side_Y;
end if;
if Board_Tiles (Spec3_Row, Spec3_Col).Level > 0 then
Board_Tiles (Spec3_Row, Spec3_Col).X :=
Board_Tile0_X + 0 * (Tile_Width + 1);
Board_Tiles (Spec3_Row, Spec3_Col).Y :=
Board_Tile0_Y + 3 * (Tile_Height + 1) + (Tile_Height + 1) / 2;
end if;
if Board_Tiles (Spec2_Row, Spec2_Col).Level > 0 then
Board_Tiles (Spec2_Row, Spec2_Col).X :=
Board_Tile0_X + 13 * (Tile_Width + 1);
Board_Tiles (Spec2_Row, Spec2_Col).Y :=
Board_Tile0_Y + 3 * (Tile_Height + 1) + (Tile_Height + 1) / 2;
end if;
if Board_Tiles (Spec1_Row, Spec1_Col).Level > 0 then
Board_Tiles (Spec1_Row, Spec1_Col).X :=
Board_Tile0_X + 14 * (Tile_Width + 1);
Board_Tiles (Spec1_Row, Spec1_Col).Y :=
Board_Tile0_Y + 3 * (Tile_Height + 1) + (Tile_Height + 1) / 2;
end if;
----Do the more regular tiles.
for Row in S_Short range 0 .. 7 loop
for Col in reverse S_Short range 1 .. 12 loop
declare
Bp : Board_Position renames Board_Tiles (Row, Col);
begin
----Skip any tiles that don't exist.
if Bp.Level /= 0 then
----Set up the face x/y coordinates.
Bp.X := Board_Tile0_X + Col * (Tile_Width + 1);
Bp.Y := Board_Tile0_Y + Row * (Tile_Height + 1);
end if;
end;
end loop;
end loop;
end Set_Tile_Controls;
--\f
procedure Pick1 (Bp : Board_Position;
Avail : in out U_Char_Array) is
begin
Pick_Tile (Avail, Bp.Tiles (0));
Bp.Level := 1;
end Pick1;
procedure Pick2 (Bp : Board_Position;
Avail : in out U_Char_Array) is
begin
Pick_Tile (Avail, Bp.Tiles (0));
Pick_Tile (Avail, Bp.Tiles (1));
Bp.Level := 2;
end Pick2;
procedure Pick3 (Bp : Board_Position;
Avail : in out U_Char_Array) is
begin
Pick_Tile (Avail, Bp.Tiles (0));
Pick_Tile (Avail, Bp.Tiles (1));
Pick_Tile (Avail, Bp.Tiles (2));
Bp.Level := 3;
end Pick3;
procedure Pick4 (Bp : Board_Position;
Avail : in out U_Char_Array) is
begin
Pick_Tile (Avail, Bp.Tiles (0));
Pick_Tile (Avail, Bp.Tiles (1));
Pick_Tile (Avail, Bp.Tiles (2));
Pick_Tile (Avail, Bp.Tiles (3));
Bp.Level := 4;
end Pick4;
--\f
procedure Setup_New_Game is
------------------------------------------------------------------------------
-- Called to generate an all-new game.
------------------------------------------------------------------------------
Avail : U_Char_Array (0 .. N_Tiles - 1);
I : S_Long;
begin
----Clear the board.
for Row in S_Short range 0 .. N_Rows - 1 loop
for Col in S_Short range 0 .. N_Cols - 1 loop
declare
Bp : Board_Position renames Board_Tiles (Row, Col);
begin
Bp.Tiles (0) := No_Tile;
Bp.Tiles (1) := No_Tile;
Bp.Tiles (2) := No_Tile;
Bp.Tiles (3) := No_Tile;
Bp.Level := 0;
end;
end loop;
end loop;
----Mark all tiles as available.
I := 0;
for Row in S_Short range 0 .. 3 loop
Avail (I) := U_Char (Row + 1);
I := I + 1;
Avail (I) := U_Char (Row + 5);
I := I + 1;
for Col in S_Short range 8 .. N_Faces - 1 loop
Avail (I) := U_Char (1 + Col rem N_Faces);
I := I + 1;
end loop;
end loop;
if I /= N_Tiles then
Text_Io.Put_Line ("NTILES gak!");
end if;
----Fill in the "odd" tile slots.
Pick1 (Board_Tiles (Spec1_Row, Spec1_Col), Avail);
Pick1 (Board_Tiles (Spec2_Row, Spec2_Col), Avail);
Pick1 (Board_Tiles (Spec3_Row, Spec3_Col), Avail);
Pick1 (Board_Tiles (Spec4_Row, Spec4_Col), Avail);
for Col in S_Short range 1 .. 12 loop
Pick1 (Board_Tiles (0, Col), Avail);
Pick1 (Board_Tiles (7, Col), Avail);
end loop;
for Row in S_Short range 1 .. 6 loop
Pick1 (Board_Tiles (Row, 3), Avail);
Pick1 (Board_Tiles (Row, 10), Avail);
end loop;
for Row in S_Short range 2 .. 5 loop
Pick1 (Board_Tiles (Row, 2), Avail);
Pick1 (Board_Tiles (Row, 11), Avail);
end loop;
for Row in S_Short range 3 .. 4 loop
Pick1 (Board_Tiles (Row, 1), Avail);
Pick1 (Board_Tiles (Row, 12), Avail);
end loop;
----Now do the next square at level 2.
for Col in S_Short range 4 .. 9 loop
Pick2 (Board_Tiles (1, Col), Avail);
Pick2 (Board_Tiles (6, Col), Avail);
end loop;
for Row in S_Short range 2 .. 5 loop
Pick2 (Board_Tiles (Row, 4), Avail);
Pick2 (Board_Tiles (Row, 9), Avail);
end loop;
----Now do the next square at level 3.
for Col in S_Short range 5 .. 8 loop
Pick3 (Board_Tiles (2, Col), Avail);
Pick3 (Board_Tiles (5, Col), Avail);
end loop;
for Row in S_Short range 3 .. 4 loop
Pick3 (Board_Tiles (Row, 5), Avail);
Pick3 (Board_Tiles (Row, 8), Avail);
end loop;
----Now do the final square at level 4.
for Row in S_Short range 3 .. 4 loop
for Col in S_Short range 6 .. 7 loop
Pick4 (Board_Tiles (Row, Col), Avail);
end loop;
end loop;
----Now set up the control information for all of the tiles.
Set_Tile_Controls;
Score := N_Tiles;
end Setup_New_Game;
--\f
procedure Restart_Game (Event : X_Button_Press_Event) is
------------------------------------------------------------------------------
-- Called when the RESTART button is pressed. Restart the game.
------------------------------------------------------------------------------
begin
----Reset levels and remove hilites.
Click1 := null;
Click2 := null;
Score := N_Tiles;
for Row in S_Short range 0 .. N_Rows - 1 loop
for Col in S_Short range 0 .. N_Cols - 1 loop
declare
Bp : Board_Position renames Board_Tiles (Row, Col);
begin
if Bp.Tiles (3) /= No_Tile then
Bp.Level := 4;
elsif Bp.Tiles (2) /= No_Tile then
Bp.Level := 3;
elsif Bp.Tiles (1) /= No_Tile then
Bp.Level := 2;
else
if Bp.Tiles (0) /= No_Tile then
Bp.Level := 1;
else
Bp.Level := 0;
end if;
end if;
end;
end loop;
end loop;
----Finish setting up and then redraw everything.
Set_Tile_Controls;
X_Clear_Area (Dpy, Main.Board, 0, 0, 0, 0, True);
end Restart_Game;
--\f
procedure Set_Tile_Draw (Row : S_Short;
Col : S_Short) is
------------------------------------------------------------------------------
-- row - Specifies the row of the tile
-- col - Specifies the column of the tile
--
-- Called to set the "draw" flag on a tile. We also recursively set the
-- draw flag on anyone that needs to be redrawn because we are being redrawn.
------------------------------------------------------------------------------
Bp : Board_Position renames Board_Tiles (Row, Col);
begin
---If we don't exist or if we are already being redrawn then stop.
if Bp.Level = 0 or else Bp.Draw then
return;
end if;
----Redraw us. Redraw anyone to our left that has a height greater than ours
-- ecause their shadow/tile-face overlaps us.
Bp.Draw := True;
if Col > 0 and then
Board_Tiles (Row, Col - 1).Level > Bp.Level then
Set_Tile_Draw (Row, Col - 1);
end if;
----Redraw anyone below us that has a level greater than ours because their
-- hadow/tile-face overlaps us.
if Row < 7 and then
Board_Tiles (Row + 1, Col).Level > Bp.Level then
Set_Tile_Draw (Row + 1, Col);
end if;
----Redraw anyone below-to-the-left of us.
if Row < 7 and then
Col > 0 and then
Board_Tiles (Row + 1, Col - 1).Level > 0 then
Set_Tile_Draw (Row + 1, Col - 1);
end if;
----Redraw anyone above-to-the-left of us that has a level greater than ours
-- ecause their tile-face overlaps our tile-edge.
if Row > 0 and then
Col > 0 and then
Board_Tiles (Row - 1, Col - 1).Level /= Bp.Level then
Set_Tile_Draw (Row - 1, Col - 1);
end if;
----If we are certain specific tiles then we may need to set specific other
-- tiles.
if Row = 3 or else Row = 4 then
if Col = 6 or else Col = 7 then
Set_Tile_Draw (Spec4_Row, Spec4_Col);
elsif Col = 1 then
Set_Tile_Draw (Spec3_Row, Spec3_Col);
end if;
end if;
end Set_Tile_Draw;
--\f
procedure Remove_Tile (Bp : Board_Position;
Row : S_Short;
Col : S_Short) is
------------------------------------------------------------------------------
-- Called to remove the top tile of the indicated Board_Position.
------------------------------------------------------------------------------
begin
----If the tile just went away then clear the area and allow the window
-- ackground to shine through.
if Bp.Level = 1 then
if (Tile_Control and Shadow) /= 0 then
X_Clear_Area (Dpy, Main.Board, Bp.X, Bp.Y - Side_Y - Shadow_Y,
U_Short (Tile_Width + Side_X + 2 + Shadow_X),
U_Short (Tile_Height + Side_Y + 2 + Shadow_Y),
False);
else
X_Clear_Area (Dpy, Main.Board, Bp.X, Bp.Y - Side_Y,
U_Short (Tile_Width + Side_X + 2),
U_Short (Tile_Height + Side_Y + 2),
False);
end if;
else
declare
Sidex : S_Short := Side_X * Bp.Level;
Sidey : S_Short := Side_Y * Bp.Level;
begin
if (Tile_Control and Shadow) /= 0 then
X_Clear_Area
(Dpy, Main.Board, Bp.X + Sidex, Bp.Y - Sidey - Shadow_Y,
U_Short (Tile_Width + 2 + Shadow_X),
U_Short (Tile_Height + 2 + Shadow_Y),
False);
else
X_Clear_Area
(Dpy, Main.Board,
Bp.X + Sidex, Bp.Y - Sidey,
U_Short (Tile_Width + 2), U_Short (Tile_Height + 2),
False);
end if;
Set_Tile_Draw (Row, Col);
end;
end if;
Bp.Level := Bp.Level - 1;
----Schedule the surrounding tiles for redrawing.
if Col = Spec1_Col then
if Row = Spec4_Row then
Set_Tile_Draw (3, 6);
Set_Tile_Draw (3, 7);
Set_Tile_Draw (4, 6);
Set_Tile_Draw (4, 7);
return;
elsif Row = Spec3_Row then
Set_Tile_Draw (3, 1);
Set_Tile_Draw (4, 1);
return;
elsif Row = Spec2_Row then
Set_Tile_Draw (Spec1_Row, Spec1_Col);
Set_Tile_Draw (3, 12);
Set_Tile_Draw (4, 12);
return;
else
Set_Tile_Draw (Spec2_Row, Spec2_Col);
Set_Tile_Draw (3, 12);
Set_Tile_Draw (4, 12);
return;
end if;
end if;
if Col = 1 and then (Row = 3 or else Row = 4) then
Set_Tile_Draw (Spec3_Row, Spec3_Col);
end if;
if Col = 12 and then (Row = 3 or else Row = 4) then
Set_Tile_Draw (Spec2_Row, Spec2_Col);
end if;
if Row > 0 then
Set_Tile_Draw (Row - 1, Col + 1);
Set_Tile_Draw (Row - 1, Col);
if Col > 0 and then
Board_Tiles (Row - 1, Col).Level = 0 then
Set_Tile_Draw (Row - 1, Col - 1);
end if;
end if;
Set_Tile_Draw (Row, Col + 1);
if Col > 0 then
Set_Tile_Draw (Row, Col - 1);
end if;
if Row < 7 then
Set_Tile_Draw (Row + 1, Col);
if Col > 0 then
Set_Tile_Draw (Row + 1, Col - 1);
end if;
end if;
end Remove_Tile;
--\f
procedure Touch_Tile (Bp : Board_Position;
Row : S_Short;
Col : S_Short;
Event : X_Button_Press_Event) is
------------------------------------------------------------------------------
-- Called when we click on a specific tile. We decide what to do. For a
-- single click we hilite the tile unless we already have two tiles hilited.
-- For a "double" click with two tiles hilited we will remove both of the
-- tiles.
------------------------------------------------------------------------------
begin
----If there is no Click1 then this guy becomes it.
if Click1 = null then
Click1 := Bp;
Click1_Row := Row;
Click1_Col := Col;
Hilite_Tile (Row, Col);
return;
end if;
----If there is no Click2 then this guy becomes it unless he is already Click1.
if Click1 /= Bp then
if Click2_Row = Row and then
Click2_Col = Col and then
Click2_Time + Dragon_Resources.Double_Click >=
Event.Button.Time then
Click2 := Bp;
end if;
if Click2 = null then
Click2 := Bp;
Click2_Row := Row;
Click2_Col := Col;
Click2_Time := Event.Button.Time;
Hilite_Tile (Row, Col);
return;
end if;
----If this guy is not one Click1 and not Click2 then we have an error.
if Click2 /= Bp then
X_Bell (Dpy, 0);
return;
end if;
end if;
----If he double-clicks then remove both tiles.
if Click2 /= null and then
Click2_Time + Dragon_Resources.Double_Click >= Event.Button.Time then
One_Button_Hint := False;
Remove_Tile (Click1, Click1_Row, Click1_Col);
Click1 := null;
Remove_Tile (Click2, Click2_Row, Click2_Col);
Click2 := null;
Score := Score - 2;
Draw_All_Tiles;
return;
end if;
----2nd click on any tile means turn-it-off.
if Click1 = Bp then
declare
S : S_Short;
begin
Hilite_Tile (Click1_Row, Click1_Col);
Click1 := Click2;
S := Click1_Row;
Click1_Row := Click2_Row;
Click2_Row := S;
S := Click1_Col;
Click1_Col := Click2_Col;
Click2_Col := S;
Click2 := null;
end;
else
Click2 := null;
Hilite_Tile (Click2_Row, Click2_Col);
end if;
Click2_Time := Event.Button.Time;
end Touch_Tile;
--\f
procedure Tile_Remove (Event : X_Button_Press_Event) is
------------------------------------------------------------------------------
-- Called when the remove-selected-tile-pair mouse button is pressed.
------------------------------------------------------------------------------
begin
if Click1 /= null and then
Click2 /= null then
Click2_Time := Event.Button.Time;
Touch_Tile (Click2, Click2_Row, Click2_Col, Event);
end if;
end Tile_Remove;
--\f
function Touch (Bp : Board_Position;
Event : X_Button_Press_Event) return Boolean is
------------------------------------------------------------------------------
-- Return TRUE if this XButtonEvent touched this Board_Position.
------------------------------------------------------------------------------
Face_X : S_Short := Bp.X + Bp.Level * Side_X;
Face_Y : S_Short := Bp.Y - Bp.Level * Side_Y;
begin
----Does this tile exist?
if Bp.Level = 0 then
return False;
end if;
----Did we touch the face?
if Event.Button.X >= Face_X and then
Event.Button.X <= Face_X + Tile_Width + 1 and then
Event.Button.Y >= Face_Y and then
Event.Button.Y <= Face_Y + Tile_Height + 1 then
return True;
end if;
----Did we touch the side?
if Event.Button.X >= Bp.X and then
Event.Button.X <= Bp.X + Tile_Width + 1 and then
Event.Button.Y >= Bp.Y and then
Event.Button.Y <= Bp.Y + Tile_Height + 1 then
return True;
end if;
----Guess not.
return False;
end Touch;
--\f
procedure Tile_Press (Event : X_Button_Press_Event) is
------------------------------------------------------------------------------
-- Called when the Board receives a BtnDown event.
------------------------------------------------------------------------------
X : S_Short;
Y : S_Short;
Row : S_Short;
Col : S_Short;
begin
----Figure out a rough row/col coordinate for the click.
Y := Event.Button.Y - Board_Tile0_Y;
if Y < 0 then
return;
end if;
Row := Y / (Tile_Height + 1);
if Row > 7 then
return;
end if;
X := Event.Button.X - Board_Tile0_X;
if X < 0 then
return;
end if;
Col := X / (Tile_Width + 1);
if Col < 0 or else Row > 14 then
goto Touched;
end if;
----See if we are a special tile.
if Col = 0 then
if Touch (Board_Tiles (Spec3_Row, Spec3_Col), Event) then
Touch_Tile (Board_Tiles (Spec3_Row, Spec3_Col),
Spec3_Row, Spec3_Col, Event);
goto Touched;
end if;
goto Touched;
elsif Col = 13 then
if Touch (Board_Tiles (Spec2_Row, Spec2_Col), Event) then
Touch_Tile (Board_Tiles (Spec2_Row, Spec2_Col),
Spec2_Row, Spec2_Col, Event);
goto Touched;
end if;
if Touch (Board_Tiles (4, 12), Event) then
Touch_Tile (Board_Tiles (4, 12), 4, 12, Event);
goto Touched;
end if;
if Touch (Board_Tiles (3, 12), Event) then
Touch_Tile (Board_Tiles (3, 12), 3, 12, Event);
goto Touched;
end if;
goto Touched;
elsif Col = Spec1_Col then
if Touch (Board_Tiles (Spec1_Row, Spec1_Col), Event) then
Touch_Tile (Board_Tiles (Spec1_Row, Spec1_Col),
Spec1_Row, Spec1_Col, Event);
goto Touched;
end if;
if Touch (Board_Tiles (Spec2_Row, Spec2_Col), Event) then
Touch_Tile (Board_Tiles (Spec2_Row, Spec2_Col),
Spec2_Row, Spec2_Col, Event);
goto Touched;
end if;
goto Touched;
elsif (Row = 3 or else Row = 4) and then (Col = 6 or else Col = 7) then
if Touch (Board_Tiles (Spec4_Row, Spec4_Col), Event) then
Touch_Tile (Board_Tiles (Spec4_Row, Spec4_Col),
Spec4_Row, Spec4_Col, Event);
goto Touched;
end if;
end if;
----See if the x/y falls exactly into somebody else's tile face.
if Col > 0 and then Row < 7 then
if Touch (Board_Tiles (Row + 1, Col - 1), Event) then
Touch_Tile (Board_Tiles (Row + 1, Col - 1),
Row + 1, Col - 1, Event);
goto Touched;
end if;
end if;
if Row < 7 then
if Touch (Board_Tiles (Row + 1, Col), Event) then
Touch_Tile (Board_Tiles (Row + 1, Col), Row + 1, Col, Event);
goto Touched;
end if;
end if;
if Col > 0 then
if Touch (Board_Tiles (Row, Col - 1), Event) then
Touch_Tile (Board_Tiles (Row, Col - 1), Row, Col - 1, Event);
goto Touched;
end if;
end if;
----We don't have a touch on a neighbor so it must be us.
if Touch (Board_Tiles (Row, Col), Event) then
Touch_Tile (Board_Tiles (Row, Col), Row, Col, Event);
goto Touched;
end if;
<<Touched>> null;
end Tile_Press;
--\f
function Tile_Not_Free (Row : S_Short;
Col : S_Short) return Boolean is
------------------------------------------------------------------------------
-- Returns TRUE if the tile has neither a left nor a right side free.
------------------------------------------------------------------------------
begin
-- -- --The 4 in the center can be covered by SPEC4.
if Row = 3 or else Row = 4 then
if (Col = 6 or else Col = 7) and then
Board_Tiles (Spec4_Row, Spec4_Col).Level > 0 then
return True;
elsif Col = 1 and then
Board_Tiles (Spec3_Row, Spec3_Col).Level > 0 and then
Board_Tiles (Row, Col + 1).Level > 0 then
return True;
elsif Col = 12 and then
Board_Tiles (Spec2_Row, Spec2_Col).Level > 0 and then
Board_Tiles (Row, Col - 1).Level > 0 then
return True;
end if;
end if;
----If a tile has a neighbor then he isn't free.
if Board_Tiles (Row, Col - 1).Level >=
Board_Tiles (Row, Col).Level and then
Board_Tiles (Row, Col + 1).Level >= Board_Tiles (Row, Col).Level then
return True;
end if;
----Check the special tiles.
if Col = Spec1_Col then
----Tiles 1, 3, and 4 are always free.
if Row /= Spec2_Row then
return False;
end if;
----Tile 2 is free if tile 1 is gone or if its two normal neighbors are gone.
if Board_Tiles (Spec1_Row, Spec1_Col).Level > 0 and then
(Board_Tiles (3, 12).Level > 0 or else
Board_Tiles (4, 12).Level > 0) then
return True;
end if;
end if;
return False;
end Tile_Not_Free;
--\f
procedure Tile_Release (Event : X_Button_Release_Event) is
------------------------------------------------------------------------------
-- Called when the Board receives a BtnUp event.
------------------------------------------------------------------------------
Tile1 : U_Char;
Tile2 : U_Char;
begin
----If there is a Click2 and if the tile type does not match with Click1 then
----nhilite Click2.
if not Cheating and then
Click1 /= null and then
Click2 /= null then
Tile1 := Click1.Tiles (S_Long (Click1.Level - 1));
Tile2 := Click2.Tiles (S_Long (Click2.Level - 1));
if -- Do tile faces match for those types that must match exactly?
((Tile1 > 8 or else Tile2 > 8) and then
Tile1 /= Tile2) or else
-- Are both tiles seasons?
(Tile1 <= 4 and then Tile2 > 4) or else
-- Are both tiles flowers?
(Tile1 >= 5 and then
Tile1 <= 8 and then
(Tile2 < 5 or else Tile2 > 8)) then
-- They don't match.
if Dragon_Resources.Sticky_Tile then
-- Simply remove tile 2 from selected tiles.
Hilite_Tile (Click2_Row, Click2_Col);
else
-- Remove tile 1 from selection and make tile 2 => tile 1.
Hilite_Tile (Click1_Row, Click1_Col);
Click1 := Click2;
Click1_Row := Click2_Row;
Click1_Col := Click2_Col;
Click2_Col := 0; -- Prevent dbl-clk removing 1 tile.
end if;
Click2 := null;
Click2_Time := 0;
end if;
end if;
----If this tile has a left or a right neighbor then he isn't allowed.
if not Cheating then
if Click2 /= null and then
Tile_Not_Free (Click2_Row, Click2_Col) then
Hilite_Tile (Click2_Row, Click2_Col);
Click2 := null;
Click2_Time := 0;
end if;
if Click1 /= null and then
Tile_Not_Free (Click1_Row, Click1_Col) then
Hilite_Tile (Click1_Row, Click1_Col);
Click1 := null;
end if;
end if;
end Tile_Release;
--\f
procedure Next_Tile (Click : U_Char;
Row : in out S_Short;
Col : in out S_Short) is
------------------------------------------------------------------------------
-- Returns the "next" tile past row/col that exists and is "free". Returns 0,0
-- when we run out of tiles.
------------------------------------------------------------------------------
Tile1 : U_Char;
Tile2 : U_Char;
begin
----Loop until we give up. Advance the column. Advance the row on column
-- verflow. Give up on row overflow.
<<Continue>> null;
Col := Col + 1;
if Col > 14 then
Col := 1;
Row := Row + 1;
if Row > 7 then
Row := 0;
Col := 0;
return;
end if;
end if;
----Check this tile. If it doesn't exist or isn't free then ignore it.
if Board_Tiles (Row, Col).Level = 0 then
goto Continue;
end if;
if Tile_Not_Free (Row, Col) then
goto Continue;
end if;
----If moving Click1 then return now.
if Click = 1 then
return;
end if;
----Continue the search if this tile does not match Click1.
Tile1 := Click1.Tiles (S_Long (Click1.Level - 1));
Tile2 := Board_Tiles (Row, Col).Tiles
(S_Long (Board_Tiles (Row, Col).Level - 1));
if -- Do tile faces match for those types that must match exactly?
((Tile1 > 8 or else Tile2 > 8) and then Tile1 /= Tile2) or else
-- Are both tiles seasons?
(Tile1 <= 4 and then Tile2 > 4) or else
-- Are both tiles flowers?
(Tile1 >= 5 and then Tile1 <= 8 and then
(Tile2 < 5 or else Tile2 > 8)) then
-- They don't match.
goto Continue;
end if;
end Next_Tile;
--\f
procedure Hints (Event : X_Button_Press_Event) is
------------------------------------------------------------------------------
-- If Click1 not present then search for the "first" remaining tile otherwise
-- use Click1 as our current "base" tile.
-- If Click1 present but not Click2 then search for any match for Click1.
-- If Click2 not present either then search for the first remaining tile past
-- Click1 otherwise search for the first remaining tile past Click2.
-- Keep searching for a new Click2 until we hit a matching tile or until we
-- run out. Exit on match with new tile as Click2.
-- Advance Click1 and start a new search for Click2. If we run out on Click1
-- then remove Click1.
------------------------------------------------------------------------------
begin
----If we have a Click1 but no Click2 then search for a Click2.
if Click1 /= null and then
Click2 = null then
One_Button_Hint := True;
Click2_Row := 0;
Click2_Col := 0;
loop
Next_Tile (2, Click2_Row, Click2_Col);
if Click2_Col = 0 then
One_Button_Hint := False;
Hilite_Tile (Click1_Row, Click1_Col);
Click1 := null;
return;
end if;
if Click2_Row /= Click1_Row or else
Click2_Col /= Click1_Col then
Click2 := Board_Tiles (Click2_Row, Click2_Col);
Hilite_Tile (Click2_Row, Click2_Col);
return;
end if;
end loop;
end if;
----Find a Click1 to work with if we don't already have one.
if Click1 = null then
Click1_Row := 0;
Click1_Col := 0;
Next_Tile (1, Click1_Row, Click1_Col);
if Click1_Col = 0 then
return;
end if;
Hilite_Tile (Click1_Row, Click1_Col);
Click1 := Board_Tiles (Click1_Row, Click1_Col);
end if;
----Find our starting position for Click2 if we don't have one.
if Click2 = null then
Click2_Row := Click1_Row;
Click2_Col := Click1_Col;
else
Hilite_Tile (Click2_Row, Click2_Col);
Click2 := null;
end if;
----Loop until we get something.
loop
Next_Tile (2, Click2_Row, Click2_Col);
if Click2_Col /= 0 then
if Click2_Row /= Click1_Row or else
Click2_Col /= Click1_Col then
Click2 := Board_Tiles (Click2_Row, Click2_Col);
Hilite_Tile (Click2_Row, Click2_Col);
return;
end if;
else
Hilite_Tile (Click1_Row, Click1_Col);
Click1 := null;
if One_Button_Hint then
One_Button_Hint := False;
return;
end if;
Next_Tile (1, Click1_Row, Click1_Col);
if Click1_Col = 0 then
return;
end if;
Hilite_Tile (Click1_Row, Click1_Col);
Click1 := Board_Tiles (Click1_Row, Click1_Col);
Click2_Row := Click1_Row;
Click2_Col := Click1_Col;
end if;
end loop;
end Hints;
--\f
begin
declare
Clk : Calendar.Day_Duration := Calendar.Seconds (Calendar.Clock);
I : Natural;
begin
I := Natural (Clk / Duration (100.0));
Clk := Calendar.Day_Duration
(Clk - Duration (Duration (I) * Duration (100.00)));
----Clk is now in the 0..99.9999 range.
Ran_Data := Ran1_Initialize
(S_Natural (Float (Clk) * Float (Natural'Last / 101)));
end;
end Board;