以前 BMP 画像を ASCII ART に直すプログラムを作りましたが、それを改良します。
fortran66.hatenablog.com
- 改良点１
以前は横幅が４の倍数である必要がありましたが、任意幅に対応しました。
- 改良点２
白ベタ、黒ベタになる部分を輝度に比例した出力になるようにしました。
入力データ
BMP に直す必要があります。
出力例
例１
入力画像
出力画像
例２
入出力画像
プログラム
手抜きで直しましたｗ
白べたは M 黒ベタは空白になるので、それが出たマスを luminosity に応じて別の文字に置き換えます。つまり、輪郭部分はドットの形状に合わせた文字となり、内部のべた部分は luminosity に依存した明暗が付きます。
module m_bmp implicit none type :: t_bmp_file_header sequence character(2) :: bfType = 'BM' ! 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 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 integer :: i, j character :: dummy open(9, file = fn//'.bmp', access = 'stream', 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(:, i), (dummy, j = 1, mod(bmp_info_header%biWidth, 4)), i = 1, bmp_info_header%biHeight) close(9) end subroutine rd_bmp end module m_bmp module m_font use m_bmp implicit none integer, parameter :: mx = 4, my = 8 character(len = *), parameter :: font_name = 'font4x8' 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) end subroutine rd_font subroutine rd_and_chop(pic, fn) type(t_bmp_array), intent(out) :: pic character(len = *), intent(in) :: fn type(t_bmp) :: bmp integer :: ix, iy, kx, ky call bmp%rd(fn) associate(nx => size(bmp%rgb, 1) / mx, ny => size(bmp%rgb, 2) / my) allocate(pic%bmp(nx, ny)) do ix = 1, nx do iy = 1, ny kx = (ix - 1) * mx + 1 ky = (iy - 1) * my + 1 pic%bmp(ix, iy)%rgb = bmp%rgb(kx:kx + mx - 1, ky:ky + my - 1) end do end do end associate end subroutine rd_and_chop pure elemental character function to_aa(ft, font) type(t_bmp ), intent(in) :: ft type(t_bmp_array), intent(in) :: font to_aa = char_font( minloc( distance(ft, font%bmp) ) ) ! find min. from font-array contains pure elemental integer function distance(ft1, ft0) type(t_bmp), intent(in) :: ft1, ft0 real, parameter :: f = 1.5 ! f empirical parameter 0.5~2.0 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 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 end function char_font end function to_aa pure elemental character function adjust(ft, chars) type(t_bmp), intent(in) :: ft character (len = *), intent(in) :: chars integer :: k k = luminosity(ft) * len(chars) / 256 / size(ft%rgb) + 1 adjust = chars(k:k) contains pure elemental integer function luminosity(ft) type(t_bmp), intent(in) :: ft real, parameter :: fr = 0.3, fg = 0.6, fb = 0.1 ! luminosity factor luminosity = sum( fr * iachar(ft%rgb%r) + fg * iachar(ft%rgb%g) + fb * iachar(ft%rgb%b) ) end function luminosity end function adjust end module m_font program BMP_to_AA use m_font implicit none character, allocatable :: aa(:, :) ! make ASCII ART block type(t_bmp_array) :: font, pic call rd_font(font) call rd_and_chop(pic, 'tktt') aa = to_aa(pic%bmp, font) where (aa == 'M') aa = adjust(pic%bmp, '***===&$#M') ! white gradation where (aa == ' ') aa = adjust(pic%bmp, ' .,`''"-:;' ) ! black gradation end block ! output to console block integer :: iy do iy = size(aa, 2), 1, -1 print '(*(g0))', aa(:, iy) end do end block end program BMP_to_AA
おまけ
出力２の文字データ
MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM#####MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM$F~~. ..~W~~~"W$#MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMW~ . .~W#MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMMMMMMMMMMMMMMMM#~ .. .~$MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMMMMMMMMMMMMMMMF . .~$MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMMMMMMMMMMMMMW' ...~#MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMMMMMMMMMMMMW' ......,$MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMMMMMMMMMMMW ......,$MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMMMMMMMMMMW' .......,##MMMMMMMMMMMMMMMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMMMMMMMMM@' .........(####MMMMMMMMMMMMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMMMMMMMM#' ... . . . ..........,######MMMMMMMMMMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMMMMMMMMF ..... . . ..........&#######MMMMMMMMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMMMMMMM@ .... .......~########MMMMMMMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMMMMMMMF ..,.. ... ...,#########MMMMMMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMMMMMMW ... ......$#########MMMMMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMMMMM#] ,>F"'',z, , .. ...(#########MMMMMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMMMMM#' .`___]_ g"=ggg&&&g______ ......($#########MMMMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMMMM#W .q&&&&&&&&&g&&&$##$&W~~~~~"a, .. ...`$##########MMMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMMM##F ,&$$$$$$$$$$$$$####$&&mg_&,., ....,$##########MMMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMMM##' (&$$#######$$$$#M###$$&&&&&&r .....&###########MMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMM##$' (&$$$####$$&&$#############$= . ....(###########MMMMMMMMMMMMMMMM
MMMMMMMMMMMMMMM##@. ,&&$$$$$$&&$&$#M##$$#######$W . ...`$##########MMMMMMMMMMMMMMMM
MMMMMMMMMMMMMM###F. .=&&$$&&$&&~~&&$$$$$$#####$&' ..... ,$###########MMMMMMMMMMMMMMM
MMMMMMMMMMMMMM###L. .(&&&F&&$$$$$&&&&$#$&$$$$$&F .. .($############MMMMMMMM###MM
MMMMMMMMMMMMMM##$N' `&&&g,~~~WW$$#####$&&$$&&~ . .. .~$##################$E=&$##
MMMMMMMMMMMMM###$(. ,=&&&&g===$&&&g_~$g&&&&=' .... .,&$#################&&$g&$$
MMMMMMMMMMMM####$& .`=&&&&&&&&&&&&$$$$&&&~' . .... ,($$################$&##&@W
MMMMMMMMMMM#####$& .~&&$$$$$$$$$$#$$$&F' . .. ,`&$################&&$#$&&
MMMMMMMMMMM#####$& ~=&$$$#######$&F~ . .. ,`($$##############$$&$###$
MMMMMMMMM#######$$ .~~&$$$$$$&W~. . .`~&$$$############$$$$&$$#
MMMMMMMM########$@ . ....,~~~~~~,,,._.. .. ,`&$$$$###########$$$$$&&$
MMMMMMMM########$F ...,,,,,,````__&$$&,. . . .`&####MMMM#########$$$$$&
MMMMMMM#########$} ....,,`zzz.`_g$#####$gg_,.. . . .U&#M#MMMMMMM#########$$$$
MMMMMM##########$' .=&g=ggggggg$MMMMMMMM##$&F, . . .%W#M#MMMMMMMM###########$
MMMMM############L ,&&&&###MMM#MMMMMMMMMM#$WF. . ,($MMMMMMMMMMMM##########
MM###############. .`/&$$#MMMMM#MMMMMMMMMM#&\'. . .H$MMMMMMMMMMMMMM########
############M###$' ,q&$$####MMMMMMMMMMMM##W&&.,. .,@MMMMMMMMMMMMMMM#######
###########MM###F .,d&$$####MMMMMMMMMMMM##$$$.,, ,(MMMMMMMMMMMMMMMMM#####
###MM###MMMMMM#@ ,d&&#$###MMMMMMMMMMMMMM#$$&'o. ,~MMMMMMMMMMMMMMMMMM####
#MMMMM##MMMMM##F ($&$##MMMMMMMMMMMMMMM##$$&&',. ..!#MMMMMMMMMMMMMMMMMMM##
MMMMMM##MMMM###' .$$$$$#MMMMMMMMMMMMMMMM#$$$=.' j.,#MMMMMMMMMMMMMMMMMMMM#
MMMMMMM##MMM##F .j&$$###MMMMMMMMMMMMMMM##$$&&). .=.,#MMMMMMMMMMMMMMMMMMMMM
####MMM##MMM##' ,$&$###MMMMMMMMMMMMMM####$$$&,. ;&,_$MMMMMMMMMMMMMMMMMMMMM
####MMM##MMM#F ,,&$$#MMMMMMMMMMMMMMMMM#MM#$$&' d&&@$MMMMMMMMMMMMMMMMMMMMM
#####MM#MMM#$ ._U$##MM#MMMMMMMMMMMMMMMMM##$$$ .$$#$$MMMMMMMMMMMMMMMMMMMMM
#####MM#MMM#F _&D$MMMMMMMMMMMMMMMMMMMMMM###&' ,##M#$MMMMMMMMMMMMMMMMMMMMM
######MMMM#@ ,&&$#MMMMMMMMMMMMMMMMMMMMMMM#$&' d#MM##MMMMMM##MMMMMMMMMMMMM
######MMM##F .,$$#MMMMMMMMMMMMMMMMMMMMMMMM#$r .$MMMMMMMMMMMM#MMMMMMMMMMMMM
######M#M#@ .=&#MMMMMMMMMMMMMMMMMMMMMMMMM#$' jMMMMMMMMMMMM#$MMMMMMMMMMMMM
##########L ,&$#MMMMMMMMMMMMMMMMMMMMMMMMM#@ _#MMMMMMMMMMMM#$MMMMMMMMMMMMM
#########$|. :&&#MMMMMMMMMMMMMMMMMMMMMMMMM#P' ,$MMMMMMMMMMMMM#&#MMMMMMMMMMMM
#######$#$Lg . `$##MMMMMMMMMMMMMMMMMMMMMMMM#$r. ..&MMMMMMMMMMMMMMMk&#MMMMMMMMMMM
########$$$@m_g. g#MMMMMMMMMMMMMMMMMMMMMMMMMM#@,. jq#MMMMMMMMMMMMMMMM&=&#MMMMMMMMMM
########$$##$$$@&ggg#MMMMMMMMMMMMMMMMMMMMMMMMMMM#@$.... ._g#MMMMMMMMMMMMMMMMMM&&&&$#MMMMMMMM
########$$$#######MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM#&_q&{.__,gg#MMMMMMMMMMMMMMMMMMMM#&&&&&$$#MMM#M
########$$$$###MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM#$##g$$$#MMMMMMMMMMMMMMMMMMMMMMMM$$$$$&&$$#MMM
########$$$&$###MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM$$$$$$$$$$$#M
#########$$$&$###MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM#$$$$$$$$$$$$$
#########$$$&&####MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM$$$$$$$$####$
#########$$$&&&#####MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM#############
##########$$$&=&#####MMMMMMMMMMMMMMMMMMMMMMM#MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM#############
##########$$$&&=&$##M#MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM#############
##########$$$&&&&&##M###MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM#############
###########$$$&&&N######MM##MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM#############
###########$$&&&&&#######MMMM#MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM##########MMMM
###########$$$&&&&$#######MMM#MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM########MMMMM
##############$gggg#####MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
続行するには何かキーを押してください . . .
