extra/colors/distances/distances.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.lch kernel math
   5 math.functions math.libm math.order math.trig ;
   6
   7 IN: colors.distances
   8
   9 : rgba-distance ( color1 color2 -- distance )
  10     [ >rgba ] bi@
  11     [ [ red>> ] bi@ - sq ]
  12     [ [ blue>> ] bi@ - sq ]
  13     [ [ green>> ] bi@ - sq ] 2tri
  14     + + sqrt ;
  15
  16 <PRIVATE
  17
  18 :: mean-hue ( h1 h2 -- mh )
  19     h2 h1 - abs 180 > [
  20         h1 h2 + dup 360 < [
  21             360 + 2 /
  22         ] [
  23             360 - 2 /
  24         ] if
  25     ] [
  26         h1 h2 + 2 /
  27     ] if ;
  28
  29 :: diff-hue ( h1 h2 -- dh )
  30     h2 h1 - dup abs 180 > [
  31         dup 0 <= [ 360 + ] [ 360 - ] if
  32     ] when ;
  33
  34 : sind ( x -- y ) deg>rad sin ;
  35
  36 : cosd ( x -- y ) deg>rad cos ;
  37
  38 : atan2d ( x y -- z ) [ deg>rad ] bi@ fatan2 ;
  39
  40 PRIVATE>
  41
  42 :: CIEDE2000 ( color1 color2 -- distance )
  43
  44     ! Ensure inputs are L*C*H*
  45     color1 >LCHab :> lch1
  46     color2 >LCHab :> lch2
  47
  48     lch1 lch2 [ l>> ] bi@ :> ( l1 l2 )
  49     lch1 lch2 [ c>> ] bi@ :> ( c1 c2 )
  50     lch1 lch2 [ h>> ] bi@ :> ( h1 h2 )
  51
  52     ! Calculate the delta values for each channel
  53     l2 l1 - :> dl
  54     c2 c1 - :> dc
  55     c2 c1 * zero? [ 0 ] [ h1 h2 diff-hue ] if
  56     2 / sind c1 c2 * sqrt * 2 * :> dh
  57
  58     ! Calculate mean values
  59     l1 l2 + 2 / :> ml
  60     c1 c2 + 2 / :> mc
  61     c2 c1 * zero? [ 0 ] [ h1 h2 mean-hue ] if :> mh
  62
  63     ! Lightness weight
  64     ml 50 - sq :> mls
  65     mls dup 20 + sqrt / 0.015 * 1 + :> sl
  66
  67     ! Chroma weight
  68     mc 0.045 * 1 + :> sc
  69
  70     ! Hue weight
  71     1
  72     mh 30 - cosd 0.17 * -
  73     mh 2 * cosd 0.24 * +
  74     mh 3 * 6 + cosd 0.32 * +
  75     mh 4 * 63 - cosd 0.20 * - :> T
  76     0.015 mc * T * 1 + :> sh
  77
  78     ! Rotation term
  79     mh 275 - 25 / sq neg e^ 30 * :> dtheta
  80     mc 7 ^ dup 25 7 ^ + / sqrt 2 * :> cr
  81     dtheta 2 * sind neg cr * :> tr
  82
  83     ! Final calculation
  84     dl sl / sq
  85     dc sc /
  86     dh sh /
  87     [ [ sq ] bi@ ] [ * tr * ] 2bi
  88     + + + sqrt ;
  89
  90 :: CIE94 ( color1 color2 -- distance )
  91
  92     ! Ensure inputs are L*a*b*
  93     color1 >laba :> lab1
  94     color2 >laba :> lab2
  95
  96     lab1 lab2 [ l>> ] bi@ :> ( l1 l2 )
  97     lab1 lab2 [ a>> ] bi@ :> ( a1 a2 )
  98     lab1 lab2 [ b>> ] bi@ :> ( b1 b2 )
  99
 100     ! Calculate the delta values for each channel
 101     l2 l1 - :> dl
 102     a2 a1 - :> da
 103     b2 b1 - :> db
 104     a1 sq b1 sq + sqrt :> c1
 105     a2 sq b2 sq + sqrt :> c2
 106     c2 c1 - :> dc
 107     da sq db sq + dc sq - sqrt :> dh
 108
 109     ! graphics arts:
 110     1 0.045 0.015 :> ( kl k1 k2 )
 111
 112     ! textiles:
 113     ! 2 0.048 0.014 :> ( kl k1 k2 )
 114
 115     kl :> sl
 116     k1 c1 * 1 + :> sc
 117     k2 c1 * 1 + :> sh
 118
 119     dl sl / sq
 120     dc sc / sq +
 121     dh sh / sq + sqrt ;
 122
 123 : CIE76 ( color1 color2 -- distance )
 124     [ >laba ] bi@
 125     [ [ l>> ] bi@ - sq ]
 126     [ [ a>> ] bi@ - sq ]
 127     [ [ b>> ] bi@ - sq ] 2tri
 128     + + sqrt ;
 129
 130 :: CMC-l:c ( color1 color2 -- distance )
 131
 132     ! Ensure inputs are L*a*b*
 133     color1 >laba :> lab1
 134     color2 >laba :> lab2
 135
 136     lab1 lab2 [ a>> ] bi@ :> ( a1 a2 )
 137     lab1 lab2 [ b>> ] bi@ :> ( b1 b2 )
 138
 139     ! Ensure inputs are L*C*H*
 140     color1 >LCHab :> lch1
 141     color2 >LCHab :> lch2
 142
 143     lch1 lch2 [ l>> ] bi@ :> ( l1 l2 )
 144     lch1 lch2 [ c>> ] bi@ :> ( c1 c2 )
 145     lch1 lch2 [ h>> ] bi@ :> ( h1 h2 )
 146
 147     a2 a1 - :> da
 148     b2 b1 - :> db
 149     c2 c1 - :> dc
 150     l2 l1 - :> dl
 151
 152     da sq db sq + dc sq - sqrt :> dh
 153
 154     l1 16 < [ 0.511 ] [
 155         l1 [ 0.040975 * ] [ 0.01765 * 1 + ] bi /
 156     ] if :> sl
 157
 158     c1 [ 0.0638 * ] [ 0.0131 * 1 + ] bi / 0.638 + :> sc
 159
 160     c1 4 ^ dup 1900 + / sqrt :> F
 161
 162     h1 164 345 between? [
 163         h1 168 + cosd 0.2 * abs 0.56 +
 164     ] [
 165         h1 35 + cosd 0.4 * abs 0.36 +
 166     ] if :> T
 167
 168     F T * 1 + F - sc * :> sh
 169
 170     2.0 :> kl ! default lightness
 171     1.0 :> kc ! default chroma
 172
 173     dl kl sl * / sq
 174     dc kc sc * / sq
 175     dh sh / sq + + sqrt ;