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
   7 combinators math.vectors classes.tuple math.geometry.rect ;
   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 first2
  25     pick y>> slide-by-line
  26     swap x>> slide-by-line ;
  27
  28 scroller H{
  29     { T{ mouse-scroll } [ do-mouse-scroll ] }
  30 } set-gestures
  31
  32 : <scroller-model> ( -- model )
  33     0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
  34
  35 : new-scroller ( gadget class -- scroller )
  36     new-frame
  37         t >>root?
  38         <scroller-model> >>model
  39         faint-boundary
  40
  41         dup model>> dependencies>> first  <x-slider> >>x dup x>> @bottom grid-add
  42         dup model>> dependencies>> second <y-slider> >>y dup y>> @right  grid-add
  43
  44         swap over model>> <viewport> >>viewport
  45         dup viewport>> @center grid-add ;
  46
  47 : <scroller> ( gadget -- scroller ) scroller new-scroller ;
  48
  49 : scroll ( value scroller -- )
  50     [
  51         dup viewport>> rect-dim { 0 0 }
  52         rot viewport>> viewport-dim 4array flip
  53     ] keep
  54     2dup control-value = [ 2drop ] [ set-control-value ] if ;
  55
  56 : rect-min ( rect1 rect2 -- rect )
  57     >r [ rect-loc ] keep r> [ rect-dim ] bi@ vmin <rect> ;
  58
  59 : (scroll>rect) ( rect scroller -- )
  60     [
  61         scroller-value vneg offset-rect
  62         viewport-gap offset-rect
  63     ] keep
  64     [ viewport>> rect-min ] keep
  65     [
  66         viewport>> 2rect-extent
  67         >r >r v- { 0 0 } vmin r> r> v- { 0 0 } vmax v+
  68     ] keep dup scroller-value rot v+ swap scroll ;
  69
  70 : relative-scroll-rect ( rect gadget scroller -- newrect )
  71     viewport>> gadget-child relative-loc offset-rect ;
  72
  73 : find-scroller* ( gadget -- scroller )
  74     dup find-scroller dup [
  75         2dup viewport>> gadget-child
  76         swap child? [ nip ] [ 2drop f ] if
  77     ] [
  78         2drop f
  79     ] if ;
  80
  81 : scroll>rect ( rect gadget -- )
  82     dup find-scroller* dup [
  83         [ relative-scroll-rect ] keep
  84         swap >>follows
  85         relayout
  86     ] [
  87         3drop
  88     ] if ;
  89
  90 : (scroll>gadget) ( gadget scroller -- )
  91     >r { 0 0 } over pref-dim <rect> swap r>
  92     [ relative-scroll-rect ] keep
  93     (scroll>rect) ;
  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     dup viewport>> viewport-dim { 0 1 } v* swap 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 dup scroller-value swap scroll ;
 121
 122 M: scroller layout*
 123     dup call-next-method
 124     dup follows>>
 125     2dup update-scroller
 126     >>follows drop ;
 127
 128 M: scroller focusable-child*
 129     viewport>> ;
 130
 131 M: scroller model-changed
 132     nip f >>follows drop ;
 133
 134 TUPLE: limited-scroller < scroller fixed-dim ;
 135
 136 : <limited-scroller> ( gadget dim -- scroller )
 137     >r limited-scroller new-scroller r> >>fixed-dim ;
 138
 139 M: limited-scroller pref-dim*
 140     fixed-dim>> ;