⚠️ Warning: This is a draft ⚠️
This means it might contain formatting issues, incorrect code, conceptual problems, or other severe issues.
If you want to help to improve and eventually enable this page, please fork RosettaGit's repository and open a merge request on GitHub.
{{collection|Basic bitmap storage}}
{{works with|Fortran|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