Bitmap/Fortran

Bitmap/Fortran is part of Basic bitmap storage. You may find other members of Basic bitmap storage at Category:Basic bitmap storage.

Works with: Fortran version 90 and later

<lang fortran>module RCImageBasic

 implicit none

 type rgbimage
    integer, dimension(:,:), pointer :: red, green, blue
    integer :: width, height
 end type rgbimage

 type rgb
    integer :: red, green, blue
 end type rgb

 interface operator (==)
    module procedure rgbequal
 end interface

 interface operator (.dist.)
    module procedure colordistance
 end interface

contains

 subroutine init_img(img)
   type(rgbimage), intent(out) :: img
   nullify(img%red)
   nullify(img%green)
   nullify(img%blue)
   img%width = 0
   img%height = 0
 end subroutine init_img

 subroutine set_color(color, red, green, blue)
   type(rgb), intent(out) :: color
   integer, intent(in) :: red, green, blue
   if ( red > 255 ) then
      color%red = 255
   elseif ( red < 0 ) then
      color%red = 0
   else
      color%red = red
   end if
   if ( green > 255 ) then
      color%green = 255
   elseif ( green < 0 ) then
      color%green = 0
   else
      color%green = green
   end if
   if ( blue > 255 ) then
      color%blue = 255
   elseif ( blue < 0 ) then
      color%blue = 0
   else
      color%blue = blue
   end if
 end subroutine set_color

 function colordistance(c1, c2) result(res)
   real :: res
   type(rgb), intent(in) :: c1, c2
   res = sqrt( real(c1%red - c2%red)**2 + real(c1%green - c2%green)**2 + &
               real(c1%blue - c2%blue)**2 ) / ( 256.0*sqrt(3.0) )
 end function colordistance

 function rgbequal(c1, c2)
   logical :: rgbequal
   type(rgb), intent(in) :: c1, c2
   rgbequal = .true.
   if ( (c1%red == c2%red) .and. (c1%green == c2%green) .and. &
        (c1%blue == c2%blue) ) return
   rgbequal = .false.
 end function rgbequal

 function inside_image(img, x, y) result(r)
   logical :: r
   type(rgbimage), intent(in) :: img
   integer, intent(in) :: x, y

   r = .false.
   if ( (x < img%width) .and. ( y < img%height ) .and. &
        (x >= 0 ) .and. ( y >= 0 ) ) then
      r = .true.
   end if
 end function inside_image

 function valid_image(img) result(r)
   logical :: r
   type(rgbimage) :: img

   r = .false.
   if ( img%width == 0 ) return
   if ( img%height == 0 ) return
   if ( .not. associated(img%red) .and. .not. associated(img%green) .and. &
        .not. associated(img%blue) ) return
   r = .true.
 end function valid_image

 subroutine normalize_img(img)
   type(rgbimage), intent(inout) :: img

   where ( img%red > 255 )
      img%red = 255
   elsewhere ( img%red < 0 )
      img%red = 0
   end where
   where ( img%green > 255 )
      img%green = 255
   elsewhere ( img%green < 0 )
      img%green = 0
   end where
   where ( img%blue > 255 )
      img%blue = 255
   elsewhere ( img%blue < 0 )
      img%blue = 0
   end where
 end subroutine normalize_img

 subroutine alloc_img(img, w, h)
   type(rgbimage) :: img
   integer, intent(in) :: w, h

   allocate(img%red(w, h))
   allocate(img%green(w, h))
   allocate(img%blue(w, h))
   img%width = w
   img%height = h
 end subroutine alloc_img

 subroutine free_img(img)
   type(rgbimage) :: img

   if ( associated(img%red) ) deallocate(img%red)
   if ( associated(img%green) ) deallocate(img%green)
   if ( associated(img%blue) ) deallocate(img%blue)
 end subroutine free_img

 subroutine fill_img(img, color)
   type(rgbimage), intent(inout) :: img
   type(rgb), intent(in) :: color

   if ( valid_image(img)  ) then
      img%red = mod(abs(color%red), 256)
      img%green = mod(abs(color%green), 256)
      img%blue = mod(abs(color%blue), 256)
   end if
 end subroutine fill_img
 
 subroutine put_pixel(img, x, y, color)
   type(rgbimage), intent(inout) :: img
   integer, intent(in) :: x, y
   type(rgb), intent(in) :: color

   if ( inside_image(img, x, y) .and. valid_image(img)) then
      img%red(x+1,y+1) = mod(abs(color%red), 256)
      img%green(x+1, y+1) = mod(abs(color%green), 256)
      img%blue(x+1, y+1) = mod(abs(color%blue), 256)
   end if
 end subroutine put_pixel

 subroutine get_pixel(img, x, y, color)
   type(rgbimage), intent(in) :: img
   integer, intent(in) :: x, y
   type(rgb), intent(out) :: color

   if ( inside_image(img, x, y) .and. valid_image(img)) then
      color%red = img%red(x+1, y+1)
      color%green = img%green(x+1, y+1)
      color%blue = img%blue(x+1, y+1)
   else
      color%red = 0
      color%green = 0
      color%blue = 0
   end if
 end subroutine get_pixel

end module RCImageBasic</lang>