重ね打ちを使っている絵。
ソース・プログラム
module uho_win use ifwina use ifwinty use ifmt, only : RTL_CRITICAL_SECTION implicit none type :: t_wnd integer (HANDLE) :: hWnd integer (HANDLE) :: hDC integer (LPINT) :: hThread integer :: id integer (HANDLE) :: hPen character (LEN = 80) :: title = 'Fortran Plot' integer :: nsize_x = 320, nsize_y = 240 real :: xmin = 0.0, xmax = 1.0, ymin = 0.0, ymax = 1.0 end type type (t_wnd) :: wnd type (RTL_CRITICAL_SECTION) :: lpCriticalSection contains !-------------------------------------------------------------------------------- integer(4) function WinMain( hInstance, hPrevInstance, lpszCmdLine, nCmdShow, wnd) implicit none integer (HANDLE), intent(in) :: hInstance, hPrevInstance integer (LPSTR) , intent(in) :: lpszCmdLine integer (SINT) , intent(in) :: nCmdShow type (t_wnd) , intent(in out) :: wnd ! 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 !side line = 6, title bar = 25 ! Init Main window noffset_x = 2 * GetSystemMetrics(SM_CXFIXEDFRAME) noffset_y = 2 * GetSystemMetrics(SM_CYFIXEDFRAME) + 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 = CreateWindowEx( 0, ClassName, & trim(wnd%title)//char(0), & int(ior(WS_OVERLAPPED, WS_SYSMENU)), & CW_USEDEFAULT, CW_USEDEFAULT, & wnd%nsize_x + noffset_x, & wnd%nsize_y + 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 return end function WinMain !---------------------------------------------------------- integer (LRESULT) function MainWndProc( hWnd, mesg, wParam, lParam ) !DEC$ ATTRIBUTES STDcall, DECORATE, ALIAS : 'MainWndProc' :: MainWndProc use IFMT implicit none 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) 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) case (WM_DESTROY) iretb = DeleteObject( wnd%hDC ) call PostQuitMessage( 0 ) 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 (WM_LBUTTONDOWN) write(*, *) 'LBUTTON ', trim(wnd%title), wnd%hWnd case (WM_RBUTTONDOWN) write(*, *) 'RBUTTON ', trim(wnd%title), wnd%hWnd case default MainWndProc = DefWindowProc( hWnd, mesg, wParam, lParam ) end select return end function MainWndProc !------------------------------------------------------------------------------- integer (HANDLE) function get_DosHndl() implicit none interface function GetConsoleWindow() ! non-existent in IFORTxx.MOD !DEC$ ATTRIBUTES DEFAULT, STDcall, DECORATE, ALIAS:'GetConsoleWindow' :: GetConsoleWindow use ifwinty integer (HANDLE) :: GetConsoleWindow end function end interface get_DosHndl = GetConsoleWindow() return end function get_DosHndl !------------------------------------------------------------------------------------- end module uho_win !================================================================================= module uhoplot use uho_win contains !------------------------------------------------------------------------------------- subroutine gr_on(text, nx, ny) use IFMT ! multithread module implicit none character (LEN = *), intent(in), optional :: text integer , intent(in), optional :: nx, ny integer (BOOL) :: iretb integer (HANDLE) :: hBmp integer (LPDWORD) :: id type (T_RECT) :: rc if ( present(text) ) wnd%title = TRIM(text) if ( present(nx) ) wnd%nsize_x = nx if ( present(ny) ) wnd%nsize_y = ny call InitializeCriticalSection( loc(lpCriticalSection)) wnd%hThread = CreateThread(0, 0, Thread_Proc, loc(wnd), CREATE_SUSPENDED, id) wnd%id = 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) return end subroutine gr_on !------------------------------------------------------------------------------------- subroutine gr_off(isec) use IFMT ! Module for multithread implicit none 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) ) return end subroutine gr_off !------------------------------------------------------------------------------------- integer (LONG) function Thread_Proc(lp_ThreadParameter) !DEC$ ATTRIBUTES STDcall, ALIAS:"_thread_proc" :: Thread_Proc implicit none integer (LPINT), intent(in) :: lp_ThreadParameter integer :: hInst type (t_wnd) :: wnd pointer (p_wnd, wnd) ! non-standard fortran p_wnd = lp_ThreadParameter hInst = GetModuleHandle(NULL) Thread_Proc = WinMain(hInst, NULL, NULL, SW_SHOWNORMAL, wnd) return end function Thread_Proc !------------------------------------------------------------------------------------- subroutine gr_show() implicit none integer (BOOL):: iretb call EnterCriticalSection( loc(lpCriticalSection) ) iretb = InvalidateRect(wnd%hWnd, NULL, FALSE) call LeaveCriticalSection( loc(lpCriticalSection)) return end subroutine gr_show !------------------------------------------------------------------------------------- subroutine gr_pencol(icol) implicit none integer, intent(in) :: icol integer :: iretb call EnterCriticalSection( loc(lpCriticalSection) ) iretb = DeleteObject(wnd%hPen) wnd%hPen = CreatePen(PS_SOLID, 1, icol) iretb = SelectObject(wnd%hDC, wnd%hPen) call LeaveCriticalSection( loc(lpCriticalSection)) return end subroutine gr_pencol !------------------------------------------------------------------------------------- subroutine gr_text(ix, iy, txt, icol) implicit none integer, intent(in) :: ix, iy character (LEN = *), intent(in) :: txt integer, intent(in), optional :: icol integer (BOOL) :: iretb integer (HANDLE) :: hFont if ( present(icol) ) iretb = SetTextColor(wnd%hDC, icol) call EnterCriticalSection( loc(lpCriticalSection) ) iretb = SetBkMode(wnd%hDC, TRANSPARENT) hFont = CreateFont( 10 , 7 , 0 , 0 ,FW_DONTCARE , FALSE , FALSE , FALSE , & ANSI_CHARSET , OUT_DEFAULT_PRECIS , & CLIP_DEFAULT_PRECIS , PROOF_QUALITY , & IOR(FIXED_PITCH, FF_ROMAN) , NULL ) iretb = SelectObject(wnd%hdc , hFont) iretb = TextOut(wnd%hDC, ix, iy, txt, LEN_TRIM(txt)) iretb = SelectObject(wnd%hdc , GetStockObject(SYSTEM_FONT)) iretb = DeleteObject(hFont) call LeaveCriticalSection( loc(lpCriticalSection) ) return end subroutine gr_text !------------------------------------------------------------------------------------- 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 module uhoplot !===================================================================================== program snoopy use uhoplot integer :: ix, iy, ic, kx = 30, ky = 10, kff = 0, kdy = 8 character(len = 136) :: text open(UNIT=7,FILE='SNPCAL.OUT',STATUS='old') text = '' do ix = kx iy = ky ic = 0 call gr_on('snoopy', 1000, 1000) call gr_pencol(irgb(0, 0, 0)) call gr_text(ix, iy, text, irgb(0, 0, 0) )! do read(7, '(a)', end = 999) text select case(text(1:1)) case ('0') ! LF ix = kx iy = iy + 2 * kdy text(1:1) = ' ' case ('1') ! FF ic = ic + 1 ix = kx iy = 500 * ic + ky text(1:1) = ' ' if (MOD(ic, 2) == 0) exit case ('+') ix = kx text(1:1) = ' ' case default iy = iy + kdy end select call gr_text(ix, iy, text, irgb(0, 0, 0) )! end do call gr_show() call gr_off() end do 999 continue stop contains end program snoopy
