【メモ帳】anime gif プログラム

前回から簡素化＋アニメ化

派生型要素の書き出し用の type bound procedure はやめにして、旧来型で sequence で要素を並べて、生 write 文で済ませることにしました。

ついでに、image block を複数書けるようにした anime gif 対応ルーチンも加えておきました。ただ手抜きで local color table には対応させていません。簡単に直せると思います。

256 色以下の Fortran 計算結果の gif anime 化にはこれで十分だと思います。またここまでくれば、透過色・インターレース等の拡張も難しくない気がします。

ただアニメーション gif の場合、状態を保たねばならないので OO 化した方がいいでしょう。

Modern Fortran Explained (Numerical Mathematics and Scientific Computation)

Modern Fortran: Tricks of the Software Engineering Trade (Chapman & Hall/CRC Computational Science)

Introduction to Modern Fortran for the Earth System Sciences (Springerbriefs in Earth System Sciences)

実行例

三つの gif ファイルを出力しています。

1. animu.gif

1. test1.gif

1. test2.gif

ソース・プログラム

global_corlor_table に 4 色以上 256 色以下の 24 bit RGB 色データをセットする。色数は 2^(n_global_color + 1) 色で指定される。図画情報は、irgb(width, height) の整数配列が図の左上を原点 (0,0) とする座標系のピクセル位置に対応しており、それぞれに global_color_table の色に対応する整数値を書き込む。

    module m_gif_types
      use, intrinsic :: iso_fortran_env
      implicit none    
      private
      public :: t_gif_header, t_image_block, t_graphic_control_extension, t_application_extension 
      ! constructors 
      interface t_gif_header
        procedure :: init_gif_header
      end interface 

      interface t_image_block
        procedure :: init_image_block
      end interface 
      
      interface t_graphic_control_extension
        procedure :: init_graphic_control_extension 
      end interface
      
      interface t_application_extension
        procedure :: init_application_extension
      end interface  
      !
      type :: t_gif_header
        sequence  
        character(3)   :: signature               = 'GIF'
        character(3)   :: version                 = '89a' ! '87a'
        integer(int16) :: width     
        integer(int16) :: height    
        integer(int8)  :: pck                     = int(B'10001010', int8) ! 1:Global Col. 3:Color Res. 1:Sort Flg. 3:Size of Global Col.
        integer(int8)  :: background_color_index  = 0
        integer(int8)  :: pixel_aspect_ratio      = 0
      end type  

      type :: t_image_block
        sequence
        integer(int8)  :: image_separator         = Z'2C'
        integer(int16) :: image_left_position     = 00
        integer(int16) :: image_top_position      = 00
        integer(int16) :: image_width  
        integer(int16) :: image_height 
        integer(int8)  :: pck                     = int(B'00000000', int8)
        ! local color table
        !integer(int8) :: LZW_minimum_code_size 
        !integer(int8) :: block_size  
        !integer(int8) :: image_data (:)
        !integer(int8) :: block_terminator        = Z'00'  
      end type t_image_block

      type :: t_graphic_control_extension
        sequence  
        integer(int8)  :: extention_introducer    = Z'21'
        integer(int8)  :: graphic_control_label   = Z'F9'
        integer(int8)  :: lock_size               = Z'04'
        integer(int8)  :: pck                     = Z'00'
        integer(int16) :: delay_time              = 50 ! msec
        integer(int8)  :: transparent_color_index = 0
        integer(int8)  :: block_terminator        = Z'00'
      end type t_graphic_control_extension
      
      type :: t_application_extension ! for animation gif
        sequence  
        integer(int8)  :: extension_intrducer     = Z'21'
        integer(int8)  :: extension_label         = Z'FF'
        integer(int8)  :: block_size_01           = Z'0B'
        character(len = 8) :: application_identifier          = 'NETSCAPE'
        character(len = 3) :: application_authentication_code = '2.0'
        integer(int8)  :: block_size_02           = Z'03' ! 0:block terminator
        integer(int8)  :: n                       = Z'01' !application_data
        integer(int16) :: nloop                   = 0     ! 0:unlimited 
        integer(int8)  :: block_terminator        = Z'00'
      end type t_application_extension   
    contains
      type(t_gif_header) function init_gif_header(nx, ny, ngcol) result(res)
        integer, intent(in) :: nx, ny, ngcol
        res%width  = nx
        res%height = ny
        res%pck = iand(res%pck, B'11111000') + int(mod(ngcol, 8), int8) ! least 3bits : size of global color : 2**(ngcol + 1) 2..256
      end function init_gif_header
    
      type(t_image_block) function init_image_block(nx, ny) result(res)
        integer, intent(in) :: nx, ny
        res%image_width  = nx
        res%image_height = ny
      end function init_image_block
    
      type(t_graphic_control_extension) function init_graphic_control_extension(it) result(res)
        integer, intent(in) :: it
        res%delay_time = it ! msec 
      end function  init_graphic_control_extension
    
      type(t_application_extension) function init_application_extension(nloop) result(res)
        integer, intent(in) :: nloop
        res%nloop = int(nloop, int16)
      end function init_application_extension  
    end module m_gif_types 

    module m_gif_lzw
      use, intrinsic :: iso_fortran_env
      use :: m_gif_types
      implicit none
      private
      public :: encoder
      type :: t_enc
        integer :: kbits = 0, id = 0
      end type    
    contains
      subroutine enc(irgb, nbits, code)               ! gif LZW 
        integer, intent(in) :: irgb(:), nbits
        type (t_enc), intent(out) :: code(:)
        integer :: dict(0:2**12 - 1) ! 0:4095
        integer :: kbits, kd, m0
        integer :: i, ip, ic, ienc
        call clear_dict()                             ! clear dictionary 
        ic = 1
        code(ic) = t_enc(kbits, 2**nbits)             ! clear_code 
        m0 = irgb(1)
        do ip = 2, size(irgb)
          call subenc(ienc, irgb(ip)) 
          if (ienc /= -1) then 
            ic = ic + 1
            code(ic) = t_enc(kbits, ienc)
          end if  
          if (kd == 2**12 - 1) then                   ! dictionary full
            ic = ic + 1  
            code(ic) = t_enc(kbits, 2**nbits)         ! clear_code
            call clear_dict()                         ! clear dictionary 
          end if
        end do
        ic = ic + 1
        code(ic) = t_enc(kbits, m0)
        ic = ic + 1 
        code(ic) = t_enc(kbits, dict(2**nbits + 1))   ! end_code  
      contains
        subroutine subenc(ienc, m1)
          integer, intent(out) :: ienc
          integer, intent(in ) :: m1
          integer :: k, id
          k = ishft(m0 + 1, 16) + m1                  ! m0 + 1 to avoid 00...0 degeneracy 
          id = findloc(dict, k, dim = 1)              ! dictionary is 0-based 
          if (id == 0) then                           ! not found in dictionary
            kd = kd + 1
            dict(kd) = k
            if (kd == 2**kbits + 1) kbits = kbits + 1
            ienc = m0
            m0 = m1
          else                                        ! found in dictionary
            ienc = -1
            m0 = id - 1                               ! because dictionary is 0-based, m0 must be shifted by 1
          end if    
        end subroutine subenc

        subroutine clear_dict()
          integer :: i
          kbits = nbits + 1
          kd = 2**nbits + 1 ! dictinary defined
          dict = 0
          forall(i = 0:kd) dict(i) = i                ! dict(nbit):clear code; dict(nbit+1):end code 
        end subroutine clear_dict
      end subroutine enc
      
      subroutine encoder(irgb, nbits, icode)
        integer, intent(in ) :: irgb(:), nbits
        integer(int8), allocatable, intent(out) :: icode(:)
        type(t_enc), allocatable :: code(:)
        integer :: i, j, k, ib, ic, nb  
        allocate(code(size(irgb) + 100))              ! ? large enough ?
        call enc(irgb, nbits, code)                   ! compress color code to LZW code
        nb = ceiling(sum(code(:)%kbits) / 8.0)        !   required bytes  
        allocate(icode(nb))
        icode = 0                                     ! pack LZW code to bit string    
        k = 0
        do i = 1, size(code)                          
          do j = 1, code(i)%kbits   
            if (btest(code(i)%id, j - 1)) then 
              ic = k / 8 + 1 
              ib = mod(k, 8)
              icode(ic) = ibset(icode(ic), ib)
            end if
            k = k + 1
          end do  
        end do            
      end subroutine encoder 
    end module m_gif_lzw
        
    module m_gif
      use, intrinsic :: iso_fortran_env
      use :: m_gif_types
      use :: m_gif_lzw
      implicit none
      private
      public :: wr_gif
    contains
      subroutine wr_gif(fn, irgb2)
        character(*), intent(in) :: fn
        integer     , intent(in) :: irgb2(:, :)
        type(t_gif_header ), allocatable :: head
        type(t_image_block), allocatable :: img
        integer :: n_global_color 
        integer(int8), allocatable :: global_color_table(:, :)
        integer(int8), allocatable :: icode(:)
        integer :: nx, ny, minbits
        ! set global color table
        n_global_color = 2
        allocate(global_color_table(3, 2**(n_global_color + 1)))
        global_color_table = 0
        global_color_table = reshape([[  0,  0,  0], [255,  0,  0], [0,255,  0], [  0,  0,255], &
                                      [255,255,  0], [255,  0,255], [0,255,255], [255,255,255]], [8,3])
        ! set header 
        nx = size(irgb2, 1)
        ny = size(irgb2, 2)
        head  = t_gif_header(nx, ny, n_global_color)
        img   = t_image_block(nx, ny)
        minbits = n_global_color + 1               
        ! encode color code to lzw code 
        block
          integer :: ix, iy  
          integer, allocatable :: irgb(:)
          allocate(irgb(size(irgb2)))
          forall(ix = 1:nx, iy = 1:ny) irgb(ix + nx * (iy - 1)) = irgb2(ix, iy)
          call encoder(irgb, minbits, icode)           ! color code to GIF LZW code
        end block
        ! write to fn
        block   
          integer :: iw, i  
          open(newunit = iw, file = fn, access = 'stream')
          write(iw) head      
          write(iw) global_color_table
          write(iw) img     
          write(iw) achar(minbits)                       ! LZW_minimum_code_size = 2..7   (2..7+1=3bit..8bit)
          do i = 255, size(icode), 255                 ! write bit sequence of 255 bytes 
            write(iw) achar(255)             
            write(iw) icode(i - 255 + 1:i)
          end do  
          write(iw) achar(size(icode(i - 255 + 1:)))   ! write remaining data (less than 255 bytes)
          write(iw) icode(i - 255 + 1:)
          write(iw) achar(00)                          ! block_terminator
          write(iw) achar(Z'3B')                       ! end of gif file
          close(iw) 
        end block
      end subroutine wr_gif  
    end module m_gif

    module m_anime_gif
      use, intrinsic :: iso_fortran_env
      use :: m_gif_types
      use :: m_gif_lzw
      implicit none
      private 
      public :: wr_gif_init, wr_gif_img, wr_gif_final
      integer, save :: iw
    contains
      subroutine wr_gif_init(fn, nx, ny, n_global_color, global_color_table, nloop)
        character(*), intent(in) :: fn
        integer, intent(in) :: nx, ny, n_global_color, nloop
        integer(int8), intent(in) :: global_color_table(:)
        type(t_gif_header), allocatable :: head
        type(t_application_extension) :: anime
        integer :: i  
        head  = t_gif_header(nx, ny, n_global_color)
        anime = t_application_extension(nloop)
        open(newunit = iw, file = fn, access = 'stream') ! iw module variable 
        write(iw) head      
        write(iw) global_color_table
        write(iw) anime
      end subroutine wr_gif_init

      subroutine wr_gif_img(irgb2, nbits, itime)
        integer, intent(in) :: irgb2(:, :), nbits, itime
        type(t_graphic_control_extension), allocatable :: ext
        type(t_image_block), allocatable :: img
        integer(int8), allocatable :: icode(:)
        integer :: i, ix, iy, nx, ny, nbyte  
        integer, allocatable :: irgb(:)
        nx = size(irgb2, 1)
        ny = size(irgb2, 2)
        ext = t_graphic_control_extension(itime)
        img = t_image_block(nx, ny)
        ! color code to lzw code 
        allocate(irgb(size(irgb2)))
        forall(ix = 1:nx, iy = 1:ny) irgb(ix + nx * (iy - 1)) = irgb2(ix, iy)
        call encoder(irgb, nbits, icode)             ! color code to GIF LZW code
        ! write bit strings to file
        write(iw) ext 
        write(iw) img     
        write(iw) achar(nbits)    ! nbits is global  ! LZW_minimum_code_size = 2..7   (2..7+1=3bit..8bit)
        do i = 1, size(icode), 255         
          nbyte = min(i + 255, size(icode)) - i
          write(iw) achar(nbyte)             
          write(iw) icode(i:i+nbyte-1)
        end do  
        write(iw) achar(00)                          ! block_terminator
      end subroutine wr_gif_img
      
      subroutine wr_gif_final()
        write(iw) achar(Z'3B')                       ! end of gif file
        close(iw) 
      end subroutine wr_gif_final
    end module m_anime_gif

    program test
      use, intrinsic :: iso_fortran_env
      use m_gif
      use m_anime_gif
      implicit none
      integer, allocatable :: irgb2(:, :)
      integer :: nx, ny, minbits
      nx = 320
      ny = 320
      allocate(irgb2(nx, ny))
      ! set global color table
      block
        integer :: n_global_color ! 2..7 ! 4..256 colors (2^(n_global_color + 1))
        integer(int8), allocatable :: global_color_table(:)
        n_global_color = 2
        allocate(global_color_table(3 * 2**(n_global_color + 1)))
        global_color_table = 0
        global_color_table = [[  0,  0,  0], [255,  0,  0], [0,255,  0], [  0,  0,255], &
                              [255,255,  0], [255,  0,255], [0,255,255], [255,255,255]]
        call wr_gif_init('animu.gif', nx, ny, n_global_color, global_color_table, 0)
        minbits = n_global_color + 1
      end block
!      
      block
        real, allocatable :: x(:, :)         ! random 
        allocate(x(nx, ny))
        call random_seed()
        call random_number(x)!
        irgb2 = int(8 * x, int8)
        call wr_gif_img(irgb2, minbits, 100)
        call wr_gif('test1.gif', irgb2)
      end block
!      
      block                                  ! tile
        integer :: ix, iy, i
        do i = 1, 24
          forall(ix = 1:nx, iy = 1:ny) irgb2(ix, iy) = mod(i + (ix - 1) / 40 + (iy - 1) / 40, 8) 
          call wr_gif_img(irgb2, minbits, 2 * i)   ! delay time 2 * i msec
        end do  
        call wr_gif('test2.gif', irgb2)
      end block
      call wr_gif_final()
    end program test

（H30.5.8　バグ修正)