extra/ui/gadgets/lists/lists.factor

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