【メモ帳】abstract type の用い方について

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

Modern Fortran Explained: Incorporating Fortran 2018 (Numerical Mathematics and Scientific Computation)

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
        ! clipping
        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 ! 0, 1, 2
            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 ! Z'E2A080' 
        shift_code = n0 + 256 * (k /64) + mod(k, 64)  !E2A180, E2A280, E2A380      
    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), '    ')  !array 4 to len 4
    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) {
    // Open a display
    d = XOpenDisplay(0);
    if ( !d ) return;
    //
    white = WhitePixel(d, DefaultScreen(d));
    black = BlackPixel(d, DefaultScreen(d));
    // Create a window
    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))  
     !   call sleep(1)  ! non-standard : sleeps 1 sec
    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'    !'0.8 0.8 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    

抽象芸術