{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Imj.Graphics.Color.Types
( Color8
, mkColor8
, Background
, Foreground
, LayeredColor(..)
, encodeColors
, color8BgSGRToCode
, color8FgSGRToCode
, Word8
, bresenhamColor8
, bresenhamColor8Length
, rgb
, gray
, Xterm256Color(..)
, onBlack
, whiteOnBlack
, white, black, red, green, magenta, cyan, yellow, blue
, RGB(..)
) where
import Data.Bits(shiftL, (.|.))
import Data.Word (Word8, Word16)
import Imj.Geo.Discrete.Bresenham3
import Imj.Graphics.Class.DiscreteDistance
import Imj.Graphics.Class.DiscreteInterpolation
import Imj.Util
data RGB = RGB {
_rgbR :: {-# UNPACK #-} !Word8
, _rgbG :: {-# UNPACK #-} !Word8
, _rgbB :: {-# UNPACK #-} !Word8
} deriving(Eq, Show, Read)
data LayeredColor = LayeredColor {
_colorsBackground :: {-# UNPACK #-} !(Color8 Background)
, _colorsForeground :: {-# UNPACK #-} !(Color8 Foreground)
} deriving(Eq, Show)
instance DiscreteDistance LayeredColor where
distance (LayeredColor bg fg) (LayeredColor bg' fg') =
succ $ pred (distance bg bg') + pred (distance fg fg')
instance DiscreteInterpolation LayeredColor where
interpolate (LayeredColor bg fg) (LayeredColor bg' fg') i
| i < lastBgFrame = LayeredColor (interpolate bg bg' i) fg
| otherwise = LayeredColor bg' $ interpolate fg fg' $ i - lastBgFrame
where
lastBgFrame = pred $ distance bg bg'
{-# INLINE encodeColors #-}
encodeColors :: LayeredColor -> Word16
encodeColors (LayeredColor (Color8 bg') (Color8 fg')) =
let fg = fromIntegral fg' :: Word16
bg = fromIntegral bg' :: Word16
in (bg `shiftL` 8) .|. fg
rgb :: Word8
-> Word8
-> Word8
-> Color8 a
rgb r g b
| r >= 6 || g >= 6 || b >= 6 = error "out of range"
| otherwise = Color8 $ fromIntegral $ 16 + 36 * r + 6 * g + b
gray :: Word8
-> Color8 a
gray i
| i >= 24 = error "out of range gray"
| otherwise = Color8 $ fromIntegral (i + 232)
data Foreground
data Background
newtype Color8 a = Color8 Word8 deriving (Eq, Show, Read, Enum)
instance DiscreteDistance (Color8 a) where
distance = bresenhamColor8Length
instance DiscreteInterpolation (Color8 a) where
interpolate c c' i
| c == c' = c
| otherwise =
let lastFrame = pred $ fromIntegral $ bresenhamColor8Length c c'
index = clamp i 0 lastFrame
in head . drop index $ bresenhamColor8 c c'
{-# INLINE mkColor8 #-}
mkColor8 :: Word8 -> Color8 a
mkColor8 = Color8
color8FgSGRToCode :: Color8 Foreground -> [Int]
color8FgSGRToCode (Color8 c) =
[38, 5, fromIntegral c]
color8BgSGRToCode :: Color8 Background -> [Int]
color8BgSGRToCode (Color8 c) =
[48, 5, fromIntegral c]
{-# INLINABLE bresenhamColor8Length #-}
bresenhamColor8Length :: Color8 a -> Color8 a -> Int
bresenhamColor8Length c c'
| c == c' = 1
| otherwise = case (color8CodeToXterm256 c, color8CodeToXterm256 c') of
(GrayColor g1, GrayColor g2) -> 1 + fromIntegral (abs (g2 - g1))
(RGBColor rgb1, RGBColor rgb2) -> bresenhamRGBLength rgb1 rgb2
(RGBColor rgb1, GrayColor g2) -> bresenhamRGBLength rgb1 (grayToRGB rgb1 g2)
(GrayColor g1, RGBColor rgb2) -> bresenhamRGBLength (grayToRGB rgb2 g1) rgb2
{-# INLINABLE bresenhamColor8 #-}
bresenhamColor8 :: Color8 a -> Color8 a -> [Color8 a]
bresenhamColor8 c c'
| c == c' = [c]
| otherwise = case (color8CodeToXterm256 c, color8CodeToXterm256 c') of
(GrayColor g1, GrayColor g2) -> map Color8 $ range g1 g2
(RGBColor rgb1, RGBColor rgb2) -> mapBresRGB rgb1 rgb2
(RGBColor rgb1, GrayColor g2) -> mapBresRGB rgb1 (grayToRGB rgb1 g2)
(GrayColor g1, RGBColor rgb2) -> mapBresRGB (grayToRGB rgb2 g1) rgb2
where
mapBresRGB c1 c2 = map (xterm256ColorToCode . RGBColor) $ bresenhamRGB c1 c2
{-# INLINABLE bresenhamRGBLength #-}
bresenhamRGBLength :: RGB -> RGB -> Int
bresenhamRGBLength (RGB r g b) (RGB r' g' b') =
bresenham3Length (fromIntegral r,fromIntegral g,fromIntegral b) (fromIntegral r',fromIntegral g',fromIntegral b')
{-# INLINABLE bresenhamRGB #-}
bresenhamRGB :: RGB -> RGB -> [RGB]
bresenhamRGB (RGB r g b) (RGB r' g' b') =
map
(\(x,y,z) -> RGB (fromIntegral x) (fromIntegral y) (fromIntegral z))
$ bresenham3 (fromIntegral r ,fromIntegral g ,fromIntegral b )
(fromIntegral r',fromIntegral g',fromIntegral b')
color8CodeToXterm256 :: Color8 a -> Xterm256Color a
color8CodeToXterm256 (Color8 c)
| c < 16 = error "interpolating 4-bit system colors is not supported"
| c < 232 = RGBColor $ asRGB (c - 16)
| otherwise = GrayColor (c - 232)
where
asRGB i = let
r = quot i 36
g = quot (i - 36 * r) 6
b = i - (6 * g + 36 * r)
in RGB r g b
xterm256ColorToCode :: Xterm256Color a -> Color8 a
xterm256ColorToCode (RGBColor (RGB r' g' b'))
= Color8 (16 + 36 * r + 6 * g + b)
where
clamp' x = clamp x 0 5
r = clamp' r'
g = clamp' g'
b = clamp' b'
xterm256ColorToCode (GrayColor y) = Color8 (232 + clamp y 0 23)
data Xterm256Color a = RGBColor !RGB
| GrayColor !Word8
deriving (Eq, Show, Read)
{-# INLINE onBlack #-}
onBlack :: Color8 Foreground -> LayeredColor
onBlack = LayeredColor (rgb 0 0 0)
{-# INLINE whiteOnBlack #-}
whiteOnBlack :: LayeredColor
whiteOnBlack = onBlack white
red, green, blue, yellow, magenta, cyan, white, black :: Color8 a
red = rgb 5 0 0
green = rgb 0 5 0
blue = rgb 0 0 5
yellow = rgb 5 5 0
magenta = rgb 5 0 5
cyan = rgb 0 5 5
white = rgb 5 5 5
black = rgb 0 0 0
grayToRGB :: RGB
-> Word8
-> RGB
grayToRGB (RGB r g b) grayComponent =
RGB (approximateGrayComponentAsRGBComponent r grayComponent)
(approximateGrayComponentAsRGBComponent g grayComponent)
(approximateGrayComponentAsRGBComponent b grayComponent)
approximateGrayComponentAsRGBComponent :: Word8
-> Word8
-> Word8
approximateGrayComponentAsRGBComponent _ 0 = 0
approximateGrayComponentAsRGBComponent _ 1 = 0
approximateGrayComponentAsRGBComponent colorComponent grayComponent =
let c = grayComponentToFollowingRGBComponent grayComponent
in if colorComponent < c
then
pred c
else
c
grayComponentToFollowingRGBComponent :: Word8
-> Word8
grayComponentToFollowingRGBComponent g
| g > 20 = 5
| g > 16 = 4
| g > 12 = 3
| g > 8 = 2
| otherwise = 1