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 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"C 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)//''C, & 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*4 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 !------------------------------------------------------------------------------- END MODULE uho_win !================================================================================= MODULE uhoplot USE uho_win CONTAINS !------------------------------------------------------------------------------------- INTEGER (HANDLE) FUNCTION get_DosHndl() IMPLICIT NONE INTERFACE FUNCTION GetConsoleWindow() ! non-existent in IFORTxx.MOD USE ifwinty INTEGER (HANDLE) :: GetConsoleWindow !DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'GetConsoleWindow' :: GetConsoleWindow END FUNCTION END INTERFACE get_DosHndl = GetConsoleWindow() RETURN END FUNCTION get_DosHndl !------------------------------------------------------------------------------------- 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_dot(ix, iy, icol) IMPLICIT NONE INTEGER, INTENT(IN) :: ix, iy INTEGER, INTENT(IN) :: icol INTEGER (BOOL):: iretb CALL EnterCriticalSection(LOC(lpCriticalSection)) iretb = SetPixel(wnd%hDC, ix, iy, icol) CALL LeaveCriticalSection(LOC(lpCriticalSection)) RETURN END SUBROUTINE gr_dot !------------------------------------------------------------------------------------- SUBROUTINE gr_move(ix, iy) IMPLICIT NONE INTEGER, INTENT(IN) :: ix, iy INTEGER (BOOL):: iretb CALL EnterCriticalSection(LOC(lpCriticalSection)) iretb = MoveToEx(wnd%hDC, ix, iy, NULL) CALL LeaveCriticalSection(LOC(lpCriticalSection)) RETURN END SUBROUTINE gr_move !------------------------------------------------------------------------------------- SUBROUTINE gr_line(ix, iy) IMPLICIT NONE INTEGER, INTENT(IN) :: ix, iy INTEGER (BOOL):: iretb CALL EnterCriticalSection(LOC(lpCriticalSection)) iretb = LineTo(wnd%hDC, ix, iy) CALL LeaveCriticalSection(LOC(lpCriticalSection)) RETURN END SUBROUTINE gr_line !------------------------------------------------------------------------------------- SUBROUTINE gr_show() IMPLICIT NONE INTEGER (BOOL):: iretb iretb = InvalidateRect(wnd%hWnd, NULL, FALSE) 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 IF (PRESENT(icol)) iretb = SetTextColor(wnd%hDC, icol) CALL EnterCriticalSection(LOC(lpCriticalSection)) iretb = TextOut(wnd%hDC, ix, iy, txt, LEN_TRIM(txt)) 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 ABE3 USE uhoplot INTEGER :: i, j CALL gr_on('Abe-san', 500, 600) CALL gr_pencol(irgb(0, 0, 0)) ! chin chin CALL line( 0.0, 32.0, 0) CALL line( 0.0, 35.0, 1) ! collar CALL line( 8.0, 0.0, 0) CALL line( 22.0, 25.0, 1) CALL line( 30.0, 55.0, 1) CALL line( 19.0, 0.0, 0) CALL line( 25.0, 10.0, 1) CALL line( 47.0, 20.0, 1) CALL line( 35.0, 40.0, 1) CALL line( 55.0, 35.0, 1) CALL line( 35.0, 40.0, 0) CALL line( 30.0, 55.0, 1) CALL line( 13.0, 20.0, 0) CALL line( 24.0, 44.0, 1) CALL line( -8.0, 0.0, 0) CALL line(-22.0, 25.0, 1) CALL line(-30.0, 55.0, 1) CALL line(-19.0, 0.0, 0) CALL line(-25.0, 10.0, 1) CALL line(-47.0, 20.0, 1) CALL line(-35.0, 40.0, 1) CALL line(-55.0, 35.0, 1) CALL line(-35.0, 40.0, 0) CALL line(-30.0, 55.0, 1) CALL line(-13.0, 20.0, 0) CALL line(-24.0, 44.0, 1) ! CALL line( 0.0, 26.0, 0) CALL line( 4.0, 26.0, 1) CALL line( 14.0, 30.0, 1) CALL line( 24.0, 44.0, 1) CALL line( 30.0, 55.0, 1) CALL line( 33.0, 65.0, 1) CALL line( 33.0, 120.0, 1) CALL line( 2.0, 120.0, 1) CALL line( 2.0, 115.0, 1) CALL line( 0.0, 106.0, 1) CALL line( -2.0, 103.0, 1) ! CALL line( 0.0, 26.0, 0) CALL line( -4.0, 26.0, 1) CALL line(-14.0, 30.0, 1) CALL line(-24.0, 44.0, 1) CALL line(-30.0, 55.0, 1) CALL line(-33.0, 65.0, 1) CALL line(-33.0, 120.0, 1) CALL line( 0.0, 120.0, 1) CALL line( 0.0, 110.0, 1) CALL line( -2.0, 103.0, 1) !right ear CALL line( 33.0, 65.0, 0) CALL line( 42.0, 77.0, 1) CALL line( 42.0, 89.0, 1) CALL line( 40.0, 93.0, 1) CALL line( 36.0, 93.0, 1) CALL line( 34.0, 86.0, 1) CALL line( 33.0, 84.0, 1) CALL line( 34.0, 86.0, 0) CALL line( 36.0, 84.0, 1) CALL line( 36.0, 74.0, 1) CALL line( 33.0, 69.0, 1) !left ear CALL line(-33.0, 65.0, 0) CALL line(-42.0, 77.0, 1) CALL line(-42.0, 89.0, 1) CALL line(-40.0, 93.0, 1) CALL line(-36.0, 93.0, 1) CALL line(-34.0, 86.0, 1) CALL line(-33.0, 84.0, 1) CALL line(-34.0, 86.0, 0) CALL line(-36.0, 84.0, 1) CALL line(-36.0, 74.0, 1) CALL line(-33.0, 69.0, 1) ! hair CALL line( 40.0, 93.0, 0) CALL line( 40.0, 120.0, 1) CALL line( 33.0, 135.0, 1) CALL line( 14.0, 147.0, 1) CALL line(-14.0, 147.0, 1) CALL line(-33.0, 135.0, 1) CALL line(-40.0, 120.0, 1) CALL line(-40.0, 93.0, 1) ! mouth CALL line(-15.0, 54.0, 0) CALL line(-14.0, 53.0, 1) CALL line( -6.0, 53.0, 1) CALL line( -5.0, 52.0, 1) CALL line( -1.0, 52.0, 0) CALL line( 7.0, 53.0, 1) CALL line( 10.0, 52.0, 1) CALL line( 11.0, 53.0, 1) ! CALL line( -6.0, 45.0, 0) CALL line( -5.0, 44.0, 1) CALL line( 5.0, 44.0, 1) CALL line( 6.0, 45.0, 0) ! nose CALL line( 2.0, 65.0, 0) CALL line( 2.0, 64.0, 1) CALL line( 0.0, 62.0, 1) CALL line( -4.0, 64.0, 1) CALL line( -6.0, 62.0, 1) CALL line( 0.0, 59.0, 1) CALL line( 5.0, 61.0, 1) CALL line( 5.0, 66.0, 1) CALL line( 4.0, 66.0, 1) CALL line( 2.0, 68.0, 1) CALL line( 2.0, 87.0, 1) CALL line( 6.0, 92.0, 1) CALL line( 5.0, 95.0, 1) ! CALL line( 3.0, 72.0, 0) CALL line( 3.0, 86.0, 1) CALL line( 4.0, 87.0, 1) CALL line( 7.0, 77.0, 1) CALL line( 3.0, 72.0, 1) ! right eye CALL line( 5.0, 95.0, 0) CALL line( 7.0, 97.0, 1) CALL line( 30.0, 97.0, 1) CALL line( 32.0, 93.0, 1) CALL line( 25.0, 94.0, 1) CALL line( 12.0, 94.0, 1) CALL line( 5.0, 95.0, 1) CALL line( 10.0, 93.0, 0) CALL line( 12.0, 94.0, 1) CALL line( 29.0, 90.0, 0) CALL line( 25.0, 94.0, 1) ! CALL line( 14.0, 85.0, 0) CALL line( 18.0, 85.0, 1) CALL line( 19.0, 84.0, 1) CALL line( 20.0, 85.0, 1) CALL line( 23.0, 84.0, 1) ! CALL line( 10.0, 83.0, 0) CALL line( 18.0, 82.0, 1) CALL line( 20.0, 81.0, 1) ! CALL line( 18.0, 90.0, 0) CALL line( 20.0, 90.0, 1) CALL line( 20.0, 92.0, 1) CALL line( 18.0, 92.0, 1) CALL line( 18.0, 90.0, 1) ! CALL line( 10.0, 91.0, 0) CALL line( 15.0, 94.0, 1) CALL line( 23.0, 94.0, 1) CALL line( 27.0, 91.0, 1) CALL line( 29.0, 87.0, 1) CALL line( 28.0, 87.0, 1) CALL line( 27.0, 90.0, 1) CALL line( 23.0, 93.0, 1) CALL line( 23.0, 89.0, 1) CALL line( 21.0, 87.0, 1) CALL line( 17.0, 87.0, 1) CALL line( 15.0, 89.0, 1) CALL line( 15.0, 91.0, 1) CALL line( 16.0, 93.0, 1) CALL line( 11.0, 90.0, 1) CALL line( 10.0, 91.0, 1) ! left eye CALL line(-33.0, 95.0, 0) CALL line(-30.0, 99.0, 1) CALL line(-12.0, 99.0, 1) CALL line( -7.0, 96.0, 1) CALL line(-10.0, 94.0, 1) CALL line(-14.0, 95.0, 1) CALL line(-33.0, 95.0, 1) CALL line(-11.0, 92.0, 0) CALL line(-14.0, 95.0, 1) ! CALL line(-23.0, 82.0, 0) CALL line(-21.0, 81.0, 1) CALL line(-14.0, 84.0, 1) ! CALL line(-27.0, 86.0, 0) CALL line(-21.0, 85.0, 1) CALL line(-15.0, 86.0, 1) ! CALL line(-29.0, 90.0, 0) CALL line(-25.0, 94.0, 1) CALL line(-15.0, 94.0, 1) CALL line(-12.0, 91.0, 1) CALL line(-13.0, 90.0, 1) CALL line(-16.0, 92.0, 1) CALL line(-17.0, 90.0, 1) CALL line(-18.0, 87.0, 1) CALL line(-22.0, 87.0, 1) CALL line(-24.0, 89.0, 1) CALL line(-24.0, 92.0, 1) CALL line(-28.0, 89.0, 1) CALL line(-29.0, 90.0, 1) ! CALL line(-19.0, 90.0, 0) CALL line(-21.0, 90.0, 1) CALL line(-21.0, 92.0, 1) CALL line(-19.0, 92.0, 1) CALL line(-19.0, 90.0, 1) ! CALL gr_text(200, 10, 'やらないか', irgb(0, 155, 255) ) ! CALL gr_show() CALL gr_off() STOP CONTAINS !------------------------------------------------ SUBROUTINE line(x, y, ipen) IMPLICIT NONE REAL , INTENT(IN) :: x, y INTEGER, INTENT(IN) :: ipen INTEGER (BOOL):: iretb INTEGER :: ix, iy ix = INT(x * 3.0 + 250.0) iy = -INT(y * 3.0 + 100.0) + 590 IF (ipen == 1) THEN CALL gr_line(ix, iy) ELSE CALL gr_move(ix, iy) END IF RETURN END SUBROUTINE line !------------------------------------------------ END PROGRAM abe3
H20(2008)-2-21 微妙に修正。
プロジェクトはコンソール用で、オプションはランタイムライブラリをマルチスレッド対応へ。
