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