abstract type に concrete な routine
以前、下記の様な記事を書きましたが、この手法はけっこう適用範囲が広いのではないかと思えてきましたので、メモっておきます。
fortran66.hatenablog.com
はじめは abstract な interface に concrete な routine を置くのはいかがなものかと思いましたが、悪くない気がしてきました。
如何なる場合によろしいか
以前の例では、CG 法で逆行列を計算する時に、密行列と疎行列では行列とベクトルの積以外は全て共通に出来るので、下部の行列形式と積計算を後から実装すべき abstract interface とし、上部の CG 法の部分はこの段階で具体的に与えられるので、procedure pointer にぶら下げる形で abstract type のメンバーとして与えました。
つまり、下部が個々に後から実装すべきもので、その下部ルーチンを共通インターフェースを通して上部ルーチンが利用する場合、この手法が使えることになります。
これは、グラフィックス・ルーチンにも適用できます。個別のデバイス装置で点を打つ機能だけを abstract interface に則って実装すれば、点の集まりで線を引くところから先は全て共通になるので、はじめから procedure pointer にぶら下げておいてもいいことになります。
また procedure pointer は、point 先の procedure の差し替えが可能なので、デバイス装置固有の線引きルーチンの方が良ければ、付け替えられることになります。
ただ postscript ファイル出力でやってみると、procedure pointer に与えた型が合わないと叱られるので、select type を使ってやらねばならず面倒でした。（改善の余地がありますが、今後の課題とします。）
例題
ここで、昨日分の記事のルーチンの改訂版を見てみることにします。全体は github に与えてあり、fpm (Fortran package manager) で実行できます。
github.com
abstract interface
pass 指定は明示しなくていいと思いますが、書いておきます。
init, point, show の三つは出力装置毎に実装する必要があるので、abstract interface に deferred 属性で与えておきます。
line, line0 は、出力装置固有の線引きルーチンを作りたい場合があるので、インターフェースを定めておきたいですが、点の連続打ちで実装を済ませる場合も多く、その場合装置に依存しない実装になるので、一か所で共通化しておきたくもあります。ここでのやり方で使い分けが実現できると思われます。
module device
implicit none
type, abstract :: device_t
integer :: nx, ny
procedure (device_line0), pointer, pass :: line0 => device_line0
procedure (device_line ), pointer, pass :: line => device_line
contains
procedure (device_init) , deferred, pass :: init
procedure (device_point), deferred, pass :: point
procedure (device_show) , deferred, pass :: show
end type device_t
abstract interface
subroutine device_init(fig)
import :: device_t
class(device_t), intent(in out) :: fig
end subroutine device_init
subroutine device_point(fig, ix, iy)
import :: device_t
class(device_t), intent(in out) :: fig
integer, intent(in) :: ix, iy
end subroutine device_point
subroutine device_show(fig)
import :: device_t
class(device_t), intent(in) :: fig
end subroutine device_show
end interface
contains
subroutine device_line0(fig, ix0, iy0, ix1, iy1)
class(device_t), intent(in out) :: fig
integer, intent(in) :: ix0, iy0, ix1, iy1
integer :: nx, ny, i
real :: d
nx = ix1 - ix0
ny = iy1 - iy0
if (nx == 0 .and. ny == 0) then
call fig%point(ix0, iy0)
else if (abs(nx) < abs(ny)) then
d = nx / real(ny)
do i = 0, ny, sign(1, ny)
call fig%point(nint(ix0 + i * d), iy0 + i)
end do
else
d = ny / real(nx)
do i = 0, nx, sign(1, nx)
call fig%point(ix0 + i, nint(iy0 + i * d))
end do
end if
end subroutine device_line0
subroutine device_line(fig, x, y, ipen)
class(device_t), intent(in out) :: fig
real, intent(in) :: x, y
integer, intent(in) :: ipen
integer, save :: ix0 = 0, iy0 = 0
integer :: ix, iy
real :: xn, yn, fx, fy
xn = fig%nx / 2.0
yn = fig%ny / 2.0 * 1.5
fx = fig%nx / 150.0
fy = fig%ny / 150.0
ix = nint( fx * x + xn)
iy = nint(-fy * y + yn)
if (ipen == 1) call fig%line0(ix0, iy0, ix, iy)
ix0 = ix
iy0 = iy
end subroutine device_line
end module device
具体的実装１
unicode 点字
module uniplot
use device
implicit none
private
public :: fig_t
type, extends(device_t) :: fig_t
private
integer, allocatable :: array(:, :)
contains
procedure :: init
procedure :: point
procedure :: show
end type fig_t
contains
subroutine init(fig)
class(fig_t), intent(in out) :: fig
allocate(fig%array(0:(fig%nx+1)/2, 0:(fig%ny+3)/4), source = 0)
end subroutine init
subroutine point(fig, ix, iy)
class(fig_t), intent(in out) :: fig
integer, intent(in) :: ix, iy
integer :: iax, iay
iax = ix / 2
iay = iy / 4
if (0<=ix .and. ix<fig%nx .and. 0<=iy .and. iy<fig%ny) then
fig%array(iax, iay) = ior(fig%array(iax, iay), icode(mod(ix, 2), mod(iy, 4)))
end if
end subroutine point
pure elemental integer function icode(kx, ky)
integer, intent(in) :: kx, ky
if (ky == 3) then
icode = 64 + 64 * kx
else
icode = 2**(ky + 3*kx)
end if
end function icode
subroutine show(fig)
class(fig_t), intent(in) :: fig
integer :: iy
do iy = 0, ubound(fig%array, 2)
print '(*(a))', reverse_endian(shift_code(fig%array(:, iy)))
end do
end subroutine show
pure elemental integer function shift_code(k)
integer, intent(in) :: k
integer, parameter :: n0 = 14852224
shift_code = n0 + 256 * (k /64) + mod(k, 64)
end function shift_code
pure elemental character(len = 4) function reverse_endian(i)
integer, intent(in) :: i
character:: tmp(4)
tmp = transfer(i, ' ', size = 4)
reverse_endian = transfer(tmp(4:1:-1), ' ')
end function reverse_endian
end module uniplot
具体的実装２
簡易 X11 window
Finalizer に window 処理の終了処理を入れてみました。Finalizer は処理系によって挙動が異なるので問題になるかもしれません。gfortran ではうまくいっているようです。
#include <X11/Xlib.h>
#include <X11/Xutil.h>
static Display* d;
static Window w;
static GC gc;
unsigned long white, black;
void X_open(int nx, int ny) {
d = XOpenDisplay(0);
if ( !d ) return;
white = WhitePixel(d, DefaultScreen(d));
black = BlackPixel(d, DefaultScreen(d));
w = XCreateSimpleWindow(d, DefaultRootWindow(d), 0, 0, nx, ny, 0, black, white);
XMapWindow(d, w);
gc = XCreateGC(d, w, 0, 0);
XFlush(d);
}
void X_point(int ix, int iy) {
XDrawPoint(d, w, gc, ix, iy);
XFlush(d);
}
void X_flush(){
XFlush(d);
}
void X_close(void) {
XFreeGC(d, gc);
XDestroyWindow(d, w);
XFlush(d);
XCloseDisplay(d);
}
module xplot
use, intrinsic :: iso_c_binding
use device
implicit none
private
public :: fig_t
interface
subroutine Xopen(nx, ny) bind(c, name = 'X_open')
use, intrinsic :: iso_c_binding , only : c_int
integer(c_int), value :: nx, ny
end subroutine Xopen
subroutine Xpoint(ix, iy) bind(c, name = 'X_point')
use, intrinsic :: iso_c_binding, only : c_int
integer(c_int), value :: ix, iy
end subroutine Xpoint
subroutine Xclose() bind(c, name = 'X_close')
end subroutine Xclose
subroutine Xflush() bind(c, name = 'X_flush')
end subroutine Xflush
end interface
type, extends(device_t) :: fig_t
private
contains
procedure :: init
procedure :: point
procedure :: show
final :: x_close
end type fig_t
contains
subroutine init(fig)
class(fig_t), intent(in out) :: fig
call Xopen(int(fig%nx, c_int), int(fig%ny, c_int))
end subroutine init
subroutine point(fig, ix, iy)
class(fig_t), intent(in out) :: fig
integer, intent(in) :: ix, iy
call Xpoint(int(ix, c_int), int(iy, c_int))
end subroutine point
subroutine show(fig)
class(fig_t), intent(in) :: fig
call XFlush()
end subroutine show
subroutine x_close(fig)
type(fig_t), intent(in out) :: fig
print *, 'press ENTER to continue'
read *
call Xclose()
end subroutine x_close
end module xplot
具体的実装 ３
postscript ファイル生成
module psplot
use device
implicit none
private
public :: fig_t
type, extends(device_t) :: fig_t
private
character(len = :), allocatable, public :: fn
integer, allocatable :: iw
contains
procedure :: init
procedure :: point
procedure :: show
procedure :: filename
final :: off
end type fig_t
contains
subroutine init(fig)
class(fig_t), intent(in out) :: fig
allocate(fig%iw)
fig%line0 => line0
fig%line => line
if (.not. allocated(fig%fn)) fig%fn = 'figure'
associate (iw => fig%iw, fn => fig%fn)
open(newunit = iw, file = trim(fn) // '.ps')
write(iw, '(a)') '%!PS-Adobe-3.0 EPSF-3.0'
write(iw, '(a, 2i8)') '%%BoundingBox: 0 0 ', fig%nx, fig%ny
write(iw, '(2a)') '%%Title: ', trim(fn)
write(iw, '(a)') '%%EndComments'
write(iw, '(a)') 'gsave'
write(iw, '(a)') '1 1 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 ', fig%ny, ' translate'
write(iw, '(a)') 'newpath'
end associate
end subroutine init
subroutine filename(fig, fn)
class(fig_t), intent(in out) :: fig
character(*), intent(in) :: fn
fig%fn = fn
end subroutine filename
subroutine off(fig)
type(fig_t), intent(in) :: fig
write(fig%iw, '(a)') 'stroke'
write(fig%iw, '(a)') 'showpage'
write(fig%iw, '(a)') 'grestore'
write(fig%iw, '(a)') '%%EOF'
close(fig%iw)
end subroutine off
subroutine point(fig, ix, iy)
class(fig_t), intent(in out) :: fig
integer, intent(in) :: ix, iy
write(fig%iw, '(a)') 'newpath'
write(fig%iw, '(*(g0))') ix, ' ', -iy, ' 0.5 0 360 arc fill'
end subroutine point
subroutine show(fig)
class(fig_t), intent(in) :: fig
write(fig%iw, '(a)') 'stroke'
write(fig%iw, '(a)') 'newpath'
end subroutine show
subroutine line0(fig, ix0, iy0, ix1, iy1)
class(device_t), intent(in out) :: fig
integer, intent(in) :: ix0, iy0, ix1, iy1
select type (fig)
type is (fig_t)
write(fig%iw, '(2i7, a)') ix0, -iy0, ' moveto'
write(fig%iw, '(2i7, a)') ix1, -iy1, ' lineto'
end select
end subroutine line0
subroutine line(fig, x, y, ipen)
class(device_t), intent(in out) :: fig
real, intent(in) :: x, y
integer, intent(in) :: ipen
real :: xn, yn, fx, fy
select type (fig)
type is (fig_t)
xn = fig%nx / 2.0
yn = fig%ny / 2.0 * 1.5
fx = fig%nx / 150.0
fy = fig%ny / 150.0
if (ipen == 1) then
write(fig%iw, '(2f10.3, a)') fx * x + xn, fy * y - yn, ' lineto'
else
write(fig%iw, '(2f10.3, a)') fx * x + xn, fy * y - yn, ' moveto'
end if
end select
end subroutine line
end module psplot
