basis/ui/gadgets/scrollers/scrollers.factor

   1 ! Copyright (C) 2005, 2008 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.theme
   5 ui.gadgets.sliders ui.gestures kernel math namespaces sequences
   6 models models.range models.compose combinators math.vectors
   7 classes.tuple math.geometry.rect combinators.short-circuit ;
   8 IN: ui.gadgets.scrollers
   9
  10 TUPLE: scroller < frame viewport x y follows ;
  11
  12 : find-scroller ( gadget -- scroller/f )
  13     [ scroller? ] find-parent ;
  14
  15 : scroll-up-page ( scroller -- ) y>> -1 swap slide-by-page ;
  16
  17 : scroll-down-page ( scroller -- ) y>> 1 swap slide-by-page ;
  18
  19 : scroll-up-line ( scroller -- ) y>> -1 swap slide-by-line ;
  20
  21 : scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
  22
  23 : do-mouse-scroll ( scroller -- )
  24     scroll-direction get-global
  25     [ first swap x>> slide-by-line ]
  26     [ second swap y>> slide-by-line ]
  27     2bi ;
  28
  29 scroller H{
  30     { T{ mouse-scroll } [ do-mouse-scroll ] }
  31 } set-gestures
  32
  33 : <scroller-model> ( -- model )
  34     0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
  35
  36 : new-scroller ( gadget class -- scroller )
  37     new-frame
  38         t >>root?
  39         <scroller-model> >>model
  40         faint-boundary
  41
  42         dup model>> dependencies>> first  <x-slider> >>x dup x>> @bottom grid-add
  43         dup model>> dependencies>> second <y-slider> >>y dup y>> @right  grid-add
  44
  45         tuck model>> <viewport> >>viewport
  46         dup viewport>> @center grid-add ; inline
  47
  48 : <scroller> ( gadget -- scroller ) scroller new-scroller ;
  49
  50 : scroll ( value scroller -- )
  51     [
  52         viewport>> [ rect-dim { 0 0 } ] [ viewport-dim ] bi
  53         4array flip
  54     ] keep
  55     2dup control-value = [ 2drop ] [ set-control-value ] if ;
  56
  57 : rect-min ( rect dim -- rect' )
  58     [ [ loc>> ] [ dim>> ] bi ] dip vmin <rect> ;
  59
  60 : (scroll>rect) ( rect scroller -- )
  61     [ [ loc>> { 1 1 } v- ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
  62     {
  63         [ scroller-value vneg offset-rect viewport-gap offset-rect ]
  64         [ viewport>> dim>> rect-min ]
  65         [ viewport>> 2rect-extent [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] 2bi* v+ ]
  66         [ scroller-value v+ ]
  67         [ scroll ]
  68     } cleave ;
  69
  70 : relative-scroll-rect ( rect gadget scroller -- newrect )
  71     viewport>> gadget-child relative-loc offset-rect ;
  72
  73 : find-scroller* ( gadget -- scroller/f )
  74     dup find-scroller
  75     { [ nip ] [ viewport>> gadget-child swap child? ] [ nip ] }
  76     2&& ;
  77
  78 : scroll>rect ( rect gadget -- )
  79     dup find-scroller* dup [
  80         [ relative-scroll-rect ] keep
  81         swap >>follows
  82         relayout
  83     ] [ 3drop ] if ;
  84
  85 : (update-scroller) ( scroller -- )
  86     [ scroller-value ] keep scroll ;
  87
  88 : (scroll>gadget) ( gadget scroller -- )
  89     2dup swap child? [
  90         [ [ pref-dim { 0 0 } swap <rect> ] keep ] dip
  91         [ relative-scroll-rect ] keep
  92         (scroll>rect)
  93     ] [ f >>follows (update-scroller) drop ] if ;
  94
  95 : scroll>gadget ( gadget -- )
  96     dup find-scroller* dup [
  97         swap >>follows
  98         relayout
  99     ] [
 100         2drop
 101     ] if ;
 102
 103 : (scroll>bottom) ( scroller -- )
 104     [ viewport>> viewport-dim { 0 1 } v* ] keep scroll ;
 105
 106 : scroll>bottom ( gadget -- )
 107     find-scroller [ t >>follows relayout-1 ] when* ;
 108
 109 : scroll>top ( gadget -- )
 110     <zero-rect> swap scroll>rect ;
 111
 112 GENERIC: update-scroller ( scroller follows -- )
 113
 114 M: t update-scroller drop (scroll>bottom) ;
 115
 116 M: gadget update-scroller swap (scroll>gadget) ;
 117
 118 M: rect update-scroller swap (scroll>rect) ;
 119
 120 M: f update-scroller drop (update-scroller) ;
 121
 122 M: scroller layout*
 123     [ call-next-method ] [
 124         dup follows>>
 125         [ update-scroller ] [ >>follows drop ] 2bi
 126     ] bi ;
 127
 128 M: scroller focusable-child*
 129     viewport>> ;
 130
 131 M: scroller model-changed
 132     f >>follows 2drop ;
 133
 134 TUPLE: limited-scroller < scroller
 135 { min-dim initial: { 0 0 } }
 136 { max-dim initial: { 1/0. 1/0. } } ;
 137
 138 : <limited-scroller> ( gadget -- scroller )
 139     limited-scroller new-scroller ;
 140
 141 M: limited-scroller pref-dim*
 142     [ call-next-method ] [ min-dim>> vmax ] [ max-dim>> vmin ] tri ;