|
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: 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