! 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
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 ;
[ <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@
[ 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 ;