basis/colors/xyz/xyz.factor

   1 ! Copyright (C) 2014 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors colors kernel math math.functions
   5 math.order ;
   6
   7 IN: colors.xyz
   8
   9 TUPLE: xyza x y z alpha ;
  10
  11 C: <xyza> xyza
  12
  13 <PRIVATE
  14
  15 CONSTANT: xyz_epsilon 216/24389
  16 CONSTANT: xyz_kappa 24389/27
  17
  18 CONSTANT: wp_x 0.95047
  19 CONSTANT: wp_y 1.00000
  20 CONSTANT: wp_z 1.08883
  21
  22 : srgb-compand ( v -- v' )
  23     dup 0.0031308 <= [ 12.92 * ] [ 2.4 recip ^ 1.055 * 0.055 - ] if ;
  24
  25 PRIVATE>
  26
  27 M: xyza >rgba
  28     [
  29         [let
  30             [ x>> ] [ y>> ] [ z>> ] tri :> ( x y z )
  31             x 3.2404542 * y -1.5371385 * z -0.4985314 * + +
  32             x -0.9692660 * y 1.8760108 * z 0.0415560 * + +
  33             x 0.0556434 * y -0.2040259 * z 1.0572252 * + +
  34             [ srgb-compand 0.0 1.0 clamp ] tri@
  35         ]
  36     ] [ alpha>> ] bi <rgba> ;
  37
  38 GENERIC: >xyza ( color -- xyza )
  39
  40 M: object >xyza >rgba >xyza ;
  41
  42 M: xyza >xyza ; inline
  43
  44 <PRIVATE
  45
  46 : invert-rgb-compand ( v -- v' )
  47     dup 0.04045 <= [ 12.92 / ] [ 0.055 + 1.055 / 2.4 ^ ] if ;
  48
  49 PRIVATE>
  50
  51 M: rgba >xyza
  52     [
  53         [let
  54             [ red>> ] [ green>> ] [ blue>> ] tri
  55             [ invert-rgb-compand ] tri@ :> ( r g b )
  56             r 0.4124564 * g 0.3575761 * b 0.1804375 * + +
  57             r 0.2126729 * g 0.7151522 * b 0.0721750 * + +
  58             r 0.0193339 * g 0.1191920 * b 0.9503041 * + +
  59         ]
  60     ] [ alpha>> ] bi <xyza> ;