give range models a step parameter; use it on sliders so the thumb can step by any...

diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor
index 19a8f17a0c041bb3a055f12442e0902952cb6277..314062591d192cff360e643d1f7479393e937268 100644 (file)
--- a/basis/math/functions/functions.factor
+++ b/basis/math/functions/functions.factor
@@ -264,5 +264,8 @@ M: real atan fatan ;
 
 : ceiling ( x -- y ) neg floor neg ; foldable
 
+: floor-to ( x step -- y )
+    dup zero? [ drop ] [ [ / floor ] [ * ] bi ] if ;
+
 : lerp ( a b t -- a_t ) [ over - ] dip * + ; inline
 

diff --git a/basis/models/range/range-tests.factor b/basis/models/range/range-tests.factor
index e9119e8452e5e8896fbd98365c4e6192b3d06aea..51f8b06ef56496d3280eb217214f465933f1b433 100644 (file)
--- a/basis/models/range/range-tests.factor
+++ b/basis/models/range/range-tests.factor
@@ -3,13 +3,17 @@ USING: arrays generic kernel math models namespaces sequences assocs
 tools.test models.range ;\r
 \r
 ! Test <range> \r
-: setup-range ( -- range ) 0 0 0 255 <range> ;\r
+: setup-range ( -- range ) 0 0 0 255 1 <range> ;\r
+: setup-stepped-range ( -- range ) 0 0 0 255 2 <range> ;\r
 \r
 ! clamp-value should not go past range ends\r
 [ 0   ] [ -10 setup-range clamp-value ] unit-test\r
 [ 255 ] [ 2000 setup-range clamp-value ] unit-test\r
 [ 14  ] [ 14 setup-range clamp-value ] unit-test\r
 \r
+! step-value\r
+[ 14  ] [ 15 setup-stepped-range step-value ] unit-test\r
+\r
 ! range min/max/page values should be correct\r
 [ 0 ] [ setup-range range-page-value ] unit-test\r
 [ 0 ] [ setup-range range-min-value ] unit-test\r

diff --git a/basis/models/range/range.factor b/basis/models/range/range.factor
index c8bc8d8e54f0de954b0d3da675d12e049b57eeff..c39c80c7d15dc63de3e9cc70e01dca338e84c55a 100644 (file)
--- a/basis/models/range/range.factor
+++ b/basis/models/range/range.factor
@@ -1,22 +1,26 @@
 ! Copyright (C) 2008 Slava Pestov.\r
 ! See http://factorcode.org/license.txt for BSD license.\r
 USING: accessors kernel models arrays sequences math math.order\r
-models.product ;\r
+models.product generalizations math.functions ;\r
 FROM: models.product => product ;\r
 IN: models.range\r
 \r
 TUPLE: range < product ;\r
 \r
-: <range> ( value page min max -- range )\r
-    4array [ <model> ] map range new-product ;\r
+: <range> ( value page min max step -- range )\r
+    5 narray [ <model> ] map range new-product ;\r
 \r
 : range-model ( range -- model ) dependencies>> first ;\r
 : range-page ( range -- model ) dependencies>> second ;\r
 : range-min ( range -- model ) dependencies>> third ;\r
 : range-max ( range -- model ) dependencies>> fourth ;\r
+: range-step ( range -- model ) dependencies>> 4 swap nth ;\r
+\r
+: step-value ( value range -- value' )\r
+    range-step value>> floor-to ;\r
 \r
 M: range range-value\r
-    [ range-model value>> ] keep clamp-value ;\r
+    [ range-model value>> ] [ clamp-value ] [ step-value ] tri ;\r
 \r
 M: range range-page-value range-page value>> ;\r
 \r

diff --git a/basis/ui/gadgets/scrollers/scrollers-tests.factor b/basis/ui/gadgets/scrollers/scrollers-tests.factor
index 4002c8b40e254b474303b53f83128c90ceb6930b..5f5cc91846cd1a5649a550ff03b6bd81f0910d14 100644 (file)
--- a/basis/ui/gadgets/scrollers/scrollers-tests.factor
+++ b/basis/ui/gadgets/scrollers/scrollers-tests.factor
@@ -21,7 +21,7 @@ IN: ui.gadgets.scrollers.tests
 
 [ ] [
     <gadget> dup "g" set
-    10 1 0 100 <range> 20 1 0 100 <range> 2array <product>
+    10 1 0 100 1 <range> 20 1 0 100 1 <range> 2array <product>
     <viewport> "v" set
 ] unit-test
 

diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor
index 0852a6fe5ddb3c3de21497a9bfe4e332be9e60f1..8c73226639d8cb746225ba48fb2692bcecbdc12a 100644 (file)
--- a/basis/ui/gadgets/scrollers/scrollers.factor
+++ b/basis/ui/gadgets/scrollers/scrollers.factor
@@ -49,7 +49,7 @@ scroller H{
 } set-gestures
 
 : <scroller-model> ( -- model )
-    0 0 0 0 <range> 0 0 0 0 <range> 2array <product> ;
+    0 0 0 0 1 <range> 0 0 0 0 1 <range> 2array <product> ;
 
 M: viewport pref-dim* gadget-child pref-viewport-dim ;
 

diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor
index d7919aafd151f1f252d63e73d4ce15112dd26061..56a60d6fc8b9ddd1e748ff5f3caf1c974e05757f 100755 (executable)
--- a/extra/color-picker/color-picker.factor
+++ b/extra/color-picker/color-picker.factor
@@ -26,7 +26,7 @@ M: color-preview model-changed
     horizontal <slider> 1 >>line ;
 
 : <color-sliders> ( -- gadget model )
-    3 [ 0 0 0 255 <range> ] replicate
+    3 [ 0 0 0 255 1 <range> ] replicate
     [ <filled-pile> { 5 5 } >>gap [ <color-slider> add-gadget ] reduce ]
     [ [ range-model ] map <product> ]
     bi ;