From 29bea4863eca1fbaf016d342cd24933b6e5745f6 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Wed, 30 Nov 2011 17:16:33 -0500
Subject: [PATCH] Add group-by to unstable/list.

---
 collects/tests/unstable/list.rkt         | 14 +++++++++++-
 collects/unstable/list.rkt               | 28 ++++++++++++++++++++++++
 collects/unstable/scribblings/list.scrbl | 16 ++++++++++++++
 3 files changed, 57 insertions(+), 1 deletion(-)

diff --git a/collects/tests/unstable/list.rkt b/collects/tests/unstable/list.rkt
index 8eb52ef1a9..98af4b2e69 100644
--- a/collects/tests/unstable/list.rkt
+++ b/collects/tests/unstable/list.rkt
@@ -37,4 +37,16 @@
                       (map/values 3 values '(1 2 3) '(4 5 6) '(7 8 9))])
          (check-equal? as '(1 2 3))
          (check-equal? bs '(4 5 6))
-         (check-equal? cs '(7 8 9)))))))
+         (check-equal? cs '(7 8 9)))))
+   (test-suite "group-by"
+     (check-equal? (group-by = '(1 4 2 56 2 3))
+                   '((3) (56) (2 2) (4) (1)))
+     (check-equal? (group-by = '(1 2 1 2 54 2 5 43 7 2 643 1 2 0))
+                   '((0) (2 2 2 2 2) (7) (43) (5) (54) (643) (1 1 1)))
+     (check-equal? (group-by (lambda (x y) (or (and (even? x) (even? y))
+                                               (and (odd?  x) (odd?  y))))
+                             '(1 4 2 56 2 3))
+                   '((2 56 2 4) (3 1)))
+     (check-equal? (group-by = '((1 a) (4 b) (2 c) (56 d) (2 e) (3 f))
+                             #:key car)
+                    '(((3 f)) ((56 d)) ((2 e) (2 c)) ((4 b)) ((1 a)))))))
diff --git a/collects/unstable/list.rkt b/collects/unstable/list.rkt
index 5135a59f81..133d1cf472 100644
--- a/collects/unstable/list.rkt
+++ b/collects/unstable/list.rkt
@@ -154,3 +154,31 @@
                (remf f (cdr ls)))]))
 
 (provide/contract [remf (-> procedure? list? list?)])
+
+
+;; stamourv added:
+
+;; (y y -> bool) (listof x) #:key (x -> y) -> (listof (listof x))
+;; groups together elements that are considered equal
+;; =? should be reflexive, transitive and commutative
+(define (group-by =? l #:key [key values])
+  (for/fold ([res '()]) ; list of lists
+      ([elt (in-list l)])
+    (let loop ([classes     res] ; "zipper" of the equivalence classes
+               [rev-classes '()])
+      (cond [(null? classes)
+             ;; did not find an equivalence class, create a new one
+             (cons (list elt) res)]
+            [(=? (key elt) (key (car (car classes))))
+             ;; found the equivalence class
+             (append rev-classes ; we keep what we skipped
+                     ;; we extend the current class
+                     (list (cons elt (car classes)))
+                     (cdr classes))] ; and add the rest
+            [else ; keep going
+             (loop (cdr classes)
+                   (cons (car classes) rev-classes))]))))
+
+(provide/contract
+ [group-by (->* (procedure? list?) (#:key procedure?)
+                list?)])
diff --git a/collects/unstable/scribblings/list.scrbl b/collects/unstable/scribblings/list.scrbl
index 4598444af0..749b50d11d 100644
--- a/collects/unstable/scribblings/list.scrbl
+++ b/collects/unstable/scribblings/list.scrbl
@@ -160,4 +160,20 @@ for which @racket[pred] produces a true value.
 
 }
 
+@addition{Vincent St-Amour}
+
+@defproc[(group-by [=? (-> B B any/c)]
+                   [lst (listof A)]
+                   [#:key extract-key (-> A B) values])
+         (listof (listof A))]{
+
+Groups the given list into equivalence classes, with equivalence being
+determined by @racket[=?].
+
+@examples[#:eval the-eval
+(group-by = '(1 2 1 2 54 2 5 43 7 2 643 1 2 0))
+]
+}
+
+
 @close-eval[the-eval]