! uuid256.f90 — reference implementation of README.md (UUID256, random layout) in Fortran 2008.  No libraries.
!
!   gfortran -O2 -o /tmp/uuid256-f90 uuid256.f90 -J /tmp && /tmp/uuid256-f90     (-J puts the .mod file outside the tree)
!   /tmp/uuid256-f90 -n 200000 -i 3          ! 2e5 ids with 3 planted duplicates (proves detection)
!   /tmp/uuid256-f90 -g [count]              ! just print one (or count) new ids, nothing else
!
!   use uuid256_mod
!   call uuid256_generate(id)                ! integer(int8) id(32), §5.1: /dev/urandom (OS CSPRNG), ver=4 / var=10 applied
!   txt = uuid256_to_canonical(id)           ! §3.1: "0001020304050607-08090a0b-4c0d0e0f-90111213-1415161718191a1b1c1d1e1f"
!   call uuid256_parse(txt, id, err, strict) ! §6: err = 0 ok, 1 length, 2 hyphen, 3 char, 4 version/variant
!
! Randomness (§5.2): /dev/urandom read as a stream — RANDOM_NUMBER is not a CSPRNG and MUST NOT be used.
! Bulk check: one urandom read for all ids, §4 applied to each, then an O(n) counting sort on the top 24 random bits
! groups ids into 16M buckets and every pair inside a bucket is compared over all 32 bytes.  Exact.

module uuid256_mod
  use iso_fortran_env, only: int8, int32, int64
  implicit none
  private
  public :: uuid256_generate, uuid256_os_random, uuid256_set_ver_var, uuid256_is_strict, uuid256_to_canonical, uuid256_parse
  public :: UUID256_SIZE, UUID256_TEXT_LEN, UUID256_VERSION, ERR_OK, ERR_LENGTH, ERR_HYPHEN, ERR_CHAR, ERR_VERSION
  integer, parameter :: UUID256_SIZE = 32, UUID256_TEXT_LEN = 68, UUID256_VERSION = 4
  integer, parameter :: ERR_OK = 0, ERR_LENGTH = 1, ERR_HYPHEN = 2, ERR_CHAR = 3, ERR_VERSION = 4
  character(len=16), parameter :: HEX = '0123456789abcdef'
contains
  ! §5.2 — n bytes from the OS CSPRNG
  subroutine uuid256_os_random(buf)
    integer(int8), intent(out) :: buf(:)
    integer :: u, ios
    open(newunit=u, file='/dev/urandom', access='stream', form='unformatted', action='read', status='old', iostat=ios)
    if (ios /= 0) error stop 'uuid256: cannot open /dev/urandom'
    read(u, iostat=ios) buf
    if (ios /= 0) error stop 'uuid256: /dev/urandom read failed'
    close(u)
  end subroutine

  pure integer function u8(b)                       ! signed int8 → 0..255
    integer(int8), intent(in) :: b
    u8 = iand(int(b), 255)
  end function

  ! §4 — force version nibble (byte 13, 1-based) and variant bits (byte 17), in place from offset off (0-based)
  pure subroutine uuid256_set_ver_var(b, off)
    integer(int8), intent(inout) :: b(:)
    integer, intent(in), optional :: off
    integer :: o
    o = 0; if (present(off)) o = off
    b(o + 13) = int(ior(iand(u8(b(o + 13)), 15), ishft(UUID256_VERSION, 4)), int8)   ! hex digit 24 = '4'
    b(o + 17) = int(ior(iand(u8(b(o + 17)), 63), 128), int8)                        ! hex digit 32 in [89ab]
  end subroutine

  ! §5.1 — a new id (32 bytes, big-endian: element 1 most significant)
  subroutine uuid256_generate(id)
    integer(int8), intent(out) :: id(UUID256_SIZE)
    call uuid256_os_random(id)
    call uuid256_set_ver_var(id)
  end subroutine

  ! §6 — ver == 4 && var == 10
  pure logical function uuid256_is_strict(b, off)
    integer(int8), intent(in) :: b(:)
    integer, intent(in), optional :: off
    integer :: o
    o = 0; if (present(off)) o = off
    uuid256_is_strict = ishft(u8(b(o + 13)), -4) == UUID256_VERSION .and. ishft(u8(b(o + 17)), -6) == 2
  end function

  ! §3.1 — canonical text: 16-8-8-8-24, lowercase, 68 chars
  pure function uuid256_to_canonical(b, off) result(txt)
    integer(int8), intent(in) :: b(:)
    integer, intent(in), optional :: off
    character(len=UUID256_TEXT_LEN) :: txt
    integer :: i, o, p, v
    o = 0; if (present(off)) o = off
    p = 1
    do i = 0, UUID256_SIZE - 1
      v = u8(b(o + i + 1))
      txt(p:p) = HEX(ishft(v, -4) + 1 : ishft(v, -4) + 1)
      txt(p+1:p+1) = HEX(iand(v, 15) + 1 : iand(v, 15) + 1)
      p = p + 2
      if (i == 7 .or. i == 11 .or. i == 15 .or. i == 19) then          ! hyphen after hex digits 16, 24, 32, 40
        txt(p:p) = '-'; p = p + 1
      end if
    end do
  end function

  pure integer function hexval(c)
    character, intent(in) :: c
    select case (c)
    case ('0':'9'); hexval = iachar(c) - 48
    case ('a':'f'); hexval = iachar(c) - 87
    case ('A':'F'); hexval = iachar(c) - 55
    case default;   hexval = -1
    end select
  end function

  ! §6 — parse canonical (68) or compact (64) form, any case; err = 0 ok / 1 length / 2 hyphen / 3 char / 4 version
  pure subroutine uuid256_parse(s, out, err, strict)
    character(len=*), intent(in) :: s
    integer(int8), intent(out) :: out(UUID256_SIZE)
    integer, intent(out) :: err
    logical, intent(in), optional :: strict
    logical :: hy, st
    integer :: i, nib, bi, cur, v, n
    st = .true.; if (present(strict)) st = strict
    out = 0_int8; err = ERR_OK
    n = len(s)
    if (n == UUID256_TEXT_LEN) then
      if (s(17:17) /= '-' .or. s(26:26) /= '-' .or. s(35:35) /= '-' .or. s(44:44) /= '-') then
        err = ERR_HYPHEN; return
      end if
      hy = .true.
    else if (n == 64) then
      hy = .false.
    else
      err = ERR_LENGTH; return
    end if
    nib = 0; bi = 1; cur = 0
    do i = 1, n
      if (hy .and. (i == 17 .or. i == 26 .or. i == 35 .or. i == 44)) cycle
      v = hexval(s(i:i))
      if (v < 0) then
        err = ERR_CHAR; return
      end if
      cur = ior(ishft(cur, 4), v)
      nib = nib + 1
      if (nib == 2) then
        out(bi) = int(cur, int8); bi = bi + 1; nib = 0; cur = 0
      end if
    end do
    if (st .and. .not. uuid256_is_strict(out)) err = ERR_VERSION
  end subroutine
end module uuid256_mod

program uuid256_main
  use iso_fortran_env, only: int8, int32, int64, output_unit
  use uuid256_mod
  implicit none
  integer(int64) :: n, planted, i, kk, src, dst, k, step, rt_ok, bad, ndups
  integer :: argc, err, fails, count_g
  character(len=64) :: arg
  integer(int8), allocatable :: buf(:)
  integer(int8) :: id(32), id2(32)
  integer(int64) :: t0, t1, t2, rate
  real(8) :: per_call, log2p

  n = 1000000_int64; planted = 0
  argc = command_argument_count()
  if (argc >= 2) then                                                    ! parse mode: -p strict, -P lenient
    call get_command_argument(1, arg)
    if (trim(arg) == '-p' .or. trim(arg) == '-P') then
      block
        character(len=:), allocatable :: text
        integer :: alen
        call get_command_argument(2, length=alen)
        allocate(character(len=alen) :: text)
        call get_command_argument(2, text)
        call uuid256_parse(text, id, err, strict=(trim(arg) == '-p'))
        if (err == 0) then
          print '(a,a)', 'ok ', lower_hex(id)
          stop
        end if
        select case (err)
        case (ERR_LENGTH);  print '(a)', 'error length'
        case (ERR_HYPHEN);  print '(a)', 'error hyphen'
        case (ERR_CHAR);    print '(a)', 'error char'
        case default;       print '(a)', 'error version'
        end select
        error stop 1
      end block
    end if
  end if
  i = 1
  do while (i <= argc)
    call get_command_argument(int(i), arg)
    if (trim(arg) == '-g') then                                       ! just print ids: -g [count]
      count_g = 1
      if (i + 1 <= argc) then
        call get_command_argument(int(i) + 1, arg)
        read(arg, *, iostat=err) count_g
        if (err /= 0 .or. count_g < 0) count_g = 1                       ! -g N: exactly N (0 allowed); junk → 1
      end if
      do k = 1, count_g
        call uuid256_generate(id); print '(a)', uuid256_to_canonical(id)
      end do
      stop
    else if (trim(arg) == '-n' .and. i + 1 <= argc) then
      i = i + 1; call get_command_argument(int(i), arg); read(arg, *, iostat=err) n
      if (err /= 0 .or. verify(trim(arg), '0123456789') /= 0) then
        print '(a,a)', '-n: invalid number ', trim(arg); error stop 2
      end if
    else if (trim(arg) == '-i' .and. i + 1 <= argc) then
      i = i + 1; call get_command_argument(int(i), arg); read(arg, *, iostat=err) planted
      if (err /= 0 .or. verify(trim(arg), '0123456789') /= 0) then
        print '(a,a)', '-i: invalid number ', trim(arg); error stop 2
      end if
    else
      print '(a)', 'usage: uuid256-f90 [-g [count]] [-n count] [-i planted_dups]'; error stop 2
    end if
    i = i + 1
  end do
  if (n < 2 .or. planted < 0 .or. planted > n / 2) then
    print '(a)', '-n must be >= 2 and -i at most n/2'; error stop 2
  end if

  print '(a)', 'UUID256 reference implementation (Fortran) — README.md (256-bit random, 16-8-8-8-24 text)'
  print '(a)', ''
  print '(a)', 'Self-tests:'
  fails = self_test()
  if (fails > 0) then
    print '(a)', '  self-test FAILED — aborting'; error stop 1
  end if

  call system_clock(t0, rate)
  do k = 1, 20000
    call uuid256_generate(id)
  end do
  call system_clock(t1)
  per_call = real(t1 - t0, 8) / real(rate, 8) / 20000.0d0
  print '(a)', ''
  print '(a,f8.2,a,f8.3,a,f8.0,a)', 'uuid256_generate per-call cost: ', per_call * 1e6, ' µs → ', 1.0 / per_call / 1e6, &
        ' M ids/s single-threaded (1e9 ids would take ~', 1e9 * per_call / 60.0, ' min just to generate; opening /dev/urandom per call dominates)'

  print '(a)', ''
  print '(a,a,a,i0)', 'Bulk exact duplicate check: n=', trim(commas(n)), ' ids, planted duplicates=', planted
  call system_clock(t0)
  allocate(buf(n * 32))
  call uuid256_os_random(buf)                                        ! §5.2, one read
  do i = 0, n - 1
    call uuid256_set_ver_var(buf, int(i * 32))                        ! §4 on every id
  end do
  call system_clock(t1)
  do kk = 0, planted - 1                                              ! id[dst] := id[src]
    src = kk * ((n / 2) / planted); dst = n - 1 - src                  ! stride: distinct pairs for every k < planted <= n/2
    buf(dst*32+1 : dst*32+32) = buf(src*32+1 : src*32+32)
    print '(a,a,a,a,a)', '  planted: id[', trim(commas(dst)), '] := id[', trim(commas(src)), ']'
  end do
  bad = 0
  do i = 0, n - 1
    if (.not. uuid256_is_strict(buf, int(i * 32))) bad = bad + 1
  end do
  call find_duplicates()
  call system_clock(t2)
  step = max(1_int64, n / 1000); rt_ok = 0
  do i = 0, n - 1, step
    id = buf(i*32+1 : i*32+32)
    call uuid256_parse(uuid256_to_canonical(id), id2, err)
    if (err == 0 .and. all(id2 == id)) rt_ok = rt_ok + 1
  end do
  print '(a)', ''
  print '(a)', '==== RESULT ===='
  print '(a,a,a,f6.1,a,f6.1,a)', 'ids generated:                   ', trim(commas(n)), '   (/dev/urandom + §4 in ', &
        real(t1 - t0) / real(rate), 's; bucket-sort+compare in ', real(t2 - t1) / real(rate), 's)'
  print '(a,a)', 'version/variant violations:      ', trim(commas(bad))
  print '(a,a,a)', 'text round-trips (sampled):      ', trim(commas(rt_ok)), ' ok'
  if (planted > 0) then
    print '(a,a,a,i0,a,a,a)', 'FULL 256-bit DUPLICATES:         ', trim(commas(ndups)), '   (planted: ', planted, ' — ', &
          trim(merge('all detected  ', 'COUNT MISMATCH', ndups == planted)), ')'
  else
    print '(a,a)', 'FULL 256-bit DUPLICATES:         ', trim(commas(ndups))
  end if
  if (ndups == 0) print '(a,a,a)', '  → no duplicates among ', trim(commas(n)), ' ids'
  log2p = 2.0d0 * log(real(n, 8)) / log(2.0d0) - 251.0d0
  print '(a,f7.1,a,es8.1)', 'expected P(any collision) §5.3:  n²/2²⁵¹ ≈ 2^', log2p, ' ≈ ', 2.0d0 ** log2p
  if (ndups /= planted) error stop 1

contains
  integer function self_test() result(f)
    character(len=64), parameter :: vin(2) = [character(len=64) :: &
      '000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f', 'fffefdfcfbfaf9f8f7f6f5f4f3f2f1f0efeeedecebeae9e8e7e6e5e4e3e2e1e0']
    character(len=68), parameter :: vout(2) = [character(len=68) :: &
      '0001020304050607-08090a0b-4c0d0e0f-90111213-1415161718191a1b1c1d1e1f', 'fffefdfcfbfaf9f8-f7f6f5f4-43f2f1f0-afeeedec-ebeae9e8e7e6e5e4e3e2e1e0']
    integer(int8) :: b(32), p1(32), p2(32), nil(32), mx(32)
    integer :: e1, e2, e3, e4, e5, e6, iv
    logical :: ok
    character(len=68) :: t, nil_txt
    f = 0
    do iv = 1, 2
      call uuid256_parse(vin(iv), b, e1, strict=.false.)
      call uuid256_set_ver_var(b)
      t = uuid256_to_canonical(b)
      call uuid256_parse(t, p1, e2)
      call uuid256_parse(upper(t), p2, e3)
      call uuid256_parse(vin(iv), nil, e4)                             ! raw compact, strict → version error (scratch out)
      ok = t == vout(iv) .and. uuid256_is_strict(b) .and. e1 == 0 .and. e2 == 0 .and. all(p1 == b) &
           .and. e3 == 0 .and. all(p2 == b) .and. e4 == ERR_VERSION
      print '(a,i0,a,a,a,a)', '  spec §11 vector ', iv, ': ', merge('PASS', 'FAIL', ok), '  ', t
      if (.not. ok) f = f + 1
    end do
    nil = 0_int8; mx = -1_int8
    nil_txt = uuid256_to_canonical(nil)
    call uuid256_parse('0001020304050607_08090a0b-4c0d0e0f-90111213-1415161718191a1b1c1d1e1f', b, e1)
    call uuid256_parse('0001020304050607-08090a0b-4c0d0e0f-90111213-1415161718191a1b1c1d1e1', b, e2)
    call uuid256_parse('0001020304050607-08090a0b-4c0d0e0f-90111213-1415161718191a1b1c1d1e1g', b, e3)
    call uuid256_parse(nil_txt, b, e4)
    call uuid256_parse(nil_txt, b, e5, strict=.false.)
    ok = e1 == ERR_HYPHEN .and. e2 == ERR_LENGTH .and. e3 == ERR_CHAR .and. e4 == ERR_VERSION .and. e5 == 0 .and. all(b == nil) &
         .and. uuid256_to_canonical(mx) == repeat('f', 16)//'-'//repeat('f', 8)//'-'//repeat('f', 8)//'-'//repeat('f', 8)//'-'//repeat('f', 24)
    print '(a,a)', '  parser rules (§3.2/§6):  ', merge('PASS', 'FAIL', ok)
    if (.not. ok) f = f + 1
    do iv = 1, 3
      call uuid256_generate(b)
      t = uuid256_to_canonical(b)
      call uuid256_parse(t, p1, e6)
      ! string offsets: hex digit 24 → char 27 (1-based, after 2 hyphens), hex digit 32 → char 36
      ok = uuid256_is_strict(b) .and. t(27:27) == '4' .and. index('89ab', t(36:36)) > 0 .and. e6 == 0 .and. all(p1 == b)
      print '(a,a,a,a)', '  uuid256_generate: ', t, '  ', merge('ok ', 'BAD', ok)
      if (.not. ok) f = f + 1
    end do
  end function

  pure function lower_hex(b) result(h)
    integer(int8), intent(in) :: b(32)
    character(len=64) :: h
    character(len=16), parameter :: hx = '0123456789abcdef'
    integer :: i, v
    do i = 1, 32
      v = iand(int(b(i)), 255)
      h(2*i-1:2*i-1) = hx(ishft(v, -4) + 1 : ishft(v, -4) + 1)
      h(2*i:2*i) = hx(iand(v, 15) + 1 : iand(v, 15) + 1)
    end do
  end function

  pure function upper(s) result(u)
    character(len=*), intent(in) :: s
    character(len=len(s)) :: u
    integer :: i
    u = s
    do i = 1, len(s)
      if (s(i:i) >= 'a' .and. s(i:i) <= 'z') u(i:i) = achar(iachar(s(i:i)) - 32)
    end do
  end function

  function commas(v) result(s)
    integer(int64), intent(in) :: v
    character(len=32) :: s, raw
    integer :: l, i, o
    write(raw, '(i0)') v
    l = len_trim(raw); s = ''; o = 1
    do i = 1, l
      if (i > 1 .and. mod(l - i + 1, 3) == 0) then
        s(o:o) = ','; o = o + 1
      end if
      s(o:o) = raw(i:i); o = o + 1
    end do
  end function

  subroutine find_duplicates()
    integer, parameter :: NB = 2**24
    integer(int32), allocatable :: start(:), cursor(:), order(:)
    integer(int64) :: i, b, lo, hi, x, y, ii, jj
    ndups = 0
    allocate(start(0:NB), cursor(0:NB), order(0:n-1))
    start = 0
    do i = 0, n - 1
      start(bucket(i) + 1) = start(bucket(i) + 1) + 1
    end do
    do b = 0, NB - 1
      start(b + 1) = start(b + 1) + start(b)                            ! exclusive prefix sums
    end do
    cursor = start
    do i = 0, n - 1
      b = bucket(i)
      order(cursor(b)) = int(i, int32); cursor(b) = cursor(b) + 1
    end do
    do b = 0, NB - 1
      lo = start(b); hi = start(b + 1)
      if (hi - lo < 2) cycle
      do x = lo, hi - 1
        do y = x + 1, hi - 1                                            ! buckets are tiny (n / 16M)
          ii = order(x); jj = order(y)
          if (all(buf(ii*32+1 : ii*32+32) == buf(jj*32+1 : jj*32+32))) then
            ndups = ndups + 1
            print '(a,a,a,a,a,a)', '  DUPLICATE  id[', trim(commas(min(ii, jj))), '] == id[', trim(commas(max(ii, jj))), ']  ', &
                  uuid256_to_canonical(buf, int(ii * 32))
          end if
        end do
      end do
    end do
    deallocate(start, cursor, order)
  end subroutine

  pure integer(int64) function bucket(i)                                ! top 24 bits (bytes 1..3 of id i)
    integer(int64), intent(in) :: i
    bucket = ior(ior(ishft(int(iand(int(buf(i*32+1)), 255), int64), 16), ishft(int(iand(int(buf(i*32+2)), 255), int64), 8)), &
                 int(iand(int(buf(i*32+3)), 255), int64))
  end function
end program uuid256_main