|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 71680 (0x11800)
Types: Ada Source
Notes: 03_class, FILE, Long Ada Source, R1k_Segment, e3_tag, package body Button, seg_005355
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦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);
--\x0c
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;
--\x0c
procedure Cheat (Event : X_Button_Press_Event) is
begin
Cheating := not Cheating;
end Cheat;
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
procedure Redraw_All (Event : X_Button_Press_Event) is
begin
X_Clear_Area (Dpy, Main.Board, 0, 0, 0, 0, True);
end Redraw_All;
--\x0c
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;
--\x0c
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;
--\x0c
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;
-- \x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
end Button;
nblk1=45
nid=0
hdr6=8a
[0x00] rec0=2c rec1=00 rec2=01 rec3=048
[0x01] rec0=19 rec1=00 rec2=02 rec3=000
[0x02] rec0=01 rec1=00 rec2=45 rec3=014
[0x03] rec0=13 rec1=00 rec2=03 rec3=05c
[0x04] rec0=00 rec1=00 rec2=44 rec3=004
[0x05] rec0=0f rec1=00 rec2=04 rec3=072
[0x06] rec0=18 rec1=00 rec2=05 rec3=06c
[0x07] rec0=01 rec1=00 rec2=43 rec3=006
[0x08] rec0=1d rec1=00 rec2=06 rec3=002
[0x09] rec0=25 rec1=00 rec2=07 rec3=026
[0x0a] rec0=19 rec1=00 rec2=08 rec3=05e
[0x0b] rec0=1f rec1=00 rec2=09 rec3=042
[0x0c] rec0=1a rec1=00 rec2=0a rec3=00c
[0x0d] rec0=1d rec1=00 rec2=0b rec3=058
[0x0e] rec0=1e rec1=00 rec2=0c rec3=02a
[0x0f] rec0=01 rec1=00 rec2=42 rec3=01a
[0x10] rec0=19 rec1=00 rec2=0d rec3=05c
[0x11] rec0=05 rec1=00 rec2=41 rec3=01c
[0x12] rec0=19 rec1=00 rec2=0e rec3=02e
[0x13] rec0=01 rec1=00 rec2=40 rec3=040
[0x14] rec0=1b rec1=00 rec2=0f rec3=010
[0x15] rec0=00 rec1=00 rec2=3f rec3=014
[0x16] rec0=1d rec1=00 rec2=10 rec3=09c
[0x17] rec0=25 rec1=00 rec2=11 rec3=034
[0x18] rec0=01 rec1=00 rec2=3e rec3=006
[0x19] rec0=1c rec1=00 rec2=12 rec3=002
[0x1a] rec0=00 rec1=00 rec2=3d rec3=004
[0x1b] rec0=1b rec1=00 rec2=13 rec3=020
[0x1c] rec0=00 rec1=00 rec2=3c rec3=006
[0x1d] rec0=1b rec1=00 rec2=14 rec3=00c
[0x1e] rec0=1d rec1=00 rec2=15 rec3=028
[0x1f] rec0=00 rec1=00 rec2=3b rec3=006
[0x20] rec0=1b rec1=00 rec2=16 rec3=016
[0x21] rec0=00 rec1=00 rec2=3a rec3=002
[0x22] rec0=18 rec1=00 rec2=17 rec3=052
[0x23] rec0=00 rec1=00 rec2=39 rec3=004
[0x24] rec0=1b rec1=00 rec2=18 rec3=012
[0x25] rec0=00 rec1=00 rec2=38 rec3=004
[0x26] rec0=1d rec1=00 rec2=19 rec3=012
[0x27] rec0=00 rec1=00 rec2=37 rec3=00c
[0x28] rec0=1a rec1=00 rec2=1a rec3=02e
[0x29] rec0=00 rec1=00 rec2=36 rec3=004
[0x2a] rec0=1c rec1=00 rec2=1b rec3=030
[0x2b] rec0=00 rec1=00 rec2=35 rec3=004
[0x2c] rec0=1f rec1=00 rec2=1c rec3=036
[0x2d] rec0=1c rec1=00 rec2=1d rec3=024
[0x2e] rec0=00 rec1=00 rec2=34 rec3=004
[0x2f] rec0=1f rec1=00 rec2=1e rec3=008
[0x30] rec0=1e rec1=00 rec2=1f rec3=024
[0x31] rec0=1c rec1=00 rec2=20 rec3=03c
[0x32] rec0=00 rec1=00 rec2=33 rec3=00c
[0x33] rec0=1c rec1=00 rec2=21 rec3=01c
[0x34] rec0=00 rec1=00 rec2=32 rec3=004
[0x35] rec0=1b rec1=00 rec2=22 rec3=006
[0x36] rec0=00 rec1=00 rec2=31 rec3=008
[0x37] rec0=1c rec1=00 rec2=23 rec3=00e
[0x38] rec0=00 rec1=00 rec2=30 rec3=004
[0x39] rec0=1e rec1=00 rec2=24 rec3=032
[0x3a] rec0=21 rec1=00 rec2=25 rec3=038
[0x3b] rec0=1e rec1=00 rec2=26 rec3=00c
[0x3c] rec0=18 rec1=00 rec2=27 rec3=04c
[0x3d] rec0=01 rec1=00 rec2=2f rec3=04a
[0x3e] rec0=18 rec1=00 rec2=28 rec3=03c
[0x3f] rec0=1a rec1=00 rec2=29 rec3=028
[0x40] rec0=12 rec1=00 rec2=2a rec3=006
[0x41] rec0=17 rec1=00 rec2=2b rec3=01a
[0x42] rec0=1b rec1=00 rec2=2c rec3=050
[0x43] rec0=19 rec1=00 rec2=2d rec3=01a
[0x44] rec0=08 rec1=00 rec2=2e rec3=000
tail 0x215009af6819787651e40 0x42a00088462063203