Natools

------------------------------------------------------------------------------
-- Copyright (c) 2015, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Ada.Calendar.Formatting;

package body Natools.Time_Keys is

   function Extract_Sub_Second (Key : String) return Duration;
      --  Read the end of Buffer and compute the Sub_Second part


   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   function Extract_Sub_Second (Key : String) return Duration is
      Sub_Second : Duration := 0.0;
   begin
      for I in reverse Key'First + 7 .. Key'Last loop
         Sub_Second := (Sub_Second + Duration (Value (Key (I)))) / 32;
         Sub_Second := (Sub_Second + Duration'Small) / 2;
      end loop;

      return Sub_Second;
   end Extract_Sub_Second;



   -----------------------
   -- Publoic Interface --
   -----------------------

   function To_Key
     (Time : Ada.Calendar.Time;
      Max_Sub_Second_Digits : in Natural := 120)
     return String
   is
      Buffer : String (1 .. 7 + Max_Sub_Second_Digits);
      Last : Positive;
      N : Natural;
      Year : Ada.Calendar.Year_Number;
      Month : Ada.Calendar.Month_Number;
      Day : Ada.Calendar.Day_Number;
      Hour : Ada.Calendar.Formatting.Hour_Number;
      Minute : Ada.Calendar.Formatting.Minute_Number;
      Second : Ada.Calendar.Formatting.Second_Number;
      Sub_Second : Ada.Calendar.Formatting.Second_Duration;
      D, Base : Duration;
      Leap_Second : Boolean;
   begin
      Ada.Calendar.Formatting.Split
        (Time,
         Year, Month, Day, Hour, Minute, Second, Sub_Second,
         Leap_Second);

      Buffer (1) := I_Image (Year / 64);
      Buffer (2) := I_Image (Year mod 64);
      Buffer (3) := I_Image (Month);
      Buffer (4) := I_Image (Day);
      Buffer (5) := I_Image (Hour);
      Buffer (6) := I_Image (Minute);

      if Leap_Second then
         pragma Assert (Second = 59);
         Buffer (7) := I_Image (60);
      else
         Buffer (7) := I_Image (Second);
      end if;

      if Sub_Second = 0.0 then
         if Second = 0 then
            if Minute = 0 then
               if Hour = 0 then
                  return Buffer (1 .. 4);
               else
                  return Buffer (1 .. 5);
               end if;
            else
               return Buffer (1 .. 6);
            end if;
         else
            return Buffer (1 .. 7);
         end if;
      end if;

      Last := 7;
      D := Sub_Second * 64;
      Base := 1.0;
      loop
         Last := Last + 1;
         Base := Base / 64.0;
         N := Natural (D);

         if Last = Buffer'Last or Base = 0.0 then
            Buffer (Last) := I_Image (N);
            exit;
         end if;

         if Duration (N) > D then
            N := N - 1;
            pragma Assert (Duration (N) <= D);
         end if;

         D := (D - Duration (N)) * 64;
         Buffer (Last) := I_Image (N);

         exit when D = 0.0;
      end loop;

      return Buffer (1 .. Last);
   end To_Key;


   function To_Time (Key : String) return Ada.Calendar.Time is
      Leap_Second : constant Boolean
        := Key'First + 6 in Key'Range and then Key (Key'First + 6) = 'x';
   begin
      return Ada.Calendar.Formatting.Time_Of
        (Year        => I_Value (Key (Key'First)) * 64
                      + I_Value (Key (Key'First + 1)),
         Month       => I_Value (Key (Key'First + 2)),
         Day         => I_Value (Key (Key'First + 3)),
         Hour        => (if Key'First + 4 in Key'Range
                         then I_Value (Key (Key'First + 4)) else 0),
         Minute      => (if Key'First + 5 in Key'Range
                         then I_Value (Key (Key'First + 5)) else 0),
         Second      => (if Key'First + 6 in Key'Range
                         then (if Leap_Second then 59
                               else I_Value (Key (Key'First + 6)))
                         else 0),
         Sub_Second  => Extract_Sub_Second (Key),
         Leap_Second => Leap_Second);
   end To_Time;

end Natools.Time_Keys;

------------------------------------------------------------------------------
-- Copyright (c) 2015, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Natools.Time_Keys provides a concise but printable representation of     --
-- time where lexicographical order matches chronological order.            --
-- It is based on a base-64 symbol set that preserve order, picked from URL --
-- unreserved character set.                                                --
-- It consists simply of time components in big-endian order, trimming      --
-- tailing zeros, and using two base-64 digits for the year, which gives a  --
-- 4096 year span.                                                          --
-- This means a second granularity can be achieved with 7 characters. The   --
-- most compact way of encoding such a timestamp would be counting seconds, --
-- like UNIX time. The time covered by this format is rought 2^37 seconds,  --
-- which would mean 5 bytes or 7 base-64 digits (though 6 would be enough   --
-- for a useful time range).                                                --
------------------------------------------------------------------------------

with Ada.Calendar;

package Natools.Time_Keys is

   function Is_Valid (Key : String) return Boolean;
      --  Check whether Key is a valid encoded time.
      --  WARNING: this function returns true for invalid dates,
      --  like February 30th.

   function To_Key
     (Time : Ada.Calendar.Time;
      Max_Sub_Second_Digits : in Natural := 120)
     return String
     with Post => Is_Valid (To_Key'Result);
      --  Convert a time into a key

   function To_Time (Key : String) return Ada.Calendar.Time
     with Pre => Is_Valid (Key);
      --  Convert a valid key into the original time

private

   subtype Base_64_Digit is Character with Static_Predicate
     => Base_64_Digit in '0' .. '9' | 'A' .. 'Z' | '_' | 'a' .. 'z' | '~';

   type Base_64_Value is mod 2 ** 6;

   Digit_Offset : constant := 48;  --  Character'Pos ('0')
   Upper_Offset : constant := 55;  --  Character'Pos ('A') - 10
   Lower_Offset : constant := 60;  --  Character'Pos ('a') - 37

   function Value (Digit : Base_64_Digit) return Base_64_Value
     is (Base_64_Value
           (case Digit is
            when '0' .. '9' => Character'Pos (Digit) - Digit_Offset,
            when 'A' .. 'Z' => Character'Pos (Digit) - Upper_Offset,
            when '_'        => 36,
            when 'a' .. 'z' => Character'Pos (Digit) - Lower_Offset,
            when '~'        => 63));

   function I_Value (Digit : Base_64_Digit) return Integer
     is (Integer (Value (Digit)));

   function Image (Digit : Base_64_Value) return Base_64_Digit
     is (case Digit is
         when  0 ..  9 => Character'Val (Natural (Digit) + Digit_Offset),
         when 10 .. 35 => Character'Val (Natural (Digit) + Upper_Offset),
         when    36    => '_',
         when 37 .. 62 => Character'Val (Natural (Digit) + Lower_Offset),
         when    63    => '~');

   function I_Image (Digit : Integer) return Base_64_Digit
     is (Image (Base_64_Value (Digit)));

   function Is_Valid (Key : String) return Boolean
     is (Key'Length >= 4
         and then Key (Key'First)
               in '0' .. '9' | 'A' .. 'Z' | '_' | 'a' .. 'z' | '~'
         and then Key (Key'First + 1)
               in '0' .. '9' | 'A' .. 'Z' | '_' | 'a' .. 'z' | '~'
         and then Key (Key'First + 2) in '1' .. '9' | 'A' .. 'C'
         and then Key (Key'First + 3) in '1' .. '9' | 'A' .. 'V'
         and then (Key'First + 4 not in Key'Range
            or else Key (Key'First + 4) in '0' .. '9' | 'A' .. 'N')
         and then (Key'First + 5 not in Key'Range or else Key (Key'First + 5)
               in '0' .. '9' | 'A' .. 'Z' | '_' | 'a' .. 'w')
         and then (Key'First + 6 not in Key'Range or else Key (Key'First + 6)
               in '0' .. '9' | 'A' .. 'Z' | '_' | 'a' .. 'x')
         and then (for all I in Key'First + 7 .. Key'Last => Key (I)
               in '0' .. '9' | 'A' .. 'Z' | '_' | 'a' .. 'z' | '~'));

end Natools.Time_Keys;