Rosetta Code

Bitmap/Fortran: Difference between revisions

Page Discussion

Bitmap/Fortran (view source)

Revision as of 15:54, 1 September 2022

1,202 bytes added ,  1 year ago
m
Fixed syntax highlighting.
m (Fixed syntax highlighting.)
 
(5 intermediate revisions by 3 users not shown)
Line 2:
 
{{works with|Fortran|90 and later}}
<langsyntaxhighlight lang="fortran">module RCImageBasicrgbimage_m
 
implicit none
 
private
public :: rgbimage
 
type rgbimage
!! usage
integer, dimension(:,:), pointer :: red, green, blue
!! integer :: width, height1) 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
 
subroutine init_imgrgbimage_init(imgthis, 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
function colordistance(c1, c2) result(res)
integer, intent(in) :: height, width
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
 
this%n = [height, width]
function rgbequal(c1, c2)
allocate (this%rgb(height,width,3), source=0)
logical :: rgbequal
end subroutine
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
 
logical function inside_imagergbimage_valid(imgthis, x, y) result(rcheck_rgb_vals)
!! checks if the image has valid dimensions and optionally valid rgb values.
logical :: r
type(rgbimage), intent(in) :: img
integer, intent(in) :: x, y
 
class(rgbimage), intent(in) :: this
r = .false.
logical, intent(in), optional :: check_rgb_vals
if ( (x < img%width) .and. ( y < img%height ) .and. &
!! check if (xrgb >=values 0are )in .and.allowed ( y >=range [0, ) ) then255]?
!! rdefault: =dont .true.check
end if
end function inside_image
 
! always check that dimensions match
function valid_image(img) result(r)
rgbimage_valid = ( all(this%n > 0) .and. &
logical :: r
& (size(this%rgb, dim=1) == this%n(1)) .and. &
type(rgbimage) :: img
& (size(this%rgb, dim=2) == this%n(2)) .and. &
& (size(this%rgb, dim=3) == 3) )
 
! optionally: check if rgb values are in allowed range
r = .false.
if ( img%width == 0 present(check_rgb_vals)) returnthen
if (check_rgb_vals) rgbimage_valid = ( rgbimage_valid .and. &
if ( img%height == 0 ) return
& (all(this%rgb >= 0)) .and. &
if ( .not. associated(img%red) .and. .not. associated(img%green) .and. &
& (all(this%rgb <= 255)) )
.not. associated(img%blue) ) return
rend = .true.if
end function valid_image
 
subroutine normalize_img(img)
type(rgbimage), intent(inout) :: img
 
end function
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
 
logical function rgbimage_inside(this, x, y)
subroutine alloc_img(img, w, h)
!! checks if given coordinates are inside the image
type(rgbimage) :: img
integer, intent(in) :: w, h
 
class(rgbimage), intent(in) :: this
allocate(img%red(w, h))
integer, intent(in) :: x, y
allocate(img%green(w, h))
allocate(img%blue(w, h))
img%width = w
img%height = h
end subroutine alloc_img
 
rgbimage_inside = ((x > 0) .and. (x <= this%n(1)) .and. (y > 0) .and. (y <= this%n(2)))
subroutine free_img(img)
end function
type(rgbimage) :: img
 
subroutine rgbimage_set_pixel(this, x, y, rgb)
if ( associated(img%red) ) deallocate(img%red)
class(rgbimage), intent(inout) :: this
if ( associated(img%green) ) deallocate(img%green)
integer, intent(in) :: x, y
if ( associated(img%blue) ) deallocate(img%blue)
!! coordinates
end subroutine free_img
integer, intent(in) :: rgb(3)
!! red, green, blue values
 
if (this%inside(x, y)) then
subroutine fill_img(img, color)
! use given data at first
type(rgbimage), intent(inout) :: img
type(rgb), intent this%rgb(inx,y,:) ::= colorrgb
 
! check if given data was out of bounds
if ( valid_image(img) ) then
where img%red = mod(abs(colorthis%red)rgb(x,y,:) > 256255)
img this%greenrgb(x,y,:) = mod(abs(color%green), 256)255
elsewhere img(this%blue = modrgb(abs(color%bluex,y,:), 256< 0)
this%rgb(x,y,:) = 0
end where
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
 
function rgbimage_get_pixel(this, x, y) result(rgb)
if ( inside_image(img, x, y) .and. valid_image(img)) then
class(rgbimage), intent(in) :: this
img%red(x+1,y+1) = mod(abs(color%red), 256)
integer, intent(in) :: x, y
img%green(x+1, y+1) = mod(abs(color%green), 256)
!! coordinates
img%blue(x+1, y+1) = mod(abs(color%blue), 256)
integer :: rgb(3)
!! red, green, blue values
 
if (this%inside(x, y)) then
rgb = this%rgb(x,y,:)
else
rgb = 0
end if
end subroutine put_pixelfunction
 
subroutine get_pixelrgbimage_normalize(img, x, y, colorthis)
!! normalize colors to be in range [0, 255]
type(rgbimage), intent(in) :: img
integer, intent(in) :: x, y
type(rgb), intent(out) :: color
 
class(rgbimage), intent(inout) :: this
if ( inside_image(img, x, y) .and. valid_image(img)) then
 
color%red = img%red(x+1, y+1)
where color%green = img(this%greenrgb(x+1:,:,:) > y+1255)
colorthis%bluergb(:,:,:) = img%blue(x+1, y+1)255
elsewhere (this%rgb(:,:,:) < 0)
else
colorthis%redrgb(:,:,:) = 0
end where
color%green = 0
end subroutine
color%blue = 0
 
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 get_pixel
 
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 RCImageBasic</langsyntaxhighlight>
PureFox
9,476

edits

Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/136160...329474"