ラインプリンタの重ね打ちを使っているので、Windowsのグラフィックでラインプリンタ動作を再現するように作ってみた試し。もう少し完成度をあげたい。
ラインプリンタ出力＋α
スヌーピーカレンダーデータは別プログラム。過去日記参照。
テスト 未完成↓
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 INTEGER (HANDLE) :: hFont IF ( PRESENT(icol) ) iretb = SetTextColor(wnd%hDC, icol) CALL EnterCriticalSection(LOC(lpCriticalSection)) iretb = SetBkMode(wnd%hDC, TRANSPARENT) hFont = CreateFont( 2 , 2 , 0 , 0 ,FW_DONTCARE , FALSE , FALSE , FALSE , & DEFAULT_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 ABE3 USE uhoplot INTEGER :: ix, iy, ic character :: text*136 CALL gr_on('snoopy', 1200, 1000) CALL gr_pencol(irgb(0, 0, 0)) ! ix = 0 iy = 0 ic = 0 open(UNIT=7,FILE='SNPCAL.OUT',STATUS='old') read(7, '(a)', end = 999) text ! skip first FF do read(7, '(a)', end = 999) text select case(text(1:1)) case ('0') ix = 300 * ic iy = iy + 36 text(1:1) = ' ' CALL gr_text(ix, iy, text, irgb(0, 0, 0) ) case ('1') if ( iy > 800 ) then ic = ic + 1 iy = 0 end if ix = 300 * ic iy = iy + 20 text(1:1) = ' ' CALL gr_text(ix, iy, text, irgb(0, 0, 0) ) case ('+') ix = 300 * ic text(1:1) = ' ' CALL gr_text(ix, iy, text, irgb(0, 0, 0) ) case default CALL gr_text(ix, iy, text, irgb(0, 0, 0) ) iy = iy + 2 !18 end select end do 999 continue ! 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
