|
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: 23196 (0x5a9c)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─ ⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦306851c02⟧
└─⟦this⟧
with Text_Io;
--/ if TeleGen2 and then Unix then
--// with Process_Control; -- Unix process control
--/ end if;
with Board;
use Board;
with Button;
use Button;
with Draw;
use Draw;
with Icon;
use Icon;
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
with Xlbt_Basic;
use Xlbt_Basic;
with Xlbt_Cursor_Font;
use Xlbt_Cursor_Font;
with Xlbt_Event;
use Xlbt_Event;
with Xlbt_Gc;
use Xlbt_Gc;
with Xlbt_Hint;
use Xlbt_Hint;
with Xlbt_Geometry;
use Xlbt_Geometry;
with Xlbt_Key;
use Xlbt_Key;
with Xlbt_Misc;
use Xlbt_Misc;
with Xlbt_Pointer;
use Xlbt_Pointer;
with Xlbt_String;
use Xlbt_String;
with Xlbt_Window;
use Xlbt_Window;
with Xlbp_Bitmap;
use Xlbp_Bitmap;
with Xlbp_Cursor;
use Xlbp_Cursor;
with Xlbp_Display;
use Xlbp_Display;
with Xlbp_Event;
use Xlbp_Event;
with Xlbp_Gc;
use Xlbp_Gc;
with Xlbp_Geometry;
use Xlbp_Geometry;
with Xlbp_Hint;
use Xlbp_Hint;
with Xlbp_Window;
use Xlbp_Window;
package body Main is
------------------------------------------------------------------------------
-- Dragon - a version of Mah-Jongg for X Windows
--
-- Author: Gary E. Barnes March 1989
--
-- main.c - The mainline code.
------------------------------------------------------------------------------
-- 05/30/90 GEB - Translate to Ada
------------------------------------------------------------------------------
Background_Width : constant := 16;
Background_Height : constant := 16;
Background_X_Hot : constant := -1;
Background_Y_Hot : constant := -1;
Background_Bits : constant U_Char_Array :=
(16#40#, 16#00#, 16#02#, 16#00#, 16#00#, 16#00#, 16#00#, 16#80#,
16#00#, 16#04#, 16#20#, 16#00#, 16#01#, 16#00#, 16#00#, 16#00#,
16#00#, 16#40#, 16#00#, 16#02#, 16#10#, 16#00#, 16#00#, 16#00#,
16#00#, 16#00#, 16#00#, 16#20#, 16#00#, 16#01#, 16#08#, 16#00#);
Gray_Width : constant := 16;
Gray_Height : constant := 16;
Gray_X_Hot : constant := -1;
Gray_Y_Hot : constant := -1;
Gray_Bits : constant U_Char_Array :=
(16#55#, 16#55#, 16#AA#, 16#AA#, 16#55#, 16#55#, 16#AA#, 16#AA#,
16#55#, 16#55#, 16#AA#, 16#AA#, 16#55#, 16#55#, 16#AA#, 16#AA#,
16#55#, 16#55#, 16#AA#, 16#AA#, 16#55#, 16#55#, 16#AA#, 16#AA#,
16#55#, 16#55#, 16#AA#, 16#AA#, 16#55#, 16#55#, 16#AA#, 16#AA#);
Shadow_Width : constant := 16;
Shadow_Height : constant := 16;
Shadow_X_Hot : constant := -1;
Shadow_Y_Hot : constant := -1;
Shadow_Bits : constant U_Char_Array :=
(16#44#, 16#04#, 16#20#, 16#22#, 16#01#, 16#11#, 16#08#, 16#88#,
16#44#, 16#40#, 16#22#, 16#02#, 16#10#, 16#11#, 16#80#, 16#88#,
16#04#, 16#44#, 16#22#, 16#20#, 16#11#, 16#01#, 16#88#, 16#08#,
16#40#, 16#44#, 16#02#, 16#22#, 16#11#, 16#10#, 16#88#, 16#80#);
--\f
------------------------------------------------------------------------------
-- Dragon Resources
------------------------------------------------------------------------------
-- static s_long def_DCTime := 250; -- ms for double click
-- static boolean def_FALSE := false;
-- static boolean def_TRUE := True;
--
-- #define offset(field) XtOffset( Dragon_Resources_Ptr, field )
-- #define BOOLEAN(name,class,field,default) )\
-- {name, class, Xlbt_Rm_Defs.Xt_R_Boolean, sizeof(boolean), offset(field), Xlbt_Rm_Defs.Xt_R_Boolean, ,\
-- (X_Univ_Ptr)default}
-- #define CURSOR(name,class,field,default) )\
-- {name, class, Xlbt_Rm_Defs.Xt_R_Cursor, sizeof(Xlbt_Basic.X_Cursor), offset(field), ,\
-- Xlbt_Rm_Defs.Xt_R_String, (X_Univ_Ptr)default}
-- #define FONT(name,class,field,default) )\
-- {name, class, Xlbt_Rm_Defs.Xt_R_Font_Struct, sizeof(Xlbt_Font.X_Font_Struct*), offset(field), ,\
-- Xlbt_Rm_Defs.Xt_R_String, (X_Univ_Ptr)default}
-- #define INT(name,class,field,default) )\
-- {name, class, Xlbt_Rm_Defs.Xt_R_Int, sizeof(s_long), offset(field), Xlbt_Rm_Defs.Xt_R_Int, (X_Univ_Ptr)default}
-- #define PIXEL(name,class,field,default) )\
-- {name, class, Xlbt_Rm_Defs.Xt_R_Pixel, sizeof(Xlbt_Basic.X_Pixel), ,\
-- offset(field), Xlbt_Rm_Defs.Xt_R_String, (X_Univ_Ptr)default}
-- #define STRING(name,class,field,default) )\
-- {name, class, Xlbt_Rm_Defs.Xt_R_String, sizeof(String), offset(field), Xlbt_Rm_Defs.Xt_R_String, ,\
-- (X_Univ_Ptr)default}
--
-- static XtResource dragon_resources() := {
-- PIXEL ( XtNbackground, XtCBackground, Background,
-- XtExtdefaultbackground ),
-- CURSOR ( "cursor", XtCCursor, Xlbt_Basic.X_Cursor, "hand2" ),
-- BOOLEAN( "debug", "Debug", Debug, and def_FALSE ),
-- INT ( "doubleClick", "DoubleClick", Double_Click_Time, and def_DCTime ),
-- PIXEL ( XtNforeground, XtCForeground, Foreground,
-- XtExtdefaultforeground ),
-- STRING ( XtNgeometry, XtCGeometry, Xlbt_Rm.X_Rm_Geometry, "450x340" ),
-- STRING ( "iconGeometry", "IconGeometry", Icon_Geometry, "64x64" ),
-- BOOLEAN( "iconic", "Iconic", Iconic, and def_FALSE ),
-- STRING ( XtNiconName, XtCIconName, Icon_Name, null ),
-- BOOLEAN( XtNreverseVideo, XtCReverseVideo, Reverse_Video, and def_FALSE ),
-- BOOLEAN( "stickyTile", "StickyTile", Sticky_Tile, and def_TRUE ),
-- BOOLEAN( "tileShadows", "TileShadows", Tile_Shadows, and def_TRUE ),
-- STRING ( "tileSides", "TileSides", Tile_Sides, "gray" ),
-- };
--\f
------------------------------------------------------------------------------
-- Dragon Command Line Options
------------------------------------------------------------------------------
-- static Xlbt_Rm2.X_Rm_Option_Desc command_line_options() := {
-- {"-cursor", ".cursor", Xlbt_Rm.X_Rm_Option_Sep_Arg, (X_Univ_Ptr)null },
-- {"-debug", ".debug", Xlbt_Rm.X_Rm_Option_No_Arg, (X_Univ_Ptr)"on" },
-- {"-double", ".doubleClick", Xlbt_Rm.X_Rm_Option_Sep_Arg, (X_Univ_Ptr)null },
-- {"-geometry", ".geometry", Xlbt_Rm.X_Rm_Option_Sep_Arg, (X_Univ_Ptr)null },
-- {"-icongeometry",".iconGeometry", Xlbt_Rm.X_Rm_Option_Sep_Arg, (X_Univ_Ptr)null },
-- {"-iconic", ".iconic", Xlbt_Rm.X_Rm_Option_No_Arg, (X_Univ_Ptr)"on" },
-- {"+iconic", ".iconic", Xlbt_Rm.X_Rm_Option_No_Arg, (X_Univ_Ptr)"off" },
-- {"-iconname", ".iconName", Xlbt_Rm.X_Rm_Option_Sep_Arg, (X_Univ_Ptr)null },
-- {"-reverse", "*reverseVideo", Xlbt_Rm.X_Rm_Option_No_Arg, (X_Univ_Ptr)"on" },
-- {"+reverse", "*reverseVideo", Xlbt_Rm.X_Rm_Option_No_Arg, (X_Univ_Ptr)"off" },
-- {"-shadows", ".tileShadows", Xlbt_Rm.X_Rm_Option_No_Arg, (X_Univ_Ptr)"off" },
-- {"+shadows", ".tileShadows", Xlbt_Rm.X_Rm_Option_No_Arg, (X_Univ_Ptr)"on" },
-- {"-sides", ".tileSides", Xlbt_Rm.X_Rm_Option_Sep_Arg, (X_Univ_Ptr)"line"},
-- {"-sticky", ".stickyTile", Xlbt_Rm.X_Rm_Option_No_Arg, (X_Univ_Ptr)"off" },
-- {"+sticky", ".stickyTile", Xlbt_Rm.X_Rm_Option_No_Arg, (X_Univ_Ptr)"on" },
-- };
--
-- typedef struct {
-- String name;
-- String desc;
-- } Option_Help;
--
-- static Option_Help command_line_help() := {
-- {"-help", "print out this message"},
-- {"-display displayname", "X server to contact"},
-- {"-cursor name", "name of the cursor to use"},
-- {"-double time", "double-click time limit in milliseconds"},
-- {"-font name", "font to use for buttons and messages"},
-- {"-geometry WxH+X+Y", "size (in pixels) and position of the board"},
-- {"-icongeometry WxH+X+Y","size (in pixels) and position of the program icon"},
-- {"-/+iconic", "begin program as an icon"},
-- {"-iconname name", "name to use with the program icon"},
-- {"-/+reverse", "turn on/off reverse video"},
-- {"-/+shadows", "turn on/off tile shadows"},
-- {"-sides line/black/gray","set the style for tile sides"},
-- {"-/+sticky", "first tile selected sticky"},
-- { null, null }
-- };
--\f
procedure Gc_Setup is
------------------------------------------------------------------------------
-- Set up the GC's that we will be using for drawing.
------------------------------------------------------------------------------
Gcv : X_Gc_Values;
Pix : X_Pixel;
begin
----Xor_GC - fg = black, bg = white, func = xor; flops colors between the
-- foreground and the background when applied.
Gcv.Funct := Gx_Xor;
Gcv.Foreground := Dragon_Resources.Foreground xor
Dragon_Resources.Background;
Gcv.Background := X_Pixel (0); -- pixel value with all bits "off"
Xor_Gc :=
X_Create_Gc (Dpy,
Dragon.Drawable,
X_Gc_Components'
(Gc_Function | Gc_Foreground | Gc_Background => True,
others => False),
Gcv);
----Normal_GC - fg = black, bg = white, func = copy
Gcv.Funct := Gx_Copy;
Gcv.Foreground := Dragon_Resources.Foreground;
Gcv.Background := Dragon_Resources.Background;
Normal_Gc :=
X_Create_Gc (Dpy,
Dragon.Drawable,
X_Gc_Components'
(Gc_Function | Gc_Foreground | Gc_Background => True,
others => False),
Gcv);
----Gray_GC - fg = black, bg = white, func = copy, tile = Gray
Gcv.Tile := X_Create_Pixmap_From_Bitmap_Data
(Dpy, Board.Drawable, Gray_Bits, Gray_Width,
Gray_Height, Dragon_Resources.Foreground,
Dragon_Resources.Background,
X_Default_Depth (Dpy, X_Default_Screen (Dpy)));
if Gcv.Tile = None_X_Pixmap then
Text_Io.Put_Line ("Can't allocate gray pixmap.");
return;
end if;
Gcv.Fill_Style := Fill_Tiled;
Gray_Gc :=
X_Create_Gc
(Dpy,
Dragon.Drawable,
X_Gc_Components'(Gc_Function | Gc_Foreground |
Gc_Background | Gc_Tile | Gc_Fill_Style => True,
others => False),
Gcv);
----Over_GC - fg = black xor white, bg = 0, func = copy
Gcv.Funct := Gx_Copy;
Gcv.Stipple := -- stipple operations are always depth 1
X_Create_Bitmap_From_Data (Dpy, Board.Drawable, Shadow_Bits,
Shadow_Width, Shadow_Height);
if Gcv.Stipple = None_X_Pixmap then
Text_Io.Put_Line ("Can't allocate shadow pixmap.");
return;
end if;
Gcv.Fill_Style := Fill_Stippled;
Over_Gc :=
X_Create_Gc
(Dpy, Dragon.Drawable,
X_Gc_Components'(Gc_Function | Gc_Foreground | Gc_Background |
Gc_Stipple | Gc_Fill_Style => True,
others => False),
Gcv);
----Reverse_GC - fg = white, bg = black, func = copy
Gcv.Funct := Gx_Copy;
Gcv.Background := Dragon_Resources.Foreground;
Gcv.Foreground := Dragon_Resources.Background;
Reverse_Gc :=
X_Create_Gc (Dpy, Dragon.Drawable,
X_Gc_Components'
(Gc_Function | Gc_Foreground | Gc_Background => True,
others => False),
Gcv);
end Gc_Setup;
--\f
procedure Set_Size_Hints (Hints : in out X_Size_Hints;
Geom : X_String) is
------------------------------------------------------------------------------
-- Hints - Receives the X/Y/Width/Height values from the Geometry string
-- Geom - Specifies the string specified by the user for the geometry
--
-- Parses the geometry string (if any) and takes care of setting the X/Y and
-- the Width/Height fields in the Hints structure.
------------------------------------------------------------------------------
Geom_Result : X_Parse_Geometry_Flags;
begin
Hints.X := 0;
Hints.Y := 0;
Geom_Result := None_X_Parse_Geometry_Flags;
if Geom /= "" then
X_Parse_Geometry (Geom,
S_Short (Hints.X), S_Short (Hints.Y),
U_Short (Hints.Width), U_Short (Hints.Height),
Geom_Result);
if Geom_Result (Width_Value) and then
Geom_Result (Height_Value) then
Hints.Width := Max (Hints.Width, Hints.Min_Width);
Hints.Height := Max (Hints.Height, Hints.Min_Height);
Hints.Flags (U_S_Size) := True;
end if;
if Geom_Result (X_Value) and then
Geom_Result (Y_Value) then
Hints.Flags (U_S_Position) := True;
end if;
end if;
if not Hints.Flags (U_S_Size) then
Hints.Width := Hints.Min_Width;
Hints.Height := Hints.Min_Height;
Hints.Flags (P_Size) := True;
end if;
if not Hints.Flags (U_S_Position) then
Hints.X := 0;
Hints.Y := 0;
Hints.Flags (P_Position) := True;
end if;
if Geom_Result (X_Negative) then
Hints.X := S_Long (X_Display_Width (Dpy, X_Default_Screen (Dpy))) +
Hints.X - S_Long (Hints.Width);
end if;
if Geom_Result (Y_Negative) then
Hints.Y := S_Long (X_Display_Height (Dpy, X_Default_Screen (Dpy))) +
Hints.Y - S_Long (Hints.Height);
end if;
end Set_Size_Hints;
--\f
procedure Main (Display : X_String) is
------------------------------------------------------------------------------
-- Our Main-Line Code.
------------------------------------------------------------------------------
Error : X_Error_String;
Class_Hint : X_Class_Hint;
Size_Hints : X_Size_Hints;
Wm_Hints : X_Wm_Hints;
Attr : X_Set_Window_Attributes;
Mask : X_New_Window_Attributes := None_X_New_Window_Attributes;
Screen : X_Screen_Number;
Event : X_Event;
Success : X_Status;
Icon_Window : X_Window := None_X_Window;
Env : constant X_String :=
X_Display_Name (Display);
begin
----Start up the toolkit. This creates a shell widget. Unfortunately the
-- only way the toolkit allows you to specify default application resources
-- is by having a /usr/lib/X11/app-defaults/Application resouce file. I'm
-- not interested in doing this. If some site wants to create one in order
-- to customize the program then that is fine. However, I want my program
-- to be "standalone"; ie. if you have the binary executable then you have
-- all you *must-have*. So, I will Destroy this widget shortly.
X_Open_Display (Env, Dpy, Error);
if Dpy = null then
Text_Io.Put_Line ("Unable to open display {" & To_String (Display) &
"}: " & To_String (Err (Error)));
raise Abandon;
end if;
Screen := X_Default_Screen (Dpy);
----Initialize the resources. Do it this way until we have real widgets.
Dragon_Resources.Background := X_White_Pixel (Dpy, Screen);
Dragon_Resources.Cursor := X_Create_Font_Cursor (Dpy, Xc_Hand2);
Dragon_Resources.Debug := False;
Dragon_Resources.Double_Click := 250;
Dragon_Resources.Foreground := X_Black_Pixel (Dpy, Screen);
Dragon_Resources.Geometry := new X_String'("450x340");
Dragon_Resources.Icon_Geometry := new X_String'("64x64");
Dragon_Resources.Iconic := False;
Dragon_Resources.Icon_Name := null;
Dragon_Resources.Reverse_Video := False;
Dragon_Resources.Sticky_Tile := True;
Dragon_Resources.Tile_Shadows := True;
Dragon_Resources.Tile_Sides := new X_String'("gray");
----Set up the various Hints structures for our main window.
Size_Hints.Min_Width := 450;
Size_Hints.Min_Height := 340;
Size_Hints.Base_Width := 450;
Size_Hints.Base_Height := 340;
Size_Hints.Width_Inc := 210;
Size_Hints.Height_Inc := 160;
Size_Hints.Min_Aspect.X := 1333;
Size_Hints.Min_Aspect.Y := 1000;
Size_Hints.Max_Aspect.X := 1333;
Size_Hints.Max_Aspect.Y := 1000;
Size_Hints.Flags :=
X_Size_Hints_Flags'
(P_Min_Size | P_Aspect | P_Resize_Inc | P_Base_Size => True,
others => False);
Set_Size_Hints (Size_Hints, Dragon_Resources.Geometry.all);
Wm_Hints.Input := True;
Wm_Hints.Flags := X_Wm_Hints_Flags'(Input_Hint => True,
others => False);
Class_Hint.Res_Name := new X_String'("dragon");
Class_Hint.Res_Class := new X_String'("Dragon");
Attr.Background_Pixel := Dragon_Resources.Background;
Attr.Border_Pixel := Dragon_Resources.Foreground;
Attr.Cursor := X_Create_Font_Cursor (Dpy, Xc_Hand2);
Mask := X_New_Window_Attributes'
(Cw_Background_Pixel | Cw_Border_Pixel | Cw_Cursor => True,
others => False);
----Set up our icon.
Icon_Setup (Wm_Hints);
if Wm_Hints.Flags (Icon_Window_Hint) then
Icon_Window := Wm_Hints.Icon_Window;
end if;
----Create our main window.
Dragon := X_Create_Window
(Dpy, X_Default_Root_Window (Dpy),
S_Short (Size_Hints.X), S_Short (Size_Hints.Y),
U_Short (Size_Hints.Width), U_Short (Size_Hints.Height),
2, X_Default_Depth (Dpy, Screen),
Input_Output, X_Default_Visual_Of_Screen
(X_Default_Screen_Of_Display (Dpy)),
Mask, Attr);
Board := Dragon;
X_Set_Wm_Properties (Dpy, Dragon, "Dragon", "Dragon",
(1 .. 0 => None_X_String_Pointer),
Size_Hints, Wm_Hints, Class_Hint, Success);
----Check the tile controls.
Tile_Control := 0;
if Dragon_Resources.Tile_Shadows then
Tile_Control := Tile_Control or Shadow;
end if;
if Dragon_Resources.Tile_Sides.all = "black" then
Tile_Control := Tile_Control or Blackside;
elsif Dragon_Resources.Tile_Sides.all = "gray" then
Tile_Control := Tile_Control or Blackside or Grayside;
elsif Dragon_Resources.Tile_Sides.all /= "line" then
Text_Io.Put_Line
("-side option not given line, gray, or black value.");
end if;
----Create the board that we will be using; realize it too.
Board_Setup;
X_Select_Input
(Dpy, Dragon,
X_Event_Mask'(Structure_Notify_Mask | Exposure_Mask |
Button_Release_Mask | Button_Press_Mask => True,
others => False));
X_Map_Window (Dpy, Dragon);
----Set up our GC's.
Gc_Setup;
----Now make it all appear in front of the user.
declare
Pix : X_Pixmap;
begin
Pix := X_Create_Pixmap_From_Bitmap_Data
(Dpy, Dragon.Drawable, Background_Bits,
Background_Width, Background_Height,
Dragon_Resources.Foreground, Dragon_Resources.Background,
X_Default_Depth (Dpy, X_Default_Screen (Dpy)));
if Pix = None_X_Pixmap then
Text_Io.Put_Line ("Can't allocate background pixmap.");
raise Abandon;
end if;
X_Set_Window_Background_Pixmap (Dpy, Board, Pix);
end;
----Now do the real thing.
loop
X_Next_Event (Dpy, Event);
if Event.Window = Dragon then
case Event.Kind is
when Expose =>
Button_Expose;
Board_Expose;
when Configure_Notify =>
Board_Configure (Event);
when Xlbt_Event.Button_Press =>
if Event.Button.State /= None_X_Key_Button_Mask then
null; -- No Meta/Shift/Control keys allowed.
elsif Event.Button.Button = Button_1 then
Button.Button_Press (Event);
Tile_Press (Event);
elsif Event.Button.Button = Button_2 then
Hints (Event);
elsif Event.Button.Button = Button_3 then
Tile_Remove (Event);
end if;
when Xlbt_Event.Button_Release =>
if Event.Button.Button = Button_1 then
Button.Button_Release (Event);
Tile_Release (Event);
end if;
when others =>
null;
end case;
elsif Event.Window = Icon_Window then
if Event.Kind = Expose then
Icon_Expose (Icon_Window, Event);
end if;
else
Text_Io.Put ("Event for window 0x");
S_Long_Io.Put
(Event.Window.Drawable.Id.Number, Base => 16, Width => 0);
Text_Io.Put (" kind: ");
Text_Io.Put (X_Event_Code'Image (Event.Kind));
Text_Io.New_Line;
end if;
end loop;
exception
----Differing forms of program termination.
when Abandon =>
--/ if TeleGen2 and then Unix then
--// Process_Control.Exit_Execution (1);
--/ end if;
raise;
when Quit =>
--/ if TeleGen2 and then Unix then
--// Process_Control.Exit_Execution (0);
--/ end if;
null;
end Main;
end Main;