color-picker: pick a bunch of color types

mrjbq7 · May 2, 2023 · 8280cfa · 8280cfa
1 parent 003159b
commit 8280cfa
Showing 1 changed file with 63 additions and 23 deletions.
diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor
@@ -1,9 +1,14 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See https://factorcode.org/license.txt for BSD license.
-USING: accessors colors formatting kernel math math.vectors
-models models.arrow models.product models.range sequences ui
-ui.gadgets ui.gadgets.labels ui.gadgets.packs ui.gadgets.sliders
+
+USING: accessors classes.tuple colors colors.hsl colors.hsv
+colors.hwb colors.ryb colors.xyy colors.xyz colors.yiq
+colors.yuv formatting inverse kernel math math.functions models
+models.arrow models.product models.range quotations sequences
+splitting ui ui.gadgets ui.gadgets.borders ui.gadgets.labels
+ui.gadgets.packs ui.gadgets.sliders ui.gadgets.tabbed
 ui.gadgets.tracks ui.pens.solid ui.tools.common ;
+
 IN: color-picker
 
 ! Simple example demonstrating the use of models.
@@ -13,34 +18,69 @@ TUPLE: color-preview < gadget ;
 : <color-preview> ( model -- gadget )
     color-preview new
         swap >>model
-        { 200 200 } >>dim ;
+        { 300 300 } >>dim ;
 
 M: color-preview model-changed
-    swap value>> >>interior relayout-1 ;
+    swap value>> <solid> >>interior relayout-1 ;
 
-: <color-model> ( model -- model )
-    [ first3 [ 256 /f ] tri@ 1 <rgba> <solid> ] <arrow> ;
+: <color-model> ( model constructor -- model )
+    1quotation '[ first3 [ 255 /f ] tri@ 1.0 @ ] <arrow> ;
 
 : <color-slider> ( model -- gadget )
     horizontal <slider> 1 >>line ;
 
-: <color-sliders> ( -- gadget model )
-    3 [ 0 0 0 255 1 <range> ] replicate
-    [ <filled-pile> { 5 5 } >>gap [ <color-slider> add-gadget ] reduce ]
-    [ [ range-model ] map <product> ]
-    bi ;
+: <color-range> ( -- range )
+    0 0 0 255 1 <range> ;
+
+: <color-label> ( text -- label )
+    [ <label> dup font>> ] [ ?named-color [ >>foreground ] when* drop ] bi ;
+
+:: <color-sliders> ( constructor -- gadget model )
+    constructor def>> [ length 2 - ] [ ?nth ] bi
+    ?wrapped all-slots but-last [ name>> ] map
+    [ length [ <color-range> ] replicate ] keep
+    '[
+        _ <filled-pile> { 5 5 } >>gap [
+            [ <color-slider> ]
+            [ <color-label> label-on-left add-gadget ] bi*
+        ] 2reduce
+    ]
+    [ [ range-model ] map <product> constructor <color-model> ] bi ;
+
+: color>string ( color -- str )
+    >rgba-components drop [ 255 * round >integer ] tri@
+    3dup "%d %d %d #%02x%02x%02x" sprintf ;
+
+: <color-status> ( model -- gadget )
+    [ color>string ] <arrow> <label-control> ;
+
+: <color-picker> ( constructor -- gadget )
+    vertical <track> white-interior { 5 5 } >>gap
+    swap <color-sliders> [ f track-add ] dip
+    [ <color-preview> 1 track-add ]
+    [ <color-status> f track-add ] bi ;
 
-: color>str ( seq -- str )
-    vtruncate v>integer first3 3dup "%d %d %d #%02x%02x%02x" sprintf ;
+: <color-pickers> ( -- gadget )
+    <tabbed-gadget> {
+        <rgba>
+        <hwba>
+        <xyza>
+        <xyYa>
+        ! <laba>
+        ! <luva>
+        ! <cmyka>
+        <hsla>
+        <hsva>
+        <hwba>
+        <ryba>
+        <yiqa>
+        <yuva>
+        ! <gray>
 
-: <color-picker> ( -- gadget )
-    vertical <track> { 5 5 } >>gap
-    <color-sliders>
-    [ f track-add ]
-    [
-        [ <color-model> <color-preview> 1 track-add ]
-        [ [ color>str ] <arrow> <label-control> white-interior f track-add ] bi
-    ] bi* ;
+    } [
+        [ <color-picker> ]
+        [ name>> "<" ?head drop ">" ?tail drop add-tab ] bi
+    ] each ;
 
 MAIN-WINDOW: color-picker-window { { title "Color Picker" } }
-    <color-picker> >>gadgets ;
+    <color-pickers> { 5 5 } <border> >>gadgets ;