From 86f375c1b521357cffb9d8411abc031da8279acb Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Tue, 9 Sep 2014 07:49:11 -0700
Subject: * eval.c (eval_init): Register intrinsic partition* function.

* lib.c (partition_star_func): New static function.
(partition_star): New function.

* lib.h (partition_star): Declared.

* txr.1: Documented partition*.
---
 ChangeLog | 11 +++++++++
 eval.c    |  1 +
 lib.c     | 77 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 lib.h     |  1 +
 txr.1     | 41 ++++++++++++++++++++++++++++++++++
 5 files changed, 131 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index 62533c85..b30c88af 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2014-09-09  Kaz Kylheku  <kaz@kylheku.com>
+
+	* eval.c (eval_init): Register intrinsic partition* function.
+
+	* lib.c (partition_star_func): New static function.
+	(partition_star): New function.
+
+	* lib.h (partition_star): Declared.
+
+	* txr.1: Documented partition*.
+
 2014-09-09  Kaz Kylheku  <kaz@kylheku.com>
 
 	* eval.c (eval_init): Register intrinsic partition function.
diff --git a/eval.c b/eval.c
index 1cfb10f2..3adeb6b8 100644
--- a/eval.c
+++ b/eval.c
@@ -3655,6 +3655,7 @@ void eval_init(void)
   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(intern(lit("partition"), user_package), func_n2(partition));
+  reg_fun(intern(lit("partition*"), user_package), func_n2(partition_star));
   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 493416fb..cb779d8d 100644
--- a/lib.c
+++ b/lib.c
@@ -1486,6 +1486,83 @@ val partition(val seq, val indices)
                                 partition_func));
 }
 
+static val partition_star_func(val env, val lcons)
+{
+  for (;;) {
+    cons_bind (seq, indices_base, env);
+    cons_bind (indices, base, indices_base);
+
+    if (indices) {
+      val index = pop(&indices);
+      val index_rebased = minus(index, base);
+      val first = nullify(sub(seq, zero, index_rebased));
+
+      seq = nullify(sub(seq, plus(index_rebased, one), t));
+
+      rplaca(env, seq);
+      rplaca(indices_base, indices);
+      rplacd(indices_base, base = plus(index, one));
+
+      if (!first)
+        continue;
+
+      rplaca(lcons, first);
+
+      while (seq && eql(car(indices), base)) {
+        seq = nullify(cdr(seq));
+        base = plus(base, one);
+        pop(&indices);
+      }
+
+      rplaca(indices_base, indices);
+      rplacd(indices_base, base);
+
+      if (seq)
+        rplacd(lcons, make_lazy_cons(lcons_fun(lcons)));
+    } else {
+      rplaca(lcons, seq);
+    }
+
+    break;
+  }
+
+  return nil;
+}
+
+val partition_star(val seq, val indices)
+{
+  val base = zero;
+  seq = nullify(seq);
+  indices = nullify(indices);
+
+  if (!seq)
+    return nil;
+
+  if (!indices)
+    return cons(seq, nil);
+
+  if (functionp(indices))
+    indices = funcall1(indices, seq);
+
+  if (indices == zero)
+    return nullify(rest(seq));
+
+  if (atom(indices)) {
+    indices = cons(indices, nil);
+  } else {
+    while (eql(car(indices), base)) {
+      seq = nullify(cdr(seq));
+      if (!seq)
+        return nil;
+      base = plus(base, one);
+      pop(&indices);
+    }
+  }
+
+  return make_lazy_cons(func_f1(cons(seq, cons(indices, base)),
+                                partition_star_func));
+}
+
 cnum c_num(val num);
 
 val eql(val left, val right)
diff --git a/lib.h b/lib.h
index 63e72c3c..77b5a342 100644
--- a/lib.h
+++ b/lib.h
@@ -446,6 +446,7 @@ val lazy_flatten(val list);
 val tuples(val n, val seq, val fill);
 val partition_by(val func, val seq);
 val partition(val seq, val indices);
+val partition_star(val seq, val indices);
 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 fddca88a..e99a6809 100644
--- a/txr.1
+++ b/txr.1
@@ -8076,6 +8076,47 @@ Examples:
   ;; split the string where there is a "b"
   (partition "abcbcbd" (op where @1 (op eql #\eb))) -> ("a" "bc" "bc" "bd")
 
+.SS Funtion partition*
+
+.TP
+Syntax:
+
+  (partition* <sequence> {<index-list> | <index> | <function>})
+
+.TP
+Description:
+
+If <sequence> is empty, then partition returns an empty list, and the
+second argument is ignored; if it is <function>, it is not called.
+
+If the second argument is of the form <index-list>, which is a sequence
+of strictly increasing non-negative integers, then partition* produces
+lazy list of pieces taken from <sequence>. The pieces are formed by
+deleting from <sequence> the elements at the positions given
+in <index-list>. The pieces are the non-empty sub-strings between
+the deleted elements.
+
+If <index-list> is empty then a one-element list containing the entire
+<sequence> is returned.
+
+If the second argument is a function, then this function is applied
+to <sequence>, and the return value of this call is then used in place of the
+second argument, which must be an <index> or <index-list>.
+
+If the second argument is an atom other than a function, it is assumed to be
+an integer index, and is turned into an <index-list> of one element.
+
+
+.TP
+Examples:
+
+  (partition* '(1 2 3 4 5) '(0 2 4)) -> ((1) (3) (5))
+
+  (partition* "abcd" '(0 3)) -> "bc"
+
+  (partition* "abcd" '(0 1 2 3)) -> nil
+
+
 .SS Function tree-find
 
 .TP
-- 
cgit v1.2.3