直線にアンチエイリアスをかける
先日 BMP ファイル上に点や直線を描くルーチンを作りましたが、直線がギザギザしているので、アンチエイリアスをかけてみることにしました。
アンチエイリアス
『フルスクラッチによるグラフィックスプログラミング入門』という本の 4.6.7 節を参考に、直線の小数部分の比で隣あう二点で色を背景色と平均化することで実現する事にしました。前回から簡単な修正ですみます。
（本では不透明度を使っていますが、よく分からないので取りあえず背景色と線形平均してみました。）
図は２１７頁から引用。
実行結果
・部分拡大図
赤はアンチエイリアスをかけた直線。青はアンチエイリアスをかけない直線。赤と青は縦方向に平行移動させているだけで、それ以外は同じ直線になっています。
・太陽も心なしか滑らかに微笑んでいるようです。
プログラム
今日は暑いので、さらに適当。画像領域からのはみ出し処理を点を打つサブルーチンに入れて。はみ出すパラメータを入れても大丈夫にしてみました。
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 :: b, g, r
end type t_rgb
type :: t_bmp
integer :: nx, ny
type (t_rgb), allocatable :: rgb(:, :)
contains
procedure :: wr => wr_bmp
procedure :: rd => rd_bmp
end type t_bmp
interface t_bmp
module procedure :: init_bmp
end interface t_bmp
contains
type (t_bmp) function init_bmp(nx, ny) result(bmp)
integer, intent(in) :: nx, ny
allocate(bmp%rgb(nx, ny))
end function init_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
integer :: i
associate(nx => size(bmp%rgb, 1), ny => size(bmp%rgb, 2))
bmp_file_header%bfSize = 14 + 40 + 0 + (3 * nx + mod(nx, 4)) * ny
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 = (3 * nx + mod(nx, 4)) * ny
open(9, file = fn//'.bmp', access = 'stream', status = 'unknown')
write(9) bmp_file_header
write(9) bmp_info_header
write(9) (bmp%rgb(:, i), repeat(achar(0), mod(nx, 4)), i = 1, ny)
close(9)
end associate
end subroutine wr_bmp
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
character :: dummy(4)
associate(nx => bmp_info_header%biWidth, ny => bmp_info_header%biHeight)
open(10, file = fn//'.bmp', access = 'stream', status = 'old')
read(10) bmp_file_header
read(10) bmp_info_header
allocate(bmp%rgb(nx, ny))
read(10) (bmp%rgb(:, i), dummy(:mod(nx, 4)), i = 1, ny)
close(10)
end associate
end subroutine rd_bmp
end module m_bmp
module m_pic
use m_bmp
implicit none
type, extends(t_bmp) :: t_pic
contains
procedure :: point, point_sc, line, lineaa
end type t_pic
interface t_pic
module procedure :: init_pic
end interface t_pic
contains
type (t_pic) function init_pic(nx, ny) result(bmp)
integer, intent(in) :: nx, ny
allocate(bmp%rgb(nx, ny), source = t_rgb(achar(0), achar(0), achar(0)))
end function init_pic
subroutine point(pic, ix, iy, rgb)
class (t_pic), intent(in out) :: pic
integer , intent(in) :: ix, iy
type (t_rgb) , intent(in) :: rgb
if (ix > 0 .and. iy > 0 .and. ix <= size(pic%rgb, 1) .and. iy <= size(pic%rgb, 2)) &
pic%rgb(ix, iy) = rgb
end subroutine point
subroutine point_sc(pic, ix, iy, rgb_fg, a)
class (t_pic), intent(in out) :: pic
integer , intent(in) :: ix, iy
type (t_rgb) , intent(in) :: rgb_fg
real , intent(in) :: a
type (t_rgb) :: rgb_bg
if (ix > 0 .and. iy > 0 .and. ix <= size(pic%rgb, 1) .and. iy <= size(pic%rgb, 2)) then
rgb_bg = pic%rgb(ix, iy) ! background color
pic%rgb(ix, iy) = scale_rgb(rgb_fg, rgb_bg, a) ! linear average
end if
end subroutine point_sc
type (t_rgb) function scale_rgb(rgb_fg, rgb_bg, a)
type (t_rgb), intent(in) :: rgb_fg, rgb_bg
real, intent(in) :: a
integer :: ib, ig, ir
ib = a * iachar(rgb_fg%b) + (1.0 - a) * iachar(rgb_bg%b)
ig = a * iachar(rgb_fg%g) + (1.0 - a) * iachar(rgb_bg%g)
ir = a * iachar(rgb_fg%r) + (1.0 - a) * iachar(rgb_bg%r)
scale_rgb = t_rgb(achar(ib), achar(ig), achar(ir))
end function scale_rgb
subroutine line(pic, ix0, iy0, ix1, iy1, rgb)
class (t_pic), intent(in out) :: pic
integer , intent(in) :: ix0, iy0, ix1, iy1
type (t_rgb) , intent(in) :: rgb
integer :: ix, iy, mx, my
real :: dx, dy, x, y
mx = ix1 - ix0
my = iy1 - iy0
if (mx == 0 .and. my == 0) then
call pic%point(ix0, iy0, rgb)
else if (abs(mx) > abs(my)) then
dy = my / real(mx)
y = iy0
do ix = 0, mx, sign(1, mx)
y = dy * ix
iy = nint(y)
call pic%point(ix0 + ix, iy0 + iy, rgb)
end do
else
dx = mx / real(my)
x = ix0
do iy = 0, my, sign(1, my)
x = dx * iy
ix = nint(x)
call pic%point(ix0 + ix, iy0 + iy, rgb)
end do
end if
end subroutine line
subroutine lineaa(pic, ix0, iy0, ix1, iy1, rgb)
class (t_pic), intent(in out) :: pic
integer , intent(in) :: ix0, iy0, ix1, iy1
type (t_rgb) , intent(in) :: rgb
integer :: ix, iy, mx, my
real :: dx, dy, x, y, a
mx = ix1 - ix0
my = iy1 - iy0
if (mx == 0 .and. my == 0) then
call pic%point(ix0, iy0, rgb)
else if (abs(mx) > abs(my)) then
dy = my / real(mx)
y = iy0
do ix = 0, mx, sign(1, mx)
y = dy * ix
iy = int(y)
a = abs(y) - floor(abs(y)) ! weight
call pic%point_sc(ix0 + ix, iy0 + iy, rgb, 1.0 - a) ! dot1
iy = iy + int(sign(1.0, dy * mx)) ! adjoint dot
call pic%point_sc(ix0 + ix, iy0 + iy, rgb, a) ! dot2
end do
else
dx = mx / real(my)
x = ix0
do iy = 0, my, sign(1, my)
x = dx * iy
ix = int(x)
a = abs(x) - floor(abs(x)) ! weight
call pic%point_sc(ix0 + ix, iy0 + iy, rgb, 1.0 - a) ! dot1
ix = ix + int(sign(1.0, dx * my)) ! adjoint dot
call pic%point_sc(ix0 + ix, iy0 + iy, rgb, a) ! dot2
end do
end if
end subroutine lineaa
end module m_pic
program bmp_RW
use m_pic
type (t_rgb), parameter :: White = t_rgb(achar(255), achar(255), achar(255)), &
& Red = t_rgb(achar( 0), achar( 0), achar(255))
integer, parameter :: nx = 640, ny = 480
integer :: i, ix, iy, ix0, ix1, iy0, iy1, nr
real :: x, y
type (t_pic) :: pic2, pic3
pic3 = t_pic(nx, ny)
pic3%rgb = White
do ix = 1, 50, 3
call pic3%lineaa(1, 1, 640, 40 * ix, Red)
call pic3%line(1, 51, 640, 40 * ix + 50, t_rgb(achar(255),achar(0),achar(0)))
end do
call pic3%wr('aa')
!
pic2 = t_pic(nx, ny)
pic2%rgb = White
nr = 110
do iy = 0, nr ! Hinomaru
ix = sqrt(real(nr**2 - iy**2))
ix0 = nx / 2 - ix
ix1 = nx / 2 + ix
iy0 = ny / 2 - iy
iy1 = ny / 2 + iy
call pic2%line(ix0, iy0, ix1, iy0, Red)
call pic2%line(ix0, iy1, ix1, iy1, Red)
end do
call ray_x(1, 3 * nx / 18) ! kou-jyou
call ray_x(nx / 4, 6 * nx / 17)
call ray_x(7 * nx / 16, nx / 2)
call ray_y(ny / 7, 5 * ny / 17)
call ray_y(8 * ny / 19, ny / 2)
call pic2%wr('sun')
contains
subroutine ray_x(ixa, ixb)
integer, intent(in) :: ixa, ixb
integer :: ix
do ix = ixa, ixb
ix0 = 1 + ix
ix1 = nx - ix
iy0 = ny
iy1 = 1
call pic2%line(ix0, iy0, ix1, iy1, Red)
call pic2%line(ix1, iy0, ix0, iy1, Red)
end do
ix0 = 1 + ix
ix1 = nx - ix
iy0 = ny
iy1 = 1
call pic2%lineaa(ix0, iy0, ix1, iy1, Red)
call pic2%lineaa(ix1, iy0, ix0, iy1, Red)
ix = ixa
ix0 = 1 + ix
ix1 = nx - ix
iy0 = ny
iy1 = 1
call pic2%lineaa(ix0, iy0, ix1, iy1, Red)
call pic2%lineaa(ix1, iy0, ix0, iy1, Red)
end subroutine ray_x
subroutine ray_y(iya, iyb)
integer, intent(in) :: iya, iyb
integer :: iy
do iy = iya, iyb
ix0 = 1
ix1 = nx
iy0 = 1 + iy
iy1 = ny - iy
call pic2%line(ix0, iy0, ix1, iy1, Red)
call pic2%line(ix1, iy0, ix0, iy1, Red)
end do
ix0 = 1
ix1 = nx
iy0 = 1 + iya
iy1 = ny - iya
call pic2%lineaa(ix0, iy0, ix1, iy1, Red)
call pic2%lineaa(ix1, iy0, ix0, iy1, Red)
ix0 = 1
ix1 = nx
iy0 = 1 + iya
iy1 = ny - iya
call pic2%lineaa(ix0, iy0, ix1, iy1, Red)
call pic2%lineaa(ix1, iy0, ix0, iy1, Red)
end subroutine ray_y
end program bmp_RW