color-picker: better tabs, more colors

mrjbq7 · May 3, 2023 · a4bd877 · a4bd877
1 parent fe714a5
commit a4bd877
Showing 1 changed file with 22 additions and 25 deletions.
diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor
@@ -1,13 +1,14 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See https://factorcode.org/license.txt for BSD license.
 
-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 ;
+USING: accessors classes.tuple colors colors.cmyk colors.gray
+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
+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
 
@@ -23,8 +24,8 @@ TUPLE: color-preview < gadget ;
 M: color-preview model-changed
     swap value>> <solid> >>interior relayout-1 ;
 
-: <color-model> ( model constructor -- model )
-    1quotation '[ first3 [ 255 /f ] tri@ 1.0 @ ] <arrow> ;
+: <color-model> ( model class -- model )
+    '[ [ 255 /f ] map 1.0 suffix _ slots>tuple ] <arrow> ;
 
 : <color-slider> ( model -- gadget )
     horizontal <slider> 1 >>line ;
@@ -36,16 +37,16 @@ M: color-preview model-changed
     [ <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 [
+    constructor def>> first ?wrapped :> color-class
+    color-class all-slots [ name>> ] map but-last :> slot-names
+    slot-names length [ <color-range> ] replicate
+    [
+        slot-names <filled-pile> { 5 5 } >>gap [
             [ <color-slider> ]
             [ <color-label> label-on-left add-gadget ] bi*
         ] 2reduce
     ]
-    [ [ range-model ] map <product> constructor <color-model> ] bi ;
+    [ [ range-model ] map <product> color-class <color-model> ] bi ;
 
 : color>string ( color -- str )
     >rgba-components drop [ 255 * round >integer ] tri@
@@ -55,32 +56,28 @@ M: color-preview model-changed
     [ color>string ] <arrow> <label-control> ;
 
 : <color-picker> ( constructor -- gadget )
-    vertical <track> white-interior { 5 5 } >>gap
+    vertical <track> { 5 5 } >>gap
     swap <color-sliders> [ f track-add ] dip
     [ <color-preview> 1 track-add ]
     [ <color-status> f track-add ] bi ;
 
 : <color-pickers> ( -- gadget )
     <tabbed-gadget> {
         <rgba>
-        <hwba>
-        <xyza>
-        <xyYa>
-        ! <laba>
-        ! <luva>
-        ! <cmyka>
         <hsla>
         <hsva>
         <hwba>
         <ryba>
+        <cmyka>
+        <gray>
+        <xyza>
+        <xyYa>
         <yiqa>
         <yuva>
-        ! <gray>
-
     } [
         [ <color-picker> ]
         [ name>> "<" ?head drop ">" ?tail drop add-tab ] bi
     ] each ;
 
 MAIN-WINDOW: color-picker-window { { title "Color Picker" } }
-    <color-pickers> { 5 5 } <border> >>gadgets ;
+    <color-pickers> { 5 5 } <border> white-interior >>gadgets ;