2005-03-10 17:57:22 -05:00
|
|
|
! Copyright (C) 2005 Slava Pestov.
|
|
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
2005-08-31 21:06:13 -04:00
|
|
|
IN: gadgets-scrolling
|
2005-12-17 09:55:00 -05:00
|
|
|
USING: arrays gadgets gadgets-layouts kernel math namespaces
|
|
|
|
sequences ;
|
2005-02-26 00:57:53 -05:00
|
|
|
|
|
|
|
! A viewport can be scrolled.
|
2005-10-10 21:12:53 -04:00
|
|
|
TUPLE: viewport ;
|
2005-06-22 02:32:17 -04:00
|
|
|
|
2005-07-20 18:04:29 -04:00
|
|
|
! A scroller combines a viewport with two x and y sliders.
|
2005-10-10 21:12:53 -04:00
|
|
|
! The follows slot is set by scroll-to.
|
|
|
|
TUPLE: scroller viewport x y follows ;
|
2005-07-20 18:04:29 -04:00
|
|
|
|
2005-10-29 23:25:38 -04:00
|
|
|
: scroller-origin ( scroller -- { x y 0 } )
|
2005-08-29 18:18:10 -04:00
|
|
|
dup scroller-x slider-value
|
|
|
|
swap scroller-y slider-value
|
2005-09-11 20:46:55 -04:00
|
|
|
0 3array ;
|
2005-08-29 18:18:10 -04:00
|
|
|
|
|
|
|
: find-scroller [ scroller? ] find-parent ;
|
2005-06-22 02:32:17 -04:00
|
|
|
|
2005-09-03 16:28:42 -04:00
|
|
|
: find-viewport [ viewport? ] find-parent ;
|
|
|
|
|
2005-08-29 18:18:10 -04:00
|
|
|
: viewport-dim gadget-child pref-dim ;
|
2005-06-22 02:32:17 -04:00
|
|
|
|
2005-02-27 16:51:12 -05:00
|
|
|
C: viewport ( content -- viewport )
|
2005-10-09 21:27:14 -04:00
|
|
|
dup delegate>gadget
|
2005-07-08 01:32:29 -04:00
|
|
|
t over set-gadget-root?
|
2005-08-29 18:18:10 -04:00
|
|
|
[ add-gadget ] keep ;
|
2005-02-27 16:51:12 -05:00
|
|
|
|
2006-01-26 23:01:14 -05:00
|
|
|
M: viewport pref-dim* gadget-child pref-dim ;
|
2005-03-07 23:15:00 -05:00
|
|
|
|
2005-08-27 01:41:42 -04:00
|
|
|
: set-slider ( page max value slider -- )
|
|
|
|
#! page/max/value are 3-vectors.
|
2005-10-24 00:08:09 -04:00
|
|
|
[ [ gadget-orientation v. ] keep set-slider-value ] keep
|
|
|
|
[ [ gadget-orientation v. ] keep set-slider-max ] keep
|
|
|
|
[ [ gadget-orientation v. ] keep set-slider-page ] keep
|
2005-08-27 01:41:42 -04:00
|
|
|
fix-slider ;
|
|
|
|
|
2005-08-29 18:18:10 -04:00
|
|
|
: update-slider ( scroller value slider -- )
|
|
|
|
>r >r scroller-viewport dup rect-dim swap viewport-dim
|
|
|
|
r> r> set-slider ;
|
2005-06-23 03:15:44 -04:00
|
|
|
|
2005-08-29 18:18:10 -04:00
|
|
|
: scroll ( scroller value -- )
|
2005-09-02 23:44:23 -04:00
|
|
|
2dup over scroller-x update-slider
|
2005-08-29 18:18:10 -04:00
|
|
|
over scroller-y update-slider ;
|
2005-02-27 16:00:55 -05:00
|
|
|
|
2005-10-23 16:18:07 -04:00
|
|
|
: pop-follows ( scroller -- follows )
|
|
|
|
dup scroller-follows f rot set-scroller-follows ;
|
2005-10-21 19:46:14 -04:00
|
|
|
|
2005-10-23 16:18:07 -04:00
|
|
|
: (do-scroll) ( gadget viewport -- point )
|
|
|
|
[ [ swap relative-rect ] keep rect-union ] keep
|
|
|
|
[ rect-extent v+ ] 2apply v- ;
|
|
|
|
|
|
|
|
: do-scroll ( scroller -- delta )
|
|
|
|
dup pop-follows dup [
|
|
|
|
swap scroller-viewport (do-scroll)
|
2005-10-10 21:12:53 -04:00
|
|
|
] [
|
2005-10-29 23:25:38 -04:00
|
|
|
2drop { 0 0 0 }
|
2005-10-23 16:18:07 -04:00
|
|
|
] if ;
|
|
|
|
|
|
|
|
: update-scroller ( scroller -- )
|
|
|
|
[ dup do-scroll ] keep scroller-origin v+ scroll ;
|
2005-09-03 17:00:49 -04:00
|
|
|
|
2005-10-10 21:12:53 -04:00
|
|
|
: position-viewport ( viewport scroller -- )
|
|
|
|
scroller-origin vneg swap gadget-child set-rect-loc ;
|
2005-09-02 23:44:23 -04:00
|
|
|
|
|
|
|
M: viewport layout* ( viewport -- )
|
2005-10-10 21:12:53 -04:00
|
|
|
dup gadget-child dup prefer layout
|
|
|
|
dup find-scroller dup update-scroller position-viewport ;
|
2005-09-02 23:44:23 -04:00
|
|
|
|
|
|
|
M: viewport focusable-child* ( viewport -- gadget )
|
|
|
|
gadget-child ;
|
|
|
|
|
2006-05-20 02:13:44 -04:00
|
|
|
M: viewport pref-dim* ( viewport -- dim )
|
|
|
|
gadget-child pref-dim ;
|
|
|
|
|
2005-10-10 21:12:53 -04:00
|
|
|
: scroll-to ( gadget -- )
|
|
|
|
#! Scroll the scroller that contains this gadget, if any, so
|
|
|
|
#! that the gadget becomes visible.
|
|
|
|
dup find-scroller dup
|
|
|
|
[ [ set-scroller-follows ] keep relayout ] [ 2drop ] if ;
|
2005-03-10 17:57:22 -05:00
|
|
|
|
2005-08-27 15:12:37 -04:00
|
|
|
: scroll-up-line scroller-y -1 swap slide-by-line ;
|
2005-07-20 16:03:03 -04:00
|
|
|
|
2005-08-27 15:12:37 -04:00
|
|
|
: scroll-down-line scroller-y 1 swap slide-by-line ;
|
2005-08-26 18:18:07 -04:00
|
|
|
|
2005-03-12 16:16:40 -05:00
|
|
|
: scroller-actions ( scroller -- )
|
2006-05-18 22:01:38 -04:00
|
|
|
dup [ scroll-up-line ] T{ wheel-up } set-action
|
|
|
|
dup [ scroll-down-line ] T{ wheel-down } set-action
|
|
|
|
[ scroller-viewport relayout-1 ] T{ slider-changed } set-action ;
|
2005-03-12 16:16:40 -05:00
|
|
|
|
2005-02-27 16:00:55 -05:00
|
|
|
C: scroller ( gadget -- scroller )
|
|
|
|
#! Wrap a scrolling pane around the gadget.
|
2006-05-19 22:29:01 -04:00
|
|
|
{
|
|
|
|
{ [ <viewport> ] set-scroller-viewport @center }
|
|
|
|
{ [ <x-slider> ] set-scroller-x @bottom }
|
|
|
|
{ [ <y-slider> ] set-scroller-y @right }
|
2006-05-20 02:13:44 -04:00
|
|
|
} make-frame* dup scroller-actions ;
|
2005-07-04 18:36:07 -04:00
|
|
|
|
2005-08-27 15:12:37 -04:00
|
|
|
M: scroller focusable-child* ( scroller -- viewport )
|
2005-07-04 18:36:07 -04:00
|
|
|
scroller-viewport ;
|
2006-05-19 22:29:01 -04:00
|
|
|
|
|
|
|
: scroller-gadget ( scroller -- gadget )
|
|
|
|
#! Gadget being scrolled.
|
|
|
|
scroller-viewport gadget-child ;
|