colors: adding sample-linear-gradient and some tests.

diff --git a/basis/colors/colors-docs.factor b/basis/colors/colors-docs.factor
index 53cca50b7ad8ffac2c5a93371b0f5bcdb0dd0729..bef12c6e377fa8e83605c47ff70fbe8b41762dd5 100644 (file)
--- a/basis/colors/colors-docs.factor
+++ b/basis/colors/colors-docs.factor
@@ -32,6 +32,11 @@ $nl
 { $subsections >rgba }
 "Extracting RGBA components of colors:"
 { $subsections >rgba-components }
+"Mixing colors:"
+{ $subsections
+    linear-gradient
+    sample-linear-gradient
+}
 "Further topics:"
 { $subsections
     "colors.protocol"
@@ -40,4 +45,4 @@ $nl
 { $vocab-subsection "Grayscale colors" "colors.gray" }
 { $vocab-subsection "HSV colors" "colors.hsv" } ;
 
-ABOUT: "colors"
\ No newline at end of file
+ABOUT: "colors"

diff --git a/basis/colors/colors.factor b/basis/colors/colors.factor
index 499fab7375c910524cf518dcf32406ba465e596b..ff4fe0539d8c744385cfea33b299b1a57bbc312d 100644 (file)
--- a/basis/colors/colors.factor
+++ b/basis/colors/colors.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2003, 2009 Slava Pestov.
 ! Copyright (C) 2008 Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators kernel math ;
+USING: accessors combinators kernel locals math sequences ;
 IN: colors
 
 TUPLE: color ;
@@ -34,5 +34,14 @@ CONSTANT: transparent T{ rgba f 0.0 0.0 0.0 0.0 }
     [ [ >rgba-components drop ] [ tri@ ] bi* ] 2bi@
     [ + ] tri-curry@ tri* 1.0 <rgba> ;
 
+:: sample-linear-gradient ( colors percent -- color )
+    colors length :> num-colors
+    num-colors 1 - percent * >integer :> left-index
+    1.0 num-colors 1 - / :> cell-range
+    percent left-index cell-range * - cell-range / :> alpha
+    left-index colors nth :> left-color
+    left-index 1 + num-colors mod colors nth :> right-color
+    left-color right-color alpha linear-gradient ;
+
 : inverse-color ( color -- color' )
     >rgba-components [ [ 1.0 swap - ] tri@ ] dip <rgba> ;