直線にアンチエイリアス

#直線にアンチエイリアスをかける

先日 BMP ファイル上に点や直線を描くルーチンを作りましたが、直線がギザギザしているので、アンチエイリアスをかけてみることにしました。

https://qiita.com/cure_honey/items/842fe514127179bf44d9

##アンチエイリアス

『フルスクラッチによるグラフィックスプログラミング入門』という本の 4.6.7 節を参考に、直線の小数部分の比で隣あう二点で色を背景色と平均化することで実現する事にしました。前回から簡単な修正ですみます。

（本では不透明度を使っていますが、よく分からないので取りあえず背景色と線形平均してみました。）

![zu1.jpg](https://qiita-image-store.s3.amazonaws.com/0/44522/4defc292-9633-321c-23ff-62746e1b1c2f.jpeg)
図は２１７頁から引用。

https://www.amazon.co.jp/dp/479800958X

##実行結果
・部分拡大図
赤はアンチエイリアスをかけた直線。青はアンチエイリアスをかけない直線。赤と青は縦方向に平行移動させているだけで、それ以外は同じ直線になっています。
![aa.png](https://qiita-image-store.s3.amazonaws.com/0/44522/c43c2a4d-7969-dee6-f6eb-1fcea5168d9a.png)

・太陽も心なしか滑らかに微笑んでいるようです。
![sun2.png](https://qiita-image-store.s3.amazonaws.com/0/44522/a646f89e-3ddd-fc41-8e0a-181e30a5d682.png)

##プログラム
今日は暑いので、さらに適当。画像領域からのはみ出し処理を点を打つサブルーチンに入れて。はみ出すパラメータを入れても大丈夫にしてみました。

```fortran
      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
```