module fortplot_text_color !! ANSI color-mode policy and SGR escape assembly for the text backend !! (issue #2062). !! !! Color modes: !! never no ANSI escapes !! ansi16 SGR 30-37/90-97 foreground colors !! ansi256 SGR 38;5;<n> foreground colors !! truecolor SGR 38;2;<r>;<g>;<b> foreground colors !! auto color only for an interactive terminal that appears to !! support it; suppressed by NO_COLOR and TERM=dumb. !! !! Saved .txt artifacts default to 'never' so bytes stay reproducible. The !! 'auto' mode is resolved conservatively at output time: file output never !! resolves to color, and terminal output resolves through the environment !! and a stdout TTY probe. All escape bytes are built with achar() so this !! source stays pure ASCII. use, intrinsic :: iso_fortran_env, only: wp => real64 use, intrinsic :: iso_c_binding, only: c_int implicit none private public :: is_valid_text_color_mode, normalize_text_color_mode public :: resolve_text_color_mode_file, resolve_text_color_mode_terminal public :: sgr_foreground, sgr_reset public :: pack_rgb, unpack_rgb public :: color_to_ansi16, color_to_ansi256 public :: COLOR_NONE character(len=1), parameter :: ESC = achar(27) !! Sentinel stored in the per-cell color buffer for cells with no plot color. integer, parameter :: COLOR_NONE = -1 interface function c_isatty(fd) bind(c, name="isatty") result(r) import :: c_int integer(c_int), value :: fd integer(c_int) :: r end function c_isatty end interface contains logical function is_valid_text_color_mode(mode) result(valid) !! True when mode names one of the five canonical color modes. character(len=*), intent(in) :: mode select case (lower_trim(mode)) case ('never', 'ansi16', 'ansi256', 'truecolor', 'auto') valid = .true. case default valid = .false. end select end function is_valid_text_color_mode function normalize_text_color_mode(name) result(mode) !! Canonicalize a user color-mode selection; unknown names fall back to !! 'never' so unexpected input can never leak escapes into output. character(len=*), intent(in) :: name character(len=:), allocatable :: mode mode = lower_trim(name) if (.not. is_valid_text_color_mode(mode)) mode = 'never' end function normalize_text_color_mode function resolve_text_color_mode_file(mode) result(resolved) !! Resolve the color mode for file output. Saved files must stay !! reproducible, so 'auto' always resolves to 'never'; explicit modes !! are honored because the caller asked for them. character(len=*), intent(in) :: mode character(len=:), allocatable :: resolved resolved = normalize_text_color_mode(mode) if (resolved == 'auto') resolved = 'never' end function resolve_text_color_mode_file function resolve_text_color_mode_terminal(mode) result(resolved) !! Resolve the color mode for interactive terminal output. Explicit !! modes are honored; 'auto' is resolved from the environment and a !! stdout TTY probe. character(len=*), intent(in) :: mode character(len=:), allocatable :: resolved resolved = normalize_text_color_mode(mode) if (resolved == 'auto') resolved = resolve_auto_from_environment() end function resolve_text_color_mode_terminal function resolve_auto_from_environment() result(resolved) !! Conservative 'auto' resolution following common terminal conventions. character(len=:), allocatable :: resolved resolved = 'never' ! NO_COLOR (any value, including empty) disables color entirely. if (env_is_set('NO_COLOR')) return ! CLICOLOR_FORCE=1 or FORCE_COLOR (non-zero) force color output. if (env_equals('CLICOLOR_FORCE', '1')) then resolved = terminal_color_capability() return end if if (env_forces_color('FORCE_COLOR')) then resolved = terminal_color_capability() return end if ! A dumb or unset terminal cannot render color. if (env_equals('TERM', 'dumb')) return if (.not. env_is_set('TERM')) return ! Require an interactive stdout. if (c_isatty(1_c_int) == 0_c_int) return resolved = terminal_color_capability() end function resolve_auto_from_environment function terminal_color_capability() result(mode) !! Best-effort color depth from COLORTERM/TERM. Defaults to ansi16 which !! every color terminal supports. character(len=:), allocatable :: mode character(len=256) :: value integer :: length, stat mode = 'ansi16' call get_environment_variable('COLORTERM', value, length, stat) if (stat == 0 .and. length > 0) then if (index(lower_trim(value(1:length)), 'truecolor') > 0) mode = 'truecolor' if (index(lower_trim(value(1:length)), '24bit') > 0) mode = 'truecolor' if (mode == 'truecolor') return end if call get_environment_variable('TERM', value, length, stat) if (stat == 0 .and. length > 0) then if (index(value(1:length), '256color') > 0) mode = 'ansi256' end if end function terminal_color_capability function sgr_foreground(mode, r, g, b) result(seq) !! SGR foreground escape for the given color mode and RGB (0..1). !! Returns an empty string for 'never'/unknown modes. character(len=*), intent(in) :: mode real(wp), intent(in) :: r, g, b character(len=:), allocatable :: seq integer :: ir, ig, ib select case (normalize_text_color_mode(mode)) case ('ansi16') seq = ESC//'['//itoa(color_to_ansi16(r, g, b))//'m' case ('ansi256') seq = ESC//'[38;5;'//itoa(color_to_ansi256(r, g, b))//'m' case ('truecolor') ir = channel_255(r) ig = channel_255(g) ib = channel_255(b) seq = ESC//'[38;2;'//itoa(ir)//';'//itoa(ig)//';'//itoa(ib)//'m' case default seq = '' end select end function sgr_foreground function sgr_reset() result(seq) !! The SGR reset escape emitted after a colored span and before every !! newline or frame boundary. character(len=:), allocatable :: seq seq = ESC//'[0m' end function sgr_reset pure integer function pack_rgb(r, g, b) result(packed) !! Pack an RGB triple (0..1) into a single 24-bit integer for the !! per-cell color buffer. real(wp), intent(in) :: r, g, b packed = channel_255(r)*65536 + channel_255(g)*256 + channel_255(b) end function pack_rgb pure subroutine unpack_rgb(packed, r, g, b) !! Inverse of pack_rgb; returns channels in 0..1. integer, intent(in) :: packed real(wp), intent(out) :: r, g, b r = real(iand(ishft(packed, -16), 255), wp)/255.0_wp g = real(iand(ishft(packed, -8), 255), wp)/255.0_wp b = real(iand(packed, 255), wp)/255.0_wp end subroutine unpack_rgb pure integer function color_to_ansi16(r, g, b) result(code) !! Map an RGB triple to a standard (30-37) or bright (90-97) SGR !! foreground code by nearest 3-bit color plus a luminance-based bright !! bit. real(wp), intent(in) :: r, g, b integer :: bit real(wp) :: luminance real(wp), parameter :: HALF = 0.5_wp bit = 0 if (r >= HALF) bit = bit + 1 if (g >= HALF) bit = bit + 2 if (b >= HALF) bit = bit + 4 luminance = 0.299_wp*r + 0.587_wp*g + 0.114_wp*b if (luminance >= 0.75_wp) then code = 90 + bit else code = 30 + bit end if end function color_to_ansi16 pure integer function color_to_ansi256(r, g, b) result(idx) !! Map an RGB triple to a 6x6x6 color-cube index (16..231). real(wp), intent(in) :: r, g, b integer :: ri, gi, bi ri = cube_axis(r) gi = cube_axis(g) bi = cube_axis(b) idx = 16 + 36*ri + 6*gi + bi end function color_to_ansi256 pure integer function cube_axis(v) result(i) !! Quantize a 0..1 channel to a 0..5 color-cube axis. real(wp), intent(in) :: v i = nint(max(0.0_wp, min(1.0_wp, v))*5.0_wp) end function cube_axis pure integer function channel_255(v) result(i) !! Clamp and scale a 0..1 channel to a 0..255 byte. real(wp), intent(in) :: v i = nint(max(0.0_wp, min(1.0_wp, v))*255.0_wp) end function channel_255 function itoa(n) result(str) !! Minimal non-negative integer to decimal string. integer, intent(in) :: n character(len=:), allocatable :: str character(len=16) :: buf write (buf, '(I0)') n str = trim(buf) end function itoa function lower_trim(s) result(out) !! Trim and lowercase an ASCII string. character(len=*), intent(in) :: s character(len=:), allocatable :: out integer :: i, c out = trim(adjustl(s)) do i = 1, len(out) c = iachar(out(i:i)) if (c >= iachar('A') .and. c <= iachar('Z')) out(i:i) = achar(c + 32) end do end function lower_trim logical function env_is_set(name) result(is_set) !! True when an environment variable is present (any value, including !! empty). character(len=*), intent(in) :: name character(len=1) :: value integer :: length, stat call get_environment_variable(name, value, length, stat) ! stat==0 present and fit, stat==-1 present but truncated. Both mean set. is_set = stat == 0 .or. stat == -1 end function env_is_set logical function env_equals(name, expected) result(matches) !! True when an environment variable is set and equals expected !! (case-insensitive, trimmed). character(len=*), intent(in) :: name, expected character(len=256) :: value integer :: length, stat matches = .false. call get_environment_variable(name, value, length, stat) if (stat /= 0) return if (length <= 0) return matches = lower_trim(value(1:length)) == lower_trim(expected) end function env_equals logical function env_forces_color(name) result(forces) !! True when a FORCE_COLOR-style variable is set to anything other than !! '0'. An empty value counts as forcing per the common convention. character(len=*), intent(in) :: name character(len=256) :: value integer :: length, stat forces = .false. call get_environment_variable(name, value, length, stat) if (stat /= 0 .and. stat /= -1) return if (length <= 0) then forces = .true. return end if forces = lower_trim(value(1:length)) /= '0' end function env_forces_color end module fortplot_text_color