From 2014daea4ca5a4f92afc07bbc08dfdcb6c095a12 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Mon, 28 Jul 2014 22:21:13 -0700
Subject: * eval.c (eval_init): Register partition-by intrinsic.

* lib.c (partition_by_func): New static function.
(partition_by): New function.

* lib.h (partition_by): Declared.

* txr.1: Documented partition-by.
---
 ChangeLog | 11 +++++++++++
 eval.c    |  1 +
 lib.c     | 46 ++++++++++++++++++++++++++++++++++++++++++++++
 lib.h     |  1 +
 txr.1     | 39 +++++++++++++++++++++++++++++++++++++++
 5 files changed, 98 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index a148c69c..c01eea05 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2014-07-28  Kaz Kylheku  <kaz@kylheku.com>
+
+	* eval.c (eval_init): Register partition-by intrinsic.
+
+	* lib.c (partition_by_func): New static function.
+	(partition_by): New function.
+
+	* lib.h (partition_by): Declared.
+
+	* txr.1: Documented partition-by.
+
 2014-07-28  Kaz Kylheku  <kaz@kylheku.com>
 
 	* arith.c (rising_product): Fix wrong m == n case,
diff --git a/eval.c b/eval.c
index d2539817..e44d132f 100644
--- a/eval.c
+++ b/eval.c
@@ -3647,6 +3647,7 @@ void eval_init(void)
   reg_fun(intern(lit("flatten"), user_package), func_n1(flatten));
   reg_fun(intern(lit("flatten*"), user_package), func_n1(lazy_flatten));
   reg_fun(intern(lit("tuples"), user_package), func_n3o(tuples, 2));
+  reg_fun(intern(lit("partition-by"), user_package), func_n2(partition_by));
   reg_fun(memq_s, func_n2(memq));
   reg_fun(memql_s, func_n2(memql));
   reg_fun(memqual_s, func_n2(memqual));
diff --git a/lib.c b/lib.c
index 563da3a0..863be13b 100644
--- a/lib.c
+++ b/lib.c
@@ -1373,6 +1373,52 @@ val tuples(val n, val seq, val fill)
                                 tuples_func));
 }
 
+static val partition_by_func(val env, val lcons)
+{
+  list_collect_decl (out, ptail);
+  cons_bind (seq_func, func, env);
+  cons_bind (flast, seq_in, seq_func);
+  val seq = seq_in;
+  val last = pop(&seq);
+  val next, fnext = nil;
+
+  ptail = list_collect(ptail, last);
+
+  while (seq) {
+    fnext = funcall1(func, next = car(seq));
+
+    if (!equal(flast, fnext))
+      break;
+
+    ptail = list_collect(ptail, next);
+
+    seq = cdr(seq);
+    last = next;
+    flast = fnext;
+  }
+
+  rplaca(seq_func, fnext);
+  rplacd(seq_func, seq);
+
+  if (seq)
+    rplacd(lcons, make_lazy_cons(lcons_fun(lcons)));
+
+  rplaca(lcons, make_like(out, seq_in));
+  return nil;
+}
+
+val partition_by(val func, val seq)
+{
+  seq = nullify(seq);
+
+  if (!seq)
+    return nil;
+
+  return make_lazy_cons(func_f1(cons(cons(funcall1(func, car(seq)), seq),
+                                     func),
+                                partition_by_func));
+}
+
 cnum c_num(val num);
 
 val eql(val left, val right)
diff --git a/lib.h b/lib.h
index f9bcb4e3..157a7994 100644
--- a/lib.h
+++ b/lib.h
@@ -443,6 +443,7 @@ val ldiff(val list1, val list2);
 val flatten(val list);
 val lazy_flatten(val list);
 val tuples(val n, val seq, val fill);
+val partition_by(val func, val seq);
 val memq(val obj, val list);
 val memql(val obj, val list);
 val memqual(val obj, val list);
diff --git a/txr.1 b/txr.1
index 230d17c3..560f359f 100644
--- a/txr.1
+++ b/txr.1
@@ -10770,6 +10770,45 @@ Examples:
   (tuples 3 "abcd" #\z) -> ("abc" "dzz")
   (tuples 3 (list 1 2) #\z) -> ((1 2 #\z))
 
+.SS Function partition-by
+
+.TP
+Syntax:
+
+  (partition-by <function> <sequence>)
+
+.TP
+Description:
+
+If <sequence> is empty, then partition-by returns an empty list,
+and <function> is never called.
+
+Otherwise, partition-by returns a lazy list of partitions of the sequence
+<sequence>.   Partitions are consecutive, non-empty sub-strings of <sequence>,
+of the same kind as <sequence>.
+
+The partitioning begins with the first element of <sequence> being is placed
+into a partition.
+
+The subsequent partitioning is done according to <function>, which is applied
+to each element of <sequence>. Whenever, for the next element, the function
+returns the same value as it returned for the previous element, the
+element is placed into the same partition. Otherwise, the next element
+is placed into, and begins, a new partition.
+
+The return values of the calls to <function> are compared using the equal
+function.
+
+Note:
+
+.TP
+Examples:
+
+  [partition-by identity '(1 2 3 3 4 4 4 5)] -> ((1) (2) (3 3) (4 4 4) (5))
+
+  (partition-by (op = 3) #(1 2 3 4 5 6 7)) -> (#(1 2) #(3) #(4 5 6 7))
+
+
 .SS Function make-like
 
 .TP
-- 
cgit v1.2.3