diff --git a/library/generic/early-generic.factor b/library/generic/early-generic.factor new file mode 100644 index 0000000000..fd421ba55a --- /dev/null +++ b/library/generic/early-generic.factor @@ -0,0 +1,14 @@ +! 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 diff --git a/library/ui/scrolling.factor b/library/ui/scrolling.factor index e72997e0cf..f880050093 100644 --- a/library/ui/scrolling.factor +++ b/library/ui/scrolling.factor @@ -44,7 +44,7 @@ M: viewport focusable-child* ( viewport -- gadget ) 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 @@ -52,6 +52,7 @@ M: viewport focusable-child* ( viewport -- gadget ) dup scroller-y swap update-slider ; : scroll ( origin scroller -- ) + dup update-sliders scroller-viewport [ [ fix-scroll ] keep set-viewport-origin ] keep relayout ; diff --git a/library/ui/sliders.factor b/library/ui/sliders.factor index 0def5a231a..7ef3afadea 100644 --- a/library/ui/sliders.factor +++ b/library/ui/sliders.factor @@ -14,6 +14,17 @@ TUPLE: slider vector elevator thumb value max page ; : 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 ; @@ -39,13 +50,11 @@ C: elevator ( -- elevator ) 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 slider>screen ; -: thumb-loc ( slider -- loc ) dup slider-value swap >thumb ; - -: thumb-dim ( slider -- h ) dup slider-page swap >thumb ; +: thumb-dim ( slider -- h ) + dup slider-page swap slider>screen ; : thumb-min { 12 12 0 } ;