Re-implement monotonic? without using rot

diff --git a/basis/grouping/grouping-docs.factor b/basis/grouping/grouping-docs.factor
index b9af98d1f8ad7434a09747e2bad665c3407140a1..4136209f4be2259527b241099d6364ea4cf74522 100644 (file)
--- a/basis/grouping/grouping-docs.factor
+++ b/basis/grouping/grouping-docs.factor
@@ -22,7 +22,12 @@ ARTICLE: "grouping" "Groups and clumps"
     { "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
         { $unchecked-example "dup n clumps unclip-last [ [ first ] map ] dip append sequence= ." "t" }
     }
-} ;
+}
+"A combinator built using clumps:"
+{ $subsection monotonic? }
+"Testing how elements are related:"
+{ $subsection all-eq? }
+{ $subsection all-equal? } ;
 
 ABOUT: "grouping"
 
@@ -123,3 +128,23 @@ HELP: <sliced-clumps>
 { <clumps> <groups> } related-words
 
 { <sliced-clumps> <sliced-groups> } related-words
+
+HELP: monotonic?
+{ $values { "seq" sequence } { "quot" { $quotation "( elt elt -- ? )" } } { "?" "a boolean" } }
+{ $description "Applies the relation to successive pairs of elements in the sequence, testing for a truth value. The relation should be a transitive relation, such as a total order or an equality relation." }
+{ $examples
+    "Testing if a sequence is non-decreasing:"
+    { $example "USING: math prettyprint sequences ;" "{ 1 1 2 } [ <= ] monotonic? ." "t" }
+    "Testing if a sequence is decreasing:"
+    { $example "USING: math prettyprint sequences ;" "{ 9 8 6 7 } [ < ] monotonic? ." "f" }
+} ;
+
+HELP: all-equal?
+{ $values { "seq" sequence } { "?" "a boolean" } }
+{ $description "Tests if all elements in the sequence are equal. Yields true with an empty sequence." } ;
+
+HELP: all-eq?
+{ $values { "seq" sequence } { "?" "a boolean" } }
+{ $description "Tests if all elements in the sequence are the same identical object. Yields true with an empty sequence." } ;
+
+{ monotonic? all-eq? all-equal? } related-words

diff --git a/basis/grouping/grouping.factor b/basis/grouping/grouping.factor
index b4d4c08d42dbb00c4e5bcae887f23aa073ed0dc7..14210d6070ef21ab74795db66e6dded4cdea65fd 100644 (file)
--- a/basis/grouping/grouping.factor
+++ b/basis/grouping/grouping.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.order strings arrays vectors sequences
 sequences.private accessors ;
@@ -87,3 +87,17 @@ INSTANCE: sliced-clumps slice-chunking
 : group ( seq n -- array ) <groups> { } like ;
 
 : clump ( seq n -- array ) <clumps> { } like ;
+
+: monotonic? ( seq quot -- ? )
+    over length 2 < [ 2drop t ] [
+        over length 2 = [
+            [ first2-unsafe ] dip call
+        ] [
+            [ 2 <sliced-clumps> ] dip
+            [ first2-unsafe ] prepose all?
+        ] if
+    ] if ; inline
+
+: all-equal? ( seq -- ? ) [ = ] monotonic? ;
+
+: all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
\ No newline at end of file

diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index 651c8e8a1492bc2c91726d934b9e798f69f4adfe..0b9dbcdfa7bc0af0d649a9f299ef8452933ce889 100644 (file)
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -415,18 +415,6 @@ HELP: filter-here
 { $description "Applies the quotation to each element in turn, and removes elements for which the quotation outputs a false value." }
 { $side-effects "seq" } ;
 
-HELP: monotonic?
-{ $values { "seq" sequence } { "quot" { $quotation "( elt elt -- ? )" } } { "?" "a boolean" } }
-{ $description "Applies the relation to successive pairs of elements in the sequence, testing for a truth value. The relation should be a transitive relation, such as a total order or an equality relation." }
-{ $examples
-    "Testing if a sequence is non-decreasing:"
-    { $example "USING: math prettyprint sequences ;" "{ 1 1 2 } [ <= ] monotonic? ." "t" }
-    "Testing if a sequence is decreasing:"
-    { $example "USING: math prettyprint sequences ;" "{ 9 8 6 7 } [ < ] monotonic? ." "f" }
-} ;
-
-{ monotonic? all-eq? all-equal? } related-words
-
 HELP: interleave
 { $values { "seq" sequence } { "between" "a quotation" } { "quot" { $quotation "( elt -- )" } } }
 { $description "Applies " { $snippet "quot" } " to each element in turn, also invoking " { $snippet "between" } " in-between each pair of elements." }
@@ -565,14 +553,6 @@ HELP: pop
 { $side-effects "seq" }
 { $errors "Throws an error if the sequence is empty." } ;
 
-HELP: all-equal?
-{ $values { "seq" sequence } { "?" "a boolean" } }
-{ $description "Tests if all elements in the sequence are equal. Yields true with an empty sequence." } ;
-
-HELP: all-eq?
-{ $values { "seq" sequence } { "?" "a boolean" } }
-{ $description "Tests if all elements in the sequence are the same identical object. Yields true with an empty sequence." } ;
-
 HELP: mismatch
 { $values { "seq1" sequence } { "seq2" sequence } { "i" "an index" } }
 { $description "Compares pairs of elements up to the minimum of the sequences' lengths, outputting the first index where the two sequences have non-equal elements, or " { $link f } " if all tested elements were equal." } ;
@@ -1443,8 +1423,6 @@ ARTICLE: "sequences-combinators" "Sequence combinators"
 "Testing if a sequence contains elements satisfying a predicate:"
 { $subsection contains? }
 { $subsection all? }
-"Testing how elements are related:"
-{ $subsection monotonic? }
 { $subsection "sequence-2combinators" }
 { $subsection "sequence-3combinators" } ;
 
@@ -1473,10 +1451,7 @@ ARTICLE: "sequences-tests" "Testing sequences"
 "Testing if a sequence contains a subsequence:"
 { $subsection head? }
 { $subsection tail? }
-{ $subsection subseq? }
-"Testing how elements are related:"
-{ $subsection all-eq? }
-{ $subsection all-equal? } ;
+{ $subsection subseq? } ;
 
 ARTICLE: "sequences-search" "Searching sequences"
 "Finding the index of an element:"

diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 5a92dcaf2dec003e0f721327bcc3f3340fbbbf1b..061da056693c57f10089a15acba12190ee637d2c 100644 (file)
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -386,10 +386,6 @@ PRIVATE>
     [ 2drop f f ]
     if ; inline
 
-: (monotonic) ( seq quot -- ? )
-    [ 2dup nth-unsafe rot 1+ rot nth-unsafe ]
-    prepose curry ; inline
-
 : (interleave) ( n elt between quot -- )
     roll 0 = [ nip ] [ swapd 2slip ] if call ; inline
 
@@ -479,9 +475,6 @@ PRIVATE>
 : partition ( seq quot -- trueseq falseseq )
     over [ 2pusher [ each ] 2dip ] dip tuck [ like ] 2bi@ ; inline
 
-: monotonic? ( seq quot -- ? )
-    [ [ length 1- ] keep ] dip (monotonic) all? ; inline
-
 : interleave ( seq between quot -- )
     [ (interleave) ] 2curry [ [ length ] keep ] dip 2each ; inline
 
@@ -671,10 +664,6 @@ PRIVATE>
 : pop ( seq -- elt )
     [ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ;
 
-: all-equal? ( seq -- ? ) [ = ] monotonic? ;
-
-: all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
-
 : exchange ( m n seq -- )
     pick over bounds-check 2drop 2dup bounds-check 2drop
     exchange-unsafe ;
@@ -696,9 +685,7 @@ PRIVATE>
     0 [ length + ] reduce ;
 
 : concat ( seq -- newseq )
-    [
-        { }
-    ] [
+    [ { } ] [
         [ sum-lengths ] keep
         [ first new-resizable ] keep
         [ [ over push-all ] each ] keep