読者です 読者をやめる 読者になる 読者になる

fortran66のブログ

fortran について書きます。

win32/PS/HTML グラフィックルーチン

しばらくぶりにプログラミングすると細かな命令を忘れていて困ります。

Fortran2003 のオブジェクト指向プログラミングの勉強を兼ねて、昔作ったグラフィック用ルーチンを整理しています。 abstract interface の使いどころが分かってきた気がします。

win32/PS/HTML 用低レベルルーチン

ここで、一旦デバイスごとの依存性が隠れて、ここから上のルーチンは完全に共通にかけます。あとはデバイスに合わせたクラス型を割り付けることで出力先が変わります。

グラフを書くための上位ルーチンを作りかけています。自動的にスケールするようにするのが難しいです。
f:id:fortran66:20160502015205p:plainf:id:fortran66:20160503212247p:plainf:id:fortran66:20160502015236p:plainf:id:fortran66:20160502015244p:plain



実行結果

ここでは、例として低レベルルーチンの直上で、今まで何度も描いてきたロジスティック方程式のカオス画像をまた描いて見ます。

allocate(fig, source = t_win32(640, 480, 'Chaos'))
f:id:fortran66:20160502014159p:plain

  • Postscript 出力

allocate(fig, source = t_PS(640, 480, 'Chaos'))
f:id:fortran66:20160502014336p:plain

試用中の Intel Fortran v.17 で実行しています。

ソース・プログラム

    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