/pliant/graphic/color/color.pli
 
 1  abstract 
 2    [Tri values colors conversions] ; eol 
 3    link "extra details" "http://www.cs.rit.edu/~ncs/color/t_convert.html" 
 4    [ and ] 
 5    link "sRGB spec" "http://www.w3.org/Graphics/Color/sRGB.html" 
 6   
 7  module "/pliant/language/unsafe.pli" 
 8  module "spectrum.pli" 
 9  module "gradation.pli" 
 10  module "/pliant/math/functions.pli" 
 11  module "/pliant/math/matrix.pli" 
 12  module "/pliant/graphic/misc/float.pli" 
 13  submodule "rgb888.pli" 
 14   
 15  function angle xx yy -> a 
 16    arg Float xx yy a 
 17    var Float z 
 18    := xx ; := yy 
 19    if x>=0.0 
 20      if y>=0.0 
 21        := 0 
 22      else 
 23        := x ; := -y ; := z ; := 1.5*pi 
 24    else 
 25      if y>=0 
 26        := x ; := y ; := -z ; := 0.5*pi 
 27      else 
 28        := -x; := -y ; := pi 
 29    if y<=x 
 30      if x=0 
 31        := 0 
 32      := z+(atan y/x) 
 33    else 
 34      := z+0.5*pi-(atan x/y) 
 35   
 36   
 37  public 
 38    type ColorXYZ 
 39      field Float32 X Y Z 
 40   
 41    type ColorXYZn 
 42      field Float32 X Y Z 
 43   
 44    type ColorYxy 
 45      field Float32 Y x y 
 46   
 47    type ColorRGB 
 48      field Float32 r g b 
 49   
 50    type ColorHSV 
 51      field Float32 h s v 
 52   
 53    type ColorLab 
 54      field Float32 L a b 
 55   
 56    type ColorLCh 
 57      field Float32 L C h 
 58   
 59   
 60  function filter_XYZ s -> xyz 
 61    arg ColorSpectrum32 s ; arg ColorXYZ xyz 
 62    var ColorSpectrum32 final := illuminant_spectrum*s 
 63    xyz := final X 
 64    xyz := final Y 
 65    xyz := final Z 
 66   
 67  constant ill_X illuminant_spectrum:X 
 68  constant ill_Y illuminant_spectrum:Y 
 69  constant ill_Z illuminant_spectrum:Z 
 70   
 71  function filter_XYZn s -> xyz 
 72    arg ColorSpectrum32 s ; arg ColorXYZn xyz 
 73    var ColorSpectrum32 final := illuminant_spectrum*s 
 74    xyz := final:X/ill_X 
 75    xyz := final:Y/ill_Y 
 76    xyz := final:Z/ill_Z 
 77   
 78  function 'cast ColorYxy' xyz -> yxy 
 79    arg ColorXYZ xyz ; arg ColorYxy yxy 
 80    yxy := xyz Y 
 81    var Float := xyz:X+xyz:Y+xyz:Z 
 82    if f<=0 
 83      := 1 
 84    yxy := xyz:X/f 
 85    yxy := xyz:Y/f 
 86   
 87  function 'cast ColorXYZn' xyz -> xyzn 
 88    arg ColorXYZ xyz ; arg ColorXYZn xyzn 
 89    xyzn := xyz:X/ill_X 
 90    xyzn := xyz:Y/ill_Y 
 91    xyzn := xyz:Z/ill_Z 
 92   
 93  function 'cast ColorXYZ' xyzn -> xyz 
 94    arg ColorXYZn xyzn ; arg ColorXYZ xyz 
 95    xyz := xyzn:X*ill_X 
 96    xyz := xyzn:Y*ill_Y 
 97    xyz := xyzn:Z*ill_Z 
 98   
 99  function 'cast ColorXYZ' yxy -> xyz 
 100    arg ColorYxy yxy ; arg ColorXYZ xyz 
 101    xyz := yxy Y 
 102    var Float := yxy:Y/yxy:y 
 103    xyz := yxy:x*f 
 104    xyz := (1-yxy:x-yxy:y)*f 
 105   
 106  function rgb_matrix -> final 
 107    arg Matrix final 
 108    (var Matrix rgb_spec) resize 3 3 
 109    # red 
 110    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) 
 111    # green 
 112    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) 
 113    # blue 
 114    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) 
 115    var ColorXYZ white := filter_XYZ (cast ColorSpectrum32) 
 116    (var Matrix ill) resize 3 1 
 117    ill 0 0 := white:X 
 118    ill 1 0 := white: 
 119    ill 2 0 := white:Z 
 120    var Matrix coeff := rgb_spec^(-1)*ill 
 121    final resize 3 3 
 122    for (var Int l) 0 2 
 123      for (var Int c) 0 2 
 124        final := (coeff 0)*(rgb_spec c) 
 125   
 126  function display 
 127    constant rgb_matrix 
 128    for (var Int l) 0 2 
 129      for (var Int c) 0 2 
 130        console (c) " " 
 131      console eol 
 132  # display 
 133   
 134  function 'cast ColorRGB' xyz -> rgb 
 135    arg ColorXYZ xyz ; arg ColorRGB rgb 
 136    constant rgb_matrix^(-1) 
 137    rgb := (m 0 0)*xyz:X+(m 0 1)*xyz:Y+(m 0 2)*xyz:Z 
 138    rgb := (m 1 0)*xyz:X+(m 1 1)*xyz:Y+(m 1 2)*xyz:Z 
 139    rgb := (m 2 0)*xyz:X+(m 2 1)*xyz:Y+(m 2 2)*xyz:Z 
 140   
 141  function 'cast ColorXYZ' rgb -> xyz 
 142    arg ColorRGB rgb ; arg ColorXYZ xyz 
 143    constant rgb_matrix 
 144    xyz := (m 0 0)*rgb:r+(m 0 1)*rgb:g+(m 0 2)*rgb:b 
 145    xyz := (m 1 0)*rgb:r+(m 1 1)*rgb:g+(m 1 2)*rgb:b 
 146    xyz := (m 2 0)*rgb:r+(m 2 1)*rgb:g+(m 2 2)*rgb:b 
 147   
 148  function test 
 149    var ColorXYZ xyz := filter_XYZ (cast ColorSpectrum32) 
 150    var ColorRGB rgb := cast xyz ColorRGB 
 151    console "r = " rgb:"  g = " rgb:"  b = " rgb:eol 
 152  # test 
 153   
 154  gvar ColorGradation rgb_gradation := color_gamma 2.4 0.03928 0.055 
 155   
 156  function 'cast ColorRGB888' rgb -> rgb888 
 157    arg ColorRGB rgb ; arg ColorRGB888 rgb888 
 158    reduction 
 159    rgb888 := rgb_gradation encode rgb:r 
 160    rgb888 := rgb_gradation encode rgb:g 
 161    rgb888 := rgb_gradation encode rgb:b 
 162   
 163  function 'cast ColorRGB' rgb888 -> rgb 
 164    arg ColorRGB888 rgb888 ; arg ColorRGB rgb 
 165    extension 
 166    rgb := rgb_gradation decode rgb888:r 
 167    rgb := rgb_gradation decode rgb888:g 
 168    rgb := rgb_gradation decode rgb888:b 
 169   
 170  function 'cast ColorRGB' hsv -> rgb 
 171    arg ColorHSV hsv ; arg ColorRGB rgb 
 172    check hsv:h>=and hsv:h<360 
 173    check hsv:s>=and hsv:s<=1 
 174    check hsv:v>=and hsv:v<=1 
 175    var Float := hsv s 
 176    var Float := hsv v 
 177    if hsv:s=0 
 178      rgb := v 
 179      rgb := v 
 180      rgb := v 
 181      return 
 182    var Float := hsv:h/60 
 183    var Int := cast h-0.5 Int 
 184    check i>=and i<=5 
 185    var Float := h-i 
 186    var Float := v*(1-s) 
 187    var Float := v*(1-s*f) 
 188    var Float := v*(1-s*(1-f)) 
 189    if i=0 
 190      rgb := v 
 191      rgb := t 
 192      rgb := p 
 193    eif i=1 
 194      rgb := q 
 195      rgb := v 
 196      rgb := p 
 197    eif i=2 
 198      rgb := p 
 199      rgb := v 
 200      rgb := t 
 201    eif i=3 
 202      rgb := p 
 203      rgb := q 
 204      rgb := v 
 205    eif i=4 
 206      rgb := t 
 207      rgb := p 
 208      rgb := v 
 209    else # i=5 
 210      rgb := v 
 211      rgb := p 
 212      rgb := q 
 213   
 214  function 'cast ColorHSV' rgb -> hsv 
 215    arg ColorRGB rgb ; arg ColorHSV hsv 
 216    # check rgb:r>=0 and rgb:r<=1 
 217    # check rgb:g>=0 and rgb:g<=1 
 218    # check rgb:b>=0 and rgb:b<=1 
 219    var Float min := min (min rgb:rgb:g) rgb:b 
 220    var Float max := max (max rgb:rgb:g) rgb:b 
 221    hsv := max 
 222    var Float delta := max-min 
 223    if max>0 
 224      hsv := delta/max 
 225    else # r=g=b=0 -> s=0, v=undefined 
 226      hsv := 0 
 227      hsv := undefined 
 228      return 
 229    var Float h 
 230    if rgb:r=max 
 231      := (rgb:g-rgb:b)/delta 
 232    eif rgb:g=max 
 233      := 2+(rgb:b-rgb:r)/delta 
 234    else 
 235      := 4+(rgb:r-rgb:g)/delta 
 236    *= 60 
 237    if h<0 
 238      += 360 
 239    hsv := h 
 240   
 241  export filter_XYZ filter_XYZn 
 242  export 'cast ColorXYZ' 'cast ColorXYZn' 'cast ColorYxy' 'cast ColorRGB' 'cast ColorRGB888' 'cast ColorHSV' 
 243   
 244   
 245  gvar Matrix r 
 246   
 247  function r_setup 
 248    var Matrix m 
 249    resize 3 3 
 250    0 0 := 0.49    ; 0 1 := 0.31    ; 0 2 := 0.20 
 251    1 0 := 0.17697 ; 1 1 := 0.81240 ; 1 2 := 0.01063 
 252    2 0 := 0       ; 2 1 := 0.01    ; 2 2 := 0.99 
 253    := m^(-1) 
 254    if false 
 255      for (var Int l) 0 2 
 256        for (var Int c) 0 2 
 257          console (r l c) " " 
 258        console eol 
 259  r_setup 
 260   
 261  function cie_rgb xyz -> rgb 
 262    arg ColorXYZ xyz ; arg ColorRGB rgb 
 263    rgb := (0 0)*xyz:+ (0 1)*xyz:+ (0 2)*xyz:Z 
 264    rgb := (1 0)*xyz:+ (1 1)*xyz:+ (1 2)*xyz:Z 
 265    rgb := (2 0)*xyz:+ (2 1)*xyz:+ (2 2)*xyz:Z 
 266   
 267  function uniform v w -> u 
 268    arg Float u 
 269    if v/w>0.008856 
 270      := (v/w)^(1/3) 
 271    else 
 272      := 7.787*v/w+16/116 
 273   
 274  function 'cast ColorLab' xyz -> lab 
 275    arg ColorXYZ xyz ; arg ColorLab lab 
 276    lab := 116*(uniform xyz:ill_Y)-16 
 277    lab := 500*((uniform xyz:ill_X)-(uniform xyz:ill_Y)) 
 278    lab := 200*((uniform xyz:ill_Y)-(uniform xyz:ill_Z)) 
 279   
 280   
 281  function linear1 u -> l 
 282    arg Float l 
 283    if u>9.03296295513076*0.008856 
 284      := ((u+0.16)/1.16) 3 
 285    else 
 286      := u/9.03296295513076 
 287   
 288  function 'cast ColorXYZ' lab -> xyz 
 289    arg ColorLab lab ; arg ColorXYZ xyz 
 290    xyz := (linear1 lab:a*1.16/500.0 lab:L/100.0) ill_X 
 291    xyz := (linear1 lab:L/100) ill_Y 
 292    xyz := (linear1 lab:L/100 lab:b*1.16/200) ill_Z 
 293   
 294   
 295  function linear2 v w -> u 
 296    arg Float u 
 297    := v/w 
 298   
 299  function lab_linear xyz -> lab 
 300    arg ColorXYZ xyz ; arg ColorLab lab 
 301    lab := 100*(linear2 xyz:ill_Y) 
 302    lab := 500*((linear2 xyz:ill_X)-(linear2 xyz:ill_Y)) 
 303    lab := 200*((linear2 xyz:ill_Y)-(linear2 xyz:ill_Z)) 
 304   
 305   
 306  function 'cast ColorLab' lch -> lab 
 307    arg ColorLCh lch ; arg ColorLab lab 
 308    lab := lch L 
 309    lab := lch:C*(cos lch:h*pi/180) 
 310    if lab:a=undefined 
 311      lab := 0 
 312    lab := lch:C*(sin lch:h*pi/180) 
 313    if lab:b=undefined 
 314      lab := 0 
 315   
 316  function 'cast ColorLCh' lab -> lch 
 317    arg ColorLab lab ; arg ColorLCh lch 
 318    lch := lab L 
 319    lch := (lab:a*lab:a+lab:b*lab:b)^0.5 
 320    if lch:C=undefined 
 321      lch := 0 
 322    lch := (angle lab:lab:b)*180/pi 
 323   
 324   
 325  export cie_rgb 'cast ColorXYZ' 'cast ColorLab' 'cast ColorLCh' 'cast ColorLab' lab_linear 
 326   
 327   
 328  function lab_distance ref test -> d 
 329    arg ColorLab ref test ; arg Float d 
 330    var Float dL := abs ref:L-test:L 
 331    var Float da := abs ref:a-test:a 
 332    var Float db := abs ref:b-test:b 
 333    := ( pow2:dL pow2:da pow2:db )^0.5 
 334    if d=undefined 
 335      := 0 
 336   
 337  function lab_distance ref test -> d 
 338    arg ColorXYZ ref test ; arg Float d 
 339    := lab_distance (cast ref ColorLab) (cast test ColorLab) 
 340    
 341  export lab_distance 
 342   
 343   
 344  function cmc_distance ref test l c -> d 
 345    arg ColorLab ref test ; arg Float d 
 346    var Float := lab_distance ref test 
 347    if l=undefined or c=undefined 
 348      return e 
 349    var ColorLCh ref_lch := cast ref ColorLCh 
 350    var ColorLCh test_lch := cast test ColorLCh 
 351    var Float dL := abs ref:L-test:L 
 352    var Float dC := abs ref_lch:C-test_lch:C 
 353    var Float dH := ( pow2:pow2:dL pow2:dC )^0.5 
 354    if dH=undefined 
 355      dH := 0 
 356    var Float := min ref_lch:test_lch:L 
 357    var Float := max ref_lch:test_lch:C 
 358    var Float := ref_lch h 
 359    if h=undefined 
 360      := 0 
 361    var Float Sl 
 362    if L>=16 
 363      Sl := 0.040975*L/(1+0.01765*L) 
 364    else 
 365      Sl := 0.511 
 366    var Float Sc := 0.0638*C/(1+0.0131*C)+0.638 
 367    var Float := (C^4/(C^4+1900))^0.5 
 368    if f=undefined 
 369      := 0 
 370    var Float T 
 371    if h<164 or h>345 
 372      := 0.36+(abs 0.4*(cos (h+35)*pi/180)) 
 373    else 
 374      := 0.56+(abs 0.2*(cos (h+168)*pi/180)) 
 375    var Float Sh := (f*T+1-f)*Sc 
 376    := ( (pow2 dL/(l*Sl)) + (pow2 dC/(c*Sc)) + (pow2 dH/Sh) )^0.5 
 377    if d=undefined 
 378      := 0 
 379   
 380  gvar Float cmc_distance_l_parameter := 1 
 381  gvar Float cmc_distance_c_parameter := 1 
 382   
 383  function cmc_distance ref test -> d 
 384    arg ColorLab ref test ; arg Float d 
 385    := cmc_distance ref test cmc_distance_l_parameter cmc_distance_c_parameter 
 386   
 387  function cmc_distance ref test l c -> d 
 388    arg ColorXYZ ref test ; arg Float c ; arg Float d 
 389    := cmc_distance (cast ref ColorLab) (cast test ColorLab) c 
 390    
 391  function cmc_distance ref test -> d 
 392    arg ColorXYZ ref test ; arg Float d 
 393    := cmc_distance (cast ref ColorLab) (cast test ColorLab) 
 394    
 395  export cmc_distance cmc_distance_l_parameter cmc_distance_c_parameter