face.F90 Source File

!< FACE, Fortran Ansi Colors Environment.
module face
!< FACE, Fortran Ansi Colors Environment.
use, intrinsic :: iso_fortran_env, only: int32

implicit none
private
public :: colorize
public :: colors_samples
public :: styles_samples
public :: ASCII
public :: UCS4

interface colorize
#if defined ASCII_SUPPORTED && defined ASCII_NEQ_DEFAULT
   module procedure colorize_ascii
   module procedure colorize_default
#else
   module procedure colorize_default
#endif
#ifdef UCS4_SUPPORTED
   module procedure colorize_ucs4
#endif
endinterface

! kind parameters
#ifdef ASCII_SUPPORTED
integer, parameter :: ASCII = selected_char_kind('ascii')     !< ASCII character set kind.
#else
integer, parameter :: ASCII = selected_char_kind('default')   !< ASCII character set kind.
#endif
#ifdef UCS4_SUPPORTED
integer, parameter :: UCS4  = selected_char_kind('iso_10646') !< Unicode character set kind.
#else
integer, parameter :: UCS4  = selected_char_kind('default')   !< Unicode character set kind.
#endif
! parameters
character(26), parameter :: UPPER_ALPHABET='ABCDEFGHIJKLMNOPQRSTUVWXYZ' !< Upper case alphabet.
character(26), parameter :: LOWER_ALPHABET='abcdefghijklmnopqrstuvwxyz' !< Lower case alphabet.
character(1),  parameter :: NL=new_line('a')                            !< New line character.
character(1),  parameter :: ESCAPE=achar(27)                            !< "\" character.
! codes
character(2), parameter :: CODE_START=ESCAPE//'['               !< Start ansi code, "\[".
character(1), parameter :: CODE_END='m'                         !< End ansi code, "m".
character(4), parameter :: CODE_CLEAR=CODE_START//'0'//CODE_END !< Clear all styles, "\[0m".
! styles codes
character(17), parameter :: STYLES(1:2,1:16)=reshape([&
             'BOLD_ON          ','1                ', &         !  Bold on.
             'ITALICS_ON       ','3                ', &         !  Italics on.
             'UNDERLINE_ON     ','4                ', &         !  Underline on.
             'INVERSE_ON       ','7                ', &         !  Inverse on: reverse foreground and background colors.
             'STRIKETHROUGH_ON ','9                ', &         !  Strikethrough on.
             'BOLD_OFF         ','22               ', &         !  Bold off.
             'ITALICS_OFF      ','23               ', &         !  Italics off.
             'UNDERLINE_OFF    ','24               ', &         !  Underline off.
             'INVERSE_OFF      ','27               ', &         !  Inverse off: reverse foreground and background colors.
             'STRIKETHROUGH_OFF','29               ', &         !  Strikethrough off.
             'FRAMED_ON        ','51               ', &         !  Framed on.
             'ENCIRCLED_ON     ','52               ', &         !  Encircled on.
             'OVERLINED_ON     ','53               ', &         !  Overlined on.
             'FRAMED_OFF       ','54               ', &         !  Framed off.
             'ENCIRCLED_OFF    ','54               ', &         !  Encircled off.
             'OVERLINED_OFF    ','55               '  &         !  Overlined off.
                                                     ], [2,16]) !< Styles.
! colors codes
character(15), parameter :: COLORS_FG(1:2,1:17)=reshape([&
                    'BLACK          ','30             ', &         !  Black.
                    'RED            ','31             ', &         !  Red.
                    'GREEN          ','32             ', &         !  Green.
                    'YELLOW         ','33             ', &         !  Yellow.
                    'BLUE           ','34             ', &         !  Blue.
                    'MAGENTA        ','35             ', &         !  Magenta.
                    'CYAN           ','36             ', &         !  Cyan.
                    'WHITE          ','37             ', &         !  White.
                    'DEFAULT        ','39             ', &         !  Default (white).
                    'BLACK_INTENSE  ','90             ', &         !  Black intense.
                    'RED_INTENSE    ','91             ', &         !  Red intense.
                    'GREEN_INTENSE  ','92             ', &         !  Green intense.
                    'YELLOW_INTENSE ','93             ', &         !  Yellow intense.
                    'BLUE_INTENSE   ','94             ', &         !  Blue intense.
                    'MAGENTA_INTENSE','95             ', &         !  Magenta intense.
                    'CYAN_INTENSE   ','96             ', &         !  Cyan intense.
                    'WHITE_INTENSE  ','97             '  &         !  White intense.
                                                        ], [2,17]) !< Foreground colors.
character(15), parameter :: COLORS_BG(1:2,1:17)=reshape([&
                    'BLACK          ','40             ', &         !  Black.
                    'RED            ','41             ', &         !  Red.
                    'GREEN          ','42             ', &         !  Green.
                    'YELLOW         ','43             ', &         !  Yellow.
                    'BLUE           ','44             ', &         !  Blue.
                    'MAGENTA        ','45             ', &         !  Magenta.
                    'CYAN           ','46             ', &         !  Cyan.
                    'WHITE          ','47             ', &         !  White.
                    'DEFAULT        ','49             ', &         !  Default (black).
                    'BLACK_INTENSE  ','100            ', &         !  Black intense.
                    'RED_INTENSE    ','101            ', &         !  Red intense.
                    'GREEN_INTENSE  ','102            ', &         !  Green intense.
                    'YELLOW_INTENSE ','103            ', &         !  Yellow intense.
                    'BLUE_INTENSE   ','104            ', &         !  Blue intense.
                    'MAGENTA_INTENSE','105            ', &         !  Magenta intense.
                    'CYAN_INTENSE   ','106            ', &         !  Cyan intense.
                    'WHITE_INTENSE  ','107            '  &         !  White intense.
                                                        ], [2,17]) !< Background colors.
contains
   ! public procedures
   subroutine colors_samples()
   !< Print to standard output all colors samples.
   integer(int32) :: c !< Counter.

   print '(A)', colorize('Foreground colors samples', color_fg='red_intense')
   do c=1, size(COLORS_FG, dim=2)
      print '(A)', '  colorize("'//COLORS_FG(1, c)//'", color_fg="'//COLORS_FG(1, c)//'") => '//&
         colorize(COLORS_FG(1, c), color_fg=COLORS_FG(1, c))//&
         ' code: '//colorize(trim(COLORS_FG(2, c)), color_fg=COLORS_FG(1, c), style='inverse_on')
   enddo
   print '(A)', colorize('Background colors samples', color_fg='red_intense')
   do c=1, size(COLORS_BG, dim=2)
      print '(A)', '  colorize("'//COLORS_BG(1, c)//'", color_bg="'//COLORS_BG(1, c)//'") => '//&
         colorize(COLORS_BG(1, c), color_bg=COLORS_BG(1, c))//&
         ' code: '//colorize(trim(COLORS_BG(2, c)), color_bg=COLORS_BG(1, c), style='inverse_on')
   enddo
   endsubroutine colors_samples

   subroutine styles_samples()
   !< Print to standard output all styles samples.
   integer(int32) :: s !< Counter.

   print '(A)', colorize('Styles samples', color_fg='red_intense')
   do s=1, size(STYLES, dim=2)
      print '(A)', '  colorize("'//STYLES(1, s)//'", style="'//STYLES(1, s)//'") => '//&
         colorize(STYLES(1, s), style=STYLES(1, s))//&
         ' code: '//colorize(trim(STYLES(2, s)), color_fg='magenta', style='inverse_on')
   enddo
   endsubroutine styles_samples

   ! private procedures
   pure function colorize_ascii(string, color_fg, color_bg, style) result(colorized)
   !< Colorize and stylize strings, ASCII kind.
   character(len=*, kind=ASCII), intent(in)           :: string    !< Input string.
   character(len=*),             intent(in), optional :: color_fg  !< Foreground color definition.
   character(len=*),             intent(in), optional :: color_bg  !< Background color definition.
   character(len=*),             intent(in), optional :: style     !< Style definition.
   character(len=:, kind=ASCII), allocatable          :: colorized !< Colorized string.
   character(len=:, kind=ASCII), allocatable          :: buffer    !< Temporary buffer.
   integer(int32)                                     :: i         !< Counter.

   colorized = string
   if (present(color_fg)) then
      i = color_index(upper(color_fg))
      if (i>0) then
         buffer = CODE_START//trim(COLORS_FG(2, i))//CODE_END
         colorized = buffer//colorized
         buffer = CODE_CLEAR
         colorized = colorized//buffer
      endif
   endif
   if (present(color_bg)) then
      i = color_index(upper(color_bg))
      if (i>0) then
         buffer = CODE_START//trim(COLORS_BG(2, i))//CODE_END
         colorized = buffer//colorized
         buffer = CODE_CLEAR
         colorized = colorized//buffer
      endif
   endif
   if (present(style)) then
      i = style_index(upper(style))
      if (i>0) then
         buffer = CODE_START//trim(STYLES(2, i))//CODE_END
         colorized = buffer//colorized
         buffer = CODE_CLEAR
         colorized = colorized//buffer
      endif
   endif
   endfunction colorize_ascii

   pure function colorize_default(string, color_fg, color_bg, style) result(colorized)
   !< Colorize and stylize strings, DEFAULT kind.
   character(len=*), intent(in)           :: string    !< Input string.
   character(len=*), intent(in), optional :: color_fg  !< Foreground color definition.
   character(len=*), intent(in), optional :: color_bg  !< Background color definition.
   character(len=*), intent(in), optional :: style     !< Style definition.
   character(len=:), allocatable          :: colorized !< Colorized string.
   integer(int32)                         :: i         !< Counter.

   colorized = string
   if (present(color_fg)) then
      i = color_index(upper(color_fg))
      if (i>0) colorized = CODE_START//trim(COLORS_FG(2, i))//CODE_END//colorized//CODE_CLEAR
   endif
   if (present(color_bg)) then
      i = color_index(upper(color_bg))
      if (i>0) colorized = CODE_START//trim(COLORS_BG(2, i))//CODE_END//colorized//CODE_CLEAR
   endif
   if (present(style)) then
      i = style_index(upper(style))
      if (i>0) colorized = CODE_START//trim(STYLES(2, i))//CODE_END//colorized//CODE_CLEAR
   endif
   endfunction colorize_default

   pure function colorize_ucs4(string, color_fg, color_bg, style) result(colorized)
   !< Colorize and stylize strings, UCS4 kind.
   character(len=*, kind=UCS4), intent(in)           :: string    !< Input string.
   character(len=*),            intent(in), optional :: color_fg  !< Foreground color definition.
   character(len=*),            intent(in), optional :: color_bg  !< Background color definition.
   character(len=*),            intent(in), optional :: style     !< Style definition.
   character(len=:, kind=UCS4), allocatable          :: colorized !< Colorized string.
   character(len=:, kind=UCS4), allocatable          :: buffer    !< Temporary buffer.
   integer(int32)                                    :: i         !< Counter.

   colorized = string
   if (present(color_fg)) then
      i = color_index(upper(color_fg))
      if (i>0) then
         buffer = CODE_START//trim(COLORS_FG(2, i))//CODE_END
         colorized = buffer//colorized
         buffer = CODE_CLEAR
         colorized = colorized//buffer
      endif
   endif
   if (present(color_bg)) then
      i = color_index(upper(color_bg))
      if (i>0) then
         buffer = CODE_START//trim(COLORS_BG(2, i))//CODE_END
         colorized = buffer//colorized
         buffer = CODE_CLEAR
         colorized = colorized//buffer
      endif
   endif
   if (present(style)) then
      i = style_index(upper(style))
      if (i>0) then
         buffer = CODE_START//trim(STYLES(2, i))//CODE_END
         colorized = buffer//colorized
         buffer = CODE_CLEAR
         colorized = colorized//buffer
      endif
   endif
   endfunction colorize_ucs4

   elemental function color_index(color)
   !< Return the array-index corresponding to the queried color.
   !<
   !< @note Because Foreground and backround colors lists share the same name, no matter what array is used to find the color index.
   !< Thus, the foreground array is used.
   character(len=*), intent(in) :: color       !< Color definition.
   integer(int32)               :: color_index !< Index into the colors arrays.
   integer(int32)               :: c           !< Counter.

   color_index = 0
   do c=1, size(COLORS_FG, dim=2)
      if (trim(COLORS_FG(1, c))==trim(adjustl(color))) then
         color_index = c
         exit
      endif
   enddo
   endfunction color_index

   elemental function style_index(style)
   !< Return the array-index corresponding to the queried style.
   character(len=*), intent(in) :: style       !< Style definition.
   integer(int32)               :: style_index !< Index into the styles array.
   integer(int32)               :: s           !< Counter.

   style_index = 0
   do s=1, size(STYLES, dim=2)
      if (trim(STYLES(1, s))==trim(adjustl(style))) then
         style_index = s
         exit
      endif
   enddo
   endfunction style_index

   elemental function upper(string)
   !< Return a string with all uppercase characters.
   character(len=*), intent(in) :: string !< Input string.
   character(len=len(string))   :: upper  !< Upper case string.
   integer                      :: n1     !< Characters counter.
   integer                      :: n2     !< Characters counter.

   upper = string
   do n1=1, len(string)
      n2 = index(LOWER_ALPHABET, string(n1:n1))
      if (n2>0) upper(n1:n1) = UPPER_ALPHABET(n2:n2)
   enddo
   endfunction upper
endmodule face