DataMuseum.dk

top - download

    Length: 18087 (0x46a7)
    Types: TextFile
    Names: »B«

└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
    └─ ⟦129cab021⟧ »DATA« 
        └─⟦this⟧ 

TextFile

with Bounded_String;
with Text_Io;
with Xlbt_Basic, Xlbt_Event, Xlbt_Window, Xlbt_Font, Xlbt_Text,
     Xlbt_String, Xlbt_Arithmetic, Xlbt_Gc, Xlbt_Hint, Xlbt_Event3;
use Xlbt_Basic, Xlbt_Event, Xlbt_Window, Xlbt_Font, Xlbt_Text,
    Xlbt_String, Xlbt_Arithmetic, Xlbt_Gc, Xlbt_Hint;
with Xlbp_Event, Xlbp_Display, Xlbp_Window, Xlbp_Font, Xlbp_Text,
     Xlbp_Sync, Xlbp_Gc, Xlbp_Graphics, Xlbp_Hint, Text_Io;
use Xlbp_Event, Xlbp_Display, Xlbp_Window, Xlbp_Font, Xlbp_Text,
    Xlbp_Sync, Xlbp_Gc, Xlbp_Graphics, Xlbp_Hint, Text_Io;

package body Easy_Y is

    Max_No_Flushed_Requests : constant Natural := 1;
    X_Request_Count         : Natural          := 0;

    The_Display                      : X_Display;
    The_Screen                       : X_Screen_Number;
    The_Root_Window, The_Main_Window : X_Window;
    The_Graphic_Context              : X_Gc;
    The_X_Mouse, The_Y_Mouse         : S_Short;

    The_Current_Window : Window_Type;

    Black, White : X_Pixel;
    The_Small_Font, The_Medium_Font, The_Large_Font : X_Font_Struct;

    procedure Set_Window_Manager_Hints (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     => The_Display,
                             Window      => The_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 (Title         : String;
                             X, Y          : S_Short;
                             Width, Height : U_Short_Positive) is
        Xswa : X_Set_Window_Attributes;
    begin
        Xswa.Event_Mask       :=
           X_Event_Mask'(Button_Press_Mask |
                         Button_Release_Mask | Exposure_Mask => True,
                         others                              => False);
        Xswa.Background_Pixel := White;
        Xswa.Border_Pixel     := Black;
        The_Main_Window       :=
           X_Create_Window
              (Display      => The_Display,
               Parent       => The_Root_Window,
               X            => X,
               Y            => Y,
               Width        => Width,
               Height       => Height,
               Border_Width => 0,
               Depth        => X_Default_Depth (The_Display, The_Screen),
               Class        => Input_Output,
               Visual       => X_Default_Visual (The_Display, The_Screen),
               Values_Mask  =>
                  (Cw_Event_Mask | Cw_Back_Pixel | Cw_Border_Pixel => True,
                   others => False),
               Values       => Xswa);
        Set_Window_Manager_Hints (Title, X, Y, Width, Height);
        X_Map_Window (The_Display, The_Main_Window);
    end Create_Window;


    procedure Create_Graphic_Context is
        Xgcv : X_Gc_Values;
    begin
        The_Graphic_Context := X_Create_Gc
                                  (The_Display, The_Main_Window.Drawable,
                                   None_X_Gc_Components, None_X_Gc_Values);  
        X_Set_Foreground (The_Display, The_Graphic_Context, Black);
        X_Set_Background (The_Display, The_Graphic_Context, White);
        Xgcv.Line_Width := 1;
        Xgcv.Cap_Style  := Cap_Round;
        X_Change_Gc
           (The_Display, The_Graphic_Context,
            (Gc_Line_Width | Gc_Cap_Style => True, others => False), Xgcv);
    end Create_Graphic_Context;


    procedure Load_The_Fonts is
    begin
        The_Small_Font  := X_Load_Query_Font (Display => The_Display,
                                              Name    => To_X_String ("rom10"));
        The_Medium_Font := X_Load_Query_Font (Display => The_Display,
                                              Name    => To_X_String ("rom14"));
        The_Large_Font  := X_Load_Query_Font (Display => The_Display,
                                              Name    => To_X_String ("rom28"));
    end Load_The_Fonts;


    procedure Open (Display : String; Window : in out Window_Type) is
        The_Name : constant X_String := X_Display_Name (To_X_String (Display));
        Error    : X_Error_String;
    begin
        X_Open_Display (The_Name, The_Display, Error);
        if The_Display = None_X_Display then
            Text_Io.Put_Line ("Fatal error, " & To_String (Err (Error)));
            raise Fatal_Error;
        end if;
        The_Screen      := X_Default_Screen (The_Display);  
        The_Root_Window := X_Root_Window (The_Display, The_Screen);
        Black           := X_Black_Pixel (The_Display, The_Screen);
        White           := X_White_Pixel (The_Display, The_Screen);
        Create_Window (Bounded_String.Image (Get_Title (Window)),
                       S_Short (Get_Left (Window)),
                       S_Short (Get_Right (Window)),
                       U_Short_Positive (Get_Width (Window)),
                       U_Short_Positive (Get_Height (Window)));
        Load_The_Fonts;
        Create_Graphic_Context;  
        Put_Font (Small_Font);
        X_Set_Font (The_Display, The_Graphic_Context,
                    The_Current_Window.Font_Pen.Font_Id);

        Put_Main_Window (The_Main_Window);
        Put_Display (The_Current_Window, The_Display);
        Put_Screen (The_Screen);
        Put_Graphic_Context (The_Graphic_Context);

        Window := The_Current_Window;
    end Open;

    procedure Update is
    begin
        loop
            exit when Easy_Y.Next_Event = Easy_Y.Update;
        end loop;
    end Update;

    procedure Flush_If_Needed is
    begin
        X_Request_Count := X_Request_Count + 1;
        if X_Request_Count >= Max_No_Flushed_Requests then
            X_Sync (The_Display, False);
            X_Request_Count := 0;
        end if;
    end Flush_If_Needed;

    procedure Move_To (X, Y : Coordinate) is
    begin
        Put_X (The_Current_Window, Object.Index (X));
        Put_Y (The_Current_Window, Object.Index (Y));
    end Move_To;


    procedure Line_To (X, Y : Coordinate) is
    begin
        X_Draw_Line (Display  => The_Display,
                     Drawable => The_Main_Window.Drawable,
                     Gc       => The_Graphic_Context,
                     X1       => Coordinate (Get_X (The_Current_Window)),
                     Y1       => Coordinate (Get_Y (The_Current_Window)),
                     X2       => X,
                     Y2       => Y);
        Flush_If_Needed;
        Put_X (The_Current_Window, Object.Index (X));
        Put_Y (The_Current_Window, Object.Index (Y));
    end Line_To;

    procedure Line (X1, Y1, X2, Y2 : Object.Index) is
    begin
        X_Draw_Line (Display  => The_Display,
                     Drawable => The_Main_Window.Drawable,
                     Gc       => The_Graphic_Context,
                     X1       => Coordinate (X1),
                     Y1       => Coordinate (Y1),
                     X2       => Coordinate (X2),
                     Y2       => Coordinate (Y2));
        Flush_If_Needed;
    end Line;

    function Get_Size (Window : in Window_Type) return Object.Index is
    begin
        return Window.Size_Pen;
    end Get_Size;


    procedure Put_Size (Window : in out Window_Type; Size : Object.Index) is
        Xgcv : X_Gc_Values;
    begin
        Window.Size_Pen := Size;
        Xgcv.Line_Width := Dimension (Size);
        X_Change_Gc (The_Display, The_Graphic_Context,
                     (Gc_Line_Width => True, others => False), Xgcv);
        Put_Graphic_Context (The_Graphic_Context);
    end Put_Size;


    procedure Put_Size (Size : Object.Index) is
        Xgcv : X_Gc_Values;
    begin
        The_Current_Window.Size_Pen := Size;
        Xgcv.Line_Width             := Dimension (Size);
        X_Change_Gc (The_Display, The_Graphic_Context,
                     (Gc_Line_Width => True, others => False), Xgcv);
        Put_Graphic_Context (The_Graphic_Context);
    end Put_Size;


    function Next_Event return Events is
        The_Button : Xlbt_Event3.X_Button_Event;
        Event      : X_Event;
    begin
        loop
            X_Next_Event (The_Display, Event);
            if Event.Window = The_Main_Window then
                case Event.Kind is  
                    when Button_Press =>
                        The_Button := Event.Button;

                        Put_X_Mouse (Object.Index (The_Button.X));
                        Put_Y_Mouse (Object.Index (The_Button.Y));
                        return Button_Down;

                    when Button_Release =>
                        Put_X_Mouse (Object.Index (The_Button.X));
                        Put_Y_Mouse (Object.Index (The_Button.Y));
                        return Button_Up;

                    when Expose =>
                        if Event.Expose.Count = 0 then
                            return Update;
                        end if;

                    when others =>
                        null;
                end case;
            end if;
        end loop;
    end Next_Event;


    function Get_X_Mouse return Object.Index is
    begin
        return Object.Index (The_Current_Window.X_Mouse);
    end Get_X_Mouse;
    procedure Put_X_Mouse (X : Object.Index) is
    begin
        The_Current_Window.X_Mouse := X;
    end Put_X_Mouse;


    function Get_Y_Mouse return Object.Index is
    begin
        return Object.Index (The_Current_Window.Y_Mouse);
    end Get_Y_Mouse;
    procedure Put_Y_Mouse (Y : Object.Index) is
    begin
        The_Current_Window.Y_Mouse := Y;
    end Put_Y_Mouse;


    procedure Put_Font (To : Fonts) is
    begin
        case To is
            when Small_Font =>
                The_Current_Window.Font_Pen := The_Small_Font;
            when Medium_Font =>  
                The_Current_Window.Font_Pen := The_Medium_Font;
            when Large_Font =>  
                The_Current_Window.Font_Pen := The_Large_Font;
        end case;  
        X_Set_Font (The_Display, The_Graphic_Context,
                    The_Current_Window.Font_Pen.Font_Id);
    end Put_Font;


    function Get_Font return X_Font_Struct is
    begin
        return The_Current_Window.Font_Pen;
    end Get_Font;


    procedure Draw_String (The_String : String) is
        Width : S_Long;
    begin
        X_Draw_Image_String (Display => The_Display,
                             Drawable => The_Main_Window.Drawable,
                             Gc => The_Graphic_Context,
                             X => Coordinate (Get_X (The_Current_Window)),
                             Y => Coordinate (Get_Y (The_Current_Window)),
                             Text => To_X_String (The_String));
        Width := X_Text_Width (Get_Font, To_X_String (The_String));
        Put_X (The_Current_Window,
               Object.Index (Coordinate (Get_X (The_Current_Window)) +
                             S_Short (Width)));
        Flush_If_Needed;
    end Draw_String;

    procedure Print (X1, Y1 : Object.Index; The_String : Object.Tiny_String) is
        Width : S_Long;
    begin
        X_Draw_Image_String
           (Display  => The_Display,
            Drawable => The_Main_Window.Drawable,
            Gc       => The_Graphic_Context,
            X        => Coordinate (X1),
            Y        => Coordinate (Y1),
            Text     => To_X_String (Bounded_String.Image (The_String)));
        Width := X_Text_Width (Get_Font,
                               To_X_String (Bounded_String.Image (The_String)));
        Flush_If_Needed;
    end Print;

    procedure Close (Window : in out Window_Type) is
        Display : X_Display := Get_Display (Window);
    begin
        X_Close_Display (Display);
        Put_Display (Window, Display);
    end Close;


    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;


    procedure Set_Display (Window : in Window_Type) is
    begin
        The_Main_Window     := Get_Main_Window;
        The_Root_Window     := Get_Root_Window;
        The_Display         := Get_Display (The_Current_Window);
        The_Screen          := Get_Screen;
        The_Graphic_Context := Get_Graphic_Context;
        The_X_Mouse         := S_Short (Get_X_Mouse);
        The_Y_Mouse         := S_Short (Get_Y_Mouse);

        The_Current_Window := Window;
    end Set_Display;

    function Get_Current_Window return Window_Type is
    begin
        return The_Current_Window;
    end Get_Current_Window;

    function Get_Display (Window : in Window_Type)
                         return Xlbt_Basic.X_Display is
    begin
        return Window.Display_Descriptor;
    end Get_Display;

    procedure Put_Display (Window  : in out Window_Type;
                           Display :        Xlbt_Basic.X_Display) is
    begin
        The_Current_Window.Display_Descriptor := Display;
    end Put_Display;


    function Get_Main_Window return Xlbt_Basic.X_Window is
    begin
        return The_Current_Window.Window_Descriptor;
    end Get_Main_Window;

    procedure Put_Main_Window (Main_Window : in Xlbt_Basic.X_Window) is
        use Xlbt_Basic;
    begin
        The_Current_Window.Window_Descriptor := Main_Window;
    end Put_Main_Window;


    function Get_Root_Window return Xlbt_Basic.X_Window is
    begin
        return The_Current_Window.Root_Window_Descriptor;
    end Get_Root_Window;

    procedure Put_Root_Window (Root_Window : in Xlbt_Basic.X_Window) is
        use Xlbt_Basic;
    begin
        The_Current_Window.Root_Window_Descriptor := Root_Window;
    end Put_Root_Window;


    function Get_Title (Window : in Window_Type) return Object.Tiny_String is
    begin
        return The_Current_Window.Title;
    end Get_Title;

    procedure Put_Title (Window : in out Window_Type;
                         Title  :        Object.Tiny_String) is
    begin
        The_Current_Window.Title := Title;
    end Put_Title;


    function Get_X (Window : in Window_Type) return Object.Index is
    begin
        return Window.X_Pen;
    end Get_X;

    procedure Put_X (Window : in out Window_Type; X : Object.Index) is
    begin
        Window.X_Pen := X;
    end Put_X;


    function Get_Y (Window : in Window_Type) return Object.Index is
    begin
        return Window.X_Pen;
    end Get_Y;

    procedure Put_Y (Window : in out Window_Type; Y : Object.Index) is
    begin
        Window.Y_Pen := Y;
    end Put_Y;


    function Get_Left (Window : in Window_Type) return Object.Index is
    begin
        return Object.Index (The_Current_Window.Left);
    end Get_Left;

    procedure Put_Left (Window : in out Window_Type; Left : Object.Index) is
    begin
        The_Current_Window.Left := Coordinate (Left);
    end Put_Left;


    function Get_Right (Window : in Window_Type) return Object.Index is
    begin  
        return Object.Index (The_Current_Window.Right);
    end Get_Right;

    procedure Put_Right (Window : in out Window_Type; Right : Object.Index) is
    begin
        The_Current_Window.Right := Coordinate (Right);
    end Put_Right;


    function Get_Width (Window : in Window_Type) return Object.Index is
    begin
        return Object.Index (The_Current_Window.Width);
    end Get_Width;

    procedure Put_Width (Window : in out Window_Type; Width : Object.Index) is
    begin
        The_Current_Window.Width := Dimension (Width);
    end Put_Width;


    function Get_Height (Window : in Window_Type) return Object.Index is
    begin
        return Object.Index (The_Current_Window.Height);
    end Get_Height;

    procedure Put_Height (Window : in out Window_Type; Height : Object.Index) is
    begin
        The_Current_Window.Height := Dimension (Height);
    end Put_Height;


    function Get_Screen return Xlbt_Basic.X_Screen_Number is
    begin
        return The_Current_Window.Screen_Descriptor;
    end Get_Screen;

    procedure Put_Screen (Screen : Xlbt_Basic.X_Screen_Number) is
    begin
        The_Current_Window.Screen_Descriptor := Screen;
    end Put_Screen;

    function Get_Graphic_Context return Xlbt_Basic.X_Gc is
    begin
        return The_Current_Window.Graphic_Context;
    end Get_Graphic_Context;

    procedure Put_Graphic_Context (Graphic_Context : Xlbt_Basic.X_Gc) is
    begin
        The_Current_Window.Graphic_Context := Graphic_Context;
    end Put_Graphic_Context;

end Easy_Y;