⟦7210bce54⟧

E3 Source Code



package body Spreadsheet_Generic is

    use Tool_Set;

    Nr_Of_Columns : constant Positive :=
       Column_Type'Pos (Column_Type'Last) -
          Column_Type'Pos (Column_Type'First) + 1;
    Nr_Of_Lines   : constant Positive := Line_Type'Pos (Line_Type'Last) -
                                            Line_Type'Pos (Line_Type'First) + 1;


    subtype Column_Number is Integer range 1 .. Nr_Of_Columns;
    subtype Line_Number   is Integer range 1 .. Nr_Of_Lines;

    Screen_Width : constant Positive := 80;
    type Column_Width_Array is array (Column_Number) of Natural;
    Default_Column_Width : constant Positive := Screen_Width / Nr_Of_Columns;

    Actual_Column_Width : Column_Width_Array;
    Column_Offset       : Column_Width_Array;

    type Cell is access String;
    Display : array (Line_Number, Column_Number) of Cell;

    The_Current_Line   : Line_Type   := Line_Type'First;
    The_Current_Column : Column_Type := Column_Type'First;
    type Field is (Cursor_Location, Status);

    -------
    function Line (C : Line_Type := The_Current_Line)     return Line_Number;
    function Col  (C : Column_Type := The_Current_Column) return Column_Number;

    -- Entry buffer management
    --
    package Buffer is
        procedure Clear; -- Untouched := true
        procedure Erase; -- Untouched := Untouched
        procedure Append (C : Character);
        procedure Put    (S : String);
        procedure Del;
        function  Get          return String;
        function  Is_Untouched return Boolean;
    end Buffer;

    package Screen is  
        procedure Open       (Name : String);
        procedure Close;
        procedure Cursor     (Offset : Integer := 0);
        procedure Normal     (S : String);
        procedure Inverse    (S : String);
        function  Prompt_For (S : String) return String;
        procedure Refresh;
        generic  -- this is the only way I could make the generic actual
                 -- parameter to Engine visible to Screen...
            with function Is_Selected
                             (L : Line_Type; C : Column_Type) return Boolean;
        procedure Refresh_And_Highlight;
        procedure Refresh_End_Of_Line;
        procedure Mark;
        procedure Unmark;
        procedure Show   (L : Line_Number; C : Column_Number);
        procedure Alert  (S : String := ""; Beeps : Natural := 2);
        procedure Banner (F : Field := Status; Text : String := "");
    end Screen;

    package Keyboard is
        type Logical_Key is --
           (Up, Down, Right, Left, Begin_Of, End_Of,-- movement keys
            Bottom, Home, -- in fact "complete" and Ascii.Vt
            --
            Definition, Help, Edit, Command, Print, Time,--
            Save, Load, --
            Compute, Format, Show, Reset, Del, Erase,
            --
            Window, Object, Image, Line, Word, Mark,
            --
            Enter, Numeric,
            --
            Ascii_Char, Unknown);

        subtype Movement_Key is Logical_Key range Up .. Home;

        function Get_Key return Logical_Key;

        function Get_Char return Character;
        -- associated with logical keys: Ascii_Char or Numeric

        Disconnect, Quit : exception;
    end Keyboard;
    -------------
    -- Bodies of default generic parameters

    function All_Columns_Equal (C : Column_Type) return Positive is
    begin
        return Default_Column_Width;
    end All_Columns_Equal;

    function All_Modifiable (L : Line_Type; C : Column_Type) return Boolean is
    begin
        return True;
    end All_Modifiable;

    function Not_Selected (L : Line_Type; C : Column_Type) return Boolean is
    begin
        return False;
    end Not_Selected;

    function No_Help return String is
    begin
        return "Sorry, no help available";
    end No_Help;

    function No_Definition (L : Line_Type; C : Column_Type) return String is
    begin
        return "Sorry, no definition available";
    end No_Definition;

    function No_Message return String is
    begin
        return "Sorry, no error message";
    end No_Message;

    function No_File_Name return String is
    begin
        return "<None>";
    end No_File_Name;
    function Default_File_Name return String is
    begin
        return "<Default>";
    end Default_File_Name;

    procedure Up_And_Left_Border is
    begin
        for L in Line_Type loop
            Set (L, Column_Type'First,
                 Left_Align (Capitalize (Line_Type'Image (L)),
                             Actual_Column_Width (Column_Number'First)));
        end loop;
        for C in Column_Type loop
            Set (Line_Type'First, C, Right_Align
                                        (Capitalize (Column_Type'Image (C)),
                                         Actual_Column_Width (Col (C))));
        end loop;
    end Up_And_Left_Border;

    procedure Upper_Left_Corner (L : out Line_Type; C : out Column_Type) is
    begin
        L := Line_Type'First;
        C := Column_Type'First;
    end Upper_Left_Corner;

    procedure Noop is
    begin
        Beep;
    end Noop;

    procedure Set (L : Line_Type := Current_Line;
                   C : Column_Type := Current_Column;
                   To_String : String;
                   Immediately_Shown : Boolean := False) is
    begin
        Display (Line (L), Col (C)).all := To_String;
        if Immediately_Shown then
            Screen.Show (Line (L), Col (C));
        end if;
    end Set;

    function Get (L : Line_Type   := Current_Line;
                  C : Column_Type := Current_Column) return String is
    begin
        return Display (Line (L), Col (C)).all;
    end Get;

    function Width (C : Column_Type := Current_Column) return Positive is
    begin
        return Actual_Column_Width (Col (C));   end Width;

    function Line (C : Line_Type := The_Current_Line) return Line_Number is
    begin
        return Line_Type'Pos (C) - Line_Type'Pos (Line_Type'First) + 1;
    end Line;
    function Col (C : Column_Type := The_Current_Column) return Column_Number is
    begin
        return Column_Type'Pos (C) - Column_Type'Pos (Column_Type'First) + 1;
    end Col;

    function Current_Line return Line_Type is
    begin
        return The_Current_Line;
    end Current_Line;
    function Current_Column return Column_Type is
    begin
        return The_Current_Column;
    end Current_Column;

    package body Buffer is separate;
    package body Keyboard is separate;
    package body Screen is separate;  
    package body Tool_Set is separate;
    procedure Engine (Window_Name          : String := Default_Name;
                      Initial_File_To_Load : String :=
                         No_File_Name) is separate;

end Spreadsheet_Generic;
DataMuseum.dk

Rational R1000/400

⟦7210bce54⟧ Ada Source

Derivation

E3 Source Code

E3 Meta Data
