module fox_m_utils_uuid

  !This generates UUIDs according to RFC 4122

  ! Only types 1 (time-based) and 4 (pseudo-RNG-based) are implemented.

#ifndef DUMMYLIB
  use fox_m_utils_mtprng, only : mtprng_state, mtprng_init, mtprng_rand64
#endif

  implicit none
  private
  
#ifndef DUMMYLIB
  integer, parameter :: i4b = selected_int_kind(9)
  integer, parameter :: i8b = selected_int_kind(18)
  
  character, parameter :: hexdigits(0:15) = &
    (/'0','1','2','3','4','5','6','7','8','9','a','b','c','d','e','f'/)
  
  type(mtprng_state), save :: rng_state
  logical, save :: initialized = .false.
  integer, save :: values_save ! must be default for date_and_time
  integer(kind=i4b), save :: hires_count = 0

! clock-seq holds a random number constant for the lifetime of the program
! using this module. That's the best we can do per S 4.1.5
  integer, save :: clock_seq = 0

#endif

  public :: generate_uuid
  
contains
  
  function generate_uuid(version) result(uuid)
    integer, intent(in), optional :: version
    character(len=36) :: uuid

#ifdef DUMMYLIB
    uuid = ""
#else
    integer(kind=i8b) :: timestamp, node
    integer(kind=i4b) :: clock_sequence

    integer(kind=i4b) :: time_low, time_mid, time_hi_and_version
    integer(kind=i4b) :: clk_seq_hi_res, clk_seq_low

    integer :: values(8) ! must be default for date_and_time
    integer(kind=i4b) :: variant, v


    if (.not.initialized) then
      ! Use the current date and time to init mtprng
      ! but this gives limited varaibility, so mix 
      ! the result up.  Can we do better? In any
      ! case, this gets passed through a quick 
      ! generator inside mtprng_init.
      call date_and_time(values=values)
      values(7) = values(7)*1000+values(5)*100+values(3)*10+values(1)
      values(8) = values(2)*1000+values(4)*100+values(6)*10+values(8)
      call mtprng_init(int(values(7)*10000+values(8), i4b), rng_state)
      clock_seq = int(mtprng_rand64(rng_state), i4b)
      initialized = .true.
    endif

    variant = 1

    if (present(version)) then
      v = version
    else
      v = 4
    endif

    select case (v)
    case (0)
      ! Nil UUID  - S 4.1.7
      uuid = repeat('0',8)//'-'//repeat('0',4)//'-'//repeat('0',4)// &
        '-'//repeat('0',4)//'-'//repeat('0',12)
      return
    case(1)
      call date_and_time(values=values)
      ! In case of too-frequent requests, we will replace time_low
      ! with the count below ...
      if (all(values==values_save)) then
        hires_count = hires_count + 1
      else
        hires_count = 0
      endif
    case(2-3)
      !Unimplemented
      uuid = ''
      return
    case(4)
      continue
    case(5)
      !Unimplemented
      uuid = ''
      return
    case default
      !Unspecified
      uuid = ''
      return
    end select

!4.1.4 Timestamp

    select case(v)
    case(1)
      timestamp = get_utc_since_1582(values)
    case(4)
      timestamp = ior(mtprng_rand64(rng_state), ishft(mtprng_rand64(rng_state), 28))
    end select

!4.1.5 Clock Sequence
    ! 14 bits
    select case(v)
    case(1)
      clock_sequence = clock_seq
    case(4)
      clock_sequence = int(mtprng_rand64(rng_state), i4b)
    end select

!4.1.6 Node
    ! 48 bits
    select case(v)
    case(1)
      node = ior(mtprng_rand64(rng_state), ishft(mtprng_rand64(rng_state), 16))
      ! No MAC address accessible - see section 4.5 !FIXME
    case(4)
      node = ior(mtprng_rand64(rng_state), ishft(mtprng_rand64(rng_state), 16))
    end select

    time_low = ibits(timestamp, 0, 32)
    time_mid = ibits(timestamp, 32, 16)
    if (hires_count==0) then
      time_hi_and_version = ior(int(ibits(timestamp, 48, 12), i4b), ishft(v, 12))
    else
      time_hi_and_version = ior(hires_count, ishft(v, 12))
    endif

    clk_seq_low = ibits(clock_sequence, 0, 8)
    clk_seq_hi_res = ior(ibits(clock_sequence, 8, 6), ishft(variant, 6))

    uuid = int32ToHexOctets(time_low, 4)//"-"// &
      int32ToHexOctets(time_mid, 2)//"-"// &
      int32ToHexOctets(time_hi_and_version, 2)//"-"// & 
      int32ToHexOctets(clk_seq_hi_res, 1)// &
      int32ToHexOctets(clk_seq_low, 1)//"-"// &
      int64ToHexOctets(node, 6)

  contains

    function int32ToHexOctets(b, n) result(s)
      integer(i4b), intent(in) :: b
      integer, intent(in) :: n ! number of octets to print
      character(len=2*n) :: s
      
      integer :: i
      
      do i = 0, 2*n-1
        s(2*n-i:2*n-i) = hexdigits(ibits(b, i*4, 4))
      enddo
      
    end function int32ToHexOctets
    function int64ToHexOctets(b, n) result(s)
      integer(i8b), intent(in) :: b
      integer, intent(in) :: n ! number of octets to print
      character(len=2*n) :: s
      
      integer :: i
      
      do i = 0, 2*n-1
        s(2*n-i:2*n-i) = hexdigits(ibits(b, i*4, 4))
      enddo
      
    end function int64ToHexOctets

#endif 
  end function generate_uuid

#ifndef DUMMYLIB
  function get_utc_since_1582(values) result(ns)
    ! This subroutine is a little broken. It only works
    ! for times after 1/1/2006 and takes no account
    ! of any future leapseconds. It ought to serve regardless.

    ! It returns the number of 100-ns intervals since 1582-10-15-00-00-00

    integer, dimension(8), intent(in) :: values
    integer(kind=i8b) :: ns

    integer :: days
    integer :: years

    integer, parameter :: days_in_normal_year(12) = &
      (/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/)

    ns = 23_i8b * 1000_i8b * 1000_i8b * 10_i8b ! 23 leap seconds until 24:00:00 31/12/2005

    ! A count of the 100-nanosecond intervals since the
    ! beginning of the day.
    ns = ns &
      ! milliseconds
      + int(values(8), i8b)             * 10_i8b * 1000_i8b &
      ! seconds
      + int(values(7), i8b)             * 10_i8b * 1000_i8b * 1000_i8b &
      ! minutes (with timezone adjustment)
      + int(values(6) + values(4), i8b) * 10_i8b * 1000_i8b * 1000_i8b * 60_i8b &
      ! hours
      + int(values(5), i8b)             * 10_i8b * 1000_i8b * 1000_i8b * 60_i8b * 60_i8b

    ! Number of days this year:
    days = sum(days_in_normal_year(:values(2)-1))
    days = days + values(3) - 1 !add days in current month
    if (values(2)>2 .and. isLeapYear(values(1))) then
      days = days + 1
    endif
    !That's all the time since the turn of this year

    days = days + 78 ! From the start of 15th Oct to the end of 31st Dec in 1582
    !That's the additional time before the turn of the year 1583

    days = days + 102  ! 102 leap years from 1584 to 2000 inclusive
    ! That's all the intercalataed days until 2000
    
    years = values(1) - 2000 - 1 ! years since 2000 - not including this year

    days = days + years/4 - years/100 + years/400 !Add extra leap days to this total:
    ! That's all out intercalated days - remaining years are all 365 days long.

    years = years + 418 ! Add the years from 1583-2000 inclusive back on.

    ! Multiply by number of time units in one day & add to today's total.
    ns = ns + 864000000000_i8b * (int(days,i8b) + 365_i8b * int(years,i8b))

  contains
    function isLeapYear(y) result(p)
      integer, intent(in) :: y
      logical :: p
      p = (mod(y,4)==0 .and. .not.mod(y,100)==0 .or. mod(y,400)==0)
    end function isLeapYear

  end function get_utc_since_1582

#endif
end module fox_m_utils_uuid