! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors colors colors.cmyk colors.gray colors.hsl
colors.hsv colors.hwb colors.lab colors.luv colors.ryb
colors.xyy colors.xyz colors.yiq colors.yuv effects formatting
kernel math math.vectors models models.arrow models.product
models.range quotations sequences sequences.generalizations
splitting stack-checker ui ui.gadgets ui.gadgets.labels
ui.gadgets.packs ui.gadgets.sliders ui.gadgets.tabbed
ui.gadgets.tracks ui.pens.solid ;
IN: color-picker

! Simple example demonstrating the use of models.

TUPLE: color-preview < gadget ;

: <color-preview> ( model -- gadget )
    color-preview new
        swap >>model
        { 200 200 } >>dim ;

M: color-preview model-changed
    swap value>> >>interior relayout-1 ;

: constructor>class-name ( word -- name )
    name>> "<" ?head drop ">" ?tail drop ;

: constructor-inputs ( word -- count )
    stack-effect in>> length ;

: <color-model> ( model word -- model )
    dup 1quotation
    '[ _ constructor-inputs firstn [ 256 /f ] tri@ @ <solid> ] <arrow> ;

: <color-slider> ( model -- gadget )
    horizontal <slider> 1 >>line ;

: <color-sliders> ( constructor -- gadget model )
    constructor-inputs [ 0 0 0 255 1 <range-model> ] replicate

    [ <filled-pile> { 5 5 } >>gap [ <color-slider> add-gadget ] reduce ]
    [ [ range-model>> ] map <product> ]
    bi ;

: color>str ( seq -- str )
    vtruncate v>integer first3 3dup "%d %d %d #%02x%02x%02x" sprintf ;
    ! vtruncate v>integer
    ! first3
    ! ! _ constructor-inputs [ firstn ] keep
    ! "%d %d %d #%02x%02x%02x" sprintf
    ! ! [ [ "%d" ] replicate " " join ]
    ! [ [ "%02x" ] replicate "" join ] bi " #" glue sprintf
    ! "%d %d %d #%02x%02x%02x" sprintf ;

: add-color-tab ( gadget constructor -- gadget )
    dup [ 1quotation ] dip dup
    '[
        vertical <track> { 5 5 } >>gap
        _ <color-sliders>
        [ f track-add ] dip

        [ _ <color-model> <color-preview> 1 track-add ]
        [ [ color>str ] <arrow> <label-control> f track-add ] bi

        _ constructor>class-name add-tab
    ] call ;

: <color-picker> ( -- gadget )
    <tabbed-gadget>
        \ <rgba> add-color-tab
        \ <hwba> add-color-tab
        \ <xyza> add-color-tab
        \ <xyYa> add-color-tab
        \ <laba> add-color-tab
        \ <luva> add-color-tab
        ! \ <cmyka> add-color-tab
        ! \ <hsla> add-color-tab
        ! \ <hsva> add-color-tab
        ! \ <hwba> add-color-tab
        ! \ <ryba> add-color-tab
        ! \ <yiqa> add-color-tab
        ! \ <yuva> add-color-tab
        ! \ <gray> add-color-tab
    ;

MAIN-WINDOW: color-picker-window { { title "Color Picker" } }
    <color-picker> >>gadgets ;