Patch title: Release 90 bulk changes
Abstract:
File: /graphic/color/color.pli
Key:
    Removed line
    Added line
abstract
  [Tri values colors conversions] ; eol
  link "extra details" "http://www.cs.rit.edu/~ncs/color/t_convert.html"
  [ and ]
  link "sRGB spec" "http://www.w3.org/Graphics/Color/sRGB.html"

module "/pliant/language/unsafe.pli"
module "spectrum.pli"
module "gradation.pli"
module "/pliant/math/functions.pli"
module "/pliant/math/matrix.pli"
module "/pliant/graphic/misc/float.pli"
submodule "rgb888.pli"

function angle xx yy -> a
  arg Float xx yy a
  var Float x y z
  x := xx ; y := yy
  if x>=0.0
    if y>=0.0
      z := 0
    else
      z := x ; x := -y ; y := z ; z := 1.5*pi
  else
    if y>=0
      z := x ; x := y ; y := -z ; z := 0.5*pi
    else
      x := -x; y := -y ; z := pi
  if y<=x
    if x=0
      a := 0
    a := z+(atan y/x)
  else
    a := z+0.5*pi-(atan x/y)


public
  type ColorXYZ
    field Float32 X Y Z

  type ColorXYZn
    field Float32 X Y Z

  type ColorYxy
    field Float32 Y x y

  type ColorRGB
    field Float32 r g b

  type ColorHSV
    field Float32 h s v

  type ColorLab
    field Float32 L a b

  type ColorLCh
    field Float32 L C h


function filter_XYZ s -> xyz
  arg ColorSpectrum32 s ; arg ColorXYZ xyz
  var ColorSpectrum32 final := illuminant_spectrum*s
  xyz X := final X
  xyz Y := final Y
  xyz Z := final Z

constant ill_X illuminant_spectrum:X
constant ill_Y illuminant_spectrum:Y
constant ill_Z illuminant_spectrum:Z

function filter_XYZn s -> xyz
  arg ColorSpectrum32 s ; arg ColorXYZn xyz
  var ColorSpectrum32 final := illuminant_spectrum*s
  xyz X := final:X/ill_X
  xyz Y := final:Y/ill_Y
  xyz Z := final:Z/ill_Z

function 'cast ColorYxy' xyz -> yxy
  arg ColorXYZ xyz ; arg ColorYxy yxy
  yxy Y := xyz Y
  var Float f := xyz:X+xyz:Y+xyz:Z
  if f<=0
    f := 1
  yxy x := xyz:X/f
  yxy y := xyz:Y/f

function 'cast ColorXYZn' xyz -> xyzn
  arg ColorXYZ xyz ; arg ColorXYZn xyzn
  xyzn X := xyz:X/ill_X
  xyzn Y := xyz:Y/ill_Y
  xyzn Z := xyz:Z/ill_Z

function 'cast ColorXYZ' xyzn -> xyz
  arg ColorXYZn xyzn ; arg ColorXYZ xyz
  xyz X := xyzn:X*ill_X
  xyz Y := xyzn:Y*ill_Y
  xyz Z := xyzn:Z*ill_Z

function 'cast ColorXYZ' yxy -> xyz
  arg ColorYxy yxy ; arg ColorXYZ xyz
  xyz Y := yxy Y
  var Float f := yxy:Y/yxy:y
  xyz X := yxy:x*f
  xyz Z := (1-yxy:x-yxy:y)*f

function rgb_matrix -> final
  arg Matrix final
  (var Matrix rgb_spec) resize 3 3
  # red
  rgb_spec 0 0 := 0.64 ; rgb_spec 1 0 := 0.33 ; rgb_spec 2 0 := 1-(rgb_spec 0 0)-(rgb_spec 1 0)
  # green
  rgb_spec 0 1 := 0.30 ; rgb_spec 1 1 := 0.60 ; rgb_spec 2 1 := 1-(rgb_spec 0 1)-(rgb_spec 1 1)
  # blue
  rgb_spec 0 2 := 0.15 ; rgb_spec 1 2 := 0.06 ; rgb_spec 2 2 := 1-(rgb_spec 0 2)-(rgb_spec 1 2)
  var ColorXYZ white := filter_XYZ (cast 1 ColorSpectrum32)
  (var Matrix ill) resize 3 1
  ill 0 0 := white:X
  ill 1 0 := white:Y 
  ill 2 0 := white:Z
  var Matrix coeff := rgb_spec^(-1)*ill
  final resize 3 3
  for (var Int l) 0 2
    for (var Int c) 0 2
      final l c := (coeff c 0)*(rgb_spec l c)

function display
  constant m rgb_matrix
  for (var Int l) 0 2
    for (var Int c) 0 2
      console (m l c) " "
    console eol
# display

function 'cast ColorRGB' xyz -> rgb
  arg ColorXYZ xyz ; arg ColorRGB rgb
  constant m rgb_matrix^(-1)
  rgb r := (m 0 0)*xyz:X+(m 0 1)*xyz:Y+(m 0 2)*xyz:Z
  rgb g := (m 1 0)*xyz:X+(m 1 1)*xyz:Y+(m 1 2)*xyz:Z
  rgb b := (m 2 0)*xyz:X+(m 2 1)*xyz:Y+(m 2 2)*xyz:Z

function 'cast ColorXYZ' rgb -> xyz
  arg ColorRGB rgb ; arg ColorXYZ xyz
  constant m rgb_matrix
  xyz X := (m 0 0)*rgb:r+(m 0 1)*rgb:g+(m 0 2)*rgb:b
  xyz Y := (m 1 0)*rgb:r+(m 1 1)*rgb:g+(m 1 2)*rgb:b
  xyz Z := (m 2 0)*rgb:r+(m 2 1)*rgb:g+(m 2 2)*rgb:b

function test
  var ColorXYZ xyz := filter_XYZ (cast 1 ColorSpectrum32)
  var ColorRGB rgb := cast xyz ColorRGB
  console "r = " rgb:r "  g = " rgb:g "  b = " rgb:b eol
# test

gvar ColorGradation rgb_gradation := color_gamma 2.4 0.03928 0.055

function 'cast ColorRGB888' rgb -> rgb888
  arg ColorRGB rgb ; arg ColorRGB888 rgb888
  reduction
  rgb888 r := rgb_gradation encode rgb:r
  rgb888 g := rgb_gradation encode rgb:g
  rgb888 b := rgb_gradation encode rgb:b

function 'cast ColorRGB' rgb888 -> rgb
  arg ColorRGB888 rgb888 ; arg ColorRGB rgb
  extension
  rgb r := rgb_gradation decode rgb888:r
  rgb g := rgb_gradation decode rgb888:g
  rgb b := rgb_gradation decode rgb888:b

function 'cast ColorRGB' hsv -> rgb
  arg ColorHSV hsv ; arg ColorRGB rgb
  check hsv:h>=0 and hsv:h<360
  check hsv:s>=0 and hsv:s<=1
  check hsv:v>=0 and hsv:v<=1
  var Float s := hsv s
  var Float v := hsv v
  if hsv:s=0
    rgb r := v
    rgb g := v
    rgb b := v
    return
  var Float h := hsv:h/60
  var Int i := cast h-0.5 Int
  check i>=0 and i<=5
  var Float f := h-i
  var Float p := v*(1-s)
  var Float q := v*(1-s*f)
  var Float t := v*(1-s*(1-f))
  if i=0
    rgb r := v
    rgb g := t
    rgb b := p
  eif i=1
    rgb r := q
    rgb g := v
    rgb b := p
  eif i=2
    rgb r := p
    rgb g := v
    rgb b := t
  eif i=3
    rgb r := p
    rgb g := q
    rgb b := v
  eif i=4
    rgb r := t
    rgb g := p
    rgb b := v
  else # i=5
    rgb r := v
    rgb g := p
    rgb b := q

function 'cast ColorHSV' rgb -> hsv
  arg ColorRGB rgb ; arg ColorHSV hsv
  # check rgb:r>=0 and rgb:r<=1
  # check rgb:g>=0 and rgb:g<=1
  # check rgb:b>=0 and rgb:b<=1
  var Float min := min (min rgb:r rgb:g) rgb:b
  var Float max := max (max rgb:r rgb:g) rgb:b
  hsv v := max
  var Float delta := max-min
  if max>0
    hsv s := delta/max
  else # r=g=b=0 -> s=0, v=undefined
    hsv s := 0
    hsv h := undefined
    return
  var Float h
  if rgb:r=max
    h := (rgb:g-rgb:b)/delta
  eif rgb:g=max
    h := 2+(rgb:b-rgb:r)/delta
  else
    h := 4+(rgb:r-rgb:g)/delta
  h *= 60
  if h<0
    h += 360
  hsv h := h

export filter_XYZ filter_XYZn
export 'cast ColorXYZ' 'cast ColorXYZn' 'cast ColorYxy' 'cast ColorRGB' 'cast ColorRGB888' 'cast ColorHSV'


gvar Matrix r

function r_setup
  var Matrix m
  m resize 3 3
  m 0 0 := 0.49    ; m 0 1 := 0.31    ; m 0 2 := 0.20
  m 1 0 := 0.17697 ; m 1 1 := 0.81240 ; m 1 2 := 0.01063
  m 2 0 := 0       ; m 2 1 := 0.01    ; m 2 2 := 0.99
  r := m^(-1)
  if false
    for (var Int l) 0 2
      for (var Int c) 0 2
        console (r l c) " "
      console eol
r_setup

function cie_rgb xyz -> rgb
  arg ColorXYZ xyz ; arg ColorRGB rgb
  rgb r := (r 0 0)*xyz:X + (r 0 1)*xyz:Y + (r 0 2)*xyz:Z
  rgb g := (r 1 0)*xyz:X + (r 1 1)*xyz:Y + (r 1 2)*xyz:Z
  rgb b := (r 2 0)*xyz:X + (r 2 1)*xyz:Y + (r 2 2)*xyz:Z

function uniform v w -> u
  arg Float v w u
  if v/w>0.008856
    u := (v/w)^(1/3)
  else
    u := 7.787*v/w+16/116

function 'cast ColorLab' xyz -> lab
  arg ColorXYZ xyz ; arg ColorLab lab
  lab L := 116*(uniform xyz:Y ill_Y)-16
  lab a := 500*((uniform xyz:X ill_X)-(uniform xyz:Y ill_Y))
  lab b := 200*((uniform xyz:Y ill_Y)-(uniform xyz:Z ill_Z))


function linear v w -> u
  arg Float v w u
  u := v/w

function lab_linear xyz -> lab
  arg ColorXYZ xyz ; arg ColorLab lab
  lab L := 100*(linear xyz:Y ill_Y)
  lab a := 500*((linear xyz:X ill_X)-(linear xyz:Y ill_Y))
  lab b := 200*((linear xyz:Y ill_Y)-(linear xyz:Z ill_Z))


function 'cast ColorLab' lch -> lab
  arg ColorLCh lch ; arg ColorLab lab
  lab L := lch L
  lab a := lch:C*(cos lch:h*pi/180)
  if lab:a=undefined
    lab a := 0
  lab b := lch:C*(sin lch:h*pi/180)
  if lab:b=undefined
    lab b := 0

function 'cast ColorLCh' lab -> lch
  arg ColorLab lab ; arg ColorLCh lch
  lch L := lab L
  lch C := (lab:a*lab:a+lab:b*lab:b)^0.5
  if lch:C=undefined
    lch C := 0
  lch h := (angle lab:a lab:b)*180/pi


export cie_rgb 'cast ColorLab' 'cast ColorLCh' 'cast ColorLab' lab_linear


function lab_distance ref test -> d
  arg ColorLab ref test ; arg Float d
  var Float dL := abs ref:L-test:L
  var Float da := abs ref:a-test:a
  var Float db := abs ref:b-test:b
  d := ( pow2:dL + pow2:da + pow2:db )^0.5
  if d=undefined
    d := 0

function lab_distance ref test -> d
  arg ColorXYZ ref test ; arg Float d
  d := lab_distance (cast ref ColorLab) (cast test ColorLab)
 
export lab_distance


function cmc_distance ref test l c -> d
  arg ColorLab ref test ; arg Float l c d
  var Float e := lab_distance ref test
  var ColorLCh ref_lch := cast ref ColorLCh
  var ColorLCh test_lch := cast test ColorLCh
  var Float dL := abs ref:L-test:L
  var Float dC := abs ref_lch:C-test_lch:C
  var Float dH := ( pow2:e - pow2:dL - pow2:dC )^0.5
  if dH=undefined
    dH := 0
  var Float L := ref_lch L
  var Float C := ref_lch C
  var Float h := ref_lch h
  if h=undefined
    h := 0
  var Float Sl
  if L>=16
    Sl := 0.040975*L/(1+0.01765*L)
  else
    Sl := 0.511
  var Float Sc := 0.0638*C/(1+0.01231*C)+0.638
  var Float f := (C^4/(C^4+1900))^0.5
  if f=undefined
    f := 0
  var Float T
  if h<164 or h>345
    T := 0.36+(abs 0.4*(cos (h+35)*pi/180))
  else
    T := 0.56+(abs 0.2*(cos (h+168)*pi/180))
  var Float Sh := (f*T+1-f)*Sc
  d := ( (pow2 dL/(l*Sl)) + (pow2 dC/(c*Sc)) + (pow2 dH/Sh) )^0.5
  if d=undefined
    d := 0

gvar Float cmc_distance_l_parameter := 1.4
gvar Float cmc_distance_c_parameter := 1

function cmc_distance ref test -> d
  arg ColorLab ref test ; arg Float d
  d := cmc_distance ref test 1 1
  d := cmc_distance ref test cmc_distance_l_parameter cmc_distance_c_parameter

function cmc_distance ref test -> d
  arg ColorXYZ ref test ; arg Float d
  d := cmc_distance (cast ref ColorLab) (cast test ColorLab)
 
export cmc_distance
export cmc_distance cmc_distance_l_parameter cmc_distance_c_parameter