! Module  : speccache_m
! Purpose : Define speccache_t type, for representing a cached
!           table of specint_t's
!
! Copyright 2022 Rich Townsend & The MSG Team
!
! This file is part of MSG. MSG is free software: you can redistribute
! it and/or modify it under the terms of the GNU General Public
! License as published by the Free Software Foundation, version 3.
!
! MSG is distributed in the hope that it will be useful, but WITHOUT
! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
! or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
! License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.

#:include 'forum.inc'

module speccache_m

   ! Uses

   use forum_m

   use specint_m
   use stat_m

   use ISO_FORTRAN_ENV

   ! No implicit typing

   implicit none

   ! Parameter definitions

   integer(ID), parameter :: INITIAL_LIMIT = 128

   ! Derived-type definitions

   type :: speccache_t
      private
      type(specint_element_t), allocatable :: specint_elements(:)
      integer, allocatable                 :: ref_counts(:)
      integer, allocatable                 :: exp_counts(:)
      real(RD)                             :: lam_min
      real(RD)                             :: lam_max
      integer(ID)                          :: ssize
      integer                              :: limit
      integer                              :: n
   contains
      private
      procedure, public :: get_lam_min
      procedure, public :: get_lam_max
      procedure, public :: get_limit
      procedure, public :: get_usage
      procedure, public :: set_lam_min
      procedure, public :: set_lam_max
      procedure, public :: set_limit
      procedure, public :: fetch
      procedure, public :: release
      procedure, public :: flush
      procedure         :: trim_
   end type speccache_t

   type :: specint_element_t
      class(specint_t), allocatable :: specint
   end type specint_element_t

   ! Interfaces

   interface speccache_t
      module procedure speccache_t_
   end interface speccache_t

   ! Access specifiers

   private

   public :: speccache_t

contains

   function speccache_t_(n, lam_min, lam_max) result(speccache)

      integer, intent(in)  :: n
      real(RD), intent(in) :: lam_min 
      real(RD), intent(in) :: lam_max
      type(speccache_t)    :: speccache

      ! Construct speccache with n entries

      allocate(speccache%specint_elements(n))

      allocate(speccache%ref_counts(n))
      speccache%ref_counts = 0

      allocate(speccache%exp_counts(n))
      speccache%exp_counts = 0

      speccache%lam_min = lam_min
      speccache%lam_max = lam_max

      speccache%ssize = 0
      speccache%limit = INITIAL_LIMIT

      speccache%n = n

      ! Finish

      return

   end function speccache_t_

   !****

   #:for name, type in (('lam_min', 'real(RD)'), &
                        ('lam_max', 'real(RD)'), &
                        ('limit', 'integer'))        
                        
      subroutine get_${name}$(self, ${name}$)

         class(speccache_t), intent(in) :: self
         ${type}$, intent(out)          :: ${name}$

         ! Get ${name}$

         ${name}$ = self%${name}$

         ! Finish

         return

      end subroutine get_${name}$

   #:endfor

   !****

   subroutine get_usage(self, usage)

      class(speccache_t), intent(in) :: self
      integer, intent(out)           :: usage

      ! Get the memory usage (megabytes)

      usage = self%ssize/(1024*1024)
     
      ! Finish

      return

   end subroutine get_usage

   !****

   subroutine set_lam_min(self, lam_min, stat)

      class(speccache_t), intent(inout) :: self
      real(RD), intent(in)              :: lam_min
      integer, intent(out), optional    :: stat

      ! Set lam_min

      if(lam_min >= self%lam_max) then
         if (PRESENT(stat)) then
            stat = STAT_INVALID_ARGUMENT
            return
         else
            @:ABORT('invalid argument')
         end if
      end if

      self%lam_min = lam_min
 
      ! Flush the cache

      call self%flush()

      ! Finish

      if (PRESENT(stat)) stat = STAT_OK

      return

   end subroutine set_lam_min

   !****

   subroutine set_lam_max(self, lam_max, stat)

      class(speccache_t), intent(inout) :: self
      real(RD), intent(in)              :: lam_max
      integer, intent(out), optional    :: stat

      ! Set lam_max

      if(lam_max <= self%lam_min) then
         if (PRESENT(stat)) then
            stat = STAT_INVALID_ARGUMENT
            return
         else
            @:ABORT('invalid argument')
         end if
      end if

      self%lam_max = lam_max

      ! Flush the cache

      call self%flush()
         
      ! Finish

      if (PRESENT(stat)) stat = STAT_OK

      return

   end subroutine set_lam_max
      
   !****

   subroutine set_limit(self, limit, stat)

      class(speccache_t), intent(inout) :: self
      integer, intent(in)               :: limit
      integer, intent(out), optional    :: stat

      ! Set the cache memory usage limit

      if (limit < 0_ID) then
         if (PRESENT(stat)) then
            stat = STAT_INVALID_ARGUMENT
            return
         else
            @:ABORT('invalid argument')
         end if
      end if

      self%limit = limit

      ! Trim the cache

      call self%trim_()
         
      ! Finish

      if (PRESENT(stat)) stat = STAT_OK

      return

   end subroutine set_limit
      
   !****

   subroutine fetch(self, i, fetch_proc, specint, stat)

      class(speccache_t), target, intent(inout) :: self
      integer, intent(in)                       :: i
      interface
         subroutine fetch_proc(i, specint, stat)
            use specint_m
            integer, intent(in)                        :: i
            class(specint_t), allocatable, intent(out) :: specint
            integer, intent(out), optional             :: stat
         end subroutine fetch_proc
      end interface
      class(specint_t), pointer, intent(out) :: specint
      integer, intent(out), optional         :: stat

      integer                       :: j
      class(specint_t), allocatable :: specint_full
      real(RD)                      :: lam_min
      real(RD)                      :: lam_max
      integer(ID)                   :: ssize
         
      ! Fetch the i'th specint

      if (i < 0 .OR. i > self%n) then
         if (PRESENT(stat)) then
            stat = STAT_INVALID_ARGUMENT
            return
         else
            @:ABORT('invalid argument')
         end if
      end if

      ! Check if the entry is already present

      if (self%ref_counts(i) > 0) then

         ! Present and referenced; increment the reference counter

         self%ref_counts(i) = self%ref_counts(i) + 1

      elseif (self%exp_counts(i) > 0) then

         ! Present but not referenced; set the reference and expiry
         ! counters

         self%ref_counts(i) = 1
         self%exp_counts(i) = 0
            
      else

         ! Fetch the specint

         call fetch_proc(i, specint_full, stat)
         if (PRESENT(stat)) then
            if (stat /= STAT_OK) return
         end if

         call specint_full%get_lam_min(lam_min)
         call specint_full%get_lam_min(lam_max)

         if (lam_min < self%lam_min .OR. lam_max > self%lam_max) then

            call specint_full%subset(self%lam_min, self%lam_max, self%specint_elements(i)%specint, stat)
            if (PRESENT(stat)) then
               if (stat /= STAT_OK) return
            end if

         else

            self%specint_elements(i)%specint = specint_full

         endif

         ! Update the storage size

         call self%specint_elements(i)%specint%get_ssize(ssize)

         self%ssize = self%ssize + ssize

         ! Set the reference and expiry counters

         self%ref_counts(i) = 1
         self%exp_counts(i) = 0

      end if

      ! Set up the return pointer

      specint => self%specint_elements(i)%specint

      ! Finish

      if (PRESENT(stat)) stat = STAT_OK

      return

   end subroutine fetch

   !****

   subroutine release(self, i, stat)

      class(speccache_t), target, intent(inout) :: self
      integer, intent(in)                       :: i
      integer, intent(out), optional            :: stat

      ! Release the i'th specint

      if (i < 0 .OR. i > self%n) then
         if (PRESENT(stat)) then
            stat = STAT_INVALID_ARGUMENT
            return
         else
            @:ABORT('invalid argument')
         end if
      end if

      if (self%ref_counts(i) > 0) then

         ! Decrement the reference counter

         self%ref_counts(i) = self%ref_counts(i) - 1

         ! If it's reached zero, set the expiry counter

         if (self%ref_counts(i) == 0) self%exp_counts(i) = MAXVAL(self%exp_counts) + 1
         
      end if

      ! Trim the cache

      call self%trim_()

      ! Finish

      return

   end subroutine release

   !****

   subroutine flush(self)

      class(speccache_t), intent(inout) :: self

      integer :: i

      ! Flush the cache

      flush_loop : do i = 1, self%n

         if (self%exp_counts(i) > 0 .OR. self%ref_counts(i) > 0) then
            deallocate(self%specint_elements(i)%specint)
         end if

      end do flush_loop

      self%ref_counts = 0
      self%exp_counts = 0

      self%ssize = 0

      ! Finish

      return

   end subroutine flush

   !****

   subroutine trim_(self)

      class(speccache_t), intent(inout) :: self

      integer     :: j
      integer     :: usage
      integer(ID) :: ssize

      ! Trim the cache so that its memory usage is smaller than limit

      trim_loop : do

         ! Check usage

         call self%get_usage(usage)

         if (usage <= self%limit) exit trim_loop

         ! Find the unreferenced entry with the smallest expiry time

         j = MINLOC(self%exp_counts, DIM=1, mask=self%ref_counts == 0 .AND. self%exp_counts > 0)

         ! Deallocate it

         call self%specint_elements(j)%specint%get_ssize(ssize)

         deallocate(self%specint_elements(j)%specint)

         self%ssize = self%ssize - ssize

         ! Update expiry counter

         self%exp_counts(j) = 0

      end do trim_loop

      ! Finish

      return

   end subroutine trim_

end module speccache_m
