Delete empty unit tests files, remove 1- and 1+, reorder IN: lines in a lot of places...

[factor.git] / basis / grouping / grouping.factor

diff --git a/basis/grouping/grouping.factor b/basis/grouping/grouping.factor
index 4a1b8c7b90c3a39071b058fbce6c670a43c2ccee..f68760a4e18e881d08d80507edd2223a90a7d99d 100644 (file)
--- a/basis/grouping/grouping.factor
+++ b/basis/grouping/grouping.factor
@@ -1,17 +1,18 @@
-! 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 ;
+sequences.private accessors fry ;
 IN: grouping
 
 <PRIVATE
 
 TUPLE: chunking-seq { seq read-only } { n read-only } ;
 
-: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
+: check-groups ( n -- n )
+    dup 0 <= [ "Invalid group count" throw ] when ; inline
 
 : new-groups ( seq n class -- groups )
-    >r check-groups r> boa ; inline
+    [ check-groups ] dip boa ; inline
 
 GENERIC: group@ ( n groups -- from to seq )
 
@@ -34,7 +35,7 @@ M: slice-chunking nth-unsafe group@ slice boa ;
 TUPLE: abstract-groups < chunking-seq ;
 
 M: abstract-groups length
-    [ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
+    [ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ;
 
 M: abstract-groups set-length
     [ n>> * ] [ seq>> ] bi set-length ;
@@ -45,10 +46,10 @@ M: abstract-groups group@
 TUPLE: abstract-clumps < chunking-seq ;
 
 M: abstract-clumps length
-    [ seq>> length ] [ n>> ] bi - 1+ ;
+    [ seq>> length ] [ n>> ] bi - 1 + ;
 
 M: abstract-clumps set-length
-    [ n>> + 1- ] [ seq>> ] bi set-length ;
+    [ n>> + 1 - ] [ seq>> ] bi set-length ;
 
 M: abstract-clumps group@
     [ n>> over + ] [ seq>> ] bi ;
@@ -86,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 @ ] all?
+        ] if
+    ] if ; inline
+
+: all-equal? ( seq -- ? ) [ = ] monotonic? ;
+
+: all-eq? ( seq -- ? ) [ eq? ] monotonic? ;