basis/colors/lch/lch.factor

   1 ! Copyright (C) 2014 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors colors colors.lab colors.luv colors.xyz kernel
   5 math math.functions math.libm math.trig ;
   6
   7 IN: colors.lch
   8
   9 TUPLE: LCHuv l c h alpha ;
  10
  11 C: <LCHuv> LCHuv
  12
  13 M: LCHuv >rgba >luva >rgba ;
  14
  15 M: LCHuv >xyza >luva >xyza ;
  16
  17 M: LCHuv >luva
  18     [
  19         [let
  20             [ l>> ] [ c>> ] [ h>> ] tri :> ( l c h )
  21             h deg>rad :> hr
  22
  23             l
  24             c hr cos *
  25             c hr sin *
  26         ]
  27     ] [ alpha>> ] bi <luva> ;
  28
  29 GENERIC: >LCHuv ( color -- LCHuv )
  30
  31 M: object >LCHuv >luva >LCHuv ;
  32
  33 M: LCHuv >LCHuv ; inline
  34
  35 M: luva >LCHuv
  36     [
  37         [let
  38             [ l>> ] [ u>> ] [ v>> ] tri :> ( l u v )
  39             v u fatan2 rad>deg
  40             [ dup 360 > ] [ 360 - ] while
  41             [ dup 0 < ] [ 360 + ] while :> h
  42
  43             l
  44             u sq v sq + sqrt
  45             h
  46         ]
  47     ] [ alpha>> ] bi <LCHuv> ;
  48
  49 TUPLE: LCHab l c h alpha ;
  50
  51 C: <LCHab> LCHab
  52
  53 M: LCHab >rgba >laba >rgba ;
  54
  55 M: LCHab >laba
  56     [
  57         [let
  58             [ l>> ] [ c>> ] [ h>> ] tri :> ( l c h )
  59             h deg>rad :> hr
  60
  61             l
  62             c hr cos *
  63             c hr sin *
  64         ]
  65     ] [ alpha>> ] bi <laba> ;
  66
  67 GENERIC: >LCHab ( color -- LCHab )
  68
  69 M: object >LCHab >laba >LCHab ;
  70
  71 M: LCHab >LCHab ; inline
  72
  73 M: laba >LCHab
  74     [
  75         [let
  76             [ l>> ] [ a>> ] [ b>> ] tri :> ( l a b )
  77             b a fatan2 rad>deg
  78             [ dup 360 > ] [ 360 - ] while
  79             [ dup 0 < ] [ 360 + ] while :> h
  80
  81             l
  82             a sq b sq + sqrt
  83             h
  84         ]
  85     ] [ alpha>> ] bi <LCHab> ;