basis/colors/ryb/ryb.factor

   1 ! Copyright (C) 2013 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors colors kernel math math.order ;
   5
   6 IN: colors.ryb
   7
   8 TUPLE: ryba
   9     { red read-only }
  10     { yellow read-only }
  11     { blue read-only }
  12     { alpha read-only } ;
  13
  14 C: <ryba> ryba
  15
  16 INSTANCE: ryba color
  17
  18 <PRIVATE
  19
  20 : normalized ( a b c quot: ( a b c -- a' b' c' ) -- a' b' c' )
  21     [ 3dup min min ] dip over
  22     [ [ - ] curry tri@ ]
  23     [ call ]
  24     [ [ + ] curry tri@ ] tri* ; inline
  25
  26 :: ryb>rgb ( r! y! b! -- r g b )
  27     r y b max max :> my
  28
  29     y b min :> g!
  30     y g - y!
  31     b g - b!
  32
  33     b g [ 0 > ] both? [
  34         b 2 * b!
  35         g 2 * g!
  36     ] when
  37
  38     r y + r!
  39     g y + g!
  40
  41     r g b 3dup max max [
  42         my swap / [ * ] curry tri@
  43     ] unless-zero ;
  44
  45 :: rgb>ryb ( r! g! b! -- r y b )
  46     r g b max max :> mg
  47
  48     r g min :> y!
  49     r y - r!
  50     g y - g!
  51
  52     b g [ 0 > ] both? [
  53         b 2 /f b!
  54         g 2 /f g!
  55     ] when
  56
  57     y g + y!
  58     b g + b!
  59
  60     r y b 3dup max max [
  61         mg swap / [ * ] curry tri@
  62     ] unless-zero ;
  63
  64 PRIVATE>
  65
  66 M: ryba >rgba
  67     [
  68         [ red>> ] [ yellow>> ] [ blue>> ] tri
  69         [ ryb>rgb ] normalized
  70     ] [ alpha>> ] bi <rgba> ;
  71
  72 GENERIC: >ryba ( color -- ryba )
  73
  74 M: object >ryba >rgba >ryba ;
  75
  76 M: ryba >ryba ; inline
  77
  78 M: rgba >ryba
  79     >rgba-components [ [ rgb>ryb ] normalized ] [ <ryba> ] bi* ;