【メモ帳】gif 画像出力プログラム　中途

途中のゴミ

風邪らしきもので寝込んでしまったので（ボージョレ・ヌーボー風に言うと『ここ１０年で最高の苦しみ』）、整理途中のゴミをメモ帳として。

八色

f:id:fortran66:20180501201254g:plain

乱数

f:id:fortran66:20180501201349g:plain

ソース・プログラム

元のファイルフォーマットに合わせて sequence を使うと、順序が固定されるが、parameterized derived type の引数としての len, kind 属性を持つ要素は先頭に置かないと駄目なようで、悩みどころ。ユーザー定義型 I/O を使って OO 化すればいいのだが、他のものまで直すことを考えると煩わしい。

findloc 関数を使っているので f2008 。

未整理。後で整理したい。(少しした。）
　

    module m_gif
      use, intrinsic :: iso_fortran_env
      implicit none    
      integer, parameter :: nx = 512, ny = 512 
      type :: t_gif_header
        sequence  
        character(3)   :: signature = 'GIF'
        character(3)   :: version   = '89a' ! '87a'
        integer(int16) :: width  = nx
        integer(int16) :: height = ny
        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  = nx 
        integer(int16) :: image_height = ny
        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

      integer :: dict(0:2**12 - 1) ! 0:4095
      integer :: nbits, kbits, kd
      type :: t_enc
        integer :: kbits = 0, id = 0
      end type    
      integer, save :: m0
    contains
      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

      subroutine subenc(ienc, m1, m00)
        integer, intent(out) :: ienc
        integer, intent(in ) :: m1
        integer, intent(in ), optional :: m00
        integer :: k, id
        if (present(m00)) m0 = m00
        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 ! dictionary is 0-based
        end if    
      end subroutine subenc

      subroutine enc(irgb, code)
        integer, intent(in) :: irgb(:)
        type (t_enc), intent(out) :: code(:)
        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  
      end subroutine enc
      
      subroutine encoder(irgb, icode)
        integer, intent(in ) :: irgb(:)
        integer(int8), allocatable, intent(out) :: icode(:)
        type(t_enc), allocatable :: code(:)
        integer :: i, j, k, ib, ic, nb  
        allocate(code(size(irgb) + 100)) ! ?
        code(:)%id = 0
        call enc(irgb, code)        
        nb = ceiling(sum(code(:)%kbits) / 8.0)  
        allocate(icode(nb))
        icode = 0
        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 
      
      subroutine wr_gif(fn, irgb)
        character(*), intent(in) :: fn
        integer     , intent(in) :: irgb(:)
        type(t_gif_header ) :: head
        type(t_image_block) :: img    
        integer :: n_global_color 
        integer(int8), allocatable :: global_color_table(:, :)
        integer(int8), allocatable :: icode(:)
        integer :: iw
        !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])
        !  
        nbits = 3                        ! global variable
        call encoder(irgb, icode)        ! rgb color to GIF LZW code
        !
        open(newunit = iw, file = fn, access = 'stream')
        write(iw) head      
        write(iw) global_color_table
        write(iw) img     
        block
          integer :: i, nbyte
          write(iw) achar([nbits])       ! 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 block
        write(iw) achar([Z'3B'])       ! end of gif file
        close(iw) 
      end subroutine wr_gif  
    end module m_gif
    
    program test
      use m_gif
      implicit none
      integer :: irgb(nx * ny)
      !
      real :: x(nx * ny)         ! random 
      block
        call random_seed()
        call random_number(x)
        irgb = int(8 * x, int8)
      end block
!      
!      block                      ! stripes 
!        integer :: ix, iy
!        forall (ix = 1:nx, iy = 1:ny) irgb(ix + nx * (iy - 1)) = mod(ix / 40, 8) 
!      end block
      ! 
      call wr_gif('test.gif', irgb)
    end program test