import Control.Exception.Base (assert)
import Control.Monad (liftM3)
import Data.Aeson
import Data.ByteString.Lazy (readFile)
import Data.Map (Map, lookup, toList)
import Data.Maybe (fromJust)
import HSLuv
maxDiff :: Double
maxDiff = 0.0000000001
maxRelDiff :: Double
maxRelDiff = 0.000000001
approxEqual :: Double -> Double -> Bool
approxEqual a b =
let diff = abs (b - a)
in diff <= maxDiff || diff <= maxRelDiff * max (abs a) (abs b)
approxEqualTriple ::
(Double, Double, Double) -> (Double, Double, Double) -> Bool
approxEqualTriple (a, b, c) (d, e, f) =
approxEqual a d && approxEqual b e && approxEqual c f
checkTestCase :: String -> TestCase -> Bool
checkTestCase hex cases =
let rgb = fromJust $ Data.Map.lookup "rgb" cases
xyz = fromJust $ Data.Map.lookup "xyz" cases
luv = fromJust $ Data.Map.lookup "luv" cases
lch = fromJust $ Data.Map.lookup "lch" cases
hsluv = fromJust $ Data.Map.lookup "hsluv" cases
hpluv = fromJust $ Data.Map.lookup "hpluv" cases
rgb'@(RGB (RGBRed rgbr') (RGBGreen rgbg') (RGBBlue rgbb')) =
fromJust $ hexToRgb hex
xyz'@(XYZ (XYZX xyzx') (XYZY xyzy') (XYZZ xyzz')) = rgbToXyz rgb'
luv'@(LUV (LUVLightness luvl') (LUVU luvu') (LUVV luvv')) = xyzToLuv xyz'
lch'@(LCH (LCHLightness lchl') (LCHChroma lchc') (LCHHue lchh')) =
luvToLch luv'
hsluvLch'@(HSLuv (HSLuvHue hsluvLchh') (HSLuvSaturation hsluvLchs') (HSLuvLightness hsluvLchl')) =
lchToHsluv lch'
hpluvLch'@(HPLuv (HPLuvHue hpluvLchh') (HPLuvPastel hpluvLchp') (HPLuvLightness hpluvLchl')) =
lchToHpluv lch'
hsluvHex'@(HSLuv (HSLuvHue hsluvHexh') (HSLuvSaturation hsluvHexs') (HSLuvLightness hsluvHexl')) =
fromJust $ hexToHsluv hex
hpluvHex'@(HPLuv (HPLuvHue hpluvHexh') (HPLuvPastel hpluvHexp') (HPLuvLightness hpluvHexl')) =
fromJust $ hexToHpluv hex
lchHsluv'@(LCH (LCHLightness lchHsluvl') (LCHChroma lchHsluvc') (LCHHue lchHsluvh')) =
hsluvToLch hsluvHex'
lchHpluv'@(LCH (LCHLightness lchHpluvl') (LCHChroma lchHpluvc') (LCHHue lchHpluvh')) =
hpluvToLch hpluvHex'
luvLch'@(LUV (LUVLightness luvLchl') (LUVU luvLchu') (LUVV luvLchv')) =
lchToLuv lchHsluv'
xyzLuv'@(XYZ (XYZX xyzLuvx') (XYZY xyzLuvy') (XYZZ xyzLuvz')) =
luvToXyz luvLch'
rgbXyz'@(RGB (RGBRed rgbXyzr') (RGBGreen rgbXyzg') (RGBBlue rgbXyzb')) =
xyzToRgb xyzLuv'
in approxEqualTriple rgb (rgbr', rgbg', rgbb') &&
approxEqualTriple xyz (xyzx', xyzy', xyzz') &&
approxEqualTriple luv (luvl', luvu', luvv') &&
approxEqualTriple lch (lchl', lchc', lchh') &&
approxEqualTriple hsluv (hsluvLchh', hsluvLchs', hsluvLchl') &&
approxEqualTriple hsluv (hsluvHexh', hsluvHexs', hsluvHexl') &&
approxEqualTriple hpluv (hpluvLchh', hpluvLchp', hpluvLchl') &&
approxEqualTriple hpluv (hpluvHexh', hpluvHexp', hpluvHexl') &&
approxEqualTriple lch (lchHsluvl', lchHsluvc', lchHsluvh') &&
approxEqualTriple lch (lchHpluvl', lchHpluvc', lchHpluvh') &&
approxEqualTriple luv (luvLchl', luvLchu', luvLchv') &&
approxEqualTriple xyz (xyzLuvx', xyzLuvy', xyzLuvz') &&
approxEqualTriple rgb (rgbXyzr', rgbXyzg', rgbXyzb') &&
hex == rgbToHex rgb' &&
hex == hsluvToHex hsluvLch' &&
hex == hpluvToHex hpluvLch' &&
hex == hsluvToHex hsluvHex' && hex == hpluvToHex hpluvHex'
checkRgbBounds :: Bool
checkRgbBounds = all checkRgbBound $ liftM3 (,,) [0, 1] [0, 1] [0, 1]
where
checkRgbBound (r, g, b) =
let RGB (RGBRed r') (RGBGreen g') (RGBBlue b') =
hsluvToRgb . rgbToHsluv $ RGB (RGBRed r) (RGBGreen g) (RGBBlue b)
in approxEqualTriple (r, g, b) (r', g', b')
type TestCase = Map String (Double, Double, Double)
type TestVectors = Map String TestCase
main :: IO ()
main = do
testVectorsString <- Data.ByteString.Lazy.readFile "test/snapshot-rev4.json"
let testVectors = fromJust (decode testVectorsString :: Maybe TestVectors)
let vectorsCheck = all (uncurry checkTestCase) (Data.Map.toList testVectors)
print $ assert (vectorsCheck && checkRgbBounds) "All tests pass."