Paste: color-picker

Author: erg
Mode: factor
Date: Wed, 12 Jan 2022 02:10:19
Plain Text | 
! 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 ;

Annotation: models.range

Author: erg
Mode: factor
Date: Wed, 12 Jan 2022 02:10:39
Plain Text | 
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel models arrays sequences math math.order
models.product generalizations sequences.generalizations
math.functions ;
FROM: models.product => product ;
IN: models.range

TUPLE: range-model < product ;

: <range-model> ( value page min max step -- range )
    5 narray [ <model> ] map range-model new-product ;

: range-model>> ( range -- model ) dependencies>> first ;
: range-page ( range -- model ) dependencies>> second ;
: range-min ( range -- model ) dependencies>> third ;
: range-max ( range -- model ) dependencies>> fourth ;
: range-step ( range -- model ) dependencies>> 4 swap nth ;

: step-value ( value range -- value' )
    range-step value>> floor-to ;

M: range-model range-value
    [ range-model>> value>> ] [ clamp-value ] [ step-value ] tri ;

M: range-model range-page-value range-page value>> ;

M: range-model range-min-value range-min value>> ;

M: range-model range-max-value range-max value>> ;

M: range-model range-max-value*
    [ range-max-value ] [ range-page-value ] bi [-] ;

M: range-model set-range-value
    [ clamp-value ] [ range-model>> ] bi set-model ;

M: range-model set-range-page-value range-page set-model ;

M: range-model set-range-min-value range-min set-model ;

M: range-model set-range-max-value range-max set-model ;

: move-by ( amount range -- )
    [ range-value + ] keep set-range-value ;

: move-by-page ( amount range -- )
    [ range-page-value * ] keep move-by ;

New Annotation

Summary:
Author:
Mode:
Body: