DataMuseum.dk Presents historical artifacts from the history of: Rational R1000/400

This is an automatic "excavation" of a thematic subset of artifacts from Datamuseum.dk's BitArchive. See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software.

top - metrics - download

⟦8ea2e8d70⟧ Ada Source

    Length: 15360 (0x3c00)
    Types: Ada Source
    Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Pen_Class, seg_0370cb, seg_0370ce

Derivation

└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
    └─⟦cfc2e13cd⟧ »Space Info Vol 2« 
        └─⟦this⟧ 

with Bounded_String, Easy_X, Object, Message, Integer_Class,
     Symbol, String_Class, Counter, Text_Io, Bug;

package body Pen_Class is
    package Bs renames Bounded_String;

    type Pen_Unary_Message is (Petit, Moyen, Large, Tonx, Tony,
                               Clone, Entexte, Rentrecheztoi);
    type Pen_Keyword_Message is (Tonx, Tony, Ecris);

    type Pen_Object is
        record
            X : Easy_X.Coordinate;
            Y : Easy_X.Coordinate;
            Font : Easy_X.Fonts;
            Used : Boolean;
        end record;
    Void_Pen : constant Pen_Object := (0, 0, Easy_X.Small_Font, False);
    subtype Id_Pen_Table is Integer range 1 .. 10;

    Pen_Table : array (Id_Pen_Table) of Pen_Object;
    Default_Pen : Object.Reference := Object.Void_Reference;


    function Search_Empty return Id_Pen_Table is
        Id : Id_Pen_Table := 1;
    begin
        loop
            exit when Pen_Table (Id) = Void_Pen;
            if Id = Id_Pen_Table'Last then
                raise Bug.Too_Many_Pens;
            end if;
            Id := Id + 1;
        end loop;
        return (Id);
    end Search_Empty;

    function Search (A_Pen : Object.Reference) return Id_Pen_Table is
        Id : Id_Pen_Table;
    begin
        Id := Id_Pen_Table (Object.Get_Value (A_Pen));
        return (Id);
    end Search;

    function Create (Name : Message.Tiny_String) return Object.Reference is
        Id : Id_Pen_Table;
        Obj : Object.Reference;
    begin
        Id := Search_Empty;  
        Pen_Table (Id).Used := True;
        Obj := Object.Create (Object.Pen_Class, Id);
        Symbol.Insert (Name, Obj);
        return (Obj);
    end Create;

    procedure Create_Default is
        Default_Pen_Name : Message.Tiny_String;
    begin  
        Bounded_String.Copy (Default_Pen_Name, "Stylo");
        Default_Pen := Pen_Class.Create (Default_Pen_Name);  
    end Create_Default;

    function Clone (The_Pen : Object.Reference) return Object.Reference is
        Id, New_Id : Id_Pen_Table;
        Result : Object.Reference;
    begin  
        Id := Search (The_Pen);  
        New_Id := Search_Empty;
        Result := Object.Create (Object.Pen_Class, New_Id);
        Pen_Table (New_Id) := Pen_Table (Id);
        return (Result);
    end Clone;

    procedure Refresh (This_Pen : Id_Pen_Table) is
    begin
        Easy_X.Set_Font (To => Pen_Table (This_Pen).Font);
        Easy_X.Move_To (X => Pen_Table (This_Pen).X,
                        Y => Pen_Table (This_Pen).Y);
    end Refresh;

    procedure Init is
    begin
        for I in Id_Pen_Table loop
            Pen_Table (I) := Void_Pen;
        end loop;  
    end Init;

    procedure Reset is
    begin  
        Init;  
        Create_Default;
    end Reset;

    procedure Go_Home (Pen : Object.Reference) is
        Id : Id_Pen_Table;  
    begin  
        Id := Search (Pen);
        Pen_Table (Id) := Void_Pen;
    end Go_Home;

    procedure In_Text (The_Pen : Object.Reference) is
        Id : Id_Pen_Table;
    begin  
        Object.In_Text (The_Pen);
        Id := Search (The_Pen);  
        Text_Io.Put_Line ("Coordonnees X:" &
                          Integer'Image (Integer (Pen_Table (Id).X)) & " Y:" &
                          Integer'Image (Integer (Pen_Table (Id).Y)));
        Text_Io.Put ("Font: ");
        case Pen_Table (Id).Font is
            when Easy_X.Small_Font =>
                Text_Io.Put_Line ("petite.");
            when Easy_X.Medium_Font =>
                Text_Io.Put_Line ("moyenne.");
            when Easy_X.Large_Font =>
                Text_Io.Put_Line ("large.");
        end case;  
    end In_Text;

    function Set_X (X, From_Pen : Object.Reference) return Object.Reference is
        Id : Id_Pen_Table;
        use Object;
    begin
        if (Object.Get_Class (X) /= Object.Integer_Class) then
            raise Bug.Mismatch_Type;
        end if;
        Id := Search (From_Pen);
        Pen_Table (Id).X := Easy_X.Coordinate (Object.Get_Value (X));
        return From_Pen;
    end Set_X;

    function Set_Y (Y, From_Pen : Object.Reference) return Object.Reference is
        Id : Id_Pen_Table;  
        use Object;
    begin  
        if (Object.Get_Class (Y) /= Object.Integer_Class) then
            raise Bug.Mismatch_Type;
        end if;
        Id := Search (From_Pen);
        Pen_Table (Id).Y := Easy_X.Coordinate (Object.Get_Value (Y));
        return From_Pen;
    end Set_Y;


    function Set_Font (Font : Pen_Unary_Message; From_Pen : Object.Reference)
                      return Object.Reference is
        Id : Id_Pen_Table;
    begin
        Id := Search (From_Pen);  
        case Font is
            when Petit =>
                Pen_Table (Id).Font := Easy_X.Small_Font;
            when Moyen =>
                Pen_Table (Id).Font := Easy_X.Medium_Font;  
            when Large =>
                Pen_Table (Id).Font := Easy_X.Large_Font;
            when others =>
                raise Bug.Unknown_Pen_Message;
        end case;
        return From_Pen;
    end Set_Font;

    function Write (The_Text, Pen : Object.Reference) return Object.Reference is
        Text : Message.Tiny_String;
        Id : Id_Pen_Table;  
        use Object;
    begin
        if (Object.Get_Class (The_Text) /= Object.String_Class) then
            raise Bug.Mismatch_Type;
        end if;
        Id := Search (Pen);
        Bounded_String.Copy (Text, String_Class.Get_String (The_Text));
        Refresh (Id);
        Easy_X.Draw_String (Bounded_String.Image (Text));
        return (The_Text);
    end Write;

    function Get_X (From_Pen : Object.Reference) return Object.Reference is
        Id : Id_Pen_Table;
        Result : Object.Reference;
    begin
        Id := Search (From_Pen);
        Result := Integer_Class.Create (Integer (Pen_Table (Id).X));
        return Result;
    end Get_X;

    function Get_Y (From_Pen : Object.Reference) return Object.Reference is
        Id : Id_Pen_Table;
        Result : Object.Reference;
    begin
        Id := Search (From_Pen);
        Result := Integer_Class.Create (Integer (Pen_Table (Id).Y));
        return Result;
    end Get_Y;


    function Send (To_Pen : Object.Reference; The_Message : Message.Tiny_String)
                  return Object.Reference is
        Result : Object.Reference;  
        The_Unary_Message : Pen_Unary_Message;
    begin  
        The_Unary_Message := Pen_Unary_Message'Value (Bs.Image (The_Message));
        Counter.Increase (Object.Pen_Class);
        case The_Unary_Message is
            when Petit | Moyen | Large =>
                Result := Set_Font (Font => The_Unary_Message,
                                    From_Pen => To_Pen);
            when Tonx =>
                Result := Get_X (From_Pen => To_Pen);
            when Tony =>
                Result := Get_Y (From_Pen => To_Pen);  
            when Clone =>
                Result := Clone (The_Pen => To_Pen);
            when Entexte =>
                In_Text (To_Pen);
                Result := To_Pen;
            when Rentrecheztoi =>
                Go_Home (To_Pen);
                Result := To_Pen;
        end case;
        Counter.Stop_Time (Object.Pen_Class);
        return Result;  
    exception
        when Constraint_Error =>
            raise Bug.Unknown_Pen_Message;
    end Send;

    function Send (To_Pen : Object.Reference;
                   The_Messages : Message.List;
                   With_Arguments : Argument.List) return Object.Reference is
        Result : Object.Reference := Object.Void_Reference;
        A_Message : Message.Tiny_String;
        A_Argument : Object.Reference;
        The_Keyword : Pen_Keyword_Message;
        Mess : Message.List;
        Args : Argument.List;
        Nb_Message : Natural;

    begin
        Mess := The_Messages;
        Args := With_Arguments;
        Nb_Message := Message.How_Many (Mess);
        for I in 1 .. Nb_Message loop  
            Counter.Increase (Object.Pen_Class);
            A_Message := Message.Get (Mess);
            The_Keyword := Pen_Keyword_Message'Value (Bs.Image (A_Message));
            A_Argument := Argument.Get (Args);
            case The_Keyword is
                when Tonx =>
                    Result := Set_X (X => A_Argument, From_Pen => To_Pen);  
                when Tony =>
                    Result := Set_Y (Y => A_Argument, From_Pen => To_Pen);
                when Ecris =>
                    Result := Write (The_Text => A_Argument, Pen => To_Pen);
            end case;
            Message.Next (Mess, A_Message);
            Argument.Next (Args, A_Argument);
            Counter.Stop_Time (Object.Pen_Class);
        end loop;
        return Result;
    exception       when Constraint_Error =>
            raise Bug.Unknown_Pen_Message;
    end Send;

begin
    Init;
end Pen_Class;

    nblk1=e
    nid=4
    hdr6=16
        [0x00] rec0=1f rec1=00 rec2=01 rec3=020
        [0x01] rec0=20 rec1=00 rec2=0a rec3=000
        [0x02] rec0=02 rec1=00 rec2=05 rec3=002
        [0x03] rec0=24 rec1=00 rec2=07 rec3=000
        [0x04] rec0=1a rec1=00 rec2=09 rec3=01e
        [0x05] rec0=1d rec1=00 rec2=0b rec3=032
        [0x06] rec0=1c rec1=00 rec2=08 rec3=086
        [0x07] rec0=1b rec1=00 rec2=03 rec3=016
        [0x08] rec0=1b rec1=00 rec2=06 rec3=010
        [0x09] rec0=19 rec1=00 rec2=0e rec3=002
        [0x0a] rec0=07 rec1=00 rec2=0c rec3=000
        [0x0b] rec0=02 rec1=00 rec2=05 rec3=000
        [0x0c] rec0=24 rec1=00 rec2=0c rec3=743
        [0x0d] rec0=80 rec1=00 rec2=00 rec3=002
    tail 0x217344c9684e18ac1d1cf 0x42a00088462060003
Free Block Chain:
  0x4: 0000  00 02 00 51 00 4a 20 20 20 20 66 75 6e 63 74 69  ┆   Q J    functi┆
  0x2: 0000  00 0d 00 d3 80 07 20 20 20 20 20 20 20 07 00 2e  ┆               .┆
  0xd: 0000  00 00 00 05 80 02 20 72 02 20 20 20 20 20 20 20  ┆       r        ┆