|
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 - downloadIndex: ┃ B T ┃
Length: 43711 (0xaabf)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─ ⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦306851c02⟧
└─⟦this⟧
with Text_Io;
with Board;
use Board;
with Draw;
use Draw;
with Main;
use Main;
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
with Xlbt_Basic;
use Xlbt_Basic;
with Xlbt_Event;
use Xlbt_Event;
with Xlbt_Graphics;
use Xlbt_Graphics;
with Xlbt_String;
use Xlbt_String;
with Xlbp_Event;
use Xlbp_Event;
with Xlbp_Graphics;
use Xlbp_Graphics;
with Xlbp_Keyboard_Control;
use Xlbp_Keyboard_Control;
with Xlbp_Proc_Var;
use Xlbp_Proc_Var;
with Xlbp_Sync;
use Xlbp_Sync;
with Xlbmp_Environment;
use Xlbmp_Environment;
package body Button is
-----------------------------------------------------------------------------
-- Dragon - a version of Mah-Jongg for X Windows
--
-- Author: Gary E. Barnes March 1989
--
-- Button - Deals with the command buttons on the board
------------------------------------------------------------------------------
-- 04/24/89 GEB - When "Other" pressed, if "Samples" is on then turn it off
-- - before changing button menus.
-- 05/30/90 GEB - Translate to Ada
------------------------------------------------------------------------------
type Action_Enum is (Call_Null, Call_New_Game, Call_Restart_Game,
Call_Save_Game, Call_Other, Call_Hints,
Call_Restore_Game, Call_Game_Exit,
Call_Redraw_All, Call_Sides,
Call_Show_Samples, Call_Cheat, Call_Sync_All);
type Button_Rec is
record
Text : X_String_Pointer;
Action : Action_Enum;
Toggle : Boolean;
Hilite : Boolean;
X : S_Short;
Y : S_Short;
Text_X : S_Short;
Text_Y : S_Short;
Border : X_Point_Array (0 .. 6 * 4 + 4 + 1);
end record;
type Button is access Button_Rec;
N_Buttons : constant := 8;
type Button_Array is array (S_Natural range 0 .. N_Buttons - 1) of Button;
type Button_2d_Array is array (S_Natural range 1 .. 2) of Button_Array;
Other_Button : constant := 3;
Samples_Button : constant := 2;
All_Buttons_Array : Button_2d_Array :=
((new Button_Rec'(new X_String'("New Game"), Call_New_Game,
False, False, 0, 0, 0, 0, (others => (0, 0))),
new Button_Rec'(new X_String'("Restart"), Call_Restart_Game,
False, False, 0, 0, 0, 0, (others => (0, 0))),
new Button_Rec'(new X_String'("Save"), Call_Save_Game, False,
False, 0, 0, 0, 0, (others => (0, 0))),
new Button_Rec'(new X_String'("Other"), Call_Other, True,
False, 0, 0, 0, 0, (others => (0, 0))),
new Button_Rec'(new X_String'("Hint"), Call_Hints, False,
False, 0, 0, 0, 0, (others => (0, 0))),
new Button_Rec'(new X_String'(""), Call_Null, False,
False, 0, 0, 0, 0, (others => (0, 0))),
new Button_Rec'(new X_String'("Restore"), Call_Restore_Game,
False, False, 0, 0, 0, 0, (others => (0, 0))),
new Button_Rec'(new X_String'("Quit"), Call_Game_Exit, False,
False, 0, 0, 0, 0, (others => (0, 0)))),
(new Button_Rec'(new X_String'("Redraw"), Call_Redraw_All,
False, False, 0, 0, 0, 0, (others => (0, 0))),
new Button_Rec'(new X_String'("Sides"), Call_Sides, False,
False, 0, 0, 0, 0, (others => (0, 0))),
new Button_Rec'(new X_String'("Samples"), Call_Show_Samples,
True, False, 0, 0, 0, 0, (others => (0, 0))),
new Button_Rec'(new X_String'("Other"), Call_Other, True,
False, 0, 0, 0, 0, (others => (0, 0))),
new Button_Rec'(new X_String'("Cheat"), Call_Cheat, True,
False, 0, 0, 0, 0, (others => (0, 0))),
new Button_Rec'(new X_String'("Sync"), Call_Sync_All, True,
False, 0, 0, 0, 0, (others => (0, 0))),
new Button_Rec'(new X_String'(""), Call_Null, False,
False, 0, 0, 0, 0, (others => (0, 0))),
new Button_Rec'(new X_String'(""), Call_Null, False,
False, 0, 0, 0, 0, (others => (0, 0)))));
All_Buttons : S_Long := 1;
Buttons1 : Button_Array renames All_Buttons_Array (1);
Buttons2 : Button_Array renames All_Buttons_Array (2);
Button_Width : S_Short := 0;
Button_Height : S_Short := 0;
Letter_Indent : S_Short := 0;
Letter_Height : S_Short := 0;
Letter_Width : S_Short := 0;
Onoff : Boolean := False;
procedure New_Game (Event : X_Button_Press_Event);
procedure Restore_Game (Event : X_Button_Press_Event);
--\f
procedure Call (What : Action_Enum;
Event : X_Button_Press_Event) is
begin
case What is
when Call_Null =>
raise Program_Error;
when Call_New_Game =>
New_Game (Event);
when Call_Restart_Game =>
Restart_Game (Event);
when Call_Save_Game =>
Save_Game (Event);
when Call_Other =>
Other (Event);
when Call_Hints =>
Hints (Event);
when Call_Restore_Game =>
Restore_Game (Event);
when Call_Game_Exit =>
Game_Exit (Event);
when Call_Redraw_All =>
Redraw_All (Event);
when Call_Sides =>
Sides (Event);
when Call_Show_Samples =>
Show_Samples (Event);
when Call_Cheat =>
Cheat (Event);
when Call_Sync_All =>
Sync_All (Event);
end case;
end Call;
--\f
procedure Cheat (Event : X_Button_Press_Event) is
begin
Cheating := not Cheating;
end Cheat;
--\f
procedure Game_Exit (Event : X_Button_Press_Event) is
------------------------------------------------------------------------------
-- Called when we want to exit.
------------------------------------------------------------------------------
Event2 : X_Event;
begin
loop
X_Next_Event (Dpy, Event2);
if Event2.Kind = Xlbt_Event.Button_Release then
exit;
end if;
end loop;
raise Quit;
end Game_Exit;
--\f
procedure New_Game (Event : X_Button_Press_Event) is
begin
Setup_New_Game;
X_Clear_Area (Dpy, Main.Board, 0, 0, 0, 0, True);
end New_Game;
--\f
procedure Other (Event : X_Button_Press_Event) is
------------------------------------------------------------------------------
-- Called to change button menus.
------------------------------------------------------------------------------
Expose : X_Expose_Event;
begin
if All_Buttons = 1 then
All_Buttons := 2;
else
-- --Turn off Samples mode if we are changing menus.
if Buttons2 (Samples_Button).Hilite then
Call ((Buttons2 (Samples_Button).Action), Event);
Buttons2 (Samples_Button).Hilite := False;
end if;
All_Buttons := 1;
end if;
All_Buttons_Array (All_Buttons) (Other_Button).Hilite :=
not All_Buttons_Array (All_Buttons) (Other_Button).Hilite;
X_Clear_Area (Dpy, Main.Board, 0, 0, 0,
U_Short (2 * Tile_Height - Side_Y - Shadow_Y - 1),
False);
Button_Expose;
end Other;
--\f
procedure Redraw_All (Event : X_Button_Press_Event) is
begin
X_Clear_Area (Dpy, Main.Board, 0, 0, 0, 0, True);
end Redraw_All;
--\f
procedure Restore_Game (Event : X_Button_Press_Event) is
------------------------------------------------------------------------------
-- Called to restore a previous game.
------------------------------------------------------------------------------
--/ if R1000 then
Name : constant X_String := X_Env_Concat_Dir_File
(X_Env_Get_Home_Dir, "dragon_save");
--/ else
--// Name : constant X_String :=
--// X_Env_Concat_Dir_File (X_Env_Get_Home_Dir, ".dragon-save");
--/ end if;
File : Text_Io.File_Type;
begin
begin
Text_Io.Open (File, Text_Io.In_File, To_String (Name));
exception
when others =>
Text_Io.Put_Line ("Cannot open the " & To_String (Name) &
" file for reading.");
X_Bell (Dpy, 100);
return;
end;
Read_Game (File);
Text_Io.Close (File);
Redraw_All (Event);
end Restore_Game;
--\f
procedure Save_Game (Event : X_Button_Press_Event) is
------------------------------------------------------------------------------
-- Called to save the current game.
------------------------------------------------------------------------------
--/ if R1000 then
Name : constant X_String := X_Env_Concat_Dir_File
(X_Env_Get_Home_Dir, "dragon_save");
--/ else
--// Name : constant X_String :=
--// X_Env_Concat_Dir_File (X_Env_Get_Home_Dir, ".dragon-save");
--/ end if;
File : Text_Io.File_Type;
begin
begin
Text_Io.Open (File, Text_Io.Out_File, To_String (Name));
exception
when others =>
begin
Text_Io.Create (File, Text_Io.Out_File, To_String (Name));
exception
when others =>
Text_Io.Put_Line ("Cannot open the " &
To_String (Name) &
" file for writing.");
X_Bell (Dpy, 100);
return;
end;
end;
Write_Game (File);
Text_Io.Close (File);
end Save_Game;
--\f
procedure Sides (Event : X_Button_Press_Event) is
begin
if (Tile_Control and Shadow) /= 0 then
if (Tile_Control and Blackside) /= 0 then
if (Tile_Control and Grayside) /= 0 then
Tile_Control :=
Tile_Control and not (Shadow or Blackside or Grayside);
else
Tile_Control := Tile_Control and not Shadow;
Tile_Control := Tile_Control or Grayside;
end if;
else
Tile_Control := Tile_Control and not Shadow;
Tile_Control := Tile_Control or Blackside;
end if;
else
Tile_Control := Tile_Control or Shadow;
end if;
X_Clear_Area (Dpy, Main.Board, 0, 0, 0, 0, True);
end Sides;
-- \f
procedure Sync_All (Event : X_Button_Press_Event) is
Void : Proc_Var_X_Synchandler.Pv;
begin
Onoff := not Onoff;
Dragon_Resources.Debug := Onoff;
Void := X_Synchronize (Dpy, Onoff);
end Sync_All;
--\f
procedure Do_Button_Configuration is
------------------------------------------------------------------------------
-- Called when the Board changes Tile sizes.
------------------------------------------------------------------------------
Buttons_Per_Line : constant := 4;
Indent : S_Short;
X, Dx : S_Short;
Y, Dy : S_Short;
I, J : S_Short;
F, S, T : S_Short;
L : S_Short;
Pnti : S_Natural;
But : Button;
procedure Pnt (X, Y : S_Short) is
begin
But.Border (Pnti).X := X;
But.Border (Pnti).Y := Y;
Pnti := Pnti + 1;
end Pnt;
begin
----Buttons will be three tiles wide and 2/3'rd of a tile high.
Button_Width := 3 * Tile_Width;
Dx := Button_Width + Tile_Width / 2;
Button_Height := 5 * Tile_Height / 9;
Dy := Tile_Height * 8 / 10;
----Letters are as large as can fit within the buttons.
Indent := Button_Height / 5;
Letter_Indent := Indent + 2;
S := Letter_Indent * 3 / 4;
T := S / 2;
F := Indent - S + T;
Letter_Height := Button_Height - (2 * Indent) - 2;
if (Letter_Height rem 2) = 0 then
Letter_Height := Letter_Height - 1;
end if;
Letter_Width := (Button_Width - (2 * Indent) - 2) / 8 - 2;
if (Letter_Width rem 2) = 0 then
Letter_Width := Letter_Width - 1;
end if;
----Now place the buttons.
for J in S_Natural range 1 .. 2 loop
X := Indent + 12;
Y := Indent + 4;
for I in All_Buttons_Array (J)'Range loop
But := All_Buttons_Array (J) (I);
if But.Text.all = "" then
goto Next_Button;
end if;
L := But.Text'Length;
if L > 8 then
Text_Io.Put_Line ("Button name too long: " &
To_String (But.Text.all));
L := 8;
end if;
But.X := X;
But.Y := Y;
But.Text_X := (Button_Width - L * (Letter_Width + 2) + 2) / 2;
But.Text_Y := Indent + 1;
Pnti := 0;
Pnt (X, Y + Indent);
Pnt (F, 0);
Pnt (0, -S);
Pnt (-T, 0);
Pnt (0, T);
Pnt (S, 0);
Pnt (0, -F);
Pnt (Button_Width - 2 * Indent, 0);
Pnt (0, F);
Pnt (S, 0);
Pnt (0, -T);
Pnt (-T, 0);
Pnt (0, S);
Pnt (F, 0);
Pnt (0, Button_Height - 2 * Indent);
Pnt (-F, 0);
Pnt (0, S);
Pnt (T, 0);
Pnt (0, -T);
Pnt (-S, 0);
Pnt (0, F);
Pnt (-(Button_Width - 2 * Indent), 0);
Pnt (0, -F);
Pnt (-S, 0);
Pnt (0, T);
Pnt (T, 0);
Pnt (0, -S);
Pnt (-F, 0);
Pnt (0, -Button_Height + 2 * Indent);
<<Next_Button>> null;
if I rem Buttons_Per_Line + 1 = Buttons_Per_Line then
X := Indent + 12;
Y := Y + Dy;
else
X := X + Dx;
end if;
end loop;
end loop;
end Do_Button_Configuration;
--\f
procedure Draw_Text (Str : X_String;
Px : S_Short;
Py : S_Short) is
------------------------------------------------------------------------------
-- Called to draw the vector text in some button.
------------------------------------------------------------------------------
X : S_Short := Px;
Y : S_Short := Py;
Pnts : X_Point_Array (0 .. 49);
Pnti : S_Long;
H1 : S_Short;
W1 : S_Short;
procedure Pnt (X, Y : S_Short) is
begin
Pnts (Pnti).X := X;
Pnts (Pnti).Y := Y;
Pnti := Pnti + 1;
end Pnt;
begin
----Position ourselves for the first letter.
H1 := Letter_Height - 1;
W1 := Letter_Width - 1;
----Loop over all letters in the text.
for Stri in Str'Range loop
Pnti := 0;
case Str (Stri) is
----The letters we have.
when '0' =>
declare
W6, H6, H26 : S_Short;
begin
H6 := H1 / 6;
H26 := H1 - 4 * H6;
W6 := W1 / 6;
Pnt (X, Y + H6 + H6);
Pnt (0, H26);
Pnt (W6, H6);
Pnt (W6, H6);
Pnt (W1 - 4 * W6, 0);
Pnt (W6, -H6);
Pnt (W6, -H6);
Pnt (0, -H26);
Pnt (-W6, -H6);
Pnt (-W6, -H6);
Pnt (-(W1 - 4 * W6), 0);
Pnt (-W6, H6);
Pnt (-W6, H6);
end;
when '1' =>
Pnt (X + (W1 + 1) / 2, Y);
Pnt (0, H1);
when '2' =>
declare
W6, W46, H6, H6r : S_Short;
begin
W6 := W1 / 6;
W46 := W1 - W6 - W6;
H6 := H1 / 6;
H6r := (H1 - H6 * 6) / 2;
Pnt (X, Y + H6);
Pnt (W6, -H6);
Pnt (W46, 0);
Pnt (W6, H6);
Pnt (0, H6 + H6r);
Pnt (-W6, H6);
Pnt (-W46, 0);
Pnt (-W6, H6);
Pnt (0, H1 - 5 * H6 - H6r);
Pnt (0, H6);
Pnt (W1, 0);
end;
when '3' =>
declare
W6, W46, H6, H6r : S_Short;
begin
W6 := W1 / 6;
W46 := W1 - W6 - W6;
H6 := H1 / 6;
H6r := (H1 - H6 * 6) / 2;
Pnt (X, Y + H6);
Pnt (W6, -H6);
Pnt (W46, 0);
Pnt (W6, H6);
Pnt (0, H6 + H6r);
Pnt (-W6, H6);
Pnt (-W46 / 2, 0);
Pnt (W46 / 2, 0);
Pnt (W6, H6);
Pnt (0, H1 - 5 * H6 - H6r);
Pnt (-W6, H6);
Pnt (-W46, 0);
Pnt (-W6, -H6);
end;
when '4' =>
declare
W23, H23 : S_Short;
begin
W23 := W1 * 2 / 3;
H23 := H1 * 2 / 3;
Pnt (X + W1, Y + H23);
Pnt (-W1, 0);
Pnt (W23, -H23);
Pnt (0, H1);
end;
when '5' =>
declare
W6, W46, H6, H6r : S_Short;
begin
W6 := W1 / 6;
W46 := W1 - W6 - W6;
H6 := H1 / 6;
H6r := (H1 - H6 * 6) / 2;
Pnt (X + W1, Y);
Pnt (-W1, 0);
Pnt (0, H1 - 3 * H6 - H6r);
Pnt (W1 - W6, 0);
Pnt (W6, H6);
Pnt (0, H6 + H6r);
Pnt (-W6, H6);
Pnt (-W46, 0);
Pnt (-W6, -H6);
end;
when '6' =>
declare
W6, W46, H6, H6r : S_Short;
begin
W6 := W1 / 6;
W46 := W1 - W6 - W6;
H6 := H1 / 6;
if ((H6 - W6) rem 2) = 1 then
H6 := H6 - 1;
end if;
H6r := (H1 - H6 * 6) / 2;
Pnt (X + W1, Y + H6);
Pnt (-W6, -H6);
Pnt (-W46, 0);
Pnt (-W6, H6);
Pnt (0, H1 - 2 * H6);
Pnt (W6, H6);
Pnt (W46, 0);
Pnt (W6, -H6);
Pnt (0, -H6 - H6r);
Pnt (-W6, -H6);
Pnt (-W46, 0);
Pnt (-W6, H6);
end;
when '7' =>
Pnt (X, Y);
Pnt (W1, 0);
Pnt (-W1, H1);
when '8' =>
declare
W6, W46, H6, H6r : S_Short;
begin
W6 := W1 / 6;
W46 := W1 - W6 - W6;
H6 := H1 / 6;
if ((H6 - W6) rem 2) = 1 then
H6 := H6 - 1;
end if;
H6r := (H1 - H6 * 6) / 2;
Pnt (X + W1, Y + H6);
Pnt (-W6, -H6);
Pnt (-W46, 0);
Pnt (-W6, H6);
Pnt (0, H6 + H6r);
Pnt (W6, H6);
Pnt (W46, 0);
Pnt (W6, H6);
Pnt (0, H1 - 5 * H6 - H6r);
Pnt (-W6, H6);
Pnt (-W46, 0);
Pnt (-W6, -H6);
Pnt (0, -H1 + 5 * H6 + H6r);
Pnt (W6, -H6);
Pnt (W46, 0);
Pnt (W6, -H6);
Pnt (0, -H6 - H6r);
end;
when '9' =>
declare
W6, W46, H6, H6r : S_Short;
begin
W6 := W1 / 6;
W46 := W1 - W6 - W6;
H6 := H1 / 6;
H6r := (H1 - H6 * 6) / 2;
Pnt (X, Y + H1 - H6);
Pnt (W6, H6);
Pnt (W46, 0);
Pnt (W6, -H6);
Pnt (0, -H1 + 2 * H6);
Pnt (-W6, -H6);
Pnt (-W46, 0);
Pnt (-W6, H6);
Pnt (0, H6 + H6r);
Pnt (W6, H6);
Pnt (W46, 0);
Pnt (W6, -H6);
end;
when 'a' | 'A' =>
declare
H2, W2, W5l, W5r : S_Short;
begin
H2 := H1 * 12 / 20;
W2 := (W1 + 1) / 2;
W5l := W1 / 5;
W5r := W1 - W5l;
Pnt (X, Y + H1);
Pnt (W5l, -(H1 - H2));
Pnt (W5r - W5l, 0);
Pnt (W2 - W5r, -H2);
Pnt (W5l - W2, H2);
Pnt (W5r - W5l, 0);
Pnt (W5l, H1 - H2);
end;
when 'b' | 'B' =>
declare
W6, H6 : S_Short;
H2 : S_Short;
begin
H2 := (H1 + 1) / 2;
W6 := W1 / 6;
H6 := H1 / 6;
Pnt (X, Y + H1);
Pnt (0, -H1);
Pnt (W1 - W6, 0);
Pnt (W6, H6);
Pnt (0, H2 - H6 - H6);
Pnt (-W6, H6);
Pnt (-(W1 - W6), 0);
Pnt (W1 - W6, 0);
Pnt (W6, H6);
Pnt (0, H1 - H2 - H6 - H6);
Pnt (-W6, H6);
Pnt (-(W1 - W6), 0);
end;
when 'c' | 'C' =>
declare
W6, W46, H6, H46 : S_Short;
begin
W6 := W1 / 6;
W46 := W1 - W6 - W6;
H6 := H1 / 6;
H46 := H1 - H6 - H6;
Pnt (X + W1, Y + H6);
Pnt (-W6, -H6);
Pnt (-W46, 0);
Pnt (-W6, H6);
Pnt (0, H46);
Pnt (W6, H6);
Pnt (W46, 0);
Pnt (W6, -H6);
end;
when 'd' | 'D' =>
declare
W6, W56, H6, H46 : S_Short;
begin
W6 := W1 / 6;
W56 := W1 - W6;
H6 := H1 / 6;
H46 := H1 - H6 - H6;
Pnt (X, Y);
Pnt (W56, 0);
Pnt (W6, H6);
Pnt (0, H46);
Pnt (-W6, H6);
Pnt (-W56, 0);
Pnt (0, -H1);
end;
when 'e' | 'E' =>
declare
H2, W2 : S_Short;
begin
H2 := (H1 + 1) / 2;
W2 := (W1 + 1) / 2;
Pnt (X + W1, Y);
Pnt (-W1, 0);
Pnt (0, H2);
Pnt (W2, 0);
Pnt (-W2, 0);
Pnt (0, H1 - H2);
Pnt (W1, 0);
end;
when 'f' | 'F' =>
declare
H2, W2 : S_Short;
begin
H2 := (H1 + 1) / 2;
W2 := (W1 + 1) / 2;
Pnt (X + W1, Y);
Pnt (-W1, 0);
Pnt (0, H2);
Pnt (W2, 0);
Pnt (-W2, 0);
Pnt (0, H1 - H2);
end;
when 'g' | 'G' =>
declare
W6, W46, H6, H46 : S_Short;
begin
W6 := W1 / 6;
W46 := W1 - W6 - W6;
H6 := H1 / 6;
H46 := H1 - H6 - H6;
Pnt (X + W1, Y + H6);
Pnt (-W6, -H6);
Pnt (-W46, 0);
Pnt (-W6, H6);
Pnt (0, H46);
Pnt (W6, H6);
Pnt (W46, 0);
Pnt (W6, -H6);
Pnt (0, H6 - (H1 + 1) / 2);
Pnt (-(W1 + 1) / 2, 0);
end;
when 'h' | 'H' =>
declare
H2 : S_Short := (H1 + 1) / 2;
begin
Pnt (X, Y);
Pnt (0, H1);
Pnt (0, -H2);
Pnt (W1, 0);
Pnt (0, H2);
Pnt (0, -H1);
end;
when 'i' | 'I' =>
declare
W2 : S_Short := (W1 + 1) / 2;
begin
Pnt (X, Y);
Pnt (W1, 0);
Pnt (-W2, 0);
Pnt (0, H1);
Pnt (-W2, 0);
Pnt (W1, 0);
end;
when 'k' | 'K' =>
declare
H2 : S_Short := (H1 + 1) / 2;
begin
Pnt (X, Y);
Pnt (0, H1);
Pnt (0, -H2);
Pnt (W1, -(H1 - H2));
Pnt (-W1, H1 - H2);
Pnt (W1, H2);
end;
when 'l' | 'L' =>
Pnt (X, Y);
Pnt (0, H1);
Pnt (W1, 0);
when 'm' | 'M' =>
declare
W2 : S_Short := (W1 + 1) / 2;
begin
Pnt (X, Y + H1);
Pnt (0, -H1);
Pnt (W2, H1);
Pnt (W1 - W2, -H1);
Pnt (0, H1);
end;
when 'n' | 'N' =>
Pnt (X, Y + H1);
Pnt (0, -H1);
Pnt (W1, H1);
Pnt (0, -H1);
when 'o' | 'O' =>
declare
W6, W46, H6, H46 : S_Short;
begin
W6 := W1 / 6;
W46 := W1 - W6 - W6;
H6 := H1 / 6;
H46 := H1 - H6 - H6;
Pnt (X + W1, Y + H6);
Pnt (-W6, -H6);
Pnt (-W46, 0);
Pnt (-W6, H6);
Pnt (0, H46);
Pnt (W6, H6);
Pnt (W46, 0);
Pnt (W6, -H6);
Pnt (0, -H46);
end;
when 'p' | 'P' =>
declare
W6, H6 : S_Short;
H2 : S_Short;
begin
H2 := (H1 + 1) / 2;
W6 := W1 / 6;
H6 := H1 / 6;
Pnt (X, Y + H1);
Pnt (0, -H1);
Pnt (W1 - W6, 0);
Pnt (W6, H6);
Pnt (0, H2 - H6 - H6);
Pnt (-W6, H6);
Pnt (-(W1 - W6), 0);
end;
when 'q' | 'Q' =>
declare
W6, W46, H6, H46 : S_Short;
begin
W6 := W1 / 6;
W46 := W1 - W6 - W6;
H6 := H1 / 6;
H46 := H1 - H6 - H6;
Pnt (X + W1, Y + H6);
Pnt (-W6, -H6);
Pnt (-W46, 0);
Pnt (-W6, H6);
Pnt (0, H46);
Pnt (W6, H6);
Pnt (W46, 0);
Pnt (-W6 - W6, -H6);
Pnt (W6 + W6, H6);
Pnt (W6, H6);
Pnt (-W6, -H6);
Pnt (W6, -H6);
Pnt (0, -H46);
end;
when 'r' | 'R' =>
declare
W6, H6 : S_Short;
H2 : S_Short;
begin
H2 := (H1 + 1) / 2;
W6 := W1 / 6;
H6 := H1 / 6;
Pnt (X, Y + H1);
Pnt (0, -H1);
Pnt (W1 - W6, 0);
Pnt (W6, H6);
Pnt (0, H2 - H6 - H6);
Pnt (-W6, H6);
Pnt (-(W1 - W6), 0);
Pnt (W1 - W6, 0);
Pnt (W6, H2);
end;
when 's' | 'S' =>
declare
W6, W46, H6, H6r : S_Short;
begin
W6 := W1 / 6;
W46 := W1 - W6 - W6;
H6 := H1 / 6;
H6r := (H1 - H6 * 6) / 2;
Pnt (X + W1, Y + H6);
Pnt (-W6, -H6);
Pnt (-W46, 0);
Pnt (-W6, H6);
Pnt (0, H6 + H6r);
Pnt (W6, H6);
Pnt (W46, 0);
Pnt (W6, H6);
Pnt (0, H6 + H6r);
Pnt (-W6, H6);
Pnt (-W46, 0);
Pnt (-W6, -H6);
end;
when 't' | 'T' =>
declare
W2 : S_Short := (W1 + 1) / 2;
begin
Pnt (X, Y);
Pnt (W1, 0);
Pnt (-W2, 0);
Pnt (0, H1);
end;
when 'u' | 'U' =>
declare
W6, H6, H56 : S_Short;
begin
W6 := W1 / 6;
H6 := H1 / 6;
H56 := H1 - H6;
Pnt (X, Y);
Pnt (0, H56);
Pnt (W6, H6);
Pnt (W1 - W6 - W6, 0);
Pnt (W6, -H6);
Pnt (0, -H56);
end;
when 'v' | 'V' =>
declare
W2 : S_Short;
begin
W2 := (W1 + 1) / 2;
Pnt (X, Y);
Pnt (W2, H1);
Pnt (W1 - W2, -H1);
end;
when 'w' | 'W' =>
declare
W4, W2 : S_Short;
begin
W4 := W1 / 4;
W2 := (W1 + 1) / 2;
Pnt (X, Y);
Pnt (W4, H1);
Pnt (W2 - W4, -H1);
Pnt (W1 - W2 - W4, H1);
Pnt (W4, -H1);
end;
when 'y' | 'Y' =>
declare
H2, W2 : S_Short;
begin
H2 := (H1 + 1) / 2;
W2 := (W1 + 1) / 2;
Pnt (X, Y);
Pnt (W2, H2);
Pnt (W1 - W2, -H2);
Pnt (-(W1 - W2), H2);
Pnt (-W2, H1 - H2);
end;
----Letters we don't have, and also blank.
when others =>
null; -- do nothing
end case;
----Draw the letter.
if Pnti > 0 then
X_Draw_Lines (Dpy, Main.Board.Drawable, Normal_Gc,
Pnts (0 .. Pnti - 1), Coord_Mode_Previous);
end if;
X := X + Letter_Width + 2;
end loop;
end Draw_Text;
--\f
procedure Draw_Score (Score : S_Long;
Px : S_Short;
Py : S_Short) is
------------------------------------------------------------------------------
-- Called to draw the score at x/y.
------------------------------------------------------------------------------
X : S_Short := Px;
Y : S_Short := Py;
Scr : X_String (1 .. 4);
W : S_Short := (Letter_Width + 2) * 3 + 4;
H : S_Short := Letter_Height + 6;
I, Lx, Ly : S_Short;
begin
if Score = 0 then
Letter_Height := Letter_Height * 3;
Letter_Width := Letter_Width * 3;
Lx := Board_Width / 6;
Ly := Board_Height / 2 - 2 * Letter_Height;
for I in reverse 1 .. 5 loop
Draw_Text ("You Win", Lx, Ly);
Lx := Lx + 2 * Letter_Width + 2;
Ly := Ly + Letter_Height + 5;
end loop;
Letter_Height := Letter_Height / 3;
Letter_Width := Letter_Width / 3;
end if;
Y := Y - H + 2;
X_Fill_Rectangle (Dpy, Main.Board.Drawable, Reverse_Gc,
X, Y, U_Short (W), U_Short (H));
X_Draw_Rectangle (Dpy, Main.Board.Drawable, Normal_Gc, X - 2,
Y - 2, U_Short (W + 4), U_Short (H + 4));
X_Draw_Rectangle (Dpy, Main.Board.Drawable, Normal_Gc, X - 1,
Y - 1, U_Short (W + 2), U_Short (H + 2));
X_Draw_Rectangle (Dpy, Main.Board.Drawable, Normal_Gc,
X, Y, U_Short (W), U_Short (H));
if Score > 99 then
Scr (1) := X_Character'Val (X_Character'Pos ('0') + Score / 100);
else
Scr (1) := ' ';
end if;
if Score > 9 then
Scr (2) := X_Character'Val
(X_Character'Pos ('0') + Score / 10 rem 10);
else
Scr (2) := ' ';
end if;
Scr (3) := X_Character'Val (X_Character'Pos ('0') + Score rem 10);
Scr (4) := X_Character'Val (8#000#);
Draw_Text (Scr, X + 3, Y + 3);
end Draw_Score;
--\f
procedure Hilite (But : Button) is
------------------------------------------------------------------------------
-- Xor the hilite pattern on the button indicated.
------------------------------------------------------------------------------
begin
X_Fill_Rectangle (Dpy, Main.Board.Drawable, Xor_Gc, But.X + 1,
But.Y + 1, U_Short (Button_Width - 1),
U_Short (Button_Height - 1));
end Hilite;
--\f
procedure Button_Expose is
------------------------------------------------------------------------------
-- Called when the Board receives an Expose event.
------------------------------------------------------------------------------
begin
----Loop over all buttons and display all "real" buttons.
for I in All_Buttons_Array (All_Buttons)'Range loop
if All_Buttons_Array (All_Buttons) (I).Text.all = "" then
goto Continue;
end if;
----Clear the space for the button and then draw the outline.
X_Fill_Rectangle (Dpy, Main.Board.Drawable, Reverse_Gc,
All_Buttons_Array (All_Buttons) (I).X,
All_Buttons_Array (All_Buttons) (I).Y,
U_Short (Button_Width + 1),
U_Short (Button_Height + 1));
X_Draw_Lines (Dpy, Main.Board.Drawable, Normal_Gc,
All_Buttons_Array (All_Buttons) (I).Border,
Coord_Mode_Previous);
----Draw the text of the button and then do hiliting if we need it.
Draw_Text (All_Buttons_Array (All_Buttons) (I).Text.all,
All_Buttons_Array (All_Buttons) (I).X +
All_Buttons_Array (All_Buttons) (I).Text_X,
All_Buttons_Array (All_Buttons) (I).Y +
All_Buttons_Array (All_Buttons) (I).Text_Y);
if All_Buttons_Array (All_Buttons) (I).Hilite then
Hilite (All_Buttons_Array (All_Buttons) (I));
end if;
<<Continue>> null;
end loop;
end Button_Expose;
--\f
procedure De_Hilite_All is
------------------------------------------------------------------------------
-- Called to take the hilite off of any and all buttons everywhere.
------------------------------------------------------------------------------
begin
for I in All_Buttons_Array (All_Buttons)'Range loop
if All_Buttons_Array (All_Buttons) (I).Text.all = "" then
goto Continue;
end if;
if All_Buttons_Array (All_Buttons) (I).Hilite and then
not All_Buttons_Array (All_Buttons) (I).Toggle then
All_Buttons_Array (All_Buttons) (I).Hilite := False;
Hilite (All_Buttons_Array (All_Buttons) (I));
X_Flush (Dpy);
end if;
<<Continue>> null;
end loop;
end De_Hilite_All;
--\f
procedure Button_Press (Event : X_Button_Press_Event) is
------------------------------------------------------------------------------
-- Called when the Board receives a BtnDown event.
------------------------------------------------------------------------------
begin
----First we make sure that nobody is hilited.
De_Hilite_All;
----See if some button just got clicked.
for I in All_Buttons_Array (All_Buttons)'Range loop
if All_Buttons_Array (All_Buttons) (I).Text.all = "" then
goto Continue;
end if;
if Event.Button.X >= All_Buttons_Array (All_Buttons) (I).X and then
Event.Button.X <= All_Buttons_Array (All_Buttons) (I).X +
Button_Width and then
Event.Button.Y >= All_Buttons_Array (All_Buttons) (I).Y and then
Event.Button.Y <= All_Buttons_Array (All_Buttons) (I).Y +
Button_Height then
----Hilite this button and then do whatever it is supposed to do.
All_Buttons_Array (All_Buttons) (I).Hilite :=
not All_Buttons_Array (All_Buttons) (I).Hilite;
Hilite (All_Buttons_Array (All_Buttons) (I));
X_Flush (Dpy);
Call (All_Buttons_Array (All_Buttons) (I).Action, Event);
exit;
end if;
<<Continue>> null;
end loop;
end Button_Press;
--\f
procedure Button_Release (Event : X_Button_Release_Event) is
------------------------------------------------------------------------------
-- Called when the Board receives a BtnUp event.
------------------------------------------------------------------------------
begin
----Turn off any and all button hilites.
De_Hilite_All;
end Button_Release;
--\f
end Button;