basis/colors/luv/luv.factor

   1 ! Copyright (C) 2014 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors colors colors.xyz colors.xyz.private kernel
   5 math math.functions ;
   6
   7 IN: colors.luv
   8
   9 TUPLE: luva l u v alpha ;
  10
  11 C: <luva> luva
  12
  13 <PRIVATE
  14
  15 :: xyz-to-uv ( x y z -- u v )
  16     x y 15 * z 3 * + + :> d
  17     4 x * d /
  18     9 y * d / ; foldable
  19
  20 PRIVATE>
  21
  22 M: luva >rgba >xyza >rgba ;
  23
  24 M: luva >xyza
  25     [
  26         [let
  27             wp_x wp_y wp_z xyz-to-uv :> ( u_wp v_wp )
  28             [ l>> ] [ u>> ] [ v>> ] tri :> ( l u v )
  29
  30             52 l * 13 l * u_wp * u + / 1 - 3 / :> a
  31             l xyz_kappa xyz_epsilon * > [
  32                 l 16 + 116 / 3 ^ wp_y *
  33             ] [
  34                 l xyz_kappa / wp_y *
  35             ] if :> y
  36             y -5 * :> b
  37             39 l * 13 l * v_wp * v + / 5 - y * :> d
  38             d b - a 1/3 + / :> x
  39             a x * b + :> z
  40
  41             x y z
  42         ]
  43     ] [ alpha>> ] bi <xyza> ;
  44
  45 GENERIC: >luva ( color -- luva )
  46
  47 M: object >luva >rgba >luva ;
  48
  49 M: rgba >luva >xyza >luva ;
  50
  51 M: luva >luva ; inline
  52
  53 M: xyza >luva
  54     [
  55         [let
  56             wp_x wp_y wp_z xyz-to-uv :> ( u_wp v_wp )
  57             [ x>> ] [ y>> ] [ z>> ] tri :> ( x_ y_ z_ )
  58             x_ y_ z_ xyz-to-uv :> ( u_ v_ )
  59
  60             y_ wp_y / :> y
  61
  62             y xyz_epsilon > [
  63                 y 1/3 ^ 116 * 16 -
  64             ] [
  65                 xyz_kappa y *
  66             ] if :> l
  67             13 l * u_ u_wp - * :> u
  68             13 l * v_ v_wp - * :> v
  69
  70             l u v
  71         ]
  72     ] [ alpha>> ] bi <luva> ;