しばらくぶりにプログラミングすると細かな命令を忘れていて困ります。
Fortran2003 のオブジェクト指向プログラミングの勉強を兼ねて、昔作ったグラフィック用ルーチンを整理しています。 abstract interface の使いどころが分かってきた気がします。
win32/PS/HTML 用低レベルルーチン
ここで、一旦デバイスごとの依存性が隠れて、ここから上のルーチンは完全に共通にかけます。あとはデバイスに合わせたクラス型を割り付けることで出力先が変わります。
グラフを書くための上位ルーチンを作りかけています。自動的にスケールするようにするのが難しいです。
実行結果
ここでは、例として低レベルルーチンの直上で、今まで何度も描いてきたロジスティック方程式のカオス画像をまた描いて見ます。
- win32 出力
allocate(fig, source = t_win32(640, 480, 'Chaos'))
- Postscript 出力
allocate(fig, source = t_PS(640, 480, 'Chaos'))
ソース・プログラム
module m_device implicit none type, abstract :: t_device integer :: nsize_x = 640, nsize_y = 480 character(len = 80) :: title = 'Plotter' integer :: width = 1, color = 0 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_line), deferred, pass :: line procedure (device_move), deferred, pass :: move end type t_device abstract interface subroutine device_on(self) import :: t_device class(t_device), intent(in out) :: self end subroutine device_on subroutine device_off(self, isec) import :: t_device class(t_device), intent(in) :: self integer (4), intent(in), optional :: isec 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, iwidth, icolor) import :: t_device class(t_device), intent(in out) :: self integer, intent(in), optional :: iwidth, icolor end subroutine device_pen subroutine device_line(self, ix, iy) import :: t_device class(t_device), intent(in) :: self integer, intent(in) :: ix, iy end subroutine device_line subroutine device_move(self, ix, iy) import :: t_device class(t_device), intent(in) :: self integer, intent(in) :: ix, iy end subroutine device_move end interface end module m_device module m_win32 use ifwina use ifwinty use ifmt, only : RTL_CRITICAL_SECTION use m_device implicit none type, extends(t_device) :: t_win32 contains procedure, pass :: on => gr_on procedure, pass :: off => gr_off procedure, pass :: show => gr_show procedure, pass :: pen => gr_pen procedure, pass :: line => gr_line procedure, pass :: move => gr_move end type t_win32 type :: t_wnd integer (HANDLE) :: hWnd integer (HANDLE) :: hDC integer (LPINT) :: hThread integer (LPDWORD):: id integer (HANDLE) :: hPen type (RTL_CRITICAL_SECTION) :: lpCriticalSection end type t_wnd type (t_wnd) :: wnd contains !-------------------------------------------------------------------------------- integer(4) function WinMain( hInstance, nCmdShow, win32 ) implicit none integer (HANDLE), intent(in) :: hInstance integer (SINT) , intent(in) :: nCmdShow type (t_win32), intent(in) :: win32 type (T_WNDCLASS) :: wc type (T_MSG) :: mesg integer (HANDLE) :: hWndMain integer (BOOL) :: iretb character (LEN = 256) :: ClassName = 'Fortran'//char(0) integer :: iwindow_frame_x, iwindow_frame_y logical, save :: first = .true. integer, parameter :: SM_CXPADDEDBORDER = 92 ! after windows7 integer :: iborder ! Init Main window iborder = GetSystemMetrics(SM_CXPADDEDBORDER) iwindow_frame_x = 2 * (GetSystemMetrics(SM_CXFRAME) + iborder) iwindow_frame_y = 2 * (GetSystemMetrics(SM_CYFRAME) + iborder) + GetSystemMetrics(SM_CYCAPTION) ! if (first) then WinMain = -1 ! Error code wc%lpszClassName = loc(ClassName) ! non-standard Fortran :: LOC(xxx) = TRANSFER(C_LOC(xxx), iii) wc%lpfnWndProc = loc(MainWndProc) ! CALLBACK procedure name wc%style = ior(CS_VREDRAW , CS_HREDRAW) wc%hInstance = hInstance wc%hIcon = NULL wc%hCursor = LoadCursor( NULL, IDC_ARROW ) wc%hbrBackground = ( COLOR_WINDOW + 1 ) if ( RegisterClass(wc) == 0 ) return ! initialize window first = .false. end if ! Init instance WinMain = -2 ! Error code hWndMain = CreateWindow( ClassName, & trim(win32%title)//char(0), & int(ior(WS_OVERLAPPED, WS_SYSMENU)), & CW_USEDEFAULT, CW_USEDEFAULT, & win32%nsize_x + iwindow_frame_x, & win32%nsize_y + iwindow_frame_y, & 0, 0, & hInstance, NULL ) if (hWndMain == 0) return iretb = ShowWindow( hWndMain, nCmdShow ) iretb = UpdateWindow( hWndMain ) ! Message Loop do while ( GetMessage (mesg, NULL, 0, 0) ) iretb = TranslateMessage( mesg ) iretb = DispatchMessage( mesg ) end do WinMain = mesg%wParam end function WinMain !------------------------------------------------------------------------------------- integer (LRESULT) function MainWndProc( hWnd, mesg, wParam, lParam ) !DEC$ ATTRIBUTES STDcall, DECORATE, ALIAS : 'MainWndProc' :: MainWndProc integer (HANDLE) , intent(in) :: hWnd integer (UINT) , intent(in) :: mesg integer (fwParam), intent(in) :: wParam integer (flParam), intent(in) :: lParam ! integer (HANDLE) :: hDC, hBmp integer (BOOL) :: iretb type (T_PAINTSTRUCT) :: ps type (T_RECT) :: rc ! MainWndProc = 0 select case ( mesg ) case (WM_CREATE) call EnterCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC wnd%hWnd = hWnd hDC = GetDC(hWnd) wnd%hDC = CreateCompatibleDC(hDC) iretb = GetClientRect(hWnd, rc) hBmp = CreateCompatibleBitmap(hDC, rc%right - rc%left, rc%bottom - rc%top) iretb = SelectObject(wnd%hDC, hBmp) iretb = PatBlt(wnd%hDC, 0, 0, rc%right - rc%left, rc%bottom - rc%top, WHITENESS) iretb = ReleaseDC(hWnd, hDC) iretb = DeleteObject(hBmp) call LeaveCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC case (WM_DESTROY) call EnterCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC iretb = DeleteObject( wnd%hDC ) call PostQuitMessage( 0 ) call LeaveCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC case (WM_PAINT) call EnterCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC hDC = BeginPaint( wnd%hWnd, ps ) iretb = GetClientRect( wnd%hWnd, rc ) iretb = BitBlt(hDC, 0, 0, rc%right - rc%left, rc%bottom - rc%top, wnd%hDC, 0, 0, SRCCOPY) iretb = endPaint( wnd%hWnd, ps ) call LeaveCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC case (WM_RBUTTONUP) call EnterCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC iretb = DeleteObject( wnd%hDC ) call PostQuitMessage( 0 ) call LeaveCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC case default MainWndProc = DefWindowProc( hWnd, mesg, wParam, lParam ) end select end function MainWndProc !------------------------------------------------------------------------------------- subroutine gr_on(self) use IFMT, only : CreateThread ! multithread module class(t_win32), intent(in out) :: self integer (BOOL) :: iretb integer (HANDLE) :: hBmp type (T_RECT) :: rc call InitializeCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC wnd%hThread = CreateThread(NULL, NULL, Thread_Proc, NULL, CREATE_SUSPENDED, wnd%id) iretb = SetThreadPriority(wnd%hThread, THREAD_PRIORITY_BELOW_NORMAL) iretb = ResumeThread(wnd%hThread) call sleep(100) ! wait for Window initialization call EnterCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC iretb = GetClientRect(wnd%hWnd, rc) hBmp = CreateCompatibleBitmap(wnd%hDC, rc%right - rc%left, rc%bottom - rc%top) iretb = SelectObject(wnd%hDC, hBmp) iretb = DeleteObject(hBmp) iretb = PatBlt(wnd%hDC, 0, 0, rc%right - rc%left, rc%bottom - rc%top, WHITENESS) wnd%hPen = CreatePen(PS_SOLID, 1, 0) call LeaveCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC contains integer (LONG) function Thread_Proc(lp_ThreadParameter) ! ?? internal function ?? !DEC$ ATTRIBUTES STDcall, ALIAS:"_thread_proc" :: Thread_Proc integer (LPINT), intent(in) :: lp_ThreadParameter integer (HANDLE) :: hInst hInst = GetModuleHandle(NULL) Thread_Proc = WinMain(hInst, SW_SHOWNORMAL, self) end function Thread_Proc end subroutine gr_on !------------------------------------------------------------------------------------- subroutine gr_off(self, isec) class(t_win32), intent(in) :: self integer (DWORD), intent(in), optional :: isec integer (BOOL) :: iretb integer (DWORD) :: iwait if (present(isec)) THEN iwait = isec * 1000 else iwait = INFINITE end if call gr_show(self) iretb = DeleteObject(wnd%hPen) iretb = WaitForSingleObject(wnd%hThread, iwait) iretb = CloseHandle(wnd%hThread) iretb = PostMessage(wnd%hWnd, WM_DESTROY, NULL, NULL) call sleep(500) wnd%hThread = NULL call DeleteCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC end subroutine gr_off !------------------------------------------------------------------------------------- subroutine gr_show(self) class(t_win32), intent(in) :: self integer (BOOL):: iretb call EnterCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC iretb = InvalidateRect(wnd%hWnd, NULL, FALSE) call LeaveCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC end subroutine gr_show !------------------------------------------------------------------------------------- subroutine gr_pen(self, iwidth, icolor) class(t_win32), intent(in out) :: self integer, intent(in), optional :: iwidth, icolor integer (BOOL) :: iretb associate( width => self%width, color => self%color ) if ( present(iwidth) ) width = iwidth if ( present(icolor) ) color = icolor call EnterCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC iretb = DeleteObject(wnd%hPen) wnd%hPen = CreatePen(PS_SOLID, width, color) iretb = SelectObject(wnd%hDC, wnd%hPen) iretb = MoveToEx(wnd%hDC, 0, 0, NULL) call LeaveCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC end associate end subroutine gr_pen !---------------------------------------------------------------- integer function irgb(ir, ig, ib) integer, intent(in) :: ir, ig, ib irgb = ir + (ig + (ib * 256)) * 256 end function irgb !---------------------------------------------------------------- subroutine gr_move(self, ix, iy) class(t_win32), intent(in) :: self integer, intent(in) :: ix, iy integer (BOOL):: iretb call EnterCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC iretb = MoveToEx(wnd%hDC, ix, iy, NULL) call LeaveCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC end subroutine gr_move !---------------------------------------------------------------- subroutine gr_line(self, ix, iy) class(t_win32), intent(in) :: self integer, intent(in) :: ix, iy integer (BOOL):: iretb call EnterCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC iretb = LineTo(wnd%hDC, ix, iy) call LeaveCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC end subroutine gr_line !---------------------------------------------------------------- end module m_win32 module m_html use m_device 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 :: line => html_line procedure, pass :: move => html_move end type t_html contains !---------------------------------------------------------------- subroutine html_on(self) class(t_html), intent(in out) :: 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 end subroutine html_on !---------------------------------------------------------------- subroutine html_off(self, isec) class(t_html), intent(in) :: self integer (4), intent(in), optional :: isec ! dummy 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>' close(iw) end associate 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();' end subroutine html_show !---------------------------------------------------------------- subroutine html_pen(self, iwidth, icolor) class(t_html), intent(in out) :: self integer, intent(in), optional :: iwidth, icolor integer :: ir, ig, ib associate (iw => self%iw, color => self%color, width => self%width) if ( present(iwidth) ) width = iwidth if ( present(icolor) ) color = icolor ir = mod(color, 256) ig = mod(color / 256, 256) ib = mod(color / 256 / 256, 256) write(iw, '(a)') 'context.stroke();' write(iw, '(a, 3(i3, a))') "context.strokeStyle = 'rgb(", ir, ',', ig, ',', ib, ")';" write(iw, '(a, i5, a)') 'context.lineWidth =', width, ';' write(iw, '(a)') 'context.beginPath();' write(iw, '(a, i7, a, i7, a)') 'context.moveTo( 0, 0);' end associate end subroutine html_pen !---------------------------------------------------------------- subroutine html_line(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, ');' end subroutine html_line !---------------------------------------------------------------- subroutine html_move(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, ');' end subroutine html_move end module m_html module m_PS use m_device 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 :: line => ps_line procedure, pass :: move => ps_move end type t_PS contains !---------------------------------------------------------------- subroutine ps_on(self) class(t_ps), intent(in out) :: 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' !'0.8 0.8 scale' write(iw, '(a)') '1 setlinewidth' write(iw, '(a)') '0.0 0.0 0.0 setrgbcolor' write(iw, '(a)') '2 setlinejoin' write(iw, '(a, i8, a)') '0 ', self%nsize_y, ' translate' write(iw, '(a)') 'newpath' end associate end subroutine ps_on !------------------------------------------------------------------------------------- subroutine ps_off(self, isec) class(t_ps), intent(in) :: self integer, intent(in), optional :: isec ! dummy write(self%iw, '(a)') 'stroke' write(self%iw, '(a)') 'showpage' write(self%iw, '(a)') 'grestore' write(self%iw, '(a)') '%%EOF' close(self%iw) end subroutine ps_off !------------------------------------------------------------------------------------- subroutine ps_show(self) class(t_ps), intent(in) :: self write(self%iw, '(a)') 'stroke' write(self%iw, '(a)') 'newpath' end subroutine ps_show !------------------------------------------------------------------------------------- subroutine ps_pen(self, iwidth, icolor) class(t_ps), intent(in out) :: self integer, intent(in), optional :: iwidth, icolor integer :: ir, ig, ib associate (iw => self%iw, color => self%color, width => self%width) if ( present(iwidth) ) width = iwidth if ( present(icolor) ) color = icolor ir = mod(color, 256) ig = mod(color / 256, 256) ib = mod(color / 256 / 256, 256) write(iw, '(a)') 'stroke' write(iw, '(3f7.3, a)') ir / 255.0, ig / 255.0, ib / 255.0, " setrgbcolor" write(iw, '(i5, a)') width, ' setlinewidth' write(iw, '(a)') 'newpath' write(iw, '(a)') ' 0 0 moveto' end associate end subroutine ps_pen !------------------------------------------------------------------------------------- subroutine ps_move(self, ix, iy) class(t_ps), intent(in) :: self integer, intent(in) :: ix, iy write(self%iw, '(2i7, a)') ix, -iy, ' moveto' end subroutine ps_move !---------------------------------------------------------------- subroutine ps_line(self, ix, iy) class(t_ps), intent(in) :: self integer, intent(in) :: ix, iy write(self%iw, '(2i7, a)') ix, -iy, ' lineto' end subroutine ps_line end module m_PS module m_lowlevel use m_device use m_html use m_PS use m_win32 implicit none private public :: t_device, t_html, t_PS, t_win32 public :: irgb end module m_lowlevel program test use m_lowlevel implicit none integer :: ix, i real :: p, x, y class (t_device), allocatable :: fig print *, 'start Chaos' allocate(fig, source = t_PS(640, 480, 'Chaos')) call fig%on() call fig%pen(1, icolor = irgb(0, 0, 0)) do ix = 1, 640 p = 0.3 x = ix * (3.0 - 1.5) / 640.0 + 1.5 do i = 1, 50 p = p + x * p * (1.0 - p) end do do i = 51, 100 y = p / 1.5 * 480.0 call fig%move(ix - 1, 480 - INT(y)) call fig%line(ix - 0, 480 - INT(y)) p = p + x * p * (1 - p) end do call fig%show() end do call fig%off() stop ' end Chaos' end program test
