module n3hashraw
  implicit none


! == CLASS DESCRIPTION ==
!
! Hash is a data structure that manages pairs of key and values, and allows
! to search a value from given key. The search is usually faster than that
! would be in a simple array (list) of key-value pairs, because only
! pairs that have keys of matching hash value should be tested in the search.
! Pairs are assorted by hash value.
!
! In this implementation, keys and values are fixed-size arrays of integers.
! All data structure is serialized (stored in an array of integer),
! since efficiency in storing/loading between disk is considered.
! Thus pointer is not used in the table since it is not suitable for
! save and load. Index of entry (pair) arry is used instead.
!
! The whole table consists of three parts:
!  * header (8 words),
!  * index table, and
!  * entry region.
! See comments on parameters named IDX_... for meaning of each header fields.
! Index table is an array of integer whose size is the hash size.
! The ((|i|))-th entry of the index table is index of the first entry
! that has hash value ((|i|)). Note that the hash value is zero-origined.
! Entry region is an array of entry, which is
!  * index to next entry (1 word),
!  * key, and
!  * value.
! Entryes with common hash value compose a chain using the next-index field.
! Note that the index of entry is one-origined. Zero means that the entry
! has never been used (just allocated), and -1 means that no entry follows
! (that is empty entry in the index table or the last entry of entry chain).
! When a key-value pair is deleted from hash table, the next-index field
! of the corresponding entry is not set to zero. Instead, it is appended into
! a chain called trash chain. When a new pair is added again, entry in the
! trash chain is used if there is.

  ! size of header in words

  integer, parameter:: HEADER_WORDS = 8
  ! magic number that tells it is hash table. Different magic number
  ! should be used if the hash function would be changed.
  integer, parameter:: IDX_MAGIC = 1
  ! key length in words
  integer, parameter:: IDX_KLEN = 2
  ! value length in words
  integer, parameter:: IDX_VLEN = 3
  ! hash size
  integer, parameter:: IDX_HSIZE = 4
  ! number of allocated entries
  integer, parameter:: IDX_ALL_ENTS = 5
  ! number of used entries
  integer, parameter:: IDX_USED_ENTS = 6
  ! number of trash entries
  integer, parameter:: IDX_TRASH_ENTS = 7
  ! pointer for 
  integer, parameter:: IDX_TRASH_PTR = 8

  integer, parameter:: HASH_SIZE = 127

  integer, parameter:: NENT_INIT = 128
  integer, parameter:: PTR_TAIL = -1
  integer, parameter:: PTR_UNUSED = 0

contains

  integer function htwords(klen, vlen, nentries) result(result)
    integer, intent(in):: klen, vlen, nentries
    result = HEADER_WORDS + HASH_SIZE + (klen + vlen + 1) * nentries
  end function

  integer function htwordsbuf(buf) result(result)
    integer, intent(in):: buf(*)
    result = htwords(buf(IDX_KLEN), buf(IDX_VLEN), buf(IDX_ALL_ENTS))
  end function

  subroutine htinit_pre(klen, vlen, nalloc)
    integer, intent(in):: klen, vlen
    integer, intent(out):: nalloc
    nalloc = htwords(klen, vlen, NENT_INIT)
  end subroutine

  integer function frame(buf, idx) result(result)
    integer, intent(in):: buf(*)
    integer, intent(in):: idx
    result = HEADER_WORDS + buf(IDX_HSIZE) + 1 &
    & + (buf(IDX_KLEN) + buf(IDX_VLEN) + 1) * (idx - 1)
  end function

  subroutine htinit(buf, klen, vlen)
    use n3bits, only: c4pack
    integer, intent(out):: buf(*)
    integer, intent(in):: klen, vlen
    integer, parameter:: clear1 = HEADER_WORDS + 1
    integer:: i, j
    buf(IDX_MAGIC) = c4pack('HASH')
    buf(IDX_KLEN) = klen
    buf(IDX_VLEN) = vlen
    buf(IDX_HSIZE) = HASH_SIZE
    buf(IDX_ALL_ENTS) = NENT_INIT
    buf(IDX_USED_ENTS) = 0
    buf(IDX_TRASH_ENTS) = 0
    buf(IDX_TRASH_PTR) = PTR_TAIL
    buf(HEADER_WORDS+1:HEADER_WORDS+HASH_SIZE) = PTR_TAIL
    do, i = 1, NENT_INIT
      j = frame(buf, i)
      buf(j) = PTR_UNUSED
    enddo
  end subroutine

  integer function htsize(buf) result(result)
    integer, intent(in):: buf(*)
    result = buf(IDX_USED_ENTS)
  end function

  subroutine gethash(buf, key, ihash)
    integer, intent(in):: buf(*)
    integer, intent(in):: key(*)
    integer, intent(out):: ihash
    integer, save:: imask
    integer:: i
    data imask /Z'20202020'/
    ihash = 0
    do, i = 1, buf(IDX_KLEN)
      ihash = ieor(ihash, ieor(imask, key(i)))
    enddo
    ihash = modulo(ihash, buf(IDX_HSIZE))
  end subroutine

  integer function chain_head(buf, ihash) result(result)
    integer, intent(in):: buf(*)
    integer, intent(in):: ihash
    integer:: base
    result = buf(HEADER_WORDS + 1 + ihash)
  end function

  subroutine set_chain_head(buf, ihash, idx)
    integer, intent(inout):: buf(*)
    integer, intent(in):: ihash, idx
    buf(HEADER_WORDS + 1 + ihash) = idx
  end subroutine

  subroutine find_entry(buf, key, iframe)
    integer, intent(in):: buf(*)
    integer, intent(in):: key(*)
    integer, intent(out):: iframe
    integer:: ihash, klen, idx
    klen = buf(IDX_KLEN)
    call gethash(buf, key, ihash)
    idx = chain_head(buf, ihash)
    iframe = -1
    do
      if (idx == PTR_TAIL) then
        iframe = -1
        return
      endif
      iframe = frame(buf, idx)
      if (all(buf(iframe+1:iframe+klen) == key(1:klen))) return
      idx = buf(iframe)
    enddo
  end subroutine

  ! QUERIES WHETHER A HASH TABLE buf HAS A SPACE TO STORE key.
  !
  subroutine htprobe(buf, key, stat)
    integer, intent(in):: buf(*)
    integer, intent(in):: key(*)
    integer, intent(out):: stat
    integer:: iframe
    !
    ! IF THERE IS EMPTY SPACE IN CHAIN REGION, THAT'S OK.
    ! USUALLY THIS FUNCTION ENDS HERE.
    !
    if (buf(IDX_ALL_ENTS) > (buf(IDX_USED_ENTS) + buf(IDX_TRASH_ENTS))) then
      stat = 0
      return
    endif
    !
    ! OTHERWISE THERE MUST BE MATCHING ENTRY
    !
    call find_entry(buf, key, iframe)
    if (iframe == -1) then
      stat = 1
    else
      stat = 0
    endif
  end subroutine

  subroutine htrefer(buf, key, value, stat)
    integer, intent(inout):: buf(*)
    integer, intent(in):: key(*)
    integer, intent(out):: value(*)
    integer, intent(out):: stat
    integer:: iframe, vlen, klen
    call find_entry(buf, key, iframe)
    if (iframe == -1) then
      stat = -1
      return
    endif
    vlen = buf(IDX_VLEN)
    klen = buf(IDX_KLEN)
    value(1:vlen) = buf(iframe+klen+1:iframe+klen+vlen)
    stat = 0
  end subroutine

  subroutine assign_new_entry(buf, ihash, iframe)
    integer, intent(inout):: buf(*)
    integer, intent(in):: ihash
    integer, intent(out):: iframe
    integer:: idx
    if (buf(IDX_TRASH_PTR) /= PTR_TAIL) then
      idx = buf(IDX_TRASH_PTR)
      iframe = frame(buf, idx)
      buf(IDX_TRASH_PTR) = buf(iframe)
      buf(iframe) = chain_head(buf, ihash)
      call set_chain_head(buf, ihash, idx)
      buf(IDX_TRASH_ENTS) = buf(IDX_TRASH_ENTS) - 1
      buf(IDX_USED_ENTS) = buf(IDX_USED_ENTS) + 1
      return
    endif
    if (buf(IDX_ALL_ENTS) <= &
    & (buf(IDX_USED_ENTS) + buf(IDX_TRASH_ENTS))) then
      iframe = -1
      return
    endif
    buf(IDX_USED_ENTS) = buf(IDX_USED_ENTS) + 1
    idx = buf(IDX_USED_ENTS) + buf(IDX_TRASH_ENTS)
    iframe = frame(buf, idx)
    buf(iframe) = chain_head(buf, ihash)
    call set_chain_head(buf, ihash, idx)
  end subroutine

  !
  ! PUT AN ENTRY {key, value} INTO A HASH TABLE buf.
  !
  subroutine htput(buf, key, value, stat)
    integer, intent(inout):: buf(*)
    integer, intent(in):: key(*)
    integer, intent(in):: value(*)
    integer, intent(out):: stat
    integer:: ihash, klen, vlen, idx, iframe
    logical:: found
    ! IF THE HEAD OF CHAIN IS VACANT, THATS FINE.
    klen = buf(IDX_KLEN)
    vlen = buf(IDX_VLEN)
    call gethash(buf, key, ihash)
    idx = chain_head(buf, ihash)
    iframe = -1
    found = .false.
    do
      if (idx == PTR_TAIL) exit
      iframe = frame(buf, idx)
      if (all(buf(iframe+1:iframe+klen) == key(1:klen))) then
        found = .true.
        exit
      endif
      idx = buf(iframe)
    enddo
    if (.not. found) then
      call assign_new_entry(buf, ihash, iframe)
      if (iframe == -1) then
        stat = -1
        return
      endif
      buf(iframe+1:iframe+klen) = key(1:klen)
    endif
    ! COPY VALUE
    buf(iframe+klen+1:iframe+klen+vlen) = value(1:vlen)
    stat = 0
  end subroutine

  ! nent_new MUST BE GREATER THAN OR EQUAL TO nentries(oht)
  subroutine htcopy(oht, nht, nent_new)
    integer, intent(in):: oht(*)
    integer, intent(out):: nht(*)
    integer, intent(in):: nent_new
    integer, parameter:: copy1 = HEADER_WORDS + 1
    integer:: copy_entries, copy2, clear1, clear2
    nht(1:HEADER_WORDS) = oht(1:HEADER_WORDS)
    nht(IDX_ALL_ENTS) = nent_new
    copy_entries = min(oht(IDX_ALL_ENTS), nht(IDX_ALL_ENTS))
    copy2 = htwords(oht(IDX_KLEN), oht(IDX_VLEN), copy_entries)
    nht(copy1:copy2) = oht(copy1:copy2)
    if (nht(IDX_ALL_ENTS) > oht(IDX_ALL_ENTS)) then
      clear1 = copy2 + 1
      clear2 = htwordsbuf(nht)
      nht(clear1:clear2) = 0
    endif
  end subroutine

  subroutine hteach(buf, callback, args, stat)
    integer, intent(in):: buf(*)
    interface
      subroutine callback(key, value, args, stat)
        integer, intent(in):: key(*)
        integer, intent(in):: value(*)
        integer, intent(in):: args(*)
        integer, intent(out):: stat
      end subroutine
    end interface
    integer, intent(in):: args(*)
    integer, intent(out):: stat
    integer:: ientry, ifr, klen, vlen
    klen = buf(IDX_KLEN)
    vlen = buf(IDX_VLEN)
    do, ientry = 1, buf(IDX_USED_ENTS) + buf(IDX_TRASH_ENTS)
      ifr = frame(buf, ientry)
      if (buf(ifr) == 0) cycle
      call callback(buf(ifr+1:ifr+klen), buf(ifr+klen+1:ifr+klen+vlen), &
      & args, stat)
      if (stat /= 0) return
    enddo
  end subroutine

  subroutine htdelete(buf, key, stat)
    integer, intent(inout):: buf(*)
    integer, intent(in):: key(*)
    integer, intent(out):: stat
    integer:: ihash, klen, ptr, iframe, iframe0
    klen = buf(IDX_KLEN)
    call gethash(buf, key, ihash)
    ptr = chain_head(buf, ihash)
    iframe = -1
    do
      if (ptr == PTR_TAIL) then
        stat = -1
        return
      endif
      iframe0 = iframe
      iframe = frame(buf, ptr)
      if (all(buf(iframe+1:iframe+klen) == key(1:klen))) exit
      ptr = buf(iframe)
    enddo
    if (iframe0 == -1) then
      call set_chain_head(buf, ihash, buf(iframe))
    else
      buf(iframe0) = buf(iframe)
    endif
    buf(iframe) = buf(IDX_TRASH_PTR)
    buf(IDX_TRASH_PTR) = ptr
    buf(IDX_USED_ENTS) = buf(IDX_USED_ENTS) - 1
    buf(IDX_TRASH_ENTS) = buf(IDX_TRASH_ENTS) + 1
    stat = 0
  end subroutine

  subroutine htdump(table, unit)
    use n3io1, only: writeln
    integer, intent(in):: table(*)
    integer, intent(in), optional:: unit
    integer:: i, entbase, entsiz, tabsiz, j, f, fz
    character(24), save:: desc(HEADER_WORDS)
    data desc(1) /'MAGIC NUMBER'/
    data desc(2) /'WORDS IN KEY'/
    data desc(3) /'WORDS IN VALUE'/
    data desc(4) /'HASH TABLE SIZE'/
    data desc(5) /'ALLOCATED ENTRIES'/
    data desc(6) /'USED ENTRIES'/
    data desc(7) /'TRASH ENTRIES'/
    data desc(8) /'POINTER TO CHAIN HEAD'/
    character(72):: line
    line = ''
    !
    ! ARRAY DECLARATION
    !
    tabsiz = htwordsbuf(table)
    write(line, '(A,I8,A)') 'INTEGER:: REFTAB(', tabsiz, ')'
    call writeln(line, unit)
    !
    ! HEADER VALUES
    !
    do, i = 1, HEADER_WORDS
      write(line, '(A,I2.1,A,Z8.8,A)') &
        & 'DATA REFTAB(', i, ")/Z'", table(i), "'/ !" // trim(desc(i))
      call writeln(line, unit)
    enddo
    !
    ! INDEX ARRAY
    !
    do, i = HEADER_WORDS + 1, HEADER_WORDS + table(IDX_HSIZE)
      write(line, '(A,I12.1,A,Z8.8,A,I12.1)') &
        & 'DATA REFTAB(', i, ")/Z'", table(i), "'/ !", i - HEADER_WORDS - 1
      call writeln(line, unit)
    enddo
    !
    ! ENTRY SPACE
    !
    entbase = HEADER_WORDS + table(IDX_HSIZE)
    entsiz = table(IDX_KLEN) + table(IDX_VLEN) + 1
    do, j = 1, table(IDX_ALL_ENTS)
      f = entbase + (j - 1) * entsiz
      if (j == table(IDX_USED_ENTS) + table(IDX_TRASH_ENTS) + 1) then
        fz = entbase + (table(IDX_ALL_ENTS) - 1) * entsiz
        if (all(table(f+1:fz+1:entsiz) == 0)) then
          write(line, '(A,3(I6,A))') 'DATA REFTAB(', f+1, ':', fz+entsiz, &
            & ')/', entsiz * (table(IDX_ALL_ENTS) - j + 1), '*0/'
          call writeln(line, unit)
          return
        else
          line = "!some unused entries are contaminated"
          call writeln(line, unit)
        endif
      endif
      write(line, '(A,I6)') '!ENTRY ', j
      call writeln(line, unit)
      if (table(f) == PTR_UNUSED) then
        write(line, '(A,3(I6,A))') 'DATA REFTAB(', f+1, ':', f+entsiz, ')/', &
          & entsiz, '*0/'
        call writeln(line, unit)
      else
        do, i = 1, entsiz
          write(line, '(A,I6.1,A,Z8.8,A)') &
          & 'DATA REFTAB(', f + i, ")/Z'", table(f + i), "'/"
          call writeln(line, unit)
        enddo
      endif
    enddo
  end subroutine

end module