* eval.c (nperm_while_fun, nperm_gen_fun, nperm_list,

nperm_vec_gen_fun, nperm_vec, nperm_str_gen_fun, nperm_str, nperm): New
static functions.
(eval_init): nperm registered as intrinsic.

* txr.1: Documented nperm function.

3 files changed, 141 insertions, 0 deletions

diff --git a/ChangeLog b/ChangeLog
index 9c775c1f..52373bfd 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2014-02-07  Kaz Kylheku  <kaz@kylheku.com>
+
+	* eval.c (nperm_while_fun, nperm_gen_fun, nperm_list,
+	nperm_vec_gen_fun, nperm_vec, nperm_str_gen_fun, nperm_str, nperm): New
+	static functions.
+	(eval_init): nperm registered as intrinsic.
+
+	* txr.1: Documented nperm function.
+
 2014-02-06  Kaz Kylheku  <kaz@kylheku.com>
 
 	Version 78
diff --git a/eval.c b/eval.c
index 613463c1..5175345d 100644
--- a/eval.c
+++ b/eval.c
@@ -2125,6 +2125,101 @@ static val force(val promise)
   return rplacd(promise, funcall(cdr(promise)));
 }
 
+static val rperm_while_fun(val env)
+{
+  val vec = cdr(env);
+  return consp(vecref(vec, zero));
+}
+
+static val rperm_gen_fun(val env)
+{
+  cons_bind (list, vec, env);
+  list_collect_decl(out, ptail);
+  cnum i;
+  cnum len = c_num(length_vec(vec));
+
+  for (i = 0; i < len; i++)
+    list_collect(ptail, car(vec->v.vec[i]));
+
+  for (i = len-1; i >= 0; i--) {
+    pop(&vec->v.vec[i]);
+    if (atom(vec->v.vec[i]) && i > 0)
+      vec->v.vec[i] = list;
+    else
+      break;
+  }
+
+  return out;
+}
+
+static val rperm_list(val list, val n)
+{
+  val vec = vector(n, list);
+  val env = cons(list, vec);
+  return generate(func_f0(env, rperm_while_fun),
+                  func_f0(env, rperm_gen_fun));
+}
+
+static val rperm_vec_gen_fun(val env)
+{
+  val list = rperm_gen_fun(env);
+  return vector_list(list);
+}
+
+static val rperm_vec(val ve, val n)
+{
+  val list = list_vector(ve);
+  val vec = vector(n, list);
+  val env = cons(list, vec);
+  return generate(func_f0(env, rperm_while_fun),
+                  func_f0(env, rperm_vec_gen_fun));
+}
+
+static val rperm_str_gen_fun(val env)
+{
+  val list = rperm_gen_fun(env);
+  return cat_str(list, nil);
+}
+
+static val rperm_str(val str, val n)
+{
+  val list = list_str(str);
+  val vec = vector(n, list);
+  val env = cons(list, vec);
+  return generate(func_f0(env, rperm_while_fun),
+                  func_f0(env, rperm_str_gen_fun));
+}
+
+static val rperm(val seq, val n)
+{
+  if (!integerp(n))
+    type_mismatch(lit("rperm: ~s is not an integer"), n, nao);
+
+  if (zerop(n))
+    return nil;
+
+  if (lt(n, zero))
+    uw_throwf(numeric_error_s, lit("rperm: ~s is not a positive integer"),
+              n, nao);
+
+  switch (type(seq)) {
+  case NIL:
+    return nil;
+  case CONS:
+  case LCONS:
+    return rperm_list(seq, n);
+  case VEC:
+    return rperm_vec(seq, n);
+  case STR:
+  case LSTR:
+  case LIT:
+    return rperm_str(seq, n);
+  default:
+    type_mismatch(lit("rperm: ~s is not a sequence"), seq, nao);
+  }
+}
+
+
 static val errno_wrap(val newval)
 {
   val oldval = num(errno);
@@ -2717,6 +2812,7 @@ void eval_init(void)
   reg_fun(generate_s, func_n2(generate));
   reg_fun(intern(lit("repeat"), user_package), func_n1v(repeatv));
   reg_fun(intern(lit("force"), user_package), func_n1(force));
+  reg_fun(intern(lit("rperm"), user_package), func_n2(rperm));
 
   reg_fun(throw_s, func_n1v(uw_throw));
   reg_fun(intern(lit("throwf"), user_package), func_n2v(uw_throwfv));
diff --git a/txr.1 b/txr.1
index d38f3733..d01c62ba 100644
--- a/txr.1
+++ b/txr.1
@@ -7869,6 +7869,42 @@ cached inside <promise> and returned, becoming the return value of the
 force function call.  If the force function is invoked additional times on
 the same promise, the cached value is retrieved.
 
+.SS Function perm
+
+.TP
+Syntax:
+
+  (rperm <seq> <len>)
+
+.TP
+Description:
+
+The rperm function returns a lazy list which consists of all the repeating
+permutations of length <len> formed by items taken from <seq>. 
+"Repeating" means that the items from <seq> can appear more than
+once in the permutations.
+
+Argument <len> must be a positive integer, and <seq> must be a sequence.
+
+If <seq> is empty, or if <len> is zero, then the empty list is returned.
+
+Otherwise permutations are returned which are sequences of the same kind as
+<seq>.
+
+The first permutation consists of <len> repetitions of the first element of
+<seq>. The next repetition, if there is one, differs from the first
+repetition in that its last element is the second element of <seq>.
+
+.TP
+Examples:
+
+  (rperm "01" 4) -> ("000" "001" "010" "011" "100" "101" "110" "111")
+
+  (rperm #(1) 3) -> (#(1 1 1))
+
+  (rperm '(0 1 2) 2) -> ((0 0) (0 1) (0 2) (1 0) (1 1) (1 2) (2 0) (2 1) (2 2))
+
+
 .SH CHARACTERS AND STRINGS
 
 .SS Function mkstring