From 2fd6367303469f0082ee8d3058c46b89bdf8e3d5 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Sun, 26 May 2019 09:30:49 -0700
Subject: [PATCH] add partition*

---
 sugar/list.rkt               | 45 ++++++++++++++++++++++++++----------
 sugar/scribblings/list.scrbl | 21 +++++++++++++----
 sugar/test/main.rkt          |  4 +++-
 3 files changed, 52 insertions(+), 18 deletions(-)

diff --git a/sugar/list.rkt b/sugar/list.rkt
index b6ba3b7..978ed48 100644
--- a/sugar/list.rkt
+++ b/sugar/list.rkt
@@ -1,4 +1,4 @@
-#lang racket/base
+#lang debug racket/base
 (require (for-syntax
           racket/base)
          racket/list
@@ -15,15 +15,29 @@
     (raise-argument-error 'trimf "list?" xs))
   (dropf-right (dropf xs test-proc) test-proc))
 
-(define (slicef-and-filter-split-helper xs pred [drop-negated? #f])
-  (let loop ([xs xs][negating? #f][acc empty])
-    (cond
-      [(empty? xs) (reverse acc)]
-      [else
-       (define loop-pred (if negating? (negate pred) pred))
-       (define-values (loop-pred-xs other-xs) (splitf-at xs loop-pred))
-       (define subxs (if (and negating? drop-negated?) empty loop-pred-xs))
-       (loop other-xs (not negating?) (if (empty? subxs) acc (cons subxs acc)))])))
+(define (slicef-and-filter-split-helper xs pred [separate-negated? #f])
+  (let loop ([xs xs][negating? #f][acc empty][negated-acc empty])
+    (match xs
+      [(? empty?) (if separate-negated?
+                      (values (reverse acc) (reverse negated-acc))
+                      (reverse acc))]
+      [(list* (? (if negating? (negate pred) pred) pred-xs) ... other-xs)
+       (cond
+         [(and negating? separate-negated?)
+          (loop other-xs
+                (not negating?)
+                acc
+                (match pred-xs
+                  [(? empty?) negated-acc]
+                  [_ (cons pred-xs negated-acc)]))]
+         [else
+          (loop other-xs
+                (not negating?)
+                (match pred-xs
+                  [(? empty?) acc]
+                  [_ (cons pred-xs acc)])
+                negated-acc)])])))
+
 
 (define+provide+safe (slicef xs pred)
   (list? procedure? . -> . (listof list?))
@@ -72,12 +86,19 @@
         (match/values (split-at xs len)
                       [(subxs rest) (loop rest (cons subxs slices))]))))
 
+(define+provide+safe (partition* pred xs)
+  (predicate/c list? . -> . (values list? list?))
+  (unless (list? xs)
+    (raise-argument-error 'partition* "list?" xs))
+  (slicef-and-filter-split-helper xs pred 'drop-negated))
+
 (define+provide+safe (filter-split xs pred)
   (list? predicate/c . -> . (listof list?))
   (unless (list? xs)
     (raise-argument-error 'filter-split "list?" xs))
-  ;; same idea as slicef, but the negated items are dropped(-
-  (slicef-and-filter-split-helper xs (negate pred) 'drop-negated))
+  ;; same idea as slicef, but the negated items are dropped
+  (define-values (negated-pred-xs _) (partition* (negate pred) xs))
+  negated-pred-xs)
 
 (define+provide+safe (frequency-hash xs)
   (list? . -> . hash?)
diff --git a/sugar/scribblings/list.scrbl b/sugar/scribblings/list.scrbl
index 4d37af7..e800c58 100644
--- a/sugar/scribblings/list.scrbl
+++ b/sugar/scribblings/list.scrbl
@@ -1,9 +1,9 @@
 #lang scribble/manual
 
-@(require scribble/eval (for-label racket sugar))
+@(require scribble/eval (for-label racket sugar racket/function))
 
 @(define my-eval (make-base-eval))
-@(my-eval `(require sugar racket/list))
+@(my-eval `(require sugar racket/list racket/function))
 
 @title{Lists}
 @defmodule[#:multi (sugar/list (submod sugar/list safe))]
@@ -33,9 +33,20 @@ Like @racket[string-split], but for lists. Drop elements from anywhere in @racke
 
 @examples[#:eval my-eval
 (filter-split '(1 a b c 2 d e f 3) integer?)
-(filter-split '(1 a b c 2 d e f 3) (compose not integer?))
-(filter-split '(a b c 1 2 3 d e f) integer?)
-(filter-split '(a b c 1 2 3 d e f) (compose not integer?))]
+(filter-split '(1 a b c 2 d e f 3) (negate integer?))]
+
+@defproc[
+(partition*
+[pred procedure?]
+[lst list?])
+(values list? list?)]
+Like @racket[partition], but contiguous groups of elements matching (or not matching) @racket[_pred] are kept together in sublists.
+
+Same as @racket[(values (filter-split _lst _pred) (filter-split _lst (negate _pred)))], but only traverses the list once.
+
+@examples[#:eval my-eval
+(partition* integer? '(1 a b c 2 d e f 3))
+(partition* (negate integer?) '(1 a b c 2 d e f 3))]
 
 @defproc[
 (slice-at
diff --git a/sugar/test/main.rkt b/sugar/test/main.rkt
index 8f68a91..01ea26f 100644
--- a/sugar/test/main.rkt
+++ b/sugar/test/main.rkt
@@ -132,7 +132,9 @@
  
  (check-equal? (trimf (list 4 1 2 3 4) even?) '(1 2 3))
  (check-equal? (trimf (list 1 3 2 4 5 6 8 9 13) odd?) '(2 4 5 6 8))
- (check-equal? (filter-split '(1 2 3 4 5 6) even?) '((1)(3)(5)))
+ (check-equal? (filter-split '(1 1 2 3 4 4 5 6) even?) '((1 1)(3)(5)))
+ (check-equal? (let-values ([(preds not-preds) (partition* even? '(1 1 2 3 4 4 5 6))])
+                 (list preds not-preds)) (list '((2)(4 4)(6)) '((1 1)(3)(5))))
  
  (define foo-path-strings '("foo" "foo.txt" "foo.bar" "foo.bar.txt"))
  (match-define (list foo-path foo.txt-path foo.bar-path foo.bar.txt-path) (map ->path foo-path-strings))