basis/colors/lch/lch.factor

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