gray/src/types.f90

module types

  use const_and_precisions, only : wp_

  implicit none

  type item
    ! An item is the building block of a queue
    class(*), allocatable :: value           ! the actual content
    type(item), pointer   :: next => null()  ! pointer to the next item
  end type

  type queue
    ! A queue is a list of items with O(1) insertion and extraction.
    ! The first item inserted (`put` operation) is the first to be
    ! extracted (`get` operation).

    ! References to the first and last items in the queue
    type(item), pointer :: first => null(), last => null()

    contains
      procedure :: put   => queue_put   ! inserts an item at the end of the queue
      procedure :: get   => queue_get   ! extracts the first item in the queue
      procedure :: empty => queue_empty ! checks whether the queue is empty
  end type

  type table
    ! A type for storing tabular data before serialisation
    integer                    :: id          ! the table unique ID
    logical                    :: active      ! whether to process the table
    character(64)              :: title       ! title of the table
    character(64), allocatable :: labels(:)   ! labels for each column
    type(queue), allocatable   :: columns(:)  ! values for each column

    contains
      procedure :: init   => table_init    ! creates an empty table
      procedure :: append => table_append  ! appends an extra row to the table
      procedure :: empty  => table_empty   ! checks whether the queue is empty
      procedure :: save   => table_save    ! processes and writes the table to file
  end type

  type wrap
    ! A wrapper type for storing (references of) heterogeneous
    ! values in an array or other homogeneuous container type
    class(*), pointer :: value
  end type

  ! Interface for custom type constructor
  interface wrap
     procedure :: wrap_init
  end interface

contains

  subroutine queue_put(self, val)
    ! Inserts an item of value `val` at the end of the `self` queue
    class(queue), intent(inout) :: self
    class(*),     intent(in)    :: val

    type(item), pointer :: i

    ! set up the item and copy the value
    allocate(i)
    allocate(i%value, source=val)

    if (self%empty()) then
      ! first item received, store it separately
      self%first => i
    else
      ! otherwise, link the last item to the new one
      self%last%next => i
    end if

    ! update the last item
    self%last => i
  end subroutine queue_put


  subroutine queue_get(self, val)
    ! Extracts the item from the front of the queue.
    ! Notes:
    !  - this assumes the queue is not empty.
    !  - this should be converted to a function once
    !    gcc bug 115072 is fixed.
    class(queue),          intent(inout) :: self
    class(*), allocatable, intent(out)   :: val

    type(item), pointer :: tmp

    ! extract the value
    allocate(val, source=self%first%value)

    tmp => self%first       ! get a grip
    self%first => tmp%next  ! shift the reference
    deallocate(tmp)         ! clear the item
  end subroutine queue_get


  pure function queue_empty(self)
    ! Whether the `self` queue is empty
    class(queue), intent(in) :: self
    logical                  :: queue_empty

    queue_empty = .not. associated(self%first)
  end function


  function wrap_init(val)
    ! Initialise a `wrap` value
    !
    ! Note: this is needed because, apparently, gfortran can't handle
    !       unlimited polymorphic arguments in the default constructor.
    class(*), target, intent(in) :: val
    type(wrap)                   :: wrap_init
    wrap_init%value => val
  end function wrap_init


  subroutine table_init(self, id, title, labels, active)
    ! Initialises the table
    class(table), intent(out) :: self
    integer,      intent(in)  :: id
    character(*), intent(in)  :: title
    character(*), intent(in)  :: labels(:)

    logical, intent(in), optional :: active

    integer :: i

    self%id      = id
    self%title   = title
    self%labels  = labels
    self%columns = [(queue(), i=1,size(labels))]

    if (present(active)) self%active = active
  end subroutine table_init


  pure function table_empty(self)
    ! Checks whether the table is empty
    class(table), intent(in) :: self
    logical                  :: table_empty

    table_empty = self%columns(1)%empty()
  end function table_empty


  subroutine table_append(self, row)
    ! Appends an extra row to the table
    !
    ! Heterogenous values are supported, provided they
    ! are wrapped in a `wrap` type.

    class(table), intent(inout) :: self
    class(*),     intent(in)    :: row(:)

    integer :: i

    do i = 1, size(self%columns)
      select type (row)
        type is (wrap)
          call self%columns(i)%put(row(i)%value)
        class default
          call self%columns(i)%put(row(i))
      end select
    end do

  end subroutine table_append


  subroutine table_save(self, error, filepath, header)
    ! Save the table to a file
    !
    ! Note: this operation consumes the table
    use utils, only : get_free_unit, digits

    ! suborutine arguments
    class(table), intent(inout)         :: self
    integer,      intent(out)           :: error
    character(*), intent(in), optional  :: filepath
    character(*),             optional  :: header

    ! local variables
    integer :: i, file
    class(*), allocatable :: val
    character(len=len(self%title) + 4) :: filepath_
    character(len=10) :: fmt

    if (self%empty()) return

    file = get_free_unit()

    ! set default file name
    if (present(filepath)) then
      filepath_ = filepath
    else
      write(filepath_, '(a,".",i0,".txt")') trim(self%title), self%id
    end if

    ! open output file
    open(unit=file, file=filepath_, action='write', iostat=error)
    if (error /= 0) return

    ! write a custom file header
    if (present(header)) write(file, '(a)') trim(header)

    ! write table header
    write(file, '(a)', advance='no') '#'
    do i = 1, size(self%columns)
      write(file, '(x,a)', advance='no') trim(self%labels(i))
    end do
    write(file, '(x)')

    ! iterate the table
    do while (.not. self%empty())

      ! write a row
      do i = 1, size(self%columns)
        call self%columns(i)%get(val)

        ! format a record
        select type (val)
          type is (integer)
            write(fmt, '("(i",i0,")")') max(5, 1 + digits(val))
            write(file, fmt, advance='no') val
          type is (real(wp_))
            write(file, '(es16.8e3)', advance='no') val
          type is (logical)
            write(file, '(l1)', advance='no') val
          type is (character(len=*))
            write(file, '(a)', advance='no') trim(val)
        end select

        ! add space between values
        if (i < size(self%columns)) write(file, '(x)', advance='no')
      end do

      ! start newline
      write(file, '(x)')
    end do

  end subroutine table_save


  subroutine test_queue()
    integer, target  :: x=1, y=2
    real, target     :: z = 1.231
    logical, target  :: p=.false.
    character(len=4) :: s='ciao'
    type(queue) :: q
    class(*), allocatable :: c

    call assert(q%empty(), 'queue is empty')

    ! put some items in
    call q%put(x)
    call q%put(y)
    call q%put(z)
    call q%put(p)
    call q%put(s)

    call assert(.not. q%empty(), 'queue is not empty')

    ! get them out and check them
    call q%get(c)
    call assert(transfer(c, x) == x, 'got back an integer')
    call q%get(c)
    call assert(transfer(c, y) == y, 'got back another integer')
    call q%get(c)
    call assert(transfer(c, z) == z, 'got back a real')
    call q%get(c)
    call assert(transfer(c, p) .eqv. p, 'got back a logical')
    call q%get(c)
    call assert(cast_char(c, 4) == s, 'got back a string')

    call assert(q%empty(), 'queue is empty again')

    ! this should be finalised
    call q%put(s)

    contains

      subroutine assert(p, msg)
        logical,          intent(in) :: p
        character(len=*), intent(in) :: msg

        if (.not. p) then
          print '(a, a)', 'assertion failed: ', msg
          stop
        end if
      end subroutine

      pure function cast_char(x, n) result(y)
        class(*), intent(in)  :: x
        integer,  intent(in)  :: n
        character(len=n)      :: y

        select type (x)
          type is (character(len=*))
            y = x
          class default
            error stop 'invalid cast to character'
        end select
      end function

  end subroutine test_queue


  subroutine test_table()
    type(table) :: tbl
    integer :: i
    class(*), allocatable :: x, y

    call tbl%init(title='testing table', id=0, labels=['x', 'y'])

    ! fill in some values
    call assert(tbl%empty(), 'table is empty')
    do i = 1, 4
      call tbl%append([0.2*i, (0.2*i)**2])
    end do
    call assert(.not. tbl%empty(), 'table is not empty')

    ! get them back
    do i = 1, 4
      call tbl%columns(1)%get(x)
      call tbl%columns(2)%get(y)
      call assert(transfer(x, 1.0) == (0.2*i),    'got correct x')
      call assert(transfer(y, 1.0) == (0.2*i)**2, 'got correct y')
    end do

    call assert(tbl%empty(), 'table is empty again')

    contains

      subroutine assert(p, msg)
        logical,          intent(in) :: p
        character(len=*), intent(in) :: msg

        if (.not. p) then
          print '(a, a)', 'assertion failed: ', msg
          stop
        end if
      end subroutine

  end subroutine test_table

end module types