奥村晴彦著『C言語による 最新 アルゴリズム事典』の「フラクタルによる画像圧縮」を移植してみました。羊歯植物のパラメータを入れています。
この本のルーチンと互換性を上げるために、uhoplotに少しサブルーチンを加えました。
MODULE plotter USE uhoplot IMPLICIT NONE REAL :: xpen = 0.0, ypen = 0.0 CONTAINS !---------------------------------------------------------------- SUBROUTINE move(x, y) IMPLICIT NONE REAL, INTENT(IN) :: x, y xpen = x ypen = y RETURN END SUBROUTINE move !---------------------------------------------------------------- SUBROUTINE move_rel(dx, dy) IMPLICIT NONE REAL, INTENT(IN) :: dx, dy xpen = xpen + dx ypen = ypen + dy RETURN END SUBROUTINE move_rel !---------------------------------------------------------------- SUBROUTINE draw(x, y) IMPLICIT NONE REAL, INTENT(IN) :: x, y CALL gr_wmove(xpen, ypen) CALL gr_wline(x , y ) xpen = x ypen = y CALL gr_show() RETURN END SUBROUTINE draw !---------------------------------------------------------------- SUBROUTINE draw_rel(dx, dy) IMPLICIT NONE REAL, INTENT(IN) :: dx, dy CALL gr_wmove(xpen, ypen) CALL gr_wline(xpen + dx, ypen + dy) xpen = xpen + dx ypen = ypen + dy CALL gr_show() RETURN END SUBROUTINE draw_rel !---------------------------------------------------------------- END MODULE plotter !================================================================ PROGRAM fern USE plotter INTEGER, PARAMETER :: n = 4, m = n * 25 REAL :: a(4) = (/ 0.0 , 0.85, 0.20, -0.15 /) REAL :: b(4) = (/ 0.0 , 0.04, -0.26, 0.28 /) REAL :: c(4) = (/ 0.0 , -0.04, 0.23, 0.26 /) REAL :: d(4) = (/ 0.16, 0.85, 0.22, 0.24 /) REAL :: e(4) = (/ 0.0 , 0.0 , 0.0 , 0.0 /) REAL :: f(4) = (/ 0.0 , 1.6 , 1.6 , 0.44 /) INTEGER :: i, j, k, ir, ip(n), itable(m) REAL :: x, y, s, t, p(n) s = 0.0 DO i = 1, n p(i) = MAX(0.01, ABS( a(i) * d(i) - b(i) * c(i) )) s = s + p(i) ip(i) = i END DO DO i = 1, n - 1 k = i DO j = i + 1, n IF ( p(j) < p(k) ) k = j END DO t = p(i) p(i) = p(k) p(k) = t ir = ip(i) ip(i) = ip(k) ip(k) = ir END DO ir = m DO i = 1, n k = INT(ir * p(i) / s + 0.5) s = s - p(i) DO WHILE ( k > 0 ) itable(ir) = ip(i) k = k - 1 ir = ir - 1 END DO END DO CALL gr_on('fern', 640, 480) CALL gr_axis(-5.0, 5.0, 0.0, 10.0) x = 0.0 y = 0.0 DO i = 1, 300000 CALL RANDOM_NUMBER(s) j = itable(INT(m * s) + 1) t = a(j) * x + b(j) * y + e(j) y = c(j) * x + d(j) * y + f(j) x = t IF (i > 10) CALL gr_wdot(x, y, irgb(0, 0, 0)) END DO CALL gr_off() STOP END PROGRAM fern
uhoplot修正版
モジュール uhoplot の終わりのほうに、gr_axis, to_ixy, gr_wdot, gr_wmove, gr_wline の５つのサブルーチンを加えました。
ちなみに uhoplot は、USE ifwinXXX 等の win32 関連のモジュールの USE ifxxxx を USE dfxxxx に書き換えることで、Compaq Visual Fortran Ver6.6 でも動作します。
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 !---------------------------------------------------------------- SUBROUTINE gr_axis(xmin, xmax, ymin, ymax) IMPLICIT NONE REAL, INTENT(IN) :: xmin, xmax, ymin, ymax wnd%xmin = xmin wnd%xmax = xmax wnd%ymin = ymin wnd%ymax = ymax RETURN END SUBROUTINE gr_axis !---------------------------------------------------------------- SUBROUTINE to_ixy(x, y, ix, iy) IMPLICIT NONE REAL , INTENT(IN ) :: x, y INTEGER, INTENT(OUT) :: ix, iy ix = INT( wnd%nsize_x * (x - wnd%xmin) / (wnd%xmax - wnd%xmin) ) iy = -INT( wnd%nsize_y * (y - wnd%ymin) / (wnd%ymax - wnd%ymin) ) + wnd%nsize_y RETURN END SUBROUTINE to_ixy !---------------------------------------------------------------- SUBROUTINE gr_wdot(x, y, icol) IMPLICIT NONE REAL, INTENT(IN) :: x, y INTEGER, INTENT(IN) :: icol INTEGER :: ix, iy INTEGER (BOOL):: iretb CALL to_ixy(x, y, ix, iy) CALL EnterCriticalSection(LOC(lpCriticalSection)) iretb = SetPixel(wnd%hDC, ix, iy, icol) CALL LeaveCriticalSection(LOC(lpCriticalSection)) RETURN END SUBROUTINE gr_wdot !---------------------------------------------------------------- SUBROUTINE gr_wmove(x, y) IMPLICIT NONE REAL, INTENT(IN) :: x, y INTEGER (BOOL):: iretb INTEGER :: ix, iy CALL to_ixy(x, y, ix, iy) CALL EnterCriticalSection(LOC(lpCriticalSection)) iretb = MoveToEx(wnd%hDC, ix, iy, NULL) CALL LeaveCriticalSection(LOC(lpCriticalSection)) RETURN END SUBROUTINE gr_wmove !---------------------------------------------------------------- SUBROUTINE gr_wline(x, y) IMPLICIT NONE REAL, INTENT(IN) :: x, y INTEGER (BOOL):: iretb INTEGER :: ix, iy CALL to_ixy(x, y, ix, iy) CALL EnterCriticalSection(LOC(lpCriticalSection)) iretb = LineTo(wnd%hDC, ix, iy) CALL LeaveCriticalSection(LOC(lpCriticalSection)) RETURN END SUBROUTINE gr_wline !---------------------------------------------------------------- END MODULE uhoplot !================================================================
