library/ui/gadgets/scrolling.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: gadgets-scrolling
   4 USING: arrays gadgets gadgets-frames gadgets-theme
   5 gadgets-viewports generic kernel math namespaces sequences ;
   6
   7 ! A scroller combines a viewport with two x and y sliders.
   8 ! The follows slot is a boolean, if true scroller will scroll
   9 ! down on the next relayout.
  10 TUPLE: scroller viewport x y follows ;
  11
  12 : scroller-origin ( scroller -- point )
  13     dup scroller-x slider-value
  14     swap scroller-y slider-value
  15     2array ;
  16
  17 : find-scroller [ scroller? ] find-parent ;
  18
  19 : scroll-up-page scroller-y -1 swap slide-by-page ;
  20
  21 : scroll-down-page scroller-y 1 swap slide-by-page ;
  22
  23 : scroll-up-line scroller-y -1 swap slide-by-line ;
  24
  25 : scroll-down-line scroller-y 1 swap slide-by-line ;
  26
  27 : do-mouse-scroll ( scroller -- )
  28     scroll-direction get-global first2
  29     pick scroller-y slide-by-line
  30     swap scroller-x slide-by-line ;
  31
  32 scroller H{
  33     { T{ mouse-scroll } [ do-mouse-scroll ] }
  34     { T{ slider-changed } [ relayout-1 ] }
  35 } set-gestures
  36
  37 C: scroller ( gadget -- scroller )
  38     #! Wrap a scrolling pane around the gadget.
  39     {
  40         { [ <viewport> ] set-scroller-viewport f @center }
  41         { [ <x-slider> ] set-scroller-x        f @bottom }
  42         { [ <y-slider> ] set-scroller-y        f @right  }
  43     } make-frame*
  44     t over set-gadget-root?
  45     dup faint-boundary ;
  46
  47 : set-slider ( value page max slider -- )
  48     #! page/max/value are 3-vectors.
  49     [ [ gadget-orientation v. ] keep set-slider-max ] keep
  50     [ [ gadget-orientation v. ] keep set-slider-page ] keep
  51     [ [ gadget-orientation v. ] keep set-slider-value* ] keep
  52     slider-elevator relayout-1 ;
  53
  54 : update-slider ( scroller value slider -- )
  55     >r swap scroller-viewport dup rect-dim swap viewport-dim
  56     r> set-slider ;
  57
  58 : position-viewport ( scroller -- )
  59     dup scroller-origin vneg viewport-gap v+
  60     swap scroller-viewport gadget-child
  61     set-rect-loc ;
  62
  63 : scroll ( scroller value -- )
  64     2dup over scroller-x update-slider
  65     dupd over scroller-y update-slider
  66     position-viewport ;
  67
  68 : (scroll>rect) ( rect scroller -- )
  69     [
  70         scroller-origin vneg offset-rect
  71         viewport-gap offset-rect
  72     ] keep
  73     [
  74         scroller-viewport 2rect-extent
  75         >r >r v- { 0 0 } vmin r> r> v- { 0 0 } vmax v+
  76     ] keep dup scroller-origin rot v+ scroll ;
  77
  78 : scroll>rect ( rect gadget -- )
  79     find-scroller dup [
  80         [ set-scroller-follows ] keep relayout
  81     ] [
  82         2drop
  83     ] if ;
  84
  85 : scroll>bottom ( gadget -- ) t swap scroll>rect ;
  86
  87 : (scroll>bottom) ( scroller -- )
  88     dup scroller-viewport viewport-dim { 0 1 } v* scroll ;
  89
  90 : update-scroller ( scroller -- )
  91     dup scroller-follows [
  92         dup scroller-follows t eq? [
  93             dup (scroll>bottom)
  94         ] [
  95             dup scroller-follows over (scroll>rect)
  96         ] if
  97         f swap set-scroller-follows
  98     ] [
  99         dup scroller-origin scroll
 100     ] if ;
 101
 102 M: scroller layout*
 103     dup delegate layout*
 104     dup layout-children
 105     update-scroller ;
 106
 107 M: scroller focusable-child*
 108     scroller-viewport ;