fortran66のブログ

fortran について書きます。

OOP 的な win32 plotter routine

自分の昔のプログラムを見ていたら callback routine (MainWndProc) へスレッドローカル記憶域(TLS)を使ってパラメータを渡していました。昔の自分の真似をして問☆題☆解☆決!

基底クラスの動的変数を、win32 型で領域確保して図を描いています。それぞれの図は独立していて、変数名で自然に区別されます。図の数はリソース内での任意個で宣言しただけ取れるはずです。

実行結果

Mandelbrot 集合の全体図と拡大図、Lorenz Attractor、ロジスティック方程式の Chaos と80年代のノリで。

ソース・コード

HTML5とPostscriptは点が打てないので、これらとの統合はまだ考え中です。色指定等に不整合がありますが、やっつけということで。

module m_oop
  implicit none

  type :: t_rgb
    integer :: ir, ig, ib
  end type t_rgb
  
  type, abstract :: t_device
    character(len = 80) :: title = 'Plotter'
    integer :: nsize_x = 640, nsize_y = 480
    integer :: line_width = 1
    type (t_rgb) :: rgb = t_rgb(0, 0, 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_lineTo), deferred, pass :: lineTo
    procedure (device_moveTo), deferred, pass :: moveTo
    procedure (device_dot), deferred, pass :: dot
  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)
      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 out) :: 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

    subroutine device_dot(self, ix, iy, icol)
      import :: t_device, t_rgb
      class(t_device), intent(in) :: self
      integer, intent(in) :: ix, iy
      integer, intent(in) :: icol
!      type (t_rgb), intent(in) :: rgb
    end subroutine device_dot
  end interface
  
end module m_oop


module m_win32
  use ifwina
  use ifwinty
  use ifmt, only : RTL_CRITICAL_SECTION
  use m_oop
  implicit none

  type :: t_wnd
    integer (HANDLE) :: hWnd      = 0
    integer (HANDLE) :: hDC       = 0
    integer (LPINT)  :: hThread   = 0
    integer (LPDWORD):: id        = 0
    integer (HANDLE) :: hPen      = 0
    type (RTL_CRITICAL_SECTION) :: lpCriticalSection = RTL_CRITICAL_SECTION(0,0,0,0,0,0)
  end type t_wnd      

  type, extends(t_device) :: t_win32
    type (t_wnd) :: wnd 
  contains 
    procedure, pass :: on => gr_on
    procedure, pass :: off => gr_off
    procedure, pass :: show => gr_show
    procedure, pass :: pen => gr_pen
    procedure, pass :: lineTo => gr_lineTo
    procedure, pass :: moveTo => gr_moveTo
    procedure, pass :: dot => gr_dot
  end type t_win32

  integer (DWORD), save :: iTls = 0
  integer, save :: nwin = 0 

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. 
    ! Init Main window
      iwindow_frame_x = 2 * GetSystemMetrics(SM_CXFIXEDFRAME) !side line = 6, title bar = 25
      iwindow_frame_y = 2 * GetSystemMetrics(SM_CYFIXEDFRAME) + 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 = CreateWindowEx(  0, 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,                        &
                                LOC(win32%wnd)                       ) ! non-standard
    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
    return
  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
    !
    TYPE (T_CREATESTRUCT) :: cs
    TYPE (t_wnd) :: wnd
    POINTER (p_cs, cs)         ! non-standard   
    POINTER (p_wnd, wnd)       ! non-standard 
    !
    MainWndProc = 0
    select case ( mesg )
      case (WM_CREATE)
        p_cs     = lParam
        p_wnd    = cs%lpCreateParams
        iretb    = TlsSetValue(iTls, p_wnd)
        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)
      case (WM_DESTROY)
        p_wnd = TlsGetValue(iTls)
        call EnterCriticalSection( loc(wnd%lpCriticalSection) )
        iretb = DeleteObject( wnd%hDC )
        call PostQuitMessage( 0 )
        call LeaveCriticalSection( loc(wnd%lpCriticalSection) )
      case (WM_PAINT)
        p_wnd = TlsGetValue(iTls)
        call EnterCriticalSection( loc(wnd%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(wnd%lpCriticalSection) )
      case (WM_RBUTTONUP)
        p_wnd = TlsGetValue(iTls)
        call EnterCriticalSection( loc(wnd%lpCriticalSection) )
        iretb = DeleteObject( wnd%hDC )
        call PostQuitMessage( 0 )
        call LeaveCriticalSection( loc(wnd%lpCriticalSection) )
      case default
        MainWndProc = DefWindowProc( hWnd, mesg, wParam, lParam )
    end select 
    return
  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
    associate(wnd => self%wnd)
      call InitializeCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC
      if (nwin == 0) iTls  = TlsAlloc()
      nwin = nwin + 1
      wnd%hThread = CreateThread(NULL, 0, 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 
      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)
    end associate
    return
  contains 

    integer (LONG) function Thread_Proc(lp_ThreadParameter)
    !DEC$ ATTRIBUTES STDcall, ALIAS:"_thread_proc" :: Thread_Proc
      integer (LPINT), intent(in) :: lp_ThreadParameter
      integer :: hInst
      hInst      = GetModuleHandle(NULL)
      Thread_Proc = WinMain(hInst, SW_SHOWNORMAL, self)
      return
    end function Thread_Proc
    
  end subroutine gr_on
  !-------------------------------------------------------------------------------------
  subroutine gr_off(self)
    class(t_win32), intent(in) :: self
    integer (BOOL)  :: iretb
    integer (DWORD) :: iwait
    associate(wnd => self%wnd)
      iwait = INFINITE
      iretb = InvalidateRect(wnd%hWnd, NULL, FALSE)
      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(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC
    end associate
    nwin = nwin - 1
    if (nwin ==0) iretb = TlsFree(iTls)
    return
  end subroutine gr_off
  !-------------------------------------------------------------------------------------
  subroutine gr_show(self)
    class(t_win32), intent(in) :: self
    integer (BOOL):: iretb
    associate(wnd => self%wnd)
      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 associate
    return
  end subroutine gr_show
  !-------------------------------------------------------------------------------------
  subroutine gr_pen(self, line_width, rgb)
    class(t_win32), intent(in out) :: self
    integer, intent(in), optional :: line_width
    type (t_rgb), intent(in), optional :: rgb
    integer (BOOL) :: iretb
    associate( rgb_ => self%rgb, line_width_ => self%line_width, wnd => self%wnd )
      if ( present(rgb) ) rgb_ = rgb
      if ( present(line_width) ) line_width_ = line_width
      call EnterCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC  
      iretb    = DeleteObject(wnd%hPen) 
      wnd%hPen = CreatePen(PS_SOLID, line_width_, irgb(rgb_))
      iretb    = SelectObject(wnd%hDC, wnd%hPen)
      iretb    = MoveToEx(wnd%hDC, 0, 0, NULL)
      call LeaveCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC
    end associate
    return
  contains 
    integer function irgb(rgb)
      type(t_rgb), intent(in) :: rgb
      irgb = rgb%ir + (rgb%ig + (rgb%ib * 256)) * 256
      return
    end function irgb
  end subroutine gr_pen
  !----------------------------------------------------------------
  subroutine gr_moveTo(self, ix, iy)
    class(t_win32), intent(in) :: self
    integer, intent(in) :: ix, iy
    integer (BOOL):: iretb
    associate(wnd => self%wnd)
      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 associate
    return
  end subroutine gr_moveTo
  !----------------------------------------------------------------
  subroutine gr_lineTo(self, ix, iy)
    class(t_win32), intent(in) :: self
    integer, intent(in) :: ix, iy
    integer (BOOL):: iretb
    associate(wnd => self%wnd)
      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 associate
    return
  end subroutine gr_lineTo
  !-------------------------------------------------------------------------------------
  subroutine gr_dot(self, ix, iy, icol)
    class(t_win32), intent(in) :: self
    integer, intent(in) :: ix, iy, icol
    integer (BOOL):: iretb
    associate(wnd => self%wnd)
      call EnterCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC
      iretb = SetPixel(wnd%hDC, ix, iy, icol)
      call LeaveCriticalSection( loc(wnd%lpCriticalSection) ) ! non-standard Fortran :: LOC
    end associate
    return
  end subroutine gr_dot
  !----------------------------------------------------------------
 end module m_win32

module m_plot
  use m_oop
  use m_win32
  implicit none
  private
  public :: t_rgb, t_device, t_win32, t_wnd
end module m_plot


!==================================================================

module m_mandel
  implicit none 
  integer, parameter :: kd = kind(0.0d0)
contains
  pure elemental integer function imandel(x, y)
    real(kd), intent(in) :: x, y
    real(kd) :: a, b, a2, b2
    integer :: icount
    a = x
    b = y
    a2 = a * a
    b2 = b * b
    icount = 150 !maxiter
    do while (a2 + b2 <= 4.0_kd .AND. icount > 0) 
      b = 2.0_kd * a * b - y
      a = a2 - b2 - x
      a2 = a * a
      b2 = b * b
      icount = icount - 1
    end do
    imandel = icount
    return
  end function imandel
end module m_mandel

!==================================================================
 
program Mandel
  use m_plot
  use m_mandel
  use ifmt, only : RTL_CRITICAL_SECTION
  implicit none
  !integer, parameter :: kd = SELECTED_REAL_KIND(15)
  integer, parameter :: m = 1000
  integer :: nwinx = 800, nwiny = 600
  integer :: i, j, k, imax, jmax, maxiter, icount, ix
  real (kd) :: xmin, xmax, ymin, ymax 
  real (kd) :: xmin1, xmax1, ymin1, ymax1 
  real (kd) :: x, y, z, dx, dy, dz, a, b, c, d, p
  real (kd) :: t0, t1 
  integer, allocatable :: ic(:, :)
  integer :: icol(0:m), it0, it1

  class(t_device), allocatable :: fig1, fig2, fig3, fig4
  type(t_rgb), parameter :: rgb_black = t_rgb(0, 0, 0)
  type(RTL_CRITICAL_SECTION), parameter :: rtl_init = RTL_CRITICAL_SECTION(0,0,0,0,0,0)
  type(t_wnd), parameter :: wnd_init = t_wnd(0, 0, 0, 0, 0,  rtl_init)
!  
  xmin = -2.0d0 
  xmax =  2.0d0 
  ymin = -2.0d0 
  ymax =  2.0d0  
  maxiter = 150
!
  dx = xmax - xmin
  dy = ymax - ymin
  if (dx <= 0.0_kd .OR. dy <= 0.0_kd .OR. maxiter <= 0 .OR. maxiter > M) stop 'input error'
  if (dx * nwinx > dy * nwiny) then
    imax = nwinx
    jmax = nint(nwinx * dy / dx)
  else
    imax = nint(nwiny * dx / dy)
    jmax = int(nwiny)
  end if
!
  dx = dx / real(imax, kd)
  dy = dy / real(jmax, kd)
  icol(0) = 0 ! black
  j = irgb(255, 255, 255)
  do i = maxiter, 1, -1
   icol(i) = j 
   if (j > 1) j = j - irgb(255, 255, 255) / maxiter
  end do
!
  allocate( ic(0:imax, 0:jmax) )  
  call system_clock(it0)
  call cpu_time(t0)
  do concurrent (i = 0:imax, j = 0:jmax) 
    x = xmin + i * dx
    y = ymax - j * dy
    ic(i, j) = imandel(x, y)
  end do
  call cpu_time(t1)
  call system_clock(it1)
  print *, ' do concurrent time =', t1 - t0, it1 - it0
!
  allocate(fig1, source = t_win32('Mandelbrot 1', imax, jmax, 1, rgb_black, wnd_init))
  call fig1%on()
  do i = 0, imax
    do j = 0, jmax
      call fig1%dot(i, j, icol(ic(i, j)))  
    end do
    call fig1%show()
  end do
  deallocate( ic )
!
  xmin = 1.10950d0
  xmax = 1.10951d0
  ymin = 0.24758d0 
  ymax = 0.24759d0 
!
  dx = xmax - xmin
  dy = ymax - ymin
  if (dx <= 0.0_kd .OR. dy <= 0.0_kd .OR. maxiter <= 0 .OR. maxiter > M) stop 'input error'
  if (dx * nwinx > dy * nwiny) then
    imax = nwinx
    jmax = nint(nwinx * dy / dx)
  else
    imax = nint(nwiny * dx / dy)
    jmax = int(nwiny)
  end if
!
  dx = dx / real(imax, kd)
  dy = dy / real(jmax, kd)
  allocate( ic(0:imax, 0:jmax) )  
  call system_clock(it0)
  call cpu_time(t0)
  do concurrent (i = 0:imax, j = 0:jmax) 
    x = xmin + i * dx
    y = ymax - j * dy
    ic(i, j) = imandel(x, y)
  end do
  call cpu_time(t1)
  call system_clock(it1)
  print *, ' do concurrent time =', t1 - t0, it1 - it0
!
  allocate(fig2, source = t_win32('Mandelbrot 2', imax, jmax, 1, rgb_black, wnd_init))
  call fig2%on()
  do i = 0, imax
    do j = 0, jmax
      call fig2%dot(i, j, icol(ic(i, j)))  
    end do
    call fig2%show()
  end do
!
  allocate(fig3, source = t_win32('Lorenz attractor', 800, 600, 1, rgb_black, wnd_init))
  call fig3%on()
  call fig3%pen(2, t_rgb(255, 125, 0))
  a = 10.0d0
  b = 28.0d0
  c = 8.0d0 / 3.0d0
  d = 0.01d0
  x = 1.0d0
  y = 1.0d0
  z = 1.0d0
  do k = 1, 3000
    dx = a * (y - x)
    dy = x * (b - z) - y
    dz = x * y - c * z
    x = x + d * dx
    y = y + d * dy
    z = z + d * dz
    if (k < 100) call fig3%moveTo( INT(12 * (x + 30)), INT(12 * z) )
    call fig3%lineTo( INT(12 * (x + 30)), INT(12 * z) )
    call fig3%show()
  end do
 ! 
  allocate(fig4, source = t_win32('Chaos', 640, 480, 1, rgb_black, wnd_init))
  call fig4%on()
  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 fig4%dot(ix, 480 - INT(y), irgb(0, 255, 122))
       p = p + x * p * (1 - p)
    end do
    call fig4%show()
  end do
  
  call fig1%off()
  deallocate(fig1)
  
  call fig2%off()
  deallocate(fig2)
  
  call fig3%off()
  deallocate(fig3)
  
  call fig4%off()
  deallocate(fig4)
  
  stop
contains 
  integer function irgb(ir, ig, ib)
    implicit none
    integer, intent(in) :: ir, ig, ib
    irgb = ir + (ig + (ib * 256)) * 256
    return
  end function irgb
end program Mandel