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