[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