library/ui/gadgets/lists.factor

   1 ! Copyright (C) 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: gadgets-lists
   4 USING: gadgets gadgets-scrolling kernel sequences models opengl
   5 math namespaces ;
   6
   7 TUPLE: list index presenter action color ;
   8
   9 : list-theme ( list -- )
  10     { 0.8 0.8 1.0 1.0 } swap set-list-color ;
  11
  12 C: list ( model presenter action -- gadget )
  13     [ set-list-action ] keep
  14     [ set-list-presenter ] keep
  15     dup rot <pile> 1 over set-pack-fill delegate>control
  16     0 over set-list-index
  17     dup list-theme ;
  18
  19 : bound-index ( list -- )
  20     dup list-index over control-value length 1- max 0 min
  21     swap set-list-index ;
  22
  23 M: list model-changed
  24     dup clear-gadget
  25     dup control-value over list-presenter map over add-gadgets
  26     bound-index ;
  27
  28 : selected-rect ( list -- rect )
  29     dup list-index swap gadget-children 2dup bounds-check?
  30     [ nth ] [ 2drop f ] if ;
  31
  32 M: list draw-gadget*
  33     dup list-color gl-color
  34     selected-rect [ rect-bounds gl-fill-rect ] when* ;
  35
  36 M: list focusable-child* drop t ;
  37
  38 : list-value ( list -- object )
  39     dup list-index swap control-value ?nth ;
  40
  41 : scroll>selected ( list -- )
  42     #! We change the rectangle's width to zero to avoid
  43     #! scrolling right.
  44     [ selected-rect rect-bounds { 0 1 } v* <rect> ] keep
  45     scroll>rect ;
  46
  47 : list-empty? ( list -- ? ) control-value empty? ;
  48
  49 : select-index ( n list -- )
  50     dup list-empty? [
  51         2drop
  52     ] [
  53         [ control-value length rem ] keep
  54         [ set-list-index ] keep
  55         [ relayout-1 ] keep
  56         scroll>selected
  57     ] if ;
  58
  59 : select-prev ( list -- )
  60     dup list-index 1- swap select-index ;
  61
  62 : select-next ( list -- )
  63     dup list-index 1+ swap select-index ;
  64
  65 : call-action ( list -- )
  66     dup list-empty? [
  67         dup list-value over list-action call
  68     ] unless drop ;
  69
  70 : click-list ( list -- )
  71     hand-gadget get [ gadget-parent list? ] find-parent
  72     dup [
  73         over gadget-children index dup -1 =
  74         [ 2drop ] [ swap select-index ] if
  75     ] [
  76         2drop
  77     ] if ;
  78
  79 list H{
  80     { T{ button-down } [ dup request-focus click-list ] }
  81     { T{ drag } [ click-list ] }
  82     { T{ key-down f f "UP" } [ select-prev ] }
  83     { T{ key-down f f "DOWN" } [ select-next ] }
  84     { T{ key-down f f "RETURN" } [ call-action ] }
  85 } set-gestures