extra/ui/gadgets/lists/lists.factor

   1 ! Copyright (C) 2006, 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: ui.commands ui.gestures ui.render ui.gadgets
   4 ui.gadgets.controls ui.gadgets.labels ui.gadgets.scrollers
   5 kernel sequences models opengl math namespaces
   6 ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
   7 math.vectors tuples ;
   8 IN: ui.gadgets.lists
   9
  10 TUPLE: list index presenter color hook ;
  11
  12 : list-theme ( list -- )
  13     { 0.8 0.8 1.0 1.0 } swap set-list-color ;
  14
  15 : <list> ( hook presenter model -- gadget )
  16     <filled-pile> list construct-control
  17     [ set-list-presenter ] keep
  18     [ set-list-hook ] keep
  19     0 over set-list-index
  20     dup list-theme ;
  21
  22 : calc-bounded-index ( n list -- m )
  23     control-value length 1- min 0 max ;
  24
  25 : bound-index ( list -- )
  26     dup list-index over calc-bounded-index
  27     swap set-list-index ;
  28
  29 : list-presentation-hook ( list -- quot )
  30     list-hook [ [ [ list? ] is? ] find-parent ] swap append ;
  31
  32 : <list-presentation> ( hook elt presenter -- gadget )
  33     keep <presentation>
  34     [ set-presentation-hook ] keep
  35     [ text-theme ] keep ;
  36
  37 : <list-items> ( list -- seq )
  38     dup list-presentation-hook
  39     over list-presenter
  40     rot control-value [
  41         >r 2dup r> swap <list-presentation>
  42     ] map 2nip ;
  43
  44 M: list model-changed
  45     dup clear-gadget
  46     dup <list-items> over add-gadgets
  47     bound-index ;
  48
  49 : selected-rect ( list -- rect )
  50     dup list-index swap gadget-children ?nth ;
  51
  52 M: list draw-gadget*
  53     origin get [
  54         dup list-color gl-color
  55         selected-rect [ rect-extent gl-fill-rect ] when*
  56     ] with-translation ;
  57
  58 M: list focusable-child* drop t ;
  59
  60 : list-value ( list -- object )
  61     dup list-index swap control-value ?nth ;
  62
  63 : scroll>selected ( list -- )
  64     #! We change the rectangle's width to zero to avoid
  65     #! scrolling right.
  66     [ selected-rect rect-bounds { 0 1 } v* <rect> ] keep
  67     scroll>rect ;
  68
  69 : list-empty? ( list -- ? ) control-value empty? ;
  70
  71 : select-index ( n list -- )
  72     dup list-empty? [
  73         2drop
  74     ] [
  75         [ control-value length rem ] keep
  76         [ set-list-index ] keep
  77         [ relayout-1 ] keep
  78         scroll>selected
  79     ] if ;
  80
  81 : select-previous ( list -- )
  82     dup list-index 1- swap select-index ;
  83
  84 : select-next ( list -- )
  85     dup list-index 1+ swap select-index ;
  86
  87 : invoke-value-action ( list -- )
  88     dup list-empty? [
  89         dup list-hook call
  90     ] [
  91         dup list-index swap nth-gadget invoke-secondary
  92     ] if ;
  93
  94 : select-gadget ( gadget list -- )
  95     swap over gadget-children index
  96     [ swap select-index ] [ drop ] if* ;
  97
  98 : clamp-loc ( point max -- point )
  99     vmin { 0 0 } vmax ;
 100
 101 : select-at ( point list -- )
 102     [ rect-dim clamp-loc ] keep
 103     [ pick-up ] keep
 104     select-gadget ;
 105
 106 : list-page ( list vec -- )
 107     >r dup selected-rect rect-bounds 2 v/n v+
 108     over visible-dim r> v* v+ swap select-at ;
 109
 110 : list-page-up ( list -- ) { 0 -1 } list-page ;
 111
 112 : list-page-down ( list -- ) { 0 1 } list-page ;
 113
 114 list "keyboard-navigation" "Lists can be navigated from the keyboard." {
 115     { T{ button-down } request-focus }
 116     { T{ key-down f f "UP" } select-previous }
 117     { T{ key-down f f "DOWN" } select-next }
 118     { T{ key-down f f "PAGE_UP" } list-page-up }
 119     { T{ key-down f f "PAGE_DOWN" } list-page-down }
 120     { T{ key-down f f "RET" } invoke-value-action }
 121 } define-command-map