--- /dev/null
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: generic
+USING: kernel kernel-internals ;
+
+DEFER: standard-combination
+
+DEFER: math-combination
+
+: delegate ( object -- delegate )
+ dup tuple? [ 3 slot ] [ drop f ] ifte ; inline
+
+: set-delegate ( delegate tuple -- )
+ dup tuple? [ 3 set-slot ] [ drop drop ] ifte ; inline
dup rect-dim pick slider-vector v. pick set-slider-page
dup viewport-dim over rect-dim vmax pick slider-vector v. pick set-slider-max
scroller-viewport dup viewport-origin over fix-scroll vneg pick slider-vector v. pick set-slider-value
- 2drop ;
+ drop slider-elevator relayout ;
: update-sliders ( scroller -- )
dup
dup scroller-y swap update-slider ;
: scroll ( origin scroller -- )
+ dup update-sliders
scroller-viewport
[ [ fix-scroll ] keep set-viewport-origin ] keep relayout ;
: find-slider [ slider? ] find-parent ;
+: slider-scale ( slider -- n )
+ #! A scaling factor such that if x is a slider co-ordinate,
+ #! x*n is the screen position of the thumb, and conversely
+ #! for x/n. The '1 max' calls avoid division by zero.
+ dup slider-elevator rect-dim over slider-vector v. 1 max
+ swap slider-max 1 max / ;
+
+: slider>screen slider-scale * ;
+
+: screen>slider slider-scale / ;
+
: elevator-click ( elevator pos -- )
2drop ;
<plain-gadget> over set-delegate
dup elevator-theme dup elevator-actions ;
-: >thumb ( n slider -- n )
- [ slider-max 1 max / ] keep
- dup slider-elevator rect-dim swap slider-vector v. * ;
-
-: thumb-loc ( slider -- loc ) dup slider-value swap >thumb ;
+: thumb-loc ( slider -- loc )
+ dup slider-value swap slider>screen ;
-: thumb-dim ( slider -- h ) dup slider-page swap >thumb ;
+: thumb-dim ( slider -- h )
+ dup slider-page swap slider>screen ;
: thumb-min { 12 12 0 } ;