extra/color-picker/color-picker.factor

   1 ! Copyright (C) 2006, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors colors formatting kernel math math.vectors
   4 models models.arrow models.product models.range sequences ui
   5 ui.gadgets ui.gadgets.labels ui.gadgets.packs ui.gadgets.sliders
   6 ui.gadgets.tracks ui.pens.solid ui.tools.common ;
   7 IN: color-picker
   8
   9 ! Simple example demonstrating the use of models.
  10
  11 TUPLE: color-preview < gadget ;
  12
  13 : <color-preview> ( model -- gadget )
  14     color-preview new
  15         swap >>model
  16         { 200 200 } >>dim ;
  17
  18 M: color-preview model-changed
  19     swap value>> >>interior relayout-1 ;
  20
  21 : <color-model> ( model -- model )
  22     [ first3 [ 256 /f ] tri@ 1 <rgba> <solid> ] <arrow> ;
  23
  24 : <color-slider> ( model -- gadget )
  25     horizontal <slider> 1 >>line ;
  26
  27 : <color-sliders> ( -- gadget model )
  28     3 [ 0 0 0 255 1 <range> ] replicate
  29     [ <filled-pile> { 5 5 } >>gap [ <color-slider> add-gadget ] reduce ]
  30     [ [ range-model ] map <product> ]
  31     bi ;
  32
  33 : color>str ( seq -- str )
  34     vtruncate v>integer first3 3dup "%d %d %d #%02x%02x%02x" sprintf ;
  35
  36 : <color-picker> ( -- gadget )
  37     vertical <track> { 5 5 } >>gap
  38     <color-sliders>
  39     [ f track-add ]
  40     [
  41         [ <color-model> <color-preview> 1 track-add ]
  42         [ [ color>str ] <arrow> <label-control> white-interior f track-add ] bi
  43     ] bi* ;
  44
  45 MAIN-WINDOW: color-picker-window { { title "Color Picker" } }
  46     <color-picker> >>gadgets ;