lib: new function, relate.

* eval.c (eval_init): Register new intrinsic relate.

* lib.c (do_relate, do_relate_dfl): New static functions.
(relate): New function.

* lib.h (relate): Declared.

* txr.1: Documented.

4 files changed, 85 insertions, 0 deletions

diff --git a/eval.c b/eval.c
index 27aca963..abd28344 100644
--- a/eval.c
+++ b/eval.c
@@ -6164,6 +6164,7 @@ void eval_init(void)
   reg_fun(intern(lit("rsearch"), user_package), func_n4o(rsearch, 2));
   reg_fun(intern(lit("where"), user_package), func_n2(where));
   reg_fun(intern(lit("select"), user_package), func_n2(sel));
+  reg_fun(intern(lit("relate"), user_package), func_n3o(relate, 2));
 
   reg_fun(intern(lit("rcons"), user_package), func_n2(rcons));
   reg_fun(intern(lit("rangep"), user_package), func_n1(rangep));
diff --git a/lib.c b/lib.c
index f0f5e035..58737f69 100644
--- a/lib.c
+++ b/lib.c
@@ -9805,6 +9805,31 @@ val sel(val seq_in, val where_in)
   return make_like(out, seq_in);
 }
 
+static val do_relate(val env, val arg)
+{
+  cons_bind (dom, rng, env);
+  val pos = posqual(arg, dom);
+  return if3(pos, ref(rng, pos), arg);
+}
+
+static val do_relate_dfl(val env, val arg)
+{
+  val dom = env->v.vec[0];
+  val rng = env->v.vec[1];
+  val dfl = env->v.vec[2];
+  val pos = posqual(arg, dom);
+  return if3(pos, ref(rng, pos), dfl);
+}
+
+
+val relate(val domain_seq, val range_seq, val dfl_val)
+{
+  return if3(missingp(dfl_val),
+             func_f1(cons(domain_seq, range_seq), do_relate),
+             func_f1(vec(domain_seq, range_seq, dfl_val, nao),
+                     do_relate_dfl));
+}
+
 val rcons(val from, val to)
 {
   val obj = make_obj();
diff --git a/lib.h b/lib.h
index 63771912..a9024443 100644
--- a/lib.h
+++ b/lib.h
@@ -1043,6 +1043,7 @@ val search(val seq, val key, val from, val to);
 val rsearch(val seq, val key, val from, val to);
 val where(val func, val seq);
 val sel(val seq, val where);
+val relate(val domain_seq, val range_seq, val dfl_val);
 val rcons(val from, val to);
 val rangep(val obj);
 val from(val range);
diff --git a/txr.1 b/txr.1
index d795fc5b..83fcf372 100644
--- a/txr.1
+++ b/txr.1
@@ -26652,6 +26652,64 @@ from the input object, and a new
 is returned whose storage is initialized by converting the extracted
 values back to the foreign representation.
 
+.coNP Function @ relate
+.synb
+.mets (relate < domain-seq < range-seq <> [ default-val ])
+.syne
+.desc
+The
+.code relate
+function returns a one-argument function which implements the relation formed
+by mapping the elements of
+.meta domain-seq
+to the positionally corresponding elements of
+.metn range-seq .
+That is to say, the function searches through the sequence
+.meta domain-seq
+to determine the position where its argument occurs, using
+.code equal
+as the comparison function.
+Then it returns the element from that position in the
+.meta range-seq
+sequence. This returned function is called the
+.IR "relation function" .
+
+If the relation function's argument is not found in
+.metn domain-seq ,
+then the behavior depends on the optional parameter
+.metn default-val .
+If an argument is given for
+.metn default-val ,
+then the relation function returns that value.
+Otherwise, the relation function returns its argument.
+
+Note: the
+.code relate
+function may be understood in terms of the following equivalences:
+
+.cblk
+  (relate d r)  <-->  (lambda (arg)
+                        (iflet ((p (posqual arg d)))
+                          [r p]
+                          arg))
+
+  (relate d r v)  <-->  (lambda (arg)
+                          (iflet ((p (posqual arg d)))
+                            [r p]
+                            v))
+.cble
+
+.TP* Examples:
+
+.cblk
+  (mapcar (relate "_" "-") "foo_bar")  ->  "foo-bar"
+
+  (mapcar (relate "0123456789" "ABCDEFGHIJ" "X") "139D-345")
+  -> "BJDXXDEF"
+
+  (mapcar (relate '(nil) '(0)) '(nil 1 2 nil 4)) -> (0 1 2 0 4)
+.cble
+
 .coNP Function @ in
 .synb
 .mets (in < sequence < key >> [ testfun <> [ keyfun ]])