basis/ui/gadgets/search-tables/search-tables.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel delegate fry sequences models
   4 combinators.short-circuit models.search models.delay calendar locals
   5 ui.gestures ui.pens ui.pens.image ui.gadgets.editors ui.gadgets.labels
   6 ui.gadgets.scrollers ui.gadgets.tables ui.gadgets.tracks
   7 ui.gadgets.borders ui.gadgets.buttons ui.baseline-alignment ui.gadgets ;
   8 IN: ui.gadgets.search-tables
   9
  10 TUPLE: search-table < track table field ;
  11
  12 : find-search-table ( gadget -- search-table/f )
  13     [ search-table? ] find-parent ;
  14
  15 TUPLE: search-field < track field ;
  16
  17 : clear-search-field ( search-field -- )
  18     field>> editor>> clear-editor ;
  19
  20 : <clear-button-pen> ( -- pen )
  21     "clear-button" theme-image <image-pen> dup
  22     "clear-button-clicked" theme-image <image-pen> dup dup <button-pen> ;
  23
  24 : <clear-button> ( search-field -- button )
  25     [ f ] dip '[ drop _ clear-search-field ] <button>
  26     <clear-button-pen> >>interior
  27     dup dup interior>> pen-pref-dim >>min-dim ;
  28
  29 : <search-field> ( model -- gadget )
  30     horizontal search-field new-track
  31         0 >>fill
  32         { 5 5 } >>gap
  33         +baseline+ >>align
  34         swap <model-field> 10 >>min-cols >>field
  35         dup field>> "Search:" label-on-left 1 track-add
  36         dup <clear-button> f track-add ;
  37
  38 M: search-field focusable-child* field>> ;
  39
  40 : pass-to-table ( gesture gadget -- ? )
  41     find-search-table table>> handle-gesture ;
  42
  43 M: search-field handle-gesture
  44     over key-gesture? [
  45         { [ pass-to-table ] [ call-next-method ] } 2&&
  46     ] [ call-next-method ] if ;
  47
  48 ! A protocol with customizable slots
  49 SLOT-PROTOCOL: table-protocol
  50 renderer
  51 action
  52 hook
  53 font
  54 selection-color
  55 focus-border-color
  56 mouse-color
  57 column-line-color
  58 selection-required?
  59 single-click?
  60 selection
  61 min-rows
  62 min-cols
  63 max-rows
  64 max-cols ;
  65
  66 CONSULT: table-protocol search-table table>> ;
  67
  68 :: <search-table> ( values renderer quot -- gadget )
  69     f <model> :> search
  70     vertical search-table new-track
  71         values >>model
  72         search <search-field> >>field
  73         dup field>> { 2 2 } <filled-border> f track-add
  74         values search 500 milliseconds <delay> quot <string-search>
  75         renderer <table> f >>takes-focus? >>table
  76         dup table>> <scroller> 1 track-add ; inline
  77
  78 M: search-table model-changed
  79     nip field>> clear-search-field ;
  80
  81 M: search-table focusable-child* field>> ;