⟦90b99a8d4⟧

TextFile

with Table_Sort_Generic;

package body Table_Formatter is
    Intercolumn_Spacing : constant := 2;
    subtype Column_Index is Natural range 1 .. Number_Of_Columns;

    type Width_List is array (Column_Index) of Natural;

    type A_String    is access String;
    type An_Item (Subitem_Length : Natural);
    type Access_Item is access An_Item;
    type An_Item (Subitem_Length : Natural) is
        record
            Subitem : String (1 .. Subitem_Length);
            Next    : Access_Item;
        end record;

    type Item_List is array (Column_Index) of Access_Item;

    type Line;
    type Access_Line       is access Line;
    type Access_Line_Array is array (Integer range <>) of Access_Line;

    Current_Line : Access_Line;

    type Line is
        record
            Values : Item_List;
            Width  : Width_List  := (others => 0);
            Next   : Access_Line := Current_Line;
        end record;

    Current_Column : Column_Index := Column_Index'Last;
    In_Subitem     : Boolean      := False;
    Max_Width      : Width_List   := (others => 0);
    Headers        : array (Column_Index) of A_String;
    Header_Column  : Natural      := 0;
    Column_Format  : array (Column_Index) of Adjust;

    function Max (Left, Right : Integer) return Integer is
    begin
        if Left >= Right then
            return Left;
        else
            return Right;
        end if;
    end Max;

    procedure Insert (S : String) is
        -- Put the String into the current row/column, appending it if
        -- there is already something there.

        Cell  : Access_Item renames Current_Line.Values (Current_Column);
        Width : Natural     renames Current_Line.Width (Current_Column);
        Max   : Natural     renames Max_Width (Current_Column);
    begin
        if Cell = null then
            Width := S'Length;
        else
            Width := Width + Subitem_Separator'Length + S'Length;
        end if;

        if Width > Max then
            Max := Width;
        end if;

        Cell := new An_Item'(S'Length, S, Cell);
    end Insert;

    procedure Item (S : String) is
        -- Begin a new cell, put S there, and mark the cell closed by
        -- setting In_Subitem to be false.
    begin
        if Current_Column = Column_Index'Last then
            Current_Line   := new Line;
            Current_Column := Column_Index'First;
        else
            Current_Column := Current_Column + 1;
        end if;

        Insert (S);
        In_Subitem := False;
    end Item;

    procedure Header (S : String; Format : Adjust := Left) is
        -- Set Header and Column Format
    begin
        Header_Column                 := Header_Column + 1;
        Column_Format (Header_Column) := Format;
        Headers (Header_Column)       := new String'(S);
    end Header;

    procedure Subitem (S : String) is
        -- If the current cell is open, add S to it.  Otherwise start a new
        -- cell, but leave it open.
    begin
        if In_Subitem then
            Insert (S);
        else
            Item (S);
        end if;

        In_Subitem := True;
    end Subitem;

    procedure Last_Subitem is
        -- If the current cell is open, close it.  If the current cell is
        -- closed, we have an item that consists of zero subitems.  Give it
        -- a visible representation.
    begin
        if In_Subitem then
            In_Subitem := False;
        else
            Item ("(none)");
        end if;
    end Last_Subitem;


    function Image (P : Access_Item) return String is
        -- P must be non-null
    begin
        if P.Next = null then
            return P.Subitem;
        end if;

        return Image (P.Next) & Subitem_Separator & P.Subitem;
        -- Recall that subitem lists are stored in reverse order
    end Image;


    procedure Display (On_File : Text_Io.File_Type) is
        -- Dump the data structure we have been building by traversing it
        -- recursively.  Note that all of the lists are stored in reverse
        -- order so that they were easy to build.

        procedure Replicate (C : Character; N : Natural) is
            -- Output N copies of C
            S : constant String (1 .. N) := (others => C);
        begin
            Text_Io.Put (On_File, S);
        end Replicate;

        procedure Display (P : Access_Item) is
        begin
            if P /= null then
                Text_Io.Put (On_File, Image (P));
            end if;
        end Display;

        procedure Display_Headers is
            Excess : Width_List;
        begin
            for J in Column_Index loop
                Excess (J) := Max (Headers (J).all'Length, Max_Width (J)) -
                                 Headers (J).all'Length;
            end loop;

            Replicate (' ', Excess (1) / 2);

            for J in Column_Index loop
                Text_Io.Put (On_File, Headers (J).all);

                if J /= Column_Index'Last then
                    Replicate (' ', (Excess (J) + 1) / 2 + Excess (J + 1) / 2 +
                                       Intercolumn_Spacing);
                end if;

            end loop;

            Text_Io.New_Line (On_File);
        end Display_Headers;

        procedure Display_Adjusted (L : Line) is
            Inner_Excess, Outer_Excess : Natural;
        begin
            for J in Column_Index loop
                Inner_Excess := Max_Width (J) - L.Width (J);
                Outer_Excess :=
                   Max (Headers (J).all'Length, Max_Width (J)) - Max_Width (J);

                case Column_Format (J) is
                    when Left =>
                        Replicate (' ', Outer_Excess / 2);
                        Display (L.Values (J));
                        if J /= Column_Index'Last then
                            Replicate (' ',
                                       (Outer_Excess + 1) / 2 + Inner_Excess +
                                          Intercolumn_Spacing);
                        end if;

                    when Right =>
                        Replicate (' ', Outer_Excess / 2 + Inner_Excess);
                        Display (L.Values (J));
                        if J /= Column_Index'Last then
                            Replicate (' ', (Outer_Excess + 1) / 2 +
                                               Intercolumn_Spacing);
                        end if;

                    when Centered =>
                        Replicate (' ', (Inner_Excess + Outer_Excess) / 2);
                        Display (L.Values (J));
                        if J /= Column_Index'Last then
                            Replicate (' ',
                                       (Inner_Excess + Outer_Excess + 1) / 2 +
                                          Intercolumn_Spacing);
                        end if;
                end case;
            end loop;

            Text_Io.New_Line (On_File);
        end Display_Adjusted;

        procedure Display (L : Access_Line) is
        begin
            if L = null then
                -- Center the header
                Display_Headers;

                -- A separator line
                for J in Column_Index loop
                    Replicate ('=', Max
                                       (Headers (J).all'Length, Max_Width (J)));
                    if J /= Column_Index'Last then
                        Replicate (' ', Intercolumn_Spacing);
                    end if;
                end loop;
                Text_Io.New_Line (On_File);
            else
                -- Display the head of the table
                Display (L.Next);

                -- Display the final line
                Display_Adjusted (L.all);
            end if;
        end Display;
    begin
        Display (Current_Line);
    end Display;


    function Normalize return Natural is
        -- Traverse the current structure looking for cells that consist
        -- of more than one subitem, and concatentate the subitems into
        -- a single item.

        -- Return the number of rows in the table.

        Result : Natural     := 0;
        Line   : Access_Line := Current_Line;
        P      : Access_Item;
    begin
        while Line /= null loop
            for J in Line.Values'Range loop
                P := Line.Values (J);

                if P = null then
                    Line.Values (J) := new An_Item'(0, "", null);
                elsif P.Next /= null then
                    Line.Values (J) :=
                       new An_Item'(Line.Width (J), Image (P), null);
                end if;
            end loop;

            Line   := Line.Next;
            Result := Result + 1;
        end loop;

        return Result;
    end Normalize;

    procedure Fill (Table : out Access_Line_Array) is
        -- Transfers the linked list pointed to by Current_Line into
        -- the sequential table.

        P : Access_Line;
    begin
        P := Current_Line;
        for J in reverse Table'Range loop
            Table (J) := P;
            P         := P.Next;
        end loop;
    end Fill;

    procedure Empty (Table : Access_Line_Array) is
        -- rebuilds the Current_Line link list from the sequential table,
        -- preserving the convention that lists are stored backwards.
    begin
        if Table'Length = 0 then
            Current_Line := null;
            return;
        end if;

        Table (Table'First).Next := null;

        for J in Table'First + 1 .. Table'Last loop
            Table (J).Next := Table (J - 1);
        end loop;

        Current_Line := Table (Table'Last);
    end Empty;


    procedure Sort (On_Field : Positive := 1) is
        Table : Access_Line_Array (1 .. Normalize);

        function "<" (Left, Right : Access_Line) return Boolean is
        begin
            return Left.Values (On_Field).Subitem <
                      Right.Values (On_Field).Subitem;
        end "<";

        procedure Table_Sort is
           new Table_Sort_Generic (Element       => Access_Line,
                                   Index         => Integer,
                                   Element_Array => Access_Line_Array);
    begin
        Fill (Table);
        Table_Sort (Table);
        Empty (Table);
    end Sort;


    procedure Sort (On_Fields : Field_List) is
        Table : Access_Line_Array (1 .. Normalize);

        function "<" (Left, Right : Access_Line) return Boolean is
        begin
            for J in On_Fields'Range loop
                if Left.Values (On_Fields (J)).Subitem <
                   Right.Values (On_Fields (J)).Subitem then
                    return True;
                end if;

                if Left.Values (On_Fields (J)).Subitem >
                   Right.Values (On_Fields (J)).Subitem then
                    return False;
                end if;
            end loop;

            return False;
        end "<";

        procedure Table_Sort is
           new Table_Sort_Generic (Element       => Access_Line,
                                   Index         => Integer,
                                   Element_Array => Access_Line_Array);
    begin
        Fill (Table);
        Table_Sort (Table);
        Empty (Table);
    end Sort;

begin

    -- Default to empty left justified headers.
    for J in Column_Index loop
        Column_Format (J) := Left;
        Headers (J)       := new String'("");
    end loop;

end Table_Formatter;
DataMuseum.dk

Rational R1000/400 Tapes

⟦90b99a8d4⟧ TextFile

Derivation

TextFile
