Bitmap/Fortran: Difference between revisions

From Rosetta Code
Content added Content deleted
(fixed improper use of the "where" statement)
(rewrote everything. just one type using type-bound procedures)
Line 2: Line 2:


{{works with|Fortran|90 and later}}
{{works with|Fortran|90 and later}}
<lang fortran>module RCImageBasic
<lang fortran>module rgbimage_m

implicit none
implicit none

private
public :: rgbimage


type rgbimage
type rgbimage
!! usage
integer, dimension(:,:), pointer :: red, green, blue
integer :: width, height
!! 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 :: dim(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 init_img(img)
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)
type(rgb), intent(out) :: color
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%dim = [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 rgbequal(c1, c2)
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 :: r
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.
if ( (x < img%width) .and. ( y < img%height ) .and. &
rgbimage_valid = ( all(this%dim > 0) .and. &
(x >= 0 ) .and. ( y >= 0 ) ) then
& (size(this%rgb, dim=1) == this%dim(1)) .and. &
& (size(this%rgb, dim=2) == this%dim(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%dim(1)) .and. (y > 0) .and. (y <= this%dim(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)
if ( associated(img%green) ) deallocate(img%green)
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)
type(rgbimage), intent(inout) :: img
class(rgbimage), intent(in) :: this
type(rgb), intent(in) :: color
integer, intent(in) :: x, y
!! coordinates
integer :: rgb(3)
!! red, green, blue values


if ( valid_image(img) ) then
if (this%inside(x, y)) then
img%red = mod(abs(color%red), 256)
rgb = this%rgb(x,y,:)
else
img%green = mod(abs(color%green), 256)
img%blue = mod(abs(color%blue), 256)
rgb = 0
end if
end if
end subroutine fill_img
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
color%red = img%red(x+1, y+1)
this%rgb(:,:,:) = 255
elsewhere (this%rgb(:,:,:) < 0)
color%green = img%green(x+1, y+1)
color%blue = img%blue(x+1, y+1)
this%rgb(:,:,:) = 0
else
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 get_pixel
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%dim(1), " ", this%dim(2)
write (iounit, '(A)') '255'

do i = 1, this%dim(1)
do j = 1, this%dim(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</lang>
end module</lang>

Revision as of 20:47, 20 February 2020

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 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 :: dim(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%dim = [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%dim > 0)                     .and. &
     &               (size(this%rgb, dim=1) == this%dim(1)) .and. &
     &               (size(this%rgb, dim=2) == this%dim(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%dim(1)) .and. (y > 0) .and. (y <= this%dim(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%dim(1), " ", this%dim(2)
   write (iounit, '(A)')         '255'

   do i = 1, this%dim(1)
     do j = 1, this%dim(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</lang>

Retrieved from "https://rosettacode.org/wiki/Bitmap/Fortran?oldid=136164"