Bitmap/Fortran: Difference between revisions
< Bitmap
Content added Content deleted
(fixed improper use of the "where" statement) |
m (Fixed syntax highlighting.) |
||
(2 intermediate revisions by one other user not shown) | |||
Line 2: | Line 2: | ||
{{works with|Fortran|90 and later}} |
{{works with|Fortran|90 and later}} |
||
< |
<syntaxhighlight lang="fortran">module rgbimage_m |
||
implicit none |
implicit none |
||
private |
|||
public :: rgbimage |
|||
type rgbimage |
type rgbimage |
||
!! usage |
|||
integer, dimension(:,:), pointer :: red, green, blue |
|||
!! 1) init |
|||
!! 2a) fill_image |
|||
end type rgbimage |
|||
!! or |
|||
!! 2b) set_pixel |
|||
!! 3) normalize |
|||
!! 4) write |
|||
private |
|||
type rgb |
|||
integer :: red, green, blue |
|||
end type rgb |
|||
integer, dimension(:,:,:), allocatable :: rgb |
|||
interface operator (==) |
|||
!! pixel arrays of rgb values |
|||
module procedure rgbequal |
|||
!! indices (i,j,k) |
|||
end interface |
|||
!! i: position x_i |
|||
!! j: position y_j |
|||
!! k=1: red, k=2: green, k=3: blue |
|||
integer :: n(2) = 0 |
|||
interface operator (.dist.) |
|||
!! image dimensions: [height, width] |
|||
module procedure colordistance |
|||
end interface |
|||
contains |
|||
procedure :: init => rgbimage_init ! inits image |
|||
procedure :: fill_image => rgbimage_fill_image ! fill image with constant rgb value |
|||
procedure :: get_pixel => rgbimage_get_pixel ! gets one pixel |
|||
procedure :: normalize => rgbimage_normalize ! normalizes all pixels onto range [0, 255] |
|||
procedure :: set_pixel => rgbimage_set_pixel ! sets one pixel |
|||
procedure :: write => rgbimage_write ! outputs image to file |
|||
procedure, private :: inside => rgbimage_inside |
|||
procedure, private :: valid => rgbimage_valid |
|||
end type |
|||
contains |
contains |
||
subroutine |
subroutine rgbimage_init(this, height, width) |
||
!! initialize image. |
|||
type(rgbimage), intent(out) :: img |
|||
!! sets dimensions, allocates pixels and sets colors to 0. |
|||
nullify(img%red) |
|||
nullify(img%green) |
|||
nullify(img%blue) |
|||
img%width = 0 |
|||
img%height = 0 |
|||
end subroutine init_img |
|||
class(rgbimage), intent(out) :: this |
|||
subroutine set_color(color, red, green, blue) |
|||
integer, intent(in) :: height, width |
|||
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 |
|||
this%n = [height, width] |
|||
function colordistance(c1, c2) result(res) |
|||
allocate (this%rgb(height,width,3), source=0) |
|||
real :: res |
|||
end subroutine |
|||
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 |
logical function rgbimage_valid(this, check_rgb_vals) |
||
!! checks if the image has valid dimensions and optionally valid rgb values. |
|||
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 |
|||
class(rgbimage), intent(in) :: this |
|||
function inside_image(img, x, y) result(r) |
|||
logical :: |
logical, intent(in), optional :: check_rgb_vals |
||
!! check if rgb values are in allowed range [0, 255]? |
|||
type(rgbimage), intent(in) :: img |
|||
!! default: dont check |
|||
integer, intent(in) :: x, y |
|||
! always check that dimensions match |
|||
r = .false. |
|||
rgbimage_valid = ( all(this%n > 0) .and. & |
|||
& (size(this%rgb, dim=1) == this%n(1)) .and. & |
|||
& (size(this%rgb, dim=2) == this%n(2)) .and. & |
|||
r = .true. |
|||
& (size(this%rgb, dim=3) == 3) ) |
|||
! optionally: check if rgb values are in allowed range |
|||
if (present(check_rgb_vals)) then |
|||
if (check_rgb_vals) rgbimage_valid = ( rgbimage_valid .and. & |
|||
& (all(this%rgb >= 0)) .and. & |
|||
& (all(this%rgb <= 255)) ) |
|||
end if |
end if |
||
end function inside_image |
|||
function valid_image(img) result(r) |
|||
logical :: r |
|||
type(rgbimage) :: img |
|||
end function |
|||
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 |
|||
logical function rgbimage_inside(this, x, y) |
|||
subroutine normalize_img(img) |
|||
!! checks if given coordinates are inside the image |
|||
type(rgbimage), intent(inout) :: img |
|||
class(rgbimage), intent(in) :: this |
|||
where ( img%red > 255 ) |
|||
integer, intent(in) :: x, y |
|||
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 |
|||
rgbimage_inside = ((x > 0) .and. (x <= this%n(1)) .and. (y > 0) .and. (y <= this%n(2))) |
|||
subroutine alloc_img(img, w, h) |
|||
end function |
|||
type(rgbimage) :: img |
|||
integer, intent(in) :: w, h |
|||
subroutine rgbimage_set_pixel(this, x, y, rgb) |
|||
allocate(img%red(w, h)) |
|||
class(rgbimage), intent(inout) :: this |
|||
allocate(img%green(w, h)) |
|||
integer, intent(in) :: x, y |
|||
allocate(img%blue(w, h)) |
|||
!! coordinates |
|||
img%width = w |
|||
integer, intent(in) :: rgb(3) |
|||
img%height = h |
|||
!! red, green, blue values |
|||
end subroutine alloc_img |
|||
if (this%inside(x, y)) then |
|||
subroutine free_img(img) |
|||
! use given data at first |
|||
type(rgbimage) :: img |
|||
this%rgb(x,y,:) = rgb |
|||
! check if given data was out of bounds |
|||
if ( associated(img%red) ) deallocate(img%red) |
|||
where (this%rgb(x,y,:) > 255) |
|||
this%rgb(x,y,:) = 255 |
|||
if ( associated(img%blue) ) deallocate(img%blue) |
|||
elsewhere (this%rgb(x,y,:) < 0) |
|||
end subroutine free_img |
|||
this%rgb(x,y,:) = 0 |
|||
end where |
|||
end if |
|||
end subroutine |
|||
function rgbimage_get_pixel(this, x, y) result(rgb) |
|||
subroutine fill_img(img, color) |
|||
class(rgbimage), intent(in) :: this |
|||
integer, intent(in) :: x, y |
|||
!! coordinates |
|||
integer :: rgb(3) |
|||
!! red, green, blue values |
|||
if ( |
if (this%inside(x, y)) then |
||
rgb = this%rgb(x,y,:) |
|||
else |
|||
img%green = mod(abs(color%green), 256) |
|||
rgb = 0 |
|||
end if |
end if |
||
end |
end function |
||
subroutine put_pixel(img, x, y, color) |
|||
type(rgbimage), intent(inout) :: img |
|||
integer, intent(in) :: x, y |
|||
type(rgb), intent(in) :: color |
|||
subroutine rgbimage_normalize(this) |
|||
if ( inside_image(img, x, y) .and. valid_image(img)) then |
|||
!! normalize colors to be in range [0, 255] |
|||
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 |
|||
class(rgbimage), intent(inout) :: this |
|||
subroutine get_pixel(img, x, y, color) |
|||
type(rgbimage), intent(in) :: img |
|||
integer, intent(in) :: x, y |
|||
type(rgb), intent(out) :: color |
|||
where (this%rgb(:,:,:) > 255) |
|||
if ( inside_image(img, x, y) .and. valid_image(img)) then |
|||
this%rgb(:,:,:) = 255 |
|||
elsewhere (this%rgb(:,:,:) < 0) |
|||
color%green = img%green(x+1, y+1) |
|||
this%rgb(:,:,:) = 0 |
|||
end where |
|||
end subroutine |
|||
color%red = 0 |
|||
color%green = 0 |
|||
subroutine rgbimage_fill_image(this, rgb) |
|||
color%blue = 0 |
|||
!! fill whole image with given rgb values. |
|||
class(rgbimage), intent(inout) :: this |
|||
integer, intent(in) :: rgb(3) |
|||
!! red, green, blue values |
|||
integer :: i |
|||
if (this%valid()) then |
|||
do i = 1, 3 |
|||
this%rgb(:,:,i) = rgb(i) |
|||
end do |
|||
end if |
end if |
||
end subroutine |
end subroutine |
||
subroutine rgbimage_write(this, fname) |
|||
class(rgbimage), intent(in) :: this |
|||
character(*), intent(in) :: fname |
|||
!! file path, e.g. "tmp/out.ppm" |
|||
integer :: iounit, ios, i,j,k |
|||
open (newunit=iounit, file=fname, iostat=ios, action='WRITE') |
|||
if (ios /= 0) error stop "Error opening file: " // fname |
|||
! write header |
|||
write (iounit, '(A)') 'P6' |
|||
write (iounit, '(I0, A, I0)') this%n(1), " ", this%n(2) |
|||
write (iounit, '(A)') '255' |
|||
do i = 1, this%n(1) |
|||
do j = 1, this%n(2) |
|||
write (iounit, '(3A1)', advance='no') [(achar(this%rgb(i,j,k)), k=1,3)] |
|||
end do |
|||
end do |
|||
close (unit=iounit, iostat=ios) |
|||
if (ios /= 0) error stop "Error closing file" |
|||
end subroutine |
|||
end module |
end module</syntaxhighlight> |
Latest revision as of 15:54, 1 September 2022
Bitmap/Fortran is part of Basic bitmap storage. You may find other members of Basic bitmap storage at Category:Basic bitmap storage.
module rgbimage_m
implicit none
private
public :: rgbimage
type rgbimage
!! usage
!! 1) init
!! 2a) fill_image
!! or
!! 2b) set_pixel
!! 3) normalize
!! 4) write
private
integer, dimension(:,:,:), allocatable :: rgb
!! pixel arrays of rgb values
!! indices (i,j,k)
!! i: position x_i
!! j: position y_j
!! k=1: red, k=2: green, k=3: blue
integer :: n(2) = 0
!! image dimensions: [height, width]
contains
procedure :: init => rgbimage_init ! inits image
procedure :: fill_image => rgbimage_fill_image ! fill image with constant rgb value
procedure :: get_pixel => rgbimage_get_pixel ! gets one pixel
procedure :: normalize => rgbimage_normalize ! normalizes all pixels onto range [0, 255]
procedure :: set_pixel => rgbimage_set_pixel ! sets one pixel
procedure :: write => rgbimage_write ! outputs image to file
procedure, private :: inside => rgbimage_inside
procedure, private :: valid => rgbimage_valid
end type
contains
subroutine rgbimage_init(this, height, width)
!! initialize image.
!! sets dimensions, allocates pixels and sets colors to 0.
class(rgbimage), intent(out) :: this
integer, intent(in) :: height, width
this%n = [height, width]
allocate (this%rgb(height,width,3), source=0)
end subroutine
logical function rgbimage_valid(this, check_rgb_vals)
!! checks if the image has valid dimensions and optionally valid rgb values.
class(rgbimage), intent(in) :: this
logical, intent(in), optional :: check_rgb_vals
!! check if rgb values are in allowed range [0, 255]?
!! default: dont check
! always check that dimensions match
rgbimage_valid = ( all(this%n > 0) .and. &
& (size(this%rgb, dim=1) == this%n(1)) .and. &
& (size(this%rgb, dim=2) == this%n(2)) .and. &
& (size(this%rgb, dim=3) == 3) )
! optionally: check if rgb values are in allowed range
if (present(check_rgb_vals)) then
if (check_rgb_vals) rgbimage_valid = ( rgbimage_valid .and. &
& (all(this%rgb >= 0)) .and. &
& (all(this%rgb <= 255)) )
end if
end function
logical function rgbimage_inside(this, x, y)
!! checks if given coordinates are inside the image
class(rgbimage), intent(in) :: this
integer, intent(in) :: x, y
rgbimage_inside = ((x > 0) .and. (x <= this%n(1)) .and. (y > 0) .and. (y <= this%n(2)))
end function
subroutine rgbimage_set_pixel(this, x, y, rgb)
class(rgbimage), intent(inout) :: this
integer, intent(in) :: x, y
!! coordinates
integer, intent(in) :: rgb(3)
!! red, green, blue values
if (this%inside(x, y)) then
! use given data at first
this%rgb(x,y,:) = rgb
! check if given data was out of bounds
where (this%rgb(x,y,:) > 255)
this%rgb(x,y,:) = 255
elsewhere (this%rgb(x,y,:) < 0)
this%rgb(x,y,:) = 0
end where
end if
end subroutine
function rgbimage_get_pixel(this, x, y) result(rgb)
class(rgbimage), intent(in) :: this
integer, intent(in) :: x, y
!! coordinates
integer :: rgb(3)
!! red, green, blue values
if (this%inside(x, y)) then
rgb = this%rgb(x,y,:)
else
rgb = 0
end if
end function
subroutine rgbimage_normalize(this)
!! normalize colors to be in range [0, 255]
class(rgbimage), intent(inout) :: this
where (this%rgb(:,:,:) > 255)
this%rgb(:,:,:) = 255
elsewhere (this%rgb(:,:,:) < 0)
this%rgb(:,:,:) = 0
end where
end subroutine
subroutine rgbimage_fill_image(this, rgb)
!! fill whole image with given rgb values.
class(rgbimage), intent(inout) :: this
integer, intent(in) :: rgb(3)
!! red, green, blue values
integer :: i
if (this%valid()) then
do i = 1, 3
this%rgb(:,:,i) = rgb(i)
end do
end if
end subroutine
subroutine rgbimage_write(this, fname)
class(rgbimage), intent(in) :: this
character(*), intent(in) :: fname
!! file path, e.g. "tmp/out.ppm"
integer :: iounit, ios, i,j,k
open (newunit=iounit, file=fname, iostat=ios, action='WRITE')
if (ios /= 0) error stop "Error opening file: " // fname
! write header
write (iounit, '(A)') 'P6'
write (iounit, '(I0, A, I0)') this%n(1), " ", this%n(2)
write (iounit, '(A)') '255'
do i = 1, this%n(1)
do j = 1, this%n(2)
write (iounit, '(3A1)', advance='no') [(achar(this%rgb(i,j,k)), k=1,3)]
end do
end do
close (unit=iounit, iostat=ios)
if (ios /= 0) error stop "Error closing file"
end subroutine
end module