From a12051582288923c9e66845e1f44b216e614b108 Mon Sep 17 00:00:00 2001
From: Alex Maestas <git@se30.xyz>
Date: Sun, 20 Feb 2022 19:18:42 +0000
Subject: [PATCH] add color>hex

found basically the same thing in the color-table extra, but this one can
round-trip an alpha channel.
---
 basis/colors/colors-tests.factor     |  5 +++++
 basis/colors/colors.factor           | 13 +++++++++++++
 extra/color-table/color-table.factor |  6 +-----
 3 files changed, 19 insertions(+), 5 deletions(-)

diff --git a/basis/colors/colors-tests.factor b/basis/colors/colors-tests.factor
index e8e1763d3b..18a69b2ad1 100644
--- a/basis/colors/colors-tests.factor
+++ b/basis/colors/colors-tests.factor
@@ -18,3 +18,8 @@ ${ "ABCDEF" hex>rgba } [ COLOR: #abcdef value>> ] unit-test
 ${ "cafebabe" hex>rgba } [ COLOR: #cafebabe value>> ] unit-test
 ${ "112233" hex>rgba } [ COLOR: #112233 value>> ] unit-test
 ${ "11223344" hex>rgba } [ COLOR: #11223344 value>> ] unit-test
+
+{ "#00000000" } [ transparent color>hex ] unit-test
+{ "#cafebabe" } [ COLOR: #cafebabe color>hex ] unit-test
+{ "#112233" } [ COLOR: #112233 color>hex ] unit-test
+{ "#11223344" } [ COLOR: #11223344 color>hex ] unit-test
diff --git a/basis/colors/colors.factor b/basis/colors/colors.factor
index 7b3844c301..413b087f0c 100644
--- a/basis/colors/colors.factor
+++ b/basis/colors/colors.factor
@@ -71,8 +71,21 @@ ERROR: invalid-hex-color hex ;
         [ drop invalid-hex-color ]
     } case <rgba> ;
 
+: component>hex ( f -- s )
+    255 * round >integer >hex
+    2 CHAR: 0 pad-head ;
+
+: (color>hex) ( seq -- hex )
+    [ component>hex ] map concat
+    "#" prepend ;
+
 PRIVATE>
 
+: color>hex ( color -- hex )
+    [ >rgba-components 4array ] [ opaque? ] bi
+    [ but-last ] when
+    (color>hex) ;
+
 : named-colors ( -- keys ) colors keys ;
 
 ERROR: no-such-color name ;
diff --git a/extra/color-table/color-table.factor b/extra/color-table/color-table.factor
index 03914c67d3..6f518eea56 100644
--- a/extra/color-table/color-table.factor
+++ b/extra/color-table/color-table.factor
@@ -13,10 +13,6 @@ SINGLETON: color-renderer
 
 CONSTANT: full-block-string $[ 10 CHAR: full-block <string> ]
 
-: rgba>hex ( rgba -- hex )
-    [ red>> ] [ green>> ] [ blue>> ] tri
-    [ 255 * round >integer ] tri@ "%02X%02X%02X" sprintf ;
-
 PRIVATE>
 
 M: color-renderer filled-column
@@ -32,7 +28,7 @@ M: color-renderer row-columns
             [ red>> "%.5f" sprintf ]
             [ green>> "%.5f" sprintf ]
             [ blue>> "%.5f" sprintf ]
-            [ rgba>hex ]
+            [ color>hex ]
         } cleave
     ] output>array ;
 
-- 
2.34.1