From 5c3dde4f0fd30f65fc1f52e448ab4e4a84b44d68 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Mon, 27 Nov 2006 01:36:44 +0000
Subject: [PATCH] Slider gadget refactoring

---
 library/ui/gadgets/buttons.factor  |  2 +-
 library/ui/gadgets/controls.factor |  6 ++++-
 library/ui/gadgets/sliders.factor  | 42 +++++++++++++-----------------
 library/ui/tools/operations.factor |  8 ++----
 4 files changed, 26 insertions(+), 32 deletions(-)

diff --git a/library/ui/gadgets/buttons.factor b/library/ui/gadgets/buttons.factor
index 622f7d4617..a54938db2d 100644
--- a/library/ui/gadgets/buttons.factor
+++ b/library/ui/gadgets/buttons.factor
@@ -83,7 +83,7 @@ M: button-paint draw-boundary
     button-paint draw-boundary ;
 
 : <radio-control> ( model value gadget -- gadget )
-    over [ swap control-model set-model* ] curry <bevel-button>
+    over [ swap set-control-value ] curry <bevel-button>
     swap [ swap >r = r> set-button-selected? ] curry <control> ;
 
 : <radio-box> ( model assoc -- gadget )
diff --git a/library/ui/gadgets/controls.factor b/library/ui/gadgets/controls.factor
index 1dbfddebb2..3a27b1b175 100644
--- a/library/ui/gadgets/controls.factor
+++ b/library/ui/gadgets/controls.factor
@@ -11,7 +11,11 @@ C: control ( model gadget quot -- gadget )
     [ set-gadget-delegate ] keep
     [ set-control-model ] keep ;
 
-: control-value ( control -- value ) control-model model-value ;
+: control-value ( control -- value )
+    control-model model-value ;
+
+: set-control-value ( value control -- )
+    control-model set-model* ;
 
 M: control graft*
     control-self dup dup control-model add-connection
diff --git a/library/ui/gadgets/sliders.factor b/library/ui/gadgets/sliders.factor
index df2731b2c5..3c8fd5de32 100644
--- a/library/ui/gadgets/sliders.factor
+++ b/library/ui/gadgets/sliders.factor
@@ -1,9 +1,9 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: gadgets-scrolling
+IN: gadgets-sliders
 USING: arrays gadgets gadgets-buttons
 gadgets-theme generic kernel math namespaces
-sequences styles threads vectors ;
+sequences styles threads vectors models ;
 
 ! An elevator has a thumb that may be moved up and down.
 TUPLE: elevator ;
@@ -11,7 +11,7 @@ TUPLE: elevator ;
 : find-elevator [ elevator? ] find-parent ;
 
 ! A slider scrolls a viewport.
-TUPLE: slider elevator thumb value saved max page ;
+TUPLE: slider elevator thumb saved max line page ;
 
 : find-slider [ slider? ] find-parent ;
 
@@ -43,26 +43,20 @@ TUPLE: slider elevator thumb value saved max page ;
 : fix-slider-value ( n slider -- n )
     slider-max* min 0 max >fixnum ;
 
-TUPLE: slider-changed ;
+: set-slider-value ( value slider -- )
+    [ fix-slider-value ] keep set-control-value ;
 
-: set-slider-value* ( value slider -- )
-    [ fix-slider-value ] keep 2dup slider-value = [
-        2drop
-    ] [
-        [ set-slider-value ] keep
-        dup slider-elevator relayout-1
-        T{ slider-changed } swap handle-gesture drop
-    ] if ;
+M: slider model-changed slider-elevator relayout-1 ;
 
 TUPLE: thumb ;
 
 : begin-drag ( thumb -- )
-    find-slider dup slider-value swap set-slider-saved ;
+    find-slider dup control-value swap set-slider-saved ;
 
 : do-drag ( thumb -- )
     find-slider drag-loc over gadget-orientation v.
     over screen>slider swap [ slider-saved + ] keep
-    set-slider-value* ;
+    set-slider-value ;
 
 thumb H{
     { T{ button-down } [ begin-drag ] }
@@ -76,18 +70,17 @@ C: thumb ( vector -- thumb )
     dup thumb-theme
     [ set-gadget-orientation ] keep ;
 
-: slide-by ( amount gadget -- )
-    #! The gadget can be any child of a slider.
-    find-slider [ slider-value + ] keep set-slider-value* ;
+: slide-by ( amount slider -- )
+    [ control-value + ] keep set-slider-value ;
 
-: slide-by-page ( -1/1 gadget -- )
+: slide-by-page ( -1/1 slider -- )
     [ slider-page * ] keep slide-by ;
 
 : page-direction ( elevator -- -1/1 )
     dup find-slider swap hand-click-rel
     over gadget-orientation v.
     over screen>slider
-    swap slider-value - sgn ;
+    swap control-value - sgn ;
 
 : elevator-click ( elevator -- )
     dup page-direction
@@ -108,7 +101,7 @@ C: elevator ( vector -- elevator )
     over gadget-orientation n*v swap slider-thumb ;
 
 : thumb-loc ( slider -- loc )
-    dup slider-value swap slider>screen ;
+    dup control-value swap slider>screen ;
 
 : layout-thumb-loc ( slider -- )
     dup thumb-loc (layout-thumb)
@@ -126,11 +119,12 @@ C: elevator ( vector -- elevator )
 M: elevator layout*
     find-slider layout-thumb ;
 
-: slide-by-line ( -1/1 slider -- ) >r 32 * r> slide-by ;
+: slide-by-line ( -1/1 slider -- )
+    [ slider-line * ] keep slide-by ;
 
 : <slide-button> ( vector polygon amount -- )
     >r gray swap <polygon-gadget> r>
-    [ swap slide-by-line ] curry <repeat-button>
+    [ swap find-slider slide-by-line ] curry <repeat-button>
     [ set-gadget-orientation ] keep ;
 
 : <left-button> { 0 1 } arrow-left -1 <slide-button> ;
@@ -158,9 +152,9 @@ M: elevator layout*
     set-slider-thumb ;
 
 C: slider ( vector -- slider )
-    dup delegate>frame
+    dup 0 <model> <frame> delegate>control
     [ set-gadget-orientation ] keep
-    0 over set-slider-value
+    32 over set-slider-line
     0 over set-slider-page
     0 over set-slider-max ;
 
diff --git a/library/ui/tools/operations.factor b/library/ui/tools/operations.factor
index 9e6ff6079e..c42c7845ae 100644
--- a/library/ui/tools/operations.factor
+++ b/library/ui/tools/operations.factor
@@ -13,12 +13,8 @@ V{ } clone operations set-global
     <operation> operations get push-new ;
 
 M: operation invoke-command ( target operation -- )
-    2dup operation-predicate call [
-        dup command-quot swap operation-listener?
-        [ curry call-listener ] [ call ] if
-    ] [
-        2drop
-    ] if ;
+    dup command-quot swap operation-listener?
+    [ curry call-listener ] [ call ] if ;
 
 : modify-listener-operation ( quot operation -- operation )
     clone t over set-operation-listener?