module cubetools_header_vo
  use cubetools_parameters
  use cubetools_header_interface
  use cubetools_header_types

  type :: vo_spatial_t
    ! See specifications in "Observation Data Model Core Components and its
    ! Implementation in the Table Access Protocol" -- IVOA Proposed
    ! Recommendation, March 30, 2016
    ! Mandatory components
    real(kind=coor_k)  :: ra      ! [deg] Central right ascension, ICRS (i.e. center of region)
    real(kind=coor_k)  :: dec     ! [deg] Central declination, ICRS (i.e. center of region)
    real(kind=coor_k)  :: fov     ! [deg] Diameter (bounds) of the covered region
    character(len=128) :: region  ! [AstroCoordArea] Region covered as specified in STC or ADQL
    real(kind=coor_k)  :: reso    ! [arcsec] Spatial resolution of data as FWHM
    integer(kind=4)    :: xel1    ! [---]  Number of elements along the first spatial axis
    integer(kind=4)    :: xel2    ! [---]  Number of elements along the second spatial axis
    ! Optional components
    logical            :: dopscale=.false.  ! Is pscale available?
    real(kind=coor_k)  :: pscale  ! [arcsec] Sampling period in world coordinate units along the spatial axis
  contains
    procedure :: from_cube    => vo_spatial_from_cube
    procedure :: from_uvtable => vo_spatial_from_uvtable
  end type vo_spatial_t

  interface json_keyval_write
    module procedure json_keyval_write_i4
    module procedure json_keyval_write_i8
    module procedure json_keyval_write_r8
    module procedure json_keyval_write_ch
  end interface json_keyval_write

  interface cubetools_header_vo_list
    module procedure cubetools_header_vo_list_interface
    module procedure cubetools_header_vo_list_header
  end interface cubetools_header_vo_list

  integer(kind=code_k), parameter :: vo_version=1

  public :: cubetools_header_vodesc_list,cubetools_header_vo_list
  private

contains

  subroutine cubetools_header_vodesc_list(error)
    !-------------------------------------------------------------------
    ! Display the VO format description
    !-------------------------------------------------------------------
    logical, intent(inout) :: error
    !
    call json_main_write_start()
    !
    call json_dict_write_start('description')
    call json_keyval_write('VERSION',vo_version)
    call json_vo_description('software_version',.false.,"string")
    call json_vo_description('dataproduct_type',.true.,"string")
    call json_vo_description('dataproduct_subtype',.false.,"string")
    call json_vo_description('calib_level',.true.,"enum integer")
    call json_vo_description('access_format',.true.,"string")
    call json_vo_description('access_estsize',.true.,"integer",unit='kB')
    call json_vo_description('target_name',.true.,"string")
    call json_vo_description('s_ra',.true.,"float",unit="degree")
    call json_vo_description('s_dec',.true.,"float",unit="degree")
    call json_vo_description('s_fov',.true.,"float",unit="degree")
    call json_vo_description('s_region',.true.,"string")
    call json_vo_description('s_xel1',.true.,"integer")
    call json_vo_description('s_xel2',.true.,"integer")
    call json_vo_description('s_resolution',.true.,"float",unit="arcsec")
    call json_vo_description('s_pixel_scale',.true.,"float",unit="arcsec")
    call json_vo_description('em_ucd',.false.,"string")
    call json_vo_description('em_min',.true.,"float",unit="m")
    call json_vo_description('em_max',.true.,"float",unit="m")
    call json_vo_description('em_res_power',.true.,"float")
    call json_vo_description('em_xel',.true.,"integer")
    call json_vo_description('pol_states',.true.,"string")
    call json_vo_description('facility_name',.true.,"string",last=.true.)
    call json_dict_write_stop(last=.true.)
    !
    call json_main_write_stop()
    !
  end subroutine cubetools_header_vodesc_list

  subroutine cubetools_header_vo_list_interface(interf,error)
    !-------------------------------------------------------------------
    ! Display the interface_t under VO format
    !-------------------------------------------------------------------
    type(cube_header_interface_t), intent(in)    :: interf
    logical,                       intent(inout) :: error
    !
    type(cube_header_t) :: head
    !
    call head%init(error)
    if (error)  return
    call cubetools_header_import_and_derive(interf,head,error)
    if (error)  return
    call cubetools_header_vo_list_header(head,error)
    if (error)  return
    call cubetools_header_final(head,error)
    if (error)  return
  end subroutine cubetools_header_vo_list_interface

  subroutine cubetools_header_vo_list_header(head,error)
    use phys_const
    use gkernel_interfaces
    use cubetools_parameters
    !-------------------------------------------------------------------
    ! Display the header_t under VO format
    !-------------------------------------------------------------------
    type(cube_header_t), intent(in)    :: head
    logical,             intent(inout) :: error
    !
    integer(kind=data_k) :: datasize
    real(kind=coor_k) :: ffirst,flast,fmin,fmax,wpower,wmin,wmax
    character(len=128) :: version
    character(len=32) :: format,type
    integer(kind=4) :: ier,level
    integer(kind=ndim_k) :: uv_axis,iaxis,nchan,nx,ny,nc
    type(vo_spatial_t) :: vospa
    !
    version = ''
    ier = sic_getlog('GAG_VERSION',version)
    ier = index(version,' ')
    version = version(1:ier)
    !
    !
    ! Detect if UV table. This is a poor man solution. The DAG knows
    ! if a node is a UV table or a cube.
    datasize = 1
    uv_axis = 0
    do iaxis=1,head%set%n
      datasize = max(datasize*head%set%axis(iaxis)%n,1)
      if (head%set%axis(iaxis)%name.eq.'UV-RAW')   uv_axis = uv_axis+1  ! Support for old tables
      if (head%set%axis(iaxis)%name.eq.'UV-DATA')  uv_axis = uv_axis+1
      if (head%set%axis(iaxis)%name.eq.'RANDOM')   uv_axis = uv_axis+1
    enddo
    datasize = datasize/256  ! [kB] ndata*4/1024
    if (uv_axis.eq.2) then
      ! A UV table
      type = 'visibility'
      format = 'application/x-mapping-uvt'
      level = 2
      call vospa%from_uvtable(head%spa,error)
      if (error)  return
      nchan = (head%spe%nc-7)/3
    else
      ! A standard cube
      nx = 0
      ny = 0
      nc = 0
      if (head%set%il.ne.0)  nx = head%set%axis(head%set%il)%n
      if (head%set%im.ne.0)  ny = head%set%axis(head%set%im)%n
      if (head%set%ic.ne.0)  nc = head%set%axis(head%set%ic)%n
      if (nx.gt.1 .and. ny.gt.1 .and. nc.le.1) then
        type = 'image'
      elseif (nx.le.1 .and. ny.le.1 .and. nc.gt.1) then
        type = 'spectrum'
      else  ! Everything else (?)
        type = 'cube'
      endif
      format = 'image/fits'
      level = 3
      call vospa%from_cube(head%spa,error)
      if (error)  return
      nchan = head%spe%nc
    endif
    !
    ! ZZZ THIS IS WRONG (or approximate by chance) FOR UV TABLES
    ffirst = head%spe%f%coord(1)      ! [MHz]
    flast  = head%spe%f%coord(nchan)  ! [MHz]
    fmin = min(ffirst,flast)
    fmax = max(ffirst,flast)
    wmin = clight_mhz/fmin  ! [m]
    wmax = clight_mhz/fmax  ! [m]
    wpower = abs(head%spe%f%val/head%spe%f%inc)
    !
    call json_main_write_start()
    !
    call json_dict_write_start('values')
    call json_keyval_write('VERSION',vo_version)
    call json_keyval_write('software_version',version)
    ! General description
    call json_keyval_write('dataproduct_type',type)
   !call json_keyval_write('dataproduct_subtype','NULL')  ! Optional
    call json_keyval_write('calib_level',level)
    call json_keyval_write('access_format',format)  ! i.e. MIME type
    call json_keyval_write('access_estsize',datasize)
    ! Spatial description
    call json_keyval_write('target_name',head%spa%source)
    call json_keyval_write('s_ra',vospa%ra)
    call json_keyval_write('s_dec',vospa%dec)
    call json_keyval_write('s_fov',vospa%fov)
    call json_keyval_write('s_region',vospa%region)
    call json_keyval_write('s_xel1',vospa%xel1)
    call json_keyval_write('s_xel2',vospa%xel2)
    call json_keyval_write('s_resolution',vospa%reso)
    if (vospa%dopscale) &
      call json_keyval_write('s_pixel_scale',vospa%pscale)
    ! Spectro description
    call json_keyval_write('em_ucd','em.freq')
    call json_keyval_write('em_min',wmin)
    call json_keyval_write('em_max',wmax)
    call json_keyval_write('em_res_power',wpower)
    call json_keyval_write('em_xel',nchan)
    ! Time description
    call json_keyval_write('t_xel',1)
    ! Polarization description
    call json_keyval_write('pol_xel',0)
    call json_keyval_write('pol_states','NULL')
    call json_keyval_write('facility_name','IRAM',last=.true.)
    call json_dict_write_stop(last=.true.)
    !
    call json_main_write_stop()
    !
  end subroutine cubetools_header_vo_list_header

  subroutine vo_spatial_from_cube(vo,spa,error)
    use phys_const
    use gkernel_types
    use gkernel_interfaces
    use cubetools_spatial_types
    !-------------------------------------------------------------------
    ! Convert a CUBE spatial_t to a vo_spatial_t.
    !
    ! This converts the actual 2D spatial coverage.
    !-------------------------------------------------------------------
    class(vo_spatial_t), intent(out)   :: vo
    type(spatial_t),     intent(in)    :: spa
    logical,             intent(inout) :: error
    !
    type(projection_t) :: proj
    real(kind=8) :: rxcent,rycent
    real(kind=coor_k) :: rxcorn(4),rycorn(4),axcorn(4),aycorn(4)
    real(kind=8) :: diag(2)
    !
    ! Setup projection
    call gwcs_projec(spa%pro%l0,spa%pro%m0,spa%pro%pa,spa%pro%code,  &
      proj,error)
    if (error)  return
    !
    ! Convert FOV center from relative to absolute
    rxcent = (spa%l%coord(1)+spa%l%coord(spa%l%n))/2.d0
    rycent = (spa%m%coord(1)+spa%m%coord(spa%m%n))/2.d0
    call rel_to_abs(proj,rxcent,rycent,vo%ra,vo%dec,1)
    vo%ra  = vo%ra/rad_per_deg
    vo%dec = vo%dec/rad_per_deg
    !
    ! Convert FOV corners from relative to absolute coordinates
    rxcorn(1) = spa%l%get_min()
    rxcorn(2) = spa%l%get_max()
    rxcorn(3) = spa%l%get_max()
    rxcorn(4) = spa%l%get_min()
    rycorn(1) = spa%m%get_min()
    rycorn(2) = spa%m%get_min()
    rycorn(3) = spa%m%get_max()
    rycorn(4) = spa%m%get_max()
    call rel_to_abs(proj,rxcorn,rycorn,axcorn,aycorn,4)
    !
    ! Compute FOV (largest diagonal)
    diag(1) = haversine(axcorn(1),aycorn(1),axcorn(3),aycorn(3))
    diag(2) = haversine(axcorn(2),aycorn(2),axcorn(4),aycorn(4))
    vo%fov = maxval(diag)
    axcorn = axcorn/rad_per_deg
    aycorn = aycorn/rad_per_deg
    vo%fov = vo%fov/rad_per_deg
    !
    ! These are degrees: we should writes digits down to arc second precision
    write(vo%region,'(A,8(1X,F8.4),A1)') 'ICRS (Polygon',      &
                                         axcorn(1),aycorn(1),  &
                                         axcorn(2),aycorn(2),  &
                                         axcorn(3),aycorn(3),  &
                                         axcorn(4),aycorn(4),')'
    !
    vo%reso = sqrt(spa%bea%major*spa%bea%minor)/rad_per_sec
    vo%dopscale = .true.
    vo%pscale = sqrt(abs(spa%l%inc*spa%m%inc))/rad_per_sec
    !
    vo%xel1 = spa%l%n
    vo%xel2 = spa%m%n
  end subroutine vo_spatial_from_cube

  subroutine vo_spatial_from_uvtable(vo,spa,error)
    use phys_const
    use cubetools_nan
    use cubetools_spatial_types
    !-------------------------------------------------------------------
    ! Convert a UV spatial_t to a vo_spatial_t.
    !
    ! This converts the primary beam into the coverage.
    !-------------------------------------------------------------------
    class(vo_spatial_t), intent(out)   :: vo
    type(spatial_t),     intent(in)    :: spa
    logical,             intent(inout) :: error
    !
    vo%ra  = spa%pro%l0/rad_per_deg
    vo%dec = spa%pro%m0/rad_per_deg
    ! Field of view: primary beam
    vo%fov = spa%bea%major/rad_per_deg  ! Ignore minor and angle (unset in UV table)
    !
    ! These are degrees: we should writes digits down to arc second precision
    write(vo%region,'(A,3(1X,F9.5),A1)') 'ICRS (Circle',  &
                                         vo%ra,vo%dec,vo%fov/2.d0,')'
    !
    ! Irrelevant:
    vo%reso = gr8nan
    vo%xel1 = 0
    vo%xel2 = 0
    vo%dopscale = .false.
  end subroutine vo_spatial_from_uvtable

  function haversine(ra1,dec1,ra2,dec2)
    !-------------------------------------------------------------------
    ! Use the haversine formula which is numerically better-conditioned
    ! for small distances
    !-------------------------------------------------------------------
    real(kind=8) :: haversine
    real(kind=8), intent(in) :: ra1,dec1
    real(kind=8), intent(in) :: ra2,dec2
    !
    real(kind=8) :: dra,ddec,term1,term2
    !
    dra = abs(ra1-ra2)
    ddec = abs(dec1-dec2)
    !
    term1 = sin(ddec/2)**2
    term2 = cos(dec1)*cos(dec2)*sin(dra/2)**2
    haversine = 2*asin(sqrt(term1+term2))
  end function haversine

  !---------------------------------------------------------------------

  subroutine json_vo_description(key,mandatory,type,unit,last)
    !-------------------------------------------------------------------
    ! Write one VO entry description
    !-------------------------------------------------------------------
    character(len=*), intent(in)           :: key
    logical,          intent(in)           :: mandatory
    character(len=*), intent(in)           :: type
    character(len=*), intent(in), optional :: unit
    logical,          intent(in), optional :: last
    ! Local
    character(len=128) :: value
    !
    write(value,'(4A)')  '{',  &
                         trim(json_keyval_l42str('mandatory',mandatory)),  &
                         ', ',  &
                         trim(json_keyval_ch2str('type',type))
    if (present(unit)) then
      write(value,'(4A)')  trim(value),  &
                           ', ',  &
                           trim(json_keyval_ch2str('unit',unit)),  &
                           '}'
    else
      write(value,'(2A)')  trim(value),  &
                           '}'
    endif
    !
    call json_keyval_write_any(key,value,last)
  end subroutine json_vo_description

  !---------------------------------------------------------------------

  subroutine json_main_write_start()
    !-------------------------------------------------------------------
    ! Start the main JSON block
    !-------------------------------------------------------------------
    write(*,'(A)')  '{'
  end subroutine json_main_write_start

  subroutine json_main_write_stop()
    !-------------------------------------------------------------------
    ! Stop the main JSON block
    !-------------------------------------------------------------------
    write(*,'(A)')  '}'
  end subroutine json_main_write_stop

  subroutine json_dict_write_start(name)
    !-------------------------------------------------------------------
    ! Start a JSON dictionary
    !-------------------------------------------------------------------
    character(len=*), intent(in) :: name
    !
    write(*,'(3A)')  '"',trim(name),'": {'
  end subroutine json_dict_write_start

  subroutine json_dict_write_stop(last)
    !-------------------------------------------------------------------
    ! Stop a JSON dictionary
    !-------------------------------------------------------------------
    logical, intent(in), optional :: last
    !
    if (present(last)) then
      if (last) then
        write(*,'(A)')  '}'
        return
      endif
    endif
    write(*,'(A)')  '},'
  end subroutine json_dict_write_stop

  function json_keyval_ch2str(key,value)
    !-------------------------------------------------------------------
    ! Create a key + string value pair as a string with proper
    ! formatting
    !-------------------------------------------------------------------
    character(len=128) :: json_keyval_ch2str
    character(len=*), intent(in) :: key
    character(len=*), intent(in) :: value
    ! Local
    character(len=128) :: string
    !
    write(string,'(A1,A,A1)')  '"',trim(value),'"'
    json_keyval_ch2str = json_keyval_any2str(key,string)
  end function json_keyval_ch2str

  function json_keyval_r82str(key,value)
    !-------------------------------------------------------------------
    ! Create a key + R*8 value pair as a string with proper formatting
    !-------------------------------------------------------------------
    character(len=128) :: json_keyval_r82str
    character(len=*), intent(in) :: key
    real(kind=8),     intent(in) :: value
    ! Local
    character(len=26) :: string
    !
    write(string,'(A1,1PG0.16,A1)')  '"',value,'"'
    json_keyval_r82str = json_keyval_any2str(key,string)
  end function json_keyval_r82str

  function json_keyval_i82str(key,value)
    !-------------------------------------------------------------------
    ! Create a key + I*8 value pair as a string with proper formatting
    !-------------------------------------------------------------------
    character(len=128) :: json_keyval_i82str
    character(len=*), intent(in) :: key
    integer(kind=8),  intent(in) :: value
    ! Local
    character(len=24) :: string
    !
    write(string,'(A1,I0,A1)')  '"',value,'"'
    json_keyval_i82str = json_keyval_any2str(key,string)
  end function json_keyval_i82str

  function json_keyval_l42str(key,value)
    !-------------------------------------------------------------------
    ! Create a key + logical value pair as a string with proper
    ! formatting
    !-------------------------------------------------------------------
    character(len=128) :: json_keyval_l42str
    character(len=*), intent(in) :: key
    logical,          intent(in) :: value
    ! Local
    character(len=5) :: string
    !
    if (value) then
      string = 'true'
    else
      string = 'false'
    endif
    json_keyval_l42str = json_keyval_any2str(key,string)
  end function json_keyval_l42str

  function json_keyval_any2str(key,value)
    !-------------------------------------------------------------------
    ! Create a key + preformatted string pair as a string (not
    ! formatting)
    !-------------------------------------------------------------------
    character(len=128) :: json_keyval_any2str
    character(len=*), intent(in) :: key
    character(len=*), intent(in) :: value
    !
    write(json_keyval_any2str,'(4A)')  '"',trim(key),'": ',trim(value)
  end function json_keyval_any2str

  subroutine json_keyval_write_i4(key,value,last)
    !-------------------------------------------------------------------
    ! Write to screen a key + I*4 value with proper formatting
    !-------------------------------------------------------------------
    character(len=*), intent(in)           :: key
    integer(kind=4),  intent(in)           :: value
    logical,          intent(in), optional :: last
    !
    character(len=1) :: trail
    !
    trail = ','
    if (present(last)) then
      if (last)  trail = ' '
    endif
    write(*,'(2A)')  trim(json_keyval_i82str(key,int(value,kind=8))),trail
  end subroutine json_keyval_write_i4

  subroutine json_keyval_write_i8(key,value,last)
    !-------------------------------------------------------------------
    ! Write to screen a key + I*8 value with proper formatting
    !-------------------------------------------------------------------
    character(len=*), intent(in)           :: key
    integer(kind=8),  intent(in)           :: value
    logical,          intent(in), optional :: last
    !
    character(len=1) :: trail
    !
    trail = ','
    if (present(last)) then
      if (last)  trail = ' '
    endif
    write(*,'(2A)')  trim(json_keyval_i82str(key,value)),trail
  end subroutine json_keyval_write_i8

  subroutine json_keyval_write_r8(key,value,last)
    !-------------------------------------------------------------------
    ! Write to screen a key + R*8 value with proper formatting
    !-------------------------------------------------------------------
    character(len=*), intent(in)           :: key
    real(kind=8),     intent(in)           :: value
    logical,          intent(in), optional :: last
    !
    character(len=1) :: trail
    !
    trail = ','
    if (present(last)) then
      if (last)  trail = ' '
    endif
    write(*,'(2A)')  trim(json_keyval_r82str(key,value)),trail
  end subroutine json_keyval_write_r8

  subroutine json_keyval_write_ch(key,value,last)
    !-------------------------------------------------------------------
    ! Write to screen a key + character string value with proper
    ! formatting
    !-------------------------------------------------------------------
    character(len=*), intent(in)           :: key
    character(len=*), intent(in)           :: value
    logical,          intent(in), optional :: last
    !
    character(len=1) :: trail
    !
    trail = ','
    if (present(last)) then
      if (last)  trail = ' '
    endif
    write(*,'(2A)')  trim(json_keyval_ch2str(key,value)),trail
  end subroutine json_keyval_write_ch

  subroutine json_keyval_write_any(key,value,last)
    !-------------------------------------------------------------------
    ! Write to screen a key + character string value with no formatting
    !-------------------------------------------------------------------
    character(len=*), intent(in)           :: key
    character(len=*), intent(in)           :: value
    logical,          intent(in), optional :: last
    !
    character(len=1) :: trail
    !
    trail = ','
    if (present(last)) then
      if (last)  trail = ' '
    endif
    write(*,'(2A)')  trim(json_keyval_any2str(key,value)),trail
  end subroutine json_keyval_write_any

end module cubetools_header_vo
