Bitmap/Fortran

From Rosetta Code
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
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