basis/colors/lab/lab.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.lab
   8
   9 TUPLE: laba l a b alpha ;
  10
  11 C: <laba> laba
  12
  13 INSTANCE: laba color
  14
  15 M: laba >rgba >xyza >rgba ;
  16
  17 M: laba >xyza
  18     [
  19         [let
  20             [ l>> ] [ a>> ] [ b>> ] tri :> ( l a b )
  21             l 16 + 116 / :> fy
  22             a 500 / fy + :> fx
  23             fy b 200 / - :> fz
  24
  25             fx 3 ^ :> fx3
  26             fz 3 ^ :> fz3
  27
  28             fx3 xyz_epsilon > [
  29                 fx3
  30             ] [
  31                 116 fx * 16 - xyz_kappa /
  32             ] if :> x
  33
  34             l xyz_kappa xyz_epsilon * > [
  35                 l 16 + 116 / 3 ^
  36             ] [
  37                 l xyz_kappa /
  38             ] if :> y
  39
  40             fz3 xyz_epsilon > [
  41                 fz3
  42             ] [
  43                 116 fz * 16 - xyz_kappa /
  44             ] if :> z
  45
  46             x wp_x * y wp_y * z wp_z *
  47         ]
  48     ] [ alpha>> ] bi <xyza> ;
  49
  50 GENERIC: >laba ( color -- laba )
  51
  52 M: object >laba >rgba >laba ;
  53
  54 M: rgba >laba >xyza >laba ;
  55
  56 M: xyza >laba
  57     [
  58         [let
  59             [ x>> wp_x / ] [ y>> wp_y / ] [ z>> wp_z / ] tri
  60             [
  61                 dup xyz_epsilon >
  62                 [ 1/3 ^ ] [ xyz_kappa * 16 + 116 / ] if
  63             ] tri@ :> ( fx fy fz )
  64             116 fy * 16 -
  65             500 fx fy - *
  66             200 fy fz - *
  67         ]
  68     ] [ alpha>> ] bi <laba> ;