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_plot use m_oop use m_html implicit none private public :: t_rgb, t_device, t_html end module m_plot program oop use m_plot implicit none type (t_html) :: html = t_html('test', 640, 480) call html%on() call html%pen(2, t_rgb(255, 0, 255)) call html%moveTo(0, 0) call html%lineTo(500, 200) call html%pen(1, t_rgb(0, 0, 255)) call html%lineTo(100, 200) call html%lineTo(100, 480) call html%off() stop end program oop
