basis/ui/gadgets/lists/lists.factor

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