|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ B T ┃
Length: 8901 (0x22c5)
Types: TextFile
Names: »B«
└─⟦149519bd4⟧ Bits:30000546 8mm tape, Rational 1000, !projects 93-07-13
└─ ⟦124ff5788⟧ »DATA«
└─⟦this⟧
└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
└─ ⟦129cab021⟧ »DATA«
└─⟦this⟧
└─⟦f64eaa120⟧ Bits:30000752 8mm tape, Rational 1000, !projects 93 02 16
└─ ⟦6f12a12be⟧ »DATA«
└─⟦this⟧
└─⟦2f6cfab89⟧ Bits:30000547 8mm tape, Rational 1000, !projects 94-01-04
└─ ⟦d65440be7⟧ »DATA«
└─⟦this⟧
separate (Time_Utilities)
package body Interval_Value is
function Value (S : String) return Interval is
-- format is ddDhh:mm:ss.milli
-- upper or lower case D is a deliminator
-- 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 Value;
end Interval_Value;