|
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 - metrics - download
Length: 14338 (0x3802)
Types: TextFile
Notes: R1k Text-file segment
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦3153fd322⟧
└─⟦this⟧
with Xlbt_Basic, Xlbt_Event, Xlbt_Window, Xlbt_Font, Xlbt_Text,
Xlbt_Key, Xlbt_String, Xlbt_Arithmetic, Xlbt_Gc, Xlbt_Hint;
use Xlbt_Basic, Xlbt_Event, Xlbt_Window, Xlbt_Font, Xlbt_Text,
Xlbt_Key, Xlbt_String, Xlbt_Arithmetic, Xlbt_Gc, Xlbt_Hint;
with Xlbp_Event, Xlbp_Display, Xlbp_Window, Xlbp_Font, Xlbp_Key,
Xlbp_Text, Xlbp_Sync, Xlbp_Gc, Xlbp_Graphics, Xlbp_Hint, Text_Io;
use Xlbp_Event, Xlbp_Display, Xlbp_Window, Xlbp_Font, Xlbp_Key,
Xlbp_Text, Xlbp_Sync, Xlbp_Gc, Xlbp_Graphics, Xlbp_Hint, Text_Io;
package body Terminal is
type Events is (Update, Button_Up, Button_Down);
type Fonts is (Small_Font, Medium_Font, Large_Font);
subtype Coordinate is S_Short;
subtype Dimension is U_Short_Positive;
package Arithmetic is
function "+" (C : Coordinate; D : Dimension) return Coordinate;
function "-" (C : Coordinate; D : Dimension) return Coordinate;
function "/" (D : Dimension; Scale : Positive) return Dimension;
function "*" (D : Dimension; Scale : Positive) return Dimension;
function "+" (D1, D2 : Dimension) return Dimension
renames Xlbt_Arithmetic."+";
function "-" (D1, D2 : Dimension) return Dimension
renames Xlbt_Arithmetic."-";
end Arithmetic;
Fatal_Error, Value_Error : exception;
task type Wait_Event is
entry Go (H : in Handle);
end Wait_Event;
type T_Acc is access Wait_Event;
type Font_Type_Type is (Small, Medium, Large);
type Font_Record_Type is
record
Font : X_Font_Struct;
Width : S_Short;
Height : S_Short;
end record;
Null_Font_Record : constant Font_Record_Type :=
(Font => None_X_Font_Struct, Width => 0, Height => 0);
type Font_Array_Type is array (Font_Type_Type) of Font_Record_Type;
Null_Font_Array : constant Font_Array_Type := (others => Null_Font_Record);
type Objet is
record
No : Integer;
Display : X_Display;
Screen : X_Screen_Number;
Root_Window, Main_Window : X_Window;
Current_Font : Font_Record_Type;
Fonts : Font_Array_Type;
Graphic_Context : X_Gc;
T : T_Acc;
Stop : Boolean;
Next, Prev : Handle;
end record;
Null_Objet : constant Objet := (No => 0,
Display => None_X_Display,
Screen => None_X_Screen_Number,
Root_Window => None_X_Window,
Main_Window => None_X_Window,
Current_Font => Null_Font_Record,
Fonts => Null_Font_Array,
Graphic_Context => None_X_Gc,
T => null,
Stop => False,
Next => null,
Prev => null);
First_Busy : Handle := null;
First_Free : Handle := null;
Max_No_Flushed_Requests : constant Natural := 1;
X_Request_Count : Natural := 0;
Black, White : X_Pixel;
Width : constant Natural := 80;
The_String : constant String (1 .. Width) := (others => ' ');
task body Wait_Event is
Event : X_Event;
Terminal : Handle;
C : Character;
Buffer : X_String (1 .. 10);
Result : S_Natural;
Key_Symbol : X_Key_Sym;
Status : X_Compose_Status;
type State_Type is (Wait_Press, Wait_Release, Wait_Read);
State : State_Type := Wait_Press;
begin
accept Go (H : in Handle) do
Terminal := H;
end Go;
while not Terminal.Stop loop
X_Next_Event (Terminal.Display, Event);
if Event.Window = Terminal.Main_Window then
case Event.Kind is
when Key_Press =>
if State = Wait_Press then
begin
X_Lookup_String (Event, Buffer, Result,
Key_Symbol, Status);
C := To_String (Buffer (1 .. Result)) (1);
State := Wait_Release;
exception
when others =>
null;
end;
end if;
when Key_Release =>
if State = Wait_Release then
State := Wait_Read;
Text_Io.Put_Line ("PASS");
Envoyer_Caractere (C => C, No => Terminal.No);
State := Wait_Press;
end if;
when others =>
Text_Io.Put_Line ("Event = " &
X_Event_Code'Image (Event.Kind));
end case;
else
Text_Io.Put_Line ("Event sur mauvaise fenetre");
end if;
end loop;
exception
when others =>
Text_Io.Put_Line ("Exception");
end Wait_Event;
function Get_Handle return Handle is
Loc_Handle : Handle := First_Free;
begin
if First_Free /= null then
First_Free := First_Free.Next;
else
Loc_Handle := new Objet;
end if;
Loc_Handle.all := Null_Objet;
Loc_Handle.T := new Wait_Event;
return Loc_Handle;
end Get_Handle;
procedure Put_Handle (H : in out Handle) is
begin
H.Next := First_Free;
First_Free := H;
end Put_Handle;
procedure Set_Window_Manager_Hints (H : Handle;
Title : String;
X, Y : S_Short;
Width, Height : U_Short_Positive) is
Success : X_Status;
Size_Hints : X_Size_Hints;
begin
Size_Hints.Flags (U_S_Position) := True;
Size_Hints.Flags (U_S_Size) := True;
Size_Hints.Width := S_Long (Width);
Size_Hints.Height := S_Long (Height);
Size_Hints.X := S_Long (X);
Size_Hints.Y := S_Long (Y);
X_Set_Wm_Properties (Display => H.Display,
Window => H.Main_Window,
Window_Name => To_X_String (Title),
Icon_Name => To_X_String (Title),
Arg_V => (1 .. 0 => null),
Normal => Size_Hints,
Wm => None_X_Wm_Hints,
Class => None_X_Class_Hint,
Status => Success);
end Set_Window_Manager_Hints;
procedure Create_Window (H : in Handle;
Title : String;
X, Y : S_Short;
Width, Height : U_Short_Positive) is
Xswa : X_Set_Window_Attributes;
begin
Xswa.Event_Mask := X_Event_Mask'(Key_Press_Mask => True,
Key_Release_Mask => True,
others => False);
Xswa.Background_Pixel := White;
Xswa.Border_Pixel := Black;
H.Main_Window :=
X_Create_Window
(Display => H.Display,
Parent => H.Root_Window,
X => X,
Y => Y,
Width => Width,
Height => Height,
Border_Width => 0,
Depth => X_Default_Depth (H.Display, H.Screen),
Class => Input_Output,
Visual => X_Default_Visual (H.Display, H.Screen),
Values_Mask =>
(Cw_Event_Mask | Cw_Back_Pixel | Cw_Border_Pixel => True,
others => False),
Values => Xswa);
Set_Window_Manager_Hints (H, Title, X, Y, Width, Height);
X_Map_Window (H.Display, H.Main_Window);
end Create_Window;
procedure Create_Graphic_Context (H : in Handle) is
Xgcv : X_Gc_Values;
begin
H.Graphic_Context := X_Create_Gc
(H.Display, H.Main_Window.Drawable,
None_X_Gc_Components, None_X_Gc_Values);
X_Set_Foreground (H.Display, H.Graphic_Context, Black);
X_Set_Background (H.Display, H.Graphic_Context, White);
Xgcv.Line_Width := 1;
Xgcv.Cap_Style := Cap_Round;
X_Change_Gc
(H.Display, H.Graphic_Context,
(Gc_Line_Width | Gc_Cap_Style => True, others => False), Xgcv);
end Create_Graphic_Context;
procedure Load_The_Fonts (H : in Handle) is
begin
H.Fonts (Small).Font :=
X_Load_Query_Font (Display => H.Display,
Name => To_X_String ("rom10"));
H.Fonts (Medium).Font :=
X_Load_Query_Font (Display => H.Display,
Name => To_X_String ("rom14"));
H.Fonts (Large).Font :=
X_Load_Query_Font (Display => H.Display,
Name => To_X_String ("rom28"));
for Ft in Font_Type_Type loop
H.Fonts (Ft).Width := S_Short (H.Fonts (Ft).Font.Max_Bounds.Width);
H.Fonts (Ft).Height := S_Short (H.Fonts (Ft).Font.Ascent +
H.Fonts (Ft).Font.Descent);
end loop;
end Load_The_Fonts;
function Creer (Col : in Coordonnees := Max_Col;
Lin : in Coordonnees := Max_Lin;
No : in Integer;
Nom : in String) return Handle is
Title : constant String := "BT/BP";
Left, Right : Coordinate := 100;
Width, Height : Dimension := 800;
The_Name : constant X_String := X_Display_Name (To_X_String (Nom));
Error : X_Error_String;
Loc_Handle : Handle := Get_Handle;
begin
Loc_Handle.No := No;
X_Open_Display (The_Name, Loc_Handle.Display, Error);
if Loc_Handle.Display = None_X_Display then
Text_Io.Put_Line ("Fatal error, " & To_String (Err (Error)));
raise Fatal_Error;
end if;
Loc_Handle.Screen := X_Default_Screen (Loc_Handle.Display);
Loc_Handle.Root_Window := X_Root_Window
(Loc_Handle.Display, Loc_Handle.Screen);
Black := X_Black_Pixel (Loc_Handle.Display, Loc_Handle.Screen);
White := X_White_Pixel (Loc_Handle.Display, Loc_Handle.Screen);
Load_The_Fonts (Loc_Handle);
Loc_Handle.Current_Font := Loc_Handle.Fonts (Small);
Width := Dimension (Loc_Handle.Current_Font.Width) * Dimension (Col);
Height := Dimension (Loc_Handle.Current_Font.Height) * Dimension (Lin);
Create_Window (Loc_Handle, Title, Left, Right, Width, Height);
Create_Graphic_Context (Loc_Handle);
X_Set_Font (Loc_Handle.Display, Loc_Handle.Graphic_Context,
Loc_Handle.Current_Font.Font.Font_Id);
Loc_Handle.Next := First_Busy;
First_Busy := Loc_Handle;
Loc_Handle.T.Go (Loc_Handle);
return Loc_Handle;
end Creer;
procedure Flush_If_Needed (H : in Handle) is
begin
X_Request_Count := X_Request_Count + 1;
if X_Request_Count >= Max_No_Flushed_Requests then
X_Sync (H.Display, False);
X_Request_Count := 0;
end if;
end Flush_If_Needed;
procedure Ecrire (Terminal : in Handle;
C : in Character;
X, Y : in Coordonnees) is
My_X_String : X_String (1 .. 1);
C_P : X_Character := X_Character'Val (Character'Pos (C));
begin
My_X_String (1) := C_P;
X_Draw_Image_String (Display => Terminal.Display,
Drawable => Terminal.Main_Window.Drawable,
Gc => Terminal.Graphic_Context,
X => Terminal.Current_Font.Width * S_Short (X - 1),
Y => Terminal.Current_Font.Height * S_Short (Y),
Text => My_X_String);
Flush_If_Needed (Terminal);
end Ecrire;
procedure Fermer (Terminal : in Handle) is
begin
Terminal.Stop := True;
X_Close_Display (Terminal.Display);
end Fermer;
package body Arithmetic is
function "+" (C : Coordinate; D : Dimension) return Coordinate is
begin
return S_Short (C) + S_Short (D);
exception
when Constraint_Error =>
raise Value_Error;
end "+";
function "-" (C : Coordinate; D : Dimension) return Coordinate is
begin
return S_Short (C) - S_Short (D);
exception
when Constraint_Error =>
raise Value_Error;
end "-";
function "/" (D : Dimension; Scale : Positive) return Dimension is
begin
return U_Short_Positive (D) / U_Short_Positive (Scale);
exception
when Constraint_Error | Numeric_Error =>
raise Value_Error;
end "/";
function "*" (D : Dimension; Scale : Positive) return Dimension is
begin
return U_Short_Positive (D) * U_Short_Positive (Scale);
exception
when Constraint_Error =>
raise Value_Error;
end "*";
end Arithmetic;
end Terminal