⟦4b27bf7af⟧

TextFile

separate (Time_Utilities)
function Interval_Value (S : String) return Interval is

    -- format is ddDhh:mm:ss.milli
    -- upper or lower case D is a delimiter
    -- all non-numeric non delimiters are ignored
    -- if only one : is given, it is assumed to separate hrs and seconds
    --    10:17 is 10hrs 17min, :10:17 is 0hrs 10min 17sec

    Position : Natural := S'First;
    Result   : Interval;

    type Kind_Value is (Day, Hour, Minute, Second, Millisecond, Number);
    type Item;
    type Item_Ptr   is access Item;

    type Item is
        record
            Kind  : Kind_Value;
            Value : Natural;
            Next  : Item_Ptr;
        end record;

    First_Item : Item_Ptr;
    Last_Item  : Item_Ptr;

    Dot_Observed    : Boolean := False;
    Colons_Observed : Natural := 0;


    function Is_Digit (Char : Character) return Boolean is
    begin
        case Char is
            when '0' .. '9' =>
                return True;
            when others =>
                return False;
        end case;
    end Is_Digit;


    function Is_Delimiter (Char : Character) return Boolean is
    begin
        case Char is
            when ':' | 'D' | 'd' | '/' | '.' =>
                return True;
            when others =>
                return False;
        end case;
    end Is_Delimiter;


    function Get_Number return Item_Ptr is
        Start : Natural := Position;
        Last  : Natural;

        function Pad_To_Three_Digits (S : String) return Natural is
        begin
            if S'Length = 1 then
                return Natural'Value (S & "00");
            elsif S'Length = 2 then
                return Natural'Value (S & '0');
            else
                return Natural'Value (S (S'First .. S'First + 2));
            end if;
        end Pad_To_Three_Digits;

        function Get_Item (N : Natural) return Item_Ptr is
        begin
            return new Item'(Kind => Number, Value => N, Next => null);
        end Get_Item;
    begin
        while Position <= S'Last and then Is_Digit (S (Position)) loop
            Position := Position + 1;
        end loop;

        if Position <= S'Last then
            Last := Position - 1;
        else
            Last := S'Last;
        end if;

        if Dot_Observed then
            return Get_Item (Pad_To_Three_Digits (S (Start .. Last)));
        else
            return Get_Item (Natural'Value (S (Start .. Last)));
        end if;
    end Get_Number;


    function Get_Item return Item_Ptr is
        Char : Character;

        function Item_Value (Ch : Character) return Item_Ptr is
            Result : Item_Ptr := new Item;
        begin
            case Ch is

                when 'D' | 'd' | '/' =>
                    Result.Kind := Day;

                when ':' =>
                    Result.Kind     := Hour;
                    Colons_Observed := Colons_Observed + 1;

                    if Colons_Observed > 2 then
                        raise Constraint_Error;
                    end if;

                when '.' =>
                    Result.Kind  := Second;
                    Dot_Observed := True;

                when others =>
                    raise Constraint_Error;
            end case;

            return Result;
        end Item_Value;
    begin
        while Position <= S'Last loop
            Char := S (Position);

            if Is_Delimiter (Char) then
                Position := Position + 1;
                return Item_Value (Char);
            elsif Is_Digit (Char) then
                return Get_Number;
            else
                Position := Position + 1;
            end if;
        end loop;

        return null;
    end Get_Item;


    procedure Build_List (First, Last : in out Item_Ptr) is
        Next_Item : Item_Ptr;
    begin
        -- build list of items
        Next_Item := Get_Item;
        First     := Next_Item;
        Last      := First;

        loop
            Next_Item := Get_Item;
            exit when Next_Item = null;

            Last.Next := Next_Item;
            Last      := Next_Item;
        end loop;
    end Build_List;


    procedure Normalize (First, Last : in out Item_Ptr) is
        Hour_Item : Item_Ptr;
        Next_Item : Item_Ptr := First;

        procedure Add (Kind : Kind_Value) is
            New_Item : Item_Ptr := new Item'(Kind, 0, null);
        begin
            Last.Next := New_Item;
            Last      := New_Item;
        end Add;
    begin
        if Colons_Observed = 2 or else Dot_Observed then
            -- find right_most hour and make it minute
            while Next_Item /= null loop
                if Next_Item.Kind = Hour then
                    Hour_Item := Next_Item;
                end if;

                Next_Item := Next_Item.Next;
            end loop;

            if Hour_Item /= null then
                Hour_Item.Kind := Minute;
            end if;
        end if;

        if Last.Kind = Number then
            if Dot_Observed then
                Add (Millisecond);
            else
                case Colons_Observed is
                    when 2 =>
                        Add (Second);
                    when 1 =>
                        Add (Minute);
                    when 0 =>
                        Add (Hour);
                    when others =>
                        raise Constraint_Error;
                end case;
            end if;
        end if;
    end Normalize;


    function Build_Value (First, Last : Item_Ptr) return Interval is
        Number_Kind : constant Kind_Value := Number;

        Result    : Interval := Null_Interval;
        Next_Item : Item_Ptr := First;
        Number    : Natural  := 0;

        procedure Get_Number (Ptr : in out Item_Ptr; Value : in out Natural) is
        begin
            if Ptr.Kind = Number_Kind then
                Value := Ptr.Value;
                Ptr   := Ptr.Next;
            else
                Value := 0;
            end if;
        end Get_Number;

        procedure Set_Field (Kind   :        Kind_Value;
                             Number :        Natural;
                             Result : in out Interval) is
            Value : Natural := Number;
        begin
            if Value = 0 then
                return;
            end if;

            case Next_Item.Kind is

                when Day =>
                    Result.Elapsed_Days :=
                       Result.Elapsed_Days + Day_Count (Value);

                when Hour =>
                    Value := Value + Natural (Result.Elapsed_Hours);
                    Set_Field (Day, Value / 24, Result);
                    Result.Elapsed_Hours := Military_Hours (Value mod 24);

                when Minute =>
                    Value := Value + Natural (Result.Elapsed_Minutes);
                    Set_Field (Hour, Value / 60, Result);
                    Result.Elapsed_Minutes := Minutes (Value mod 60);

                when Second =>
                    Value := Value + Natural (Result.Elapsed_Seconds);
                    Set_Field (Minute, Value / 60, Result);
                    Result.Elapsed_Seconds := Seconds (Value mod 60);

                when Millisecond =>
                    Value := Value + Natural (Result.Elapsed_Milliseconds);
                    Set_Field (Second, Value / 1000, Result);
                    Result.Elapsed_Milliseconds :=
                       Milliseconds (Value mod 1000);

                when others =>
                    raise Constraint_Error;
            end case;
        end Set_Field;

    begin
        while Next_Item /= null loop
            Get_Number (Next_Item, Number);
            -- increments next_item (if appropriate)

            Set_Field (Next_Item.Kind, Number, Result);
            Next_Item := Next_Item.Next;
        end loop;

        return Result;
    end Build_Value;

begin
    Build_List (First_Item, Last_Item);
    Normalize (First_Item, Last_Item);
    return Build_Value (First_Item, Last_Item);
end Interval_Value;
DataMuseum.dk

Rational R1000/400 Tapes

⟦4b27bf7af⟧ TextFile

Derivation

TextFile
