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 ui.gadgets ui.gadgets.viewports
   4 ui.gadgets.frames ui.gadgets.grids ui.gadgets.sliders
   5 ui.gestures kernel math namespaces sequences models models.range
   6 models.product combinators math.vectors classes.tuple
   7 math.rectangles combinators.short-circuit ;
   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 <PRIVATE
  33
  34 : do-mouse-scroll ( scroller -- )
  35     scroll-direction get-global
  36     [ first swap x>> slide-by-line ]
  37     [ second swap y>> slide-by-line ]
  38     2bi ;
  39
  40 scroller H{
  41     { mouse-scroll [ do-mouse-scroll ] }
  42 } set-gestures
  43
  44 : <scroller-model> ( -- model )
  45     0 0 0 0 <range> 0 0 0 0 <range> 2array <product> ;
  46
  47 M: viewport pref-dim* gadget-child pref-viewport-dim ;
  48
  49 : scroll ( value scroller -- )
  50     [
  51         viewport>> [ dim>> { 0 0 } ] [ gadget-child pref-dim ] bi
  52         4array flip
  53     ] keep
  54     2dup control-value = [ 2drop ] [ set-control-value ] if ;
  55
  56 : (scroll>rect) ( rect scroller -- )
  57     [ [ loc>> ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
  58     {
  59         [ scroller-value vneg offset-rect ]
  60         [ viewport>> dim>> rect-min ]
  61         [ viewport>> [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] with-rect-extents v+ ]
  62         [ scroller-value v+ ]
  63         [ scroll ]
  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     [ scroller-value ] keep scroll ;
  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 scroll ;
  86
  87 GENERIC: update-scroller ( scroller follows -- )
  88
  89 M: t update-scroller drop (scroll>bottom) ;
  90
  91 M: gadget update-scroller swap (scroll>gadget) ;
  92
  93 M: rect update-scroller swap (scroll>rect) ;
  94
  95 M: f update-scroller drop (update-scroller) ;
  96
  97 M: scroller layout*
  98     [ call-next-method ] [
  99         dup follows>>
 100         [ update-scroller ] [ >>follows drop ] 2bi
 101     ] bi ;
 102
 103 M: scroller focusable-child*
 104     viewport>> ;
 105
 106 M: scroller model-changed
 107     f >>follows 2drop ;
 108
 109 : build-scroller ( scroller -- scroller )
 110     dup x>> { 0 1 } grid-add
 111     dup y>> { 1 0 } grid-add
 112     dup viewport>> { 0 0 } grid-add ; inline
 113
 114 : <column-header-viewport> ( scroller -- viewport )
 115     [ column-header>> ] [ model>> ] bi
 116     <viewport> horizontal >>constraint ;
 117
 118 : build-header-scroller ( scroller -- scroller )
 119     dup <column-header-viewport> { 0 0 } grid-add
 120     dup x>> { 0 2 } grid-add
 121     dup y>> { 1 1 } grid-add
 122     dup viewport>> { 0 1 } grid-add ; inline
 123
 124 : init-scroller ( column-header scroller -- scroller )
 125     { 1 1 } >>gap
 126     over { 0 1 } { 0 0 } ? >>filled-cell
 127     t >>root?
 128     <scroller-model> >>model
 129     swap >>column-header ; inline
 130
 131 : build-children ( gadget scroller -- scroller )
 132     dup model>> dependencies>>
 133     [ first horizontal <slider> >>x ]
 134     [ second vertical <slider> >>y ] bi
 135     [ nip ] [ model>> <viewport> ] 2bi >>viewport ; inline
 136
 137 PRIVATE>
 138
 139 : <scroller> ( gadget -- scroller )
 140     dup viewport-column-header
 141     dup [ 2 3 ] [ 2 2 ] if scroller new-frame
 142         init-scroller
 143         build-children
 144         dup column-header>>
 145         [ build-header-scroller ] [ build-scroller ] if ;
 146
 147 : scroll>rect ( rect gadget -- )
 148     dup find-scroller* dup [
 149         [ relative-scroll-rect ] keep
 150         swap >>follows
 151         relayout
 152     ] [ 3drop ] if ;
 153
 154 : scroll>gadget ( gadget -- )
 155     dup find-scroller* dup [
 156         swap >>follows
 157         relayout
 158     ] [
 159         2drop
 160     ] if ;
 161
 162 : scroll>bottom ( gadget -- )
 163     find-scroller [ t >>follows relayout-1 ] when* ;
 164
 165 : scroll>top ( gadget -- )
 166     <zero-rect> swap scroll>rect ;