Fortran で ASCII ART カラー版

少し Fortran2003/08 の機能を試してみることにして、やっつけ仕事でカラーの BMP も出力するようにしてみました。

１バイト整数問題は、変数をキャラクターにして、iachar で４バイト整数に直すようにしてみました。これで unsigned int(1) として扱えます。transfer 命令は、遅いし使いづらいのでこちらの方が楽です。

まぁフォントデータは、BMPファイルを入力とすることにしました。１文字あたりのドット数はソースに与える必要がありますが、フォント画像での行数などは、ある程度適宜処理します。US DOS窓8x8 のフォントでの出力例を示します。

なお入力の BMP ファイルのドット幅は４の倍数である必要があるようです。

コンパイルは intel fortran 2015 beta で行いました。この beta 版でしか対応していない f2008 機能を使っているので、正式のリリース版ではコンパイルできません。　

兎角さん

白黒　コンソール出力

ソース　

    module m_bmp
      implicit none
      type :: t_bmp_file_header
        sequence  
        integer(2) :: bfType = transfer('BM', 0_2, 1) ! BitMap
        integer(4) :: bfSize          ! file size in bytes
        integer(2) :: bfReserved1 = 0 ! always 0
        integer(2) :: bfReserved2 = 0 ! always 0
        integer(4) :: bfOffBits
      end type t_bmp_file_header
      !
      type :: t_bmp_info_header
        sequence
        integer(4) :: biSize     = Z'28' ! size of bmp_info_header ; 40bytes 
        integer(4) :: biWidth
        integer(4) :: biHeight
        integer(2) :: biPlanes   = 1 ! always 1
        integer(2) :: biBitCount
        integer(4) :: biCompression = 0 ! 0:nocompression, 1:8bitRLE, 2:4bitRLE, 3:bitfield
        integer(4) :: biSizeImage
        integer(4) :: biXPelsPerMeter = 3780 ! 96dpi
        integer(4) :: biYPelsPerMeter = 3780 ! 96dpi 
        integer(4) :: biClrUsed      = 0
        integer(4) :: biClrImportant = 0 
      end type t_bmp_info_header
      !
      type :: t_rgb
        sequence
        character :: r, g, b
      end type t_rgb 
      type :: t_bmp
        type(t_rgb), allocatable :: rgb(:, :)
      contains 
        procedure :: rd => rd_bmp
        procedure :: wr => wr_bmp
      end type  
    contains   
      subroutine rd_bmp(bmp, fn)
        class(t_bmp), intent(out) :: bmp
        character(len = *), intent(in) :: fn
        type(t_bmp_file_header) :: bmp_file_header
        type(t_bmp_info_header) :: bmp_info_header
        open(9, file = fn//'.bmp', form = 'binary', status = 'unknown')
        read(9) bmp_file_header, bmp_info_header
        allocate( bmp%rgb(bmp_info_header%biWidth, bmp_info_header%biHeight) )
        read(9) bmp%rgb
        close(9)
        return
      end subroutine rd_bmp
      
      subroutine wr_bmp(bmp, fn)
        class(t_bmp), intent(in) :: bmp
        character(len = *), intent(in) :: fn
        type(t_bmp_file_header) :: bmp_file_header
        type(t_bmp_info_header) :: bmp_info_header
        associate(nx => size(bmp%rgb, 1), ny => size(bmp%rgb, 2))
          bmp_file_header%bfSize      = 14 + 40 + 0 + nx * ny * 3
          bmp_file_header%bfOffBits   = 14 + 40
          bmp_info_header%biWidth     = nx
          bmp_info_header%biHeight    = ny
          bmp_info_header%biBitCount  = 24 
          bmp_info_header%biSizeImage = nx * ny * 3
        end associate
        open(9, file = fn//'.bmp', form = 'binary', status = 'unknown')
        write(9) bmp_file_header
        write(9) bmp_info_header
        write(9) bmp%rgb
        close(9)
        return
      end subroutine wr_bmp  
    end module m_bmp

    module m_font
      use m_bmp 
      implicit none
      integer, parameter :: mx = 8, my = 8
      character(len = *), parameter :: font_name = 'font8x8' 
      type :: t_bmp_array
        type(t_bmp), allocatable :: bmp(:, :)  
      end type t_bmp_array 
    contains
      subroutine rd_font(font)
        type(t_bmp_array), intent(out) :: font
        call rd_and_chop(font, font_name)
        return
      end subroutine rd_font
    
      subroutine rd_and_chop(font, fn)
        type(t_bmp_array), intent(out) :: font
        character(len = *), intent(in) :: fn
        type(t_bmp) :: bmp 
        integer :: ix, iy
        call bmp%rd(fn)
        associate(nx => size(bmp%rgb, 1) / mx, ny => size(bmp%rgb, 2) / my)
          allocate(font%bmp(nx, ny))
          do concurrent (ix = 1:nx, iy = 1:ny)
            block
              integer :: kx, ky  
              kx = (ix - 1) * mx + 1 
              ky = (iy - 1) * my + 1    
              font%bmp(ix, iy)%rgb = bmp%rgb(kx:kx + mx - 1, ky:ky + my - 1)
            end block
          end do
        end associate  
        return 
      end subroutine rd_and_chop

      pure elemental character function to_aa(ft, font, flag)
        type(t_bmp      ), intent(in) :: ft                
        type(t_bmp_array), intent(in) :: font
        character, intent(in) :: flag
        to_aa = char_font( minloc( distance(ft, font%bmp, flag) ) ) ! find min. from font-array
        return
      contains
        pure elemental integer function distance(ft1, ft0, flag) 
          type(t_bmp), intent(in) :: ft1, ft0
          character, intent(in) :: flag
          real, parameter :: f = 1.46      ! f empirical parameter  1.0~2.5
          select case(flag)
            case('r')  
              distance = sum( ( iachar(ft1%rgb%r) - f * iachar(ft0%rgb%r) )**2 )
            case('g')  
              distance = sum( ( iachar(ft1%rgb%g) - f * iachar(ft0%rgb%g) )**2 )
            case('b')  
              distance = sum( ( iachar(ft1%rgb%b) - f * iachar(ft0%rgb%b) )**2 )
            case default  
              distance = sum( ( (iachar(ft1%rgb%r) + iachar(ft1%rgb%g) + iachar(ft1%rgb%b) ) &
                          - f * (iachar(ft0%rgb%r) + iachar(ft0%rgb%g) + iachar(ft0%rgb%b) ) )**2 )
          end select
          return
        end function distance   
        
        pure character function char_font(ipos)
          integer, intent(in) :: ipos(2)
          associate(nx => size(font%bmp, 1), ny => size(font%bmp, 2))
            char_font = achar( ipos(1) + (ny - ipos(2)) * nx - 1 + x'20' )  
          end associate  
          return
        end function char_font
      end function to_aa
      
      subroutine aa_to_bmpfile(r, g, b, font, fn)
        character, intent(in) :: r(:, :), g(:, :), b(:, :)
        type(t_bmp_array), intent(in) :: font
        character(len = *), intent(in) :: fn
        type(t_bmp) :: bmp
        integer :: nx, ny
        nx = size(font%bmp, 1)
        ny = size(font%bmp, 2)
        call to_rgb(r, g, b, bmp)
        call bmp%wr(fn)
        return
      contains
        subroutine to_rgb(r, g, b, bmp)
          character, intent(in) :: r(:, :), g(:, :), b(:, :)
          type(t_bmp), intent(out) :: bmp
          integer :: ix, iy
          allocate(bmp%rgb(size(r, 1) * mx, size(r, 2) * my))
          do ix = 1, size(r, 1)
            do iy = size(r, 2), 1, -1
              associate(kx => (ix - 1) * mx + 1, ky => (iy - 1) * my + 1, &
                        bp => bmp%rgb(kx:kx + mx - 1, ky:ky + my - 1))
                bp%r = font%bmp(cha_to_ix(r(ix, iy)), cha_to_iy(r(ix, iy)))%rgb%r 
                bp%g = font%bmp(cha_to_ix(g(ix, iy)), cha_to_iy(g(ix, iy)))%rgb%g 
                bp%b = font%bmp(cha_to_ix(b(ix, iy)), cha_to_iy(b(ix, iy)))%rgb%b 
              end associate  
            end do
          end do  
          return
        end subroutine to_rgb
        
        pure elemental integer function cha_to_ix(c)
          character, intent(in) :: c
          cha_to_ix = mod(iachar(c) - z'20', nx) + 1 
          return
        end function cha_to_ix  

        pure elemental integer function cha_to_iy(c)
          character, intent(in) :: c
          cha_to_iy = ny - (iachar(c) - z'20') / nx  
          return
        end function cha_to_iy  
      end subroutine aa_to_bmpfile
    end module m_font

書き出し関連はまだ雑なままです。

    program BMP_to_AA
      use m_font
      implicit none
      character, allocatable :: mono(:, :)
! make ASCII ART      
      block 
        type(t_bmp_array) :: font, pic 
        character, allocatable :: r(:, :), g(:, :), b(:, :)
        call rd_font(font) 
        call rd_and_chop(pic, 'tokaku4')
        mono = to_aa(pic%bmp, font, ' ')
        r    = to_aa(pic%bmp, font, 'r')
        g    = to_aa(pic%bmp, font, 'g')
        b    = to_aa(pic%bmp, font, 'b')
        call aa_to_bmpfile(r, g, b, font, 'out')
      end block  
! output to console
      block 
        integer :: iy  
        do iy = size(mono, 2), 1, -1       
          print '(*(g0))', mono(:, iy)
        end do
      end block  
      stop
    end program BMP_to_AA