136 lines
3.6 KiB
Factor
Executable File
136 lines
3.6 KiB
Factor
Executable File
! Copyright (C) 2005, 2007 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: arrays ui.gadgets
|
|
ui.gadgets.viewports ui.gadgets.frames ui.gadgets.grids
|
|
ui.gadgets.theme ui.gadgets.sliders ui.gestures kernel math
|
|
namespaces sequences models combinators math.vectors
|
|
classes.tuple ;
|
|
IN: ui.gadgets.scrollers
|
|
|
|
TUPLE: scroller viewport x y follows ;
|
|
|
|
: find-scroller ( gadget -- scroller/f )
|
|
[ [ scroller? ] is? ] find-parent ;
|
|
|
|
: scroll-up-page scroller-y -1 swap slide-by-page ;
|
|
|
|
: scroll-down-page scroller-y 1 swap slide-by-page ;
|
|
|
|
: scroll-up-line scroller-y -1 swap slide-by-line ;
|
|
|
|
: scroll-down-line scroller-y 1 swap slide-by-line ;
|
|
|
|
: do-mouse-scroll ( scroller -- )
|
|
scroll-direction get-global first2
|
|
pick scroller-y slide-by-line
|
|
swap scroller-x slide-by-line ;
|
|
|
|
scroller H{
|
|
{ T{ mouse-scroll } [ do-mouse-scroll ] }
|
|
} set-gestures
|
|
|
|
: viewport, ( child -- )
|
|
g gadget-model <viewport>
|
|
g-> set-scroller-viewport @center frame, ;
|
|
|
|
: <scroller-model> ( -- model )
|
|
0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
|
|
|
|
: x-model g gadget-model model-dependencies first ;
|
|
|
|
: y-model g gadget-model model-dependencies second ;
|
|
|
|
: <scroller> ( gadget -- scroller )
|
|
<scroller-model> <frame> scroller construct-control [
|
|
[
|
|
x-model <x-slider> g-> set-scroller-x @bottom frame,
|
|
y-model <y-slider> g-> set-scroller-y @right frame,
|
|
viewport,
|
|
] with-gadget
|
|
] keep t over set-gadget-root? dup faint-boundary ;
|
|
|
|
: scroll ( value scroller -- )
|
|
[
|
|
dup scroller-viewport rect-dim { 0 0 }
|
|
rot scroller-viewport viewport-dim 4array flip
|
|
] keep
|
|
2dup control-value = [ 2drop ] [ set-control-value ] if ;
|
|
|
|
: rect-min ( rect1 rect2 -- rect )
|
|
>r [ rect-loc ] keep r> [ rect-dim ] bi@ vmin <rect> ;
|
|
|
|
: (scroll>rect) ( rect scroller -- )
|
|
[
|
|
scroller-value vneg offset-rect
|
|
viewport-gap offset-rect
|
|
] keep
|
|
[ scroller-viewport rect-min ] keep
|
|
[
|
|
scroller-viewport 2rect-extent
|
|
>r >r v- { 0 0 } vmin r> r> v- { 0 0 } vmax v+
|
|
] keep dup scroller-value rot v+ swap scroll ;
|
|
|
|
: relative-scroll-rect ( rect gadget scroller -- newrect )
|
|
scroller-viewport gadget-child relative-loc offset-rect ;
|
|
|
|
: find-scroller* ( gadget -- scroller )
|
|
dup find-scroller dup [
|
|
2dup scroller-viewport gadget-child
|
|
swap child? [ nip ] [ 2drop f ] if
|
|
] [
|
|
2drop f
|
|
] if ;
|
|
|
|
: scroll>rect ( rect gadget -- )
|
|
dup find-scroller* dup [
|
|
[ relative-scroll-rect ] keep
|
|
[ set-scroller-follows ] keep
|
|
relayout
|
|
] [
|
|
3drop
|
|
] if ;
|
|
|
|
: (scroll>gadget) ( gadget scroller -- )
|
|
>r { 0 0 } over pref-dim <rect> swap r>
|
|
[ relative-scroll-rect ] keep
|
|
(scroll>rect) ;
|
|
|
|
: scroll>gadget ( gadget -- )
|
|
dup find-scroller* dup [
|
|
[ set-scroller-follows ] keep
|
|
relayout
|
|
] [
|
|
2drop
|
|
] if ;
|
|
|
|
: (scroll>bottom) ( scroller -- )
|
|
dup scroller-viewport viewport-dim { 0 1 } v* swap scroll ;
|
|
|
|
: scroll>bottom ( gadget -- )
|
|
find-scroller [
|
|
t over set-scroller-follows relayout-1
|
|
] when* ;
|
|
|
|
: scroll>top ( gadget -- )
|
|
<zero-rect> swap scroll>rect ;
|
|
|
|
: update-scroller ( scroller follows -- )
|
|
{
|
|
{ [ dup t eq? ] [ drop (scroll>bottom) ] }
|
|
{ [ dup rect? ] [ swap (scroll>rect) ] }
|
|
{ [ dup ] [ swap (scroll>gadget) ] }
|
|
{ [ t ] [ drop dup scroller-value swap scroll ] }
|
|
} cond ;
|
|
|
|
M: scroller layout*
|
|
dup delegate layout*
|
|
dup scroller-follows
|
|
[ update-scroller ] 2keep
|
|
swap set-scroller-follows ;
|
|
|
|
M: scroller focusable-child*
|
|
scroller-viewport ;
|
|
|
|
M: scroller model-changed
|
|
nip f swap set-scroller-follows ;
|