fortran66のブログ

fortran について書きます。

OOP2

[Fortran2003]オブジェクト指向でplot

メインルーチンで、異なる出力デバイスをALLOCATEするところで出力先の切り替えをすることで、それ以外の記述を共通化できました。ポストスクリプトHTML5を切り替えています。

program oop
  use m_plot
  implicit none
  class(t_device), allocatable :: fig
  
  allocate(fig, source = t_html('test', 640, 480) )
  call fig%on()
  call fig%moveTo(0, 0)
  call fig%lineTo(500, 200)
  call fig%off()
  deallocate(fig)    

  allocate(fig, source = t_ps('test', 640, 480) )
  call fig%on()
  call fig%moveTo(0, 0)
  call fig%lineTo(500, 200)
  call fig%off()
  deallocate(fig)

  stop  
end program oop    

ソース

module m_oop
  implicit none
  
  type, abstract :: t_device
    character(len = 80) :: title = 'Plotter'
    integer :: nsize_x = 640, nsize_y = 480
  contains
    procedure (device_on), deferred, pass :: on
    procedure (device_off), deferred, pass :: off
    procedure (device_show), deferred, pass :: show
    procedure (device_pen), deferred, pass :: pen
    procedure (device_lineTo), deferred, pass :: lineTo
    procedure (device_moveTo), deferred, pass :: moveTo
  end type t_device 

  type :: t_rgb
    integer :: ir, ig, ib
  end type t_rgb

  abstract interface 
    subroutine device_on(self)
      import :: t_device
      class(t_device), intent(in) :: self
    end subroutine device_on
  
    subroutine device_off(self)
      import :: t_device
      class(t_device), intent(in) :: self
    end subroutine device_off

    subroutine device_show(self)
      import :: t_device
      class(t_device), intent(in) :: self
    end subroutine device_show
    
    subroutine device_pen(self, line_width, rgb)
      import :: t_device, t_rgb
      class(t_device), intent(in) :: self
      integer, intent(in), optional :: line_width
      type (t_rgb), intent(in), optional :: rgb
    end subroutine device_pen

    subroutine device_lineTo(self, ix, iy)
      import :: t_device
      class(t_device), intent(in) :: self
      integer, intent(in) :: ix, iy
    end subroutine device_lineTo
  
    subroutine device_moveTo(self, ix, iy)
      import :: t_device
      class(t_device), intent(in) :: self
      integer, intent(in) :: ix, iy
    end subroutine device_moveTo
  end interface

end module m_oop


module m_html
  use m_oop
  implicit none
  private
  public :: t_html
  type, extends(t_device) :: t_html
    integer :: iw = 9
  contains 
    procedure, pass :: on => html_on
    procedure, pass :: off => html_off
    procedure, pass :: show => html_show
    procedure, pass :: pen => html_pen
    procedure, pass :: lineTo => html_lineTo
    procedure, pass :: moveTo => html_moveTo
  end type t_html
contains
  !----------------------------------------------------------------
  subroutine html_on(self)
    class(t_html), intent(in) :: self
    associate (iw => self%iw, title => self%title)
      open(iw, file = trim(title) // '.html')
      write(iw, '(a)') '<!DOCTYPE html>'
      write(iw, '(a)') '<html>'
      write(iw, '(a)') '<head>'
      write(iw, '(a)') '<meta charset="Shift_JIS">'
      write(iw, '(3a)') '<title>', trim(title), '</title>'
      write(iw, '(a)')  '<script type="text/javascript">'
      write(iw, '(a)') '<!--'
      write(iw, '(a)') 'function plotter() {'
      write(iw, '(3a)') "var canvas = document.getElementById('", trim(title), "');"
      write(iw, '(a)') "var context = canvas.getContext('2d');"
      write(iw, '(a)') '//'
      write(iw, '(a)') 'context.scale(1, 1);'
      write(iw, '(a)') 'context.lineWidth = 1;'               ! pen default
      write(iw, '(a)') "context.strokeStyle = 'rgb(0, 0, 0)';"  ! pen default
      write(iw, '(a)') 'context.lineCap = "butt";'
      write(iw, '(a)') 'context.beginPath();'
    end associate
    return
  end subroutine html_on
  !----------------------------------------------------------------
  subroutine html_off(self)
    class(t_html), intent(in) :: self
    associate (iw => self%iw, title => self%title, nx => self%nsize_x, ny => self%nsize_y)
      write(iw, '(a)') 'context.stroke();'
      write(iw, '(a)') '}'
      write(iw, '(a)') '//-->'
      write(iw, '(a)') '</script>'
      write(iw, '(a)') '</head>'
      write(iw, '(a)') '<body onLoad="plotter()">'
      write(iw, '(3a, i6, a, i6, a)') '<canvas id="', trim(title) , '" width="', nx, '" height="', ny, '">'
      write(iw, '(a)') '</canvas>'
      write(iw, '(a)') '</body>'
      write(iw, '(a)') '</html>' 
    end associate
    return
  end subroutine html_off
  !----------------------------------------------------------------
  subroutine html_show(self)
    class(t_html), intent(in) :: self
    write(self%iw, '(a)') 'context.stroke();'
    write(self%iw, '(a)') 'context.beginPath();'
    return
  end subroutine html_show
  !----------------------------------------------------------------
  subroutine html_pen(self, line_width, rgb)
    class(t_html), intent(in) :: self
    integer, intent(in), optional :: line_width
    type (t_rgb), intent(in), optional :: rgb
    integer, save :: line_width_ = 1             ! line width 1 dot  
    type (t_rgb), save :: rgb_   = t_rgb(0, 0, 0) ! line color black
    if ( present(line_width) ) line_width_ = line_width
    if ( present(rgb) ) rgb_ = rgb
    associate (iw => self%iw)
      write(iw, '(a)') 'context.stroke();'
      write(iw, '(a, 3(i3, a))') "context.strokeStyle = 'rgb(", rgb_%ir, ',', rgb_%ig, ',', rgb_%ib, ")';"
      write(iw, '(a,  i5, a)') 'context.lineWidth =', line_width_, ';'
      write(iw, '(a)') 'context.beginPath();'
      write(iw, '(a, i7, a, i7, a)') 'context.moveTo( 0, 0);'
    end associate
    return
  end subroutine html_pen
  !----------------------------------------------------------------
  subroutine html_lineTo(self, ix, iy)
    class(t_html), intent(in) :: self
    integer, intent(in) :: ix, iy
    write(self%iw, '(a, i7, a, i7, a)') 'context.lineTo(', ix, ',', iy, ');'
    return
  end subroutine html_lineTo
  !----------------------------------------------------------------
  subroutine html_moveTo(self, ix, iy)
    class(t_html), intent(in) :: self
    integer, intent(in) :: ix, iy
    write(self%iw, '(a, i7, a, i7, a)') 'context.moveTo(', ix, ',', iy, ');'
    return
  end subroutine html_moveTo  
end module m_html


module m_PS
use m_oop
  implicit none
  private
  public :: t_PS
  type, extends(t_device) :: t_PS
    integer :: iw = 9
  contains 
    procedure, pass :: on => ps_on
    procedure, pass :: off => ps_off
    procedure, pass :: show => ps_show
    procedure, pass :: pen => ps_pen
    procedure, pass :: lineTo => ps_lineTo
    procedure, pass :: moveTo => ps_moveTo
  end type t_PS
contains
  !----------------------------------------------------------------
  subroutine ps_on(self)
    class(t_ps), intent(in) :: self
    associate (iw => self%iw, title => self%title)
      open(iw, file = trim(title) // '.ps')
      write(iw, '(a)') '%!PS-Adobe-3.0 EPSF-3.0'
      write(iw, '(a, 2i8)') '%%BoundingBox: 0 0 ', self%nsize_x, self%nsize_y
      write(iw, '(2a)') '%%Title: ', trim(self%title)
      write(iw, '(a)') '%%EndComments'
      write(iw, '(a)') 'gsave'
      write(iw, '(a)') '1 1 scale'
      write(iw, '(a)') '1 setlinewidth'
      write(iw, '(a)') '0.0 0.0 0.0 setrgbcolor'
      write(iw, '(a)') '2 setlinejoin'
      write(iw, '(a)') 'newpath'
    end associate
    return
  end subroutine ps_on
  !-------------------------------------------------------------------------------------
  subroutine ps_off(self)
    class(t_ps), intent(in) :: self
    write(self%iw, '(a)') 'stroke'
    write(self%iw, '(a)') 'showpage'
    write(self%iw, '(a)') 'grestore'
    write(self%iw, '(a)') '%%EOF'
    return
  end subroutine ps_off
  !-------------------------------------------------------------------------------------
  subroutine ps_show(self)
    class(t_ps), intent(in) :: self
    write(self%iw, '(a)') 'stroke'
    write(self%iw, '(a)') 'newpath'
    return
  end subroutine ps_show
  !-------------------------------------------------------------------------------------
  subroutine ps_pen(self, line_width, rgb)
    class(t_ps), intent(in) :: self
    integer, intent(in), optional :: line_width
    type (t_rgb), intent(in), optional :: rgb
    integer :: line_width_ = 1
    type (t_rgb) :: rgb_ = t_rgb(0, 0, 0)
    if ( present(rgb) ) rgb_ = rgb
    if ( present(line_width) ) line_width_ = line_width
    associate (iw => self%iw)
      write(iw, '(a)') 'stroke'
      write(iw, '(3f7.3, a)') rgb_%ir / 255.0, rgb_%ig / 255.0, rgb_%ib / 255.0, " setrgbcolor"
      write(iw, '(i5, a)') line_width_, ' setlinewidth'
      write(iw, '(a)') 'newpath'
      write(iw, '(a)') ' 0 0 moveto'
    end associate
    return
  end subroutine ps_pen
  !-------------------------------------------------------------------------------------
  subroutine ps_moveTo(self, ix, iy)
    class(t_ps), intent(in) :: self
    integer, intent(in) :: ix, iy
    write(self%iw, '(2i7, a)') ix, iy, ' moveto'
    return
  end subroutine ps_moveTo
  !----------------------------------------------------------------
  subroutine ps_lineTo(self, ix, iy)
    class(t_ps), intent(in) :: self
    integer, intent(in) :: ix, iy
    write(self%iw, '(2i7, a)') ix, iy, ' lineto'
    return
  end subroutine ps_lineTo
end module m_PS


module m_plot
  use m_oop
  use m_html
  use m_PS
  implicit none
  private
  public :: t_rgb, t_device, t_html, t_PS
end module m_plot


program oop
  use m_plot
  implicit none
  class(t_device), allocatable :: fig
  
  allocate(fig, source = t_html('test', 640, 480) )
  call fig%on()
  call fig%pen(2, t_rgb(0, 255, 255))
  call fig%moveTo(0, 0)
  call fig%lineTo(500, 200)
  call fig%pen(1, t_rgb(0, 0, 255))
  call fig%lineTo(100, 200)
  call fig%lineTo(100, 480)
  call fig%off()
  deallocate(fig)    

  allocate(fig, source = t_ps('test', 640, 480) )
  call fig%on()
  call fig%pen(2, t_rgb(0, 255, 255))
  call fig%moveTo(0, 0)
  call fig%lineTo(500, 200)
  call fig%pen(1, t_rgb(0, 0, 255))
  call fig%lineTo(100, 200)
  call fig%lineTo(100, 480)
  call fig%off()
  deallocate(fig)    

  stop  
end program oop