core/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-labels gadgets-scrolling kernel sequences
   5 generic models opengl math namespaces gadgets-theme
   6 gadgets-presentations ;
   7
   8 TUPLE: list index presenter color hook ;
   9
  10 : list-theme ( list -- )
  11     { 0.8 0.8 1.0 1.0 } swap set-list-color ;
  12
  13 C: list ( hook presenter model -- gadget )
  14     [ swap <pile> delegate>control ] keep
  15     [ set-list-presenter ] keep
  16     [ set-list-hook ] keep
  17     0 over set-list-index
  18     1 over set-pack-fill
  19     dup list-theme ;
  20
  21 : bound-index ( list -- )
  22     dup list-index over control-value length 1- max 0 min
  23     swap set-list-index ;
  24
  25 : list-presentation-hook ( list -- quot )
  26     list-hook [ [ [ list? ] is? ] find-parent ] swap append ;
  27
  28 : <list-presentation> ( hook presenter elt -- gadget )
  29     [ swap call ] keep <presentation>
  30     [ set-presentation-hook ] keep
  31     [ text-theme ] keep ;
  32
  33 : <list-items> ( list -- seq )
  34     dup list-presentation-hook
  35     over list-presenter
  36     rot control-value [
  37         >r 2dup r> <list-presentation>
  38     ] map 2nip ;
  39
  40 M: list model-changed
  41     dup clear-gadget
  42     dup <list-items> over add-gadgets
  43     bound-index ;
  44
  45 : selected-rect ( list -- rect )
  46     dup list-index swap gadget-children 2dup bounds-check?
  47     [ nth ] [ 2drop f ] if ;
  48
  49 M: list draw-gadget*
  50     origin get [
  51         dup list-color gl-color
  52         selected-rect [ rect-extent gl-fill-rect ] when*
  53     ] with-translation ;
  54
  55 M: list focusable-child* drop t ;
  56
  57 : list-value ( list -- object )
  58     dup list-index swap control-value ?nth ;
  59
  60 : scroll>selected ( list -- )
  61     #! We change the rectangle's width to zero to avoid
  62     #! scrolling right.
  63     [ selected-rect rect-bounds { 0 1 } v* <rect> ] keep
  64     scroll>rect ;
  65
  66 : list-empty? ( list -- ? ) control-value empty? ;
  67
  68 : select-index ( n list -- )
  69     dup list-empty? [
  70         2drop
  71     ] [
  72         [ control-value length rem ] keep
  73         [ set-list-index ] keep
  74         [ relayout-1 ] keep
  75         scroll>selected
  76     ] if ;
  77
  78 : select-prev ( list -- )
  79     dup list-index 1- swap select-index ;
  80
  81 : select-next ( list -- )
  82     dup list-index 1+ swap select-index ;
  83
  84 : list-action ( list -- )
  85     dup list-empty? [
  86         dup list-hook call
  87     ] [
  88         dup list-index swap nth-gadget invoke-secondary
  89     ] if ; inline
  90
  91 list "commands" {
  92     { "Request focus" T{ button-down } [ request-focus ] }
  93     { "Select previous value" T{ key-down f f "UP" } [ select-prev ] }
  94     { "Select next value" T{ key-down f f "DOWN" } [ select-next ] }
  95     { "Invoke value action" T{ key-down f f "RETURN" } [ list-action ] }
  96 } define-commands