Fortran 用 Win32 最小限グラフィック

Intel Visual Fortran のコマンドプロンプト実行時に、ちょっとした図を書くための最小セットです。マルチスレッドで作図用のウィンドウを開くので、コマンドプロンプトで入出力しながら対話式に作図することが出来ます。

一応 Intel Visual Fortran v.17 preview 付属の Intel Inspector 2017 でメモリーリークチェック等を調べたところ、特に重大な不具合もないようです。

私なりに理解できる範囲で、おおむね必要最小限度の構成にしたつもりです。仕組み理解に使えるのではないかと思います。XYプロッタのペンアップ、ペンダウン、移動に相当する動作をするので、これの上によりまっとうなルーチンを積み上げてゆけば、昔風の作図は可能です。つまらない図を書くのに、大げさなライブラリを導入したくない向きに向いているのではないかと思います。gr_on, gr_off 等の名前は、奥村晴彦著「C言語による最新アルゴリズム辞典」から借りてきています。

実行例

簡単な例として正方形中にランダムに点を打って、四分の一円に入る割合を数えて円周率を求めています。

ソースプログラム

注意点として、Windows7 以降で窓の枠線の取り方が変わったらしく、その分の補正幅を加えないとダメになったようなのですが、それに必要な定数 SM_CXPADDEDBORDER が、intel fortran で用意されていないようなので、自分で定義してやる必要があります。

なお、Inspector にかける時は、窓の立ち上がりに時間がかかるので、gr_on での call sleep(500) ! wait for Window initialization でスリープ時間を5000 = 5 秒位に長めに取っておく必要があります。

    module m_window
      use ifwina
      use ifwinty
      use ifmt, only : RTL_CRITICAL_SECTION
      implicit none
      type :: t_wnd
        integer          :: nx = 640, ny = 480 
        character (LEN = 80) :: title = 'Fortran Plot'
        ! win32
        integer (HANDLE) :: hWnd
        integer (HANDLE) :: hDC
        integer (LPINT)  :: hThread
        integer (LPDWORD):: id
        integer (HANDLE) :: hPen
      end type t_wnd
  
      type (t_wnd), save :: wnd
      type (RTL_CRITICAL_SECTION), save :: lpCriticalSection
    contains
      !--------------------------------------------------------------------------------
      integer(LRESULT) function WinMain( hInstance, hPrevInstance, lpszCmdLine, nCmdShow)
      !DEC$ ATTRIBUTES STDCALL, DECORATE, ALIAS : 'WinMain' :: WinMain
        integer (HANDLE), intent(in) :: hInstance, hPrevInstance 
        integer (LPSTR) , intent(in) :: lpszCmdLine
        integer (SINT)  , intent(in) :: nCmdShow
        ! Variables
        logical, save :: qfirst = .true.
        type (T_WNDCLASS) :: wc
        type (T_MSG)      :: mesg
        integer (HANDLE)  :: hWndMain
        integer (BOOL)    :: iretb
        character (LEN = 256) :: ClassName = 'Fortran'//char(0)
        integer :: noffset_x, noffset_y 
        !  Init   Main window
        integer, parameter :: SM_CXPADDEDBORDER = 92  ! after windows7
        integer :: iborder
        iborder = GetSystemMetrics(SM_CXPADDEDBORDER) 
        noffset_x = 2 * (GetSystemMetrics(SM_CXFRAME) + iborder)  
        noffset_y = 2 * (GetSystemMetrics(SM_CYFRAME) + iborder) + GetSystemMetrics(SM_CYCAPTION)
        !
        WinMain = -1 ! Error code 
        if (qfirst) then
          wc%lpszClassName = loc(ClassName)
          wc%lpfnWndProc   = loc(MainWndProc)               ! call BACK 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
          qfirst = .FALSE.
        end if
        !Init instance
        WinMain = -2 ! Error code 
        hWndMain = CreateWindow( ClassName,                      &
                                 trim(wnd%title)//char(0),       &
                                 ior(WS_OVERLAPPED, WS_SYSMENU), &
                                 CW_USEDEFAULT, CW_USEDEFAULT,   &
                                 wnd%nx + noffset_x,             &
                                 wnd%ny + noffset_y,             &
                                 0,  0,                          &
                                 hInstance, loc(wnd)              ) 
        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
        use IFMT, only : EnterCriticalSection, LeaveCriticalSection
        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(lpCriticalSection) )
            hDC      = GetDC(hWnd)
            iretb    = GetClientRect(hWnd, rc)
            hBmp     = CreateCompatibleBitmap(hDC, rc%right - rc%left, rc%bottom - rc%top)
            wnd%hWnd = hWnd
            wnd%hDC  = CreateCompatibleDC(hDC)
            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(lpCriticalSection) )
          case (WM_DESTROY)
            call EnterCriticalSection( loc(lpCriticalSection) )
            iretb = DeleteObject( wnd%hDC )
            call PostQuitMessage( 0 )
            call LeaveCriticalSection( loc(lpCriticalSection) )
          case (WM_PAINT)
            call EnterCriticalSection( loc(lpCriticalSection) )
            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(lpCriticalSection) )
          case default
            MainWndProc = DefWindowProc( hWnd, mesg, wParam, lParam )
        end select 
      end function MainWndProc
    end module m_window
    !=================================================================================
    module m_graphics
      use m_window
      implicit none
    contains
      !-------------------------------------------------------------------------------------
      subroutine gr_on(text, nx, ny)
        use IFMT, only :  InitializeCriticalSection, CreateThread, EnterCriticalSection, LeaveCriticalSection
        character (LEN = *), intent(in), optional :: text
        integer            , intent(in), optional :: nx, ny
        integer (BOOL)   :: iretb
        integer (HANDLE) :: hBmp
        type (T_RECT)    :: rc
        if ( present(text) ) wnd%title = trim(text)
        if ( present(nx)   ) wnd%nx    = nx
        if ( present(ny)   ) wnd%ny    = ny
        call InitializeCriticalSection( loc(lpCriticalSection) )
        wnd%hThread = CreateThread(NULL, NULL, Thread_Proc, loc(wnd), CREATE_SUSPENDED, wnd%id)
        iretb       = SetThreadPriority(wnd%hThread, THREAD_PRIORITY_BELOW_NORMAL)
        iretb       = ResumeThread(wnd%hThread)
        call sleep(500) ! wait for Window initialization 
        call EnterCriticalSection( loc(lpCriticalSection) )
        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(lpCriticalSection) )
      end subroutine gr_on
      !-------------------------------------------------------------------------------------
      integer (LONG) function Thread_Proc(lp_ThreadParameter)
      !DEC$ ATTRIBUTES STDcall, ALIAS:"_thread_proc" :: Thread_Proc
        integer (LPINT), intent(in) :: lp_ThreadParameter
        integer (HANDLE) :: hInst
        hInst       = GetModuleHandle(NULL) 
        Thread_Proc = WinMain(hInst, NULL, NULL, SW_SHOWNORMAL)
      end function Thread_Proc
      !-------------------------------------------------------------------------------------
      subroutine gr_off(isec)
        use IFMT, only : DeleteCriticalSection, EnterCriticalSection, LeaveCriticalSection
        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() 
        iretb = DeleteObject(wnd%hPen) 
        iretb = WaitForSingleObject(wnd%hThread, iwait)
        iretb = CloseHandle(wnd%hThread)
        iretb = PostMessage(wnd%hWnd, WM_DESTROY, NULL, NULL)
        wnd%hThread = NULL
        call DeleteCriticalSection( loc(lpCriticalSection) )
      end subroutine gr_off
      !-------------------------------------------------------------------------------------
      subroutine gr_show()
        integer (BOOL):: iretb
        call EnterCriticalSection( loc(lpCriticalSection) )
        iretb = InvalidateRect(wnd%hWnd, NULL, FALSE)
        call LeaveCriticalSection( loc(lpCriticalSection) )
      end subroutine gr_show
      !-------------------------------------------------------------------------------------
      subroutine gr_move(ix, iy)
        integer, intent(in) :: ix, iy
        integer (BOOL):: iretb
        call EnterCriticalSection( loc(lpCriticalSection) )
        iretb = MoveToEx(wnd%hDC, ix, iy, NULL)
        call LeaveCriticalSection( loc(lpCriticalSection) )
      end subroutine gr_move
      !-------------------------------------------------------------------------------------
      subroutine gr_line(ix, iy)
        integer, intent(in) :: ix, iy
        integer (BOOL):: iretb
        call EnterCriticalSection( loc(lpCriticalSection) )
        iretb = LineTo(wnd%hDC, ix, iy)
        call LeaveCriticalSection( loc(lpCriticalSection) )
      end subroutine gr_line
      !-------------------------------------------------------------------------------------
      subroutine gr_pen(iwidth, icolor)
        integer, intent(in) :: iwidth
        integer, intent(in), optional :: icolor
        integer :: iretb
        integer, save :: kcol = 0
        if (present(icolor)) kcol = icolor
        call EnterCriticalSection( loc(lpCriticalSection) )
        iretb    = DeleteObject(wnd%hPen) 
        wnd%hPen = CreatePen(PS_SOLID, iwidth, kcol)
        iretb    = SelectObject(wnd%hDC, wnd%hPen)
        call LeaveCriticalSection( loc(lpCriticalSection) )
      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
    end module m_graphics
    !================================================================
    program plot
      use m_graphics
      real, parameter :: pi = 4 * atan(1.0)
      integer, parameter :: n = 10000
      integer :: i, ix, iy
      real :: x(2 * n)
      call gr_on('Monte Carlo', 640, 640)
      call gr_pen(3, icolor = irgb(255, 0, 0))
      call gr_move(0, 0)
      do i = 0, 50
        ix =       nint(640 * sin(pi * i / 50))   
        iy = 640 - nint(640 * cos(pi * i / 50))   
        call gr_line(ix, iy)
      end do    
      call gr_pen(4, icolor = irgb(0, 0, 255))
      call random_seed()
      call random_number(x)
      print *, 'pi =', 4 * count( x(::2)**2 + x(2::2)**2 < 1.0 ) / real(n)
      do i = 1, n
        ix =       x(i    ) * 640
        iy = 640 - x(i + 1) * 640
        call gr_move(ix, iy)
        call gr_line(ix, iy)
      end do     
      call gr_off()
    end program plot