steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

colors.lch: implement CIELCH colors.

db4
John Benediktsson 2014-06-24 06:58:02 -07:00
parent 08dcbdc949
commit 3a9f4edcff
4 changed files with 128 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
extra/colors/lch/authors.txt Normal file
View File

@ -0,0 +1 @@
John Benediktsson

31
extra/colors/lch/lch-tests.factor Normal file
View File

@ -0,0 +1,31 @@
! Copyright (C) 2014 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
USING: arrays colors kernel locals math.functions math.ranges
sequences tools.test ;
IN: colors.lch
{ t } [
0.0 1.0 0.1 <range> [| r |
0.0 1.0 0.1 <range> [| g |
0.0 1.0 0.1 <range> [| b |
r g b 1.0 <rgba> dup >LCHuv >rgba
[ >rgba-components 4array ] bi@
[ 0.00001 ~ ] 2all?
] all?
] all?
] all?
] unit-test
{ t } [
0.0 1.0 0.1 <range> [| r |
0.0 1.0 0.1 <range> [| g |
0.0 1.0 0.1 <range> [| b |
r g b 1.0 <rgba> dup >LCHab >rgba
[ >rgba-components 4array ] bi@
[ 0.00001 ~ ] 2all?
] all?
] all?
] all?
] unit-test

95
extra/colors/lch/lch.factor Normal file
View File

@ -0,0 +1,95 @@
! Copyright (C) 2014 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
USING: accessors colors colors.lab colors.luv colors.xyz kernel
locals math math.constants math.functions math.libm ;
IN: colors.lch
TUPLE: LCHuv l c h alpha ;
C: <LCHuv> LCHuv
<PRIVATE
: deg>rad ( degrees -- radians )
pi * 180 / ; inline
: rad>deg ( radians -- degrees )
180 * pi / ; inline
PRIVATE>
M: LCHuv >rgba >luva >rgba ;
M: LCHuv >xyza >luva >xyza ;
M: LCHuv >luva
[
[let
[ l>> ] [ c>> ] [ h>> ] tri :> ( l c h )
h deg>rad :> hr
l
c hr cos *
c hr sin *
]
] [ alpha>> ] bi <luva> ;
GENERIC: >LCHuv ( color -- LCHuv )
M: object >LCHuv >luva >LCHuv ;
M: LCHuv >LCHuv ; inline
M: luva >LCHuv
[
[let
[ l>> ] [ u>> ] [ v>> ] tri :> ( l u v )
v u fatan2 rad>deg
[ dup 360 > ] [ 360 - ] while
[ dup 0 < ] [ 360 + ] while :> h
l
u sq v sq + sqrt
h
]
] [ alpha>> ] bi <LCHuv> ;
TUPLE: LCHab l c h alpha ;
C: <LCHab> LCHab
M: LCHab >rgba >laba >rgba ;
M: LCHab >laba
[
[let
[ l>> ] [ c>> ] [ h>> ] tri :> ( l c h )
h deg>rad :> hr
l
c hr cos *
c hr sin *
]
] [ alpha>> ] bi <laba> ;
GENERIC: >LCHab ( color -- LCHab )
M: object >LCHab >laba >LCHab ;
M: LCHab >LCHab ; inline
M: laba >LCHab
[
[let
[ l>> ] [ a>> ] [ b>> ] tri :> ( l a b )
b a fatan2 rad>deg
[ dup 360 > ] [ 360 - ] while
[ dup 0 < ] [ 360 + ] while :> h
l
a sq b sq + sqrt
h
]
] [ alpha>> ] bi <LCHab> ;

1
extra/colors/lch/summary.txt Normal file
View File

@ -0,0 +1 @@
CIELCH colors