basis/ui/gadgets/scrollers/scrollers.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators combinators.short-circuit
   4 kernel math.rectangles math.vectors models models.product
   5 models.range namespaces sequences ui.gadgets ui.gadgets.frames
   6 ui.gadgets.grids ui.gadgets.sliders ui.gadgets.viewports
   7 ui.gestures ;
   8 IN: ui.gadgets.scrollers
   9
  10 TUPLE: scroller < frame column-header viewport x y follows ;
  11
  12 ! Scrollable gadget protocol; optional
  13 GENERIC: pref-viewport-dim ( gadget -- dim )
  14
  15 M: gadget pref-viewport-dim pref-dim ;
  16
  17 GENERIC: viewport-column-header ( gadget -- gadget/f )
  18
  19 M: gadget viewport-column-header drop f ;
  20
  21 : find-scroller ( gadget -- scroller/f )
  22     [ scroller? ] find-parent ;
  23
  24 : scroll-up-page ( scroller -- ) y>> -1 swap slide-by-page ;
  25
  26 : scroll-down-page ( scroller -- ) y>> 1 swap slide-by-page ;
  27
  28 : scroll-up-line ( scroller -- ) y>> -1 swap slide-by-line ;
  29
  30 : scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
  31
  32 : set-scroll-position ( value scroller -- )
  33     [
  34         viewport>> [ dim>> { 0 0 } ] [ gadget-child pref-dim ] bi
  35         4array flip
  36     ] keep
  37     2dup control-value = [ 2drop ] [ set-control-value ] if ;
  38
  39 <PRIVATE
  40
  41 : do-mouse-scroll ( scroller -- )
  42     scroll-direction get-global
  43     [ first swap x>> slide-by-line ]
  44     [ second swap y>> slide-by-line ]
  45     2bi ;
  46
  47 scroller H{
  48     { mouse-scroll [ do-mouse-scroll ] }
  49 } set-gestures
  50
  51 : <scroller-model> ( -- model )
  52     0 0 0 0 1 <range> 0 0 0 0 1 <range> 2array <product> ;
  53
  54 M: viewport pref-dim* gadget-child pref-viewport-dim ;
  55
  56 : (scroll>rect) ( rect scroller -- )
  57     {
  58         [ scroll-position vneg offset-rect ]
  59         [ viewport>> dim>> rect-min ]
  60         [ viewport>> loc>> offset-rect ]
  61         [ viewport>> [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] with-rect-extents v+ ]
  62         [ scroll-position v+ ]
  63         [ set-scroll-position ]
  64     } cleave ;
  65
  66 : relative-scroll-rect ( rect gadget scroller -- newrect )
  67     viewport>> gadget-child relative-loc offset-rect ;
  68
  69 : find-scroller* ( gadget -- scroller/f )
  70     dup find-scroller
  71     { [ nip ] [ viewport>> gadget-child swap child? ] [ nip ] }
  72     2&& ;
  73
  74 : (update-scroller) ( scroller -- )
  75     [ scroll-position ] keep set-scroll-position ;
  76
  77 : (scroll>gadget) ( gadget scroller -- )
  78     2dup swap child? [
  79         [ [ [ { 0 0 } ] dip pref-dim <rect> ] keep ] dip
  80         [ relative-scroll-rect ] keep
  81         (scroll>rect)
  82     ] [ f >>follows (update-scroller) drop ] if ;
  83
  84 : (scroll>bottom) ( scroller -- )
  85     [ viewport>> gadget-child pref-dim { 0 1 } v* ] keep
  86     set-scroll-position ;
  87
  88 GENERIC: update-scroller ( scroller follows -- )
  89
  90 M: t update-scroller drop (scroll>bottom) ;
  91
  92 M: gadget update-scroller swap (scroll>gadget) ;
  93
  94 M: rect update-scroller swap (scroll>rect) ;
  95
  96 M: f update-scroller drop (update-scroller) ;
  97
  98 M: scroller layout*
  99     [ call-next-method ] [
 100         dup follows>>
 101         [ update-scroller ] [ >>follows drop ] 2bi
 102     ] bi ;
 103
 104 M: scroller focusable-child*
 105     viewport>> ;
 106
 107 M: scroller model-changed
 108     f >>follows 2drop ;
 109
 110 : build-scroller ( scroller -- scroller )
 111     dup x>> { 0 1 } grid-add
 112     dup y>> { 1 0 } grid-add
 113     dup viewport>> { 0 0 } grid-add ; inline
 114
 115 : <column-header-viewport> ( scroller -- viewport )
 116     [ column-header>> ] [ model>> ] bi
 117     <viewport> horizontal >>constraint ;
 118
 119 : build-header-scroller ( scroller -- scroller )
 120     dup <column-header-viewport> { 0 0 } grid-add
 121     dup x>> { 0 2 } grid-add
 122     dup y>> { 1 1 } grid-add
 123     dup viewport>> { 0 1 } grid-add ; inline
 124
 125 : init-scroller ( column-header scroller -- scroller )
 126     { 1 1 } >>gap
 127     over { 0 1 } { 0 0 } ? >>filled-cell
 128     t >>root?
 129     <scroller-model> >>model
 130     swap >>column-header ; inline
 131
 132 : build-children ( gadget scroller -- scroller )
 133     dup model>> dependencies>>
 134     [ first horizontal <slider> >>x ]
 135     [ second vertical <slider> >>y ] bi
 136     [ nip ] [ model>> <viewport> ] 2bi >>viewport ; inline
 137
 138 PRIVATE>
 139
 140 : <scroller> ( gadget -- scroller )
 141     dup viewport-column-header
 142     dup [ 2 3 ] [ 2 2 ] if scroller new-frame
 143         init-scroller
 144         build-children
 145         dup column-header>>
 146         [ build-header-scroller ] [ build-scroller ] if ;
 147
 148 : scroll>rect ( rect gadget -- )
 149     dup find-scroller* dup [
 150         [ relative-scroll-rect ] keep
 151         swap >>follows
 152         relayout
 153     ] [ 3drop ] if ;
 154
 155 : scroll>gadget ( gadget -- )
 156     dup find-scroller* dup [
 157         swap >>follows
 158         relayout
 159     ] [
 160         2drop
 161     ] if ;
 162
 163 : scroll>bottom ( gadget -- )
 164     find-scroller [ t >>follows relayout-1 ] when* ;
 165
 166 : scroll>top ( gadget -- )
 167     <zero-rect> swap scroll>rect ;