Bitmap/Fortran

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>