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: kernel math math.functions math.parser models
   4 models.arrow models.range models.product sequences ui
   5 ui.gadgets ui.gadgets.tracks ui.gadgets.labels ui.gadgets.packs
   6 ui.gadgets.sliders ui.pens.solid ui.render math.rectangles accessors
   7 ui.gadgets.grids colors ;
   8 IN: color-picker
   9
  10 ! Simple example demonstrating the use of models.
  11
  12 TUPLE: color-preview < gadget ;
  13
  14 : <color-preview> ( model -- gadget )
  15     color-preview new
  16         swap >>model
  17         { 100 100 } >>dim ;
  18
  19 M: color-preview model-changed
  20     swap value>> >>interior relayout-1 ;
  21
  22 : <color-model> ( model -- model )
  23     [ first3 [ 256 /f ] tri@ 1 <rgba> <solid> ] <arrow> ;
  24
  25 : <color-slider> ( model -- gadget )
  26     horizontal <slider> 1 >>line ;
  27
  28 : <color-sliders> ( -- gadget model )
  29     3 [ 0 0 0 255 1 <range> ] replicate
  30     [ <filled-pile> { 5 5 } >>gap [ <color-slider> add-gadget ] reduce ]
  31     [ [ range-model ] map <product> ]
  32     bi ;
  33
  34 : <color-picker> ( -- gadget )
  35     vertical <track>
  36         { 5 5 } >>gap
  37         <color-sliders>
  38         [ f track-add ]
  39         [
  40             [ <color-model> <color-preview> 1 track-add ]
  41             [
  42                 [ [ truncate number>string ] map " " join ]
  43                 <arrow> <label-control>
  44                 f track-add
  45             ] bi
  46         ] bi* ;
  47
  48 : color-picker-window ( -- )
  49     [ <color-picker> "Color Picker" open-window ] with-ui ;
  50
  51 MAIN: color-picker-window