From ab58598e62eb7ca718d2ee083c1c2c2ede4d6db3 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Fri, 9 Feb 2024 07:34:15 -0800
Subject: New function: cons-count.

* eval.c (eval_init): Register cons-count intrinsic.

* lib.c (cons_count_rec): New static function.
(cons_count): New function.

* lib.h (cons_count): Declared.

* tests/012/cons.tl: New tests.

* txr.1: Documented.
---
 eval.c            |  1 +
 lib.c             | 19 +++++++++++++++++++
 lib.h             |  1 +
 tests/012/cons.tl |  9 +++++++++
 txr.1             | 41 +++++++++++++++++++++++++++++++++++++++++
 5 files changed, 71 insertions(+)

diff --git a/eval.c b/eval.c
index 52bfe4af..4de90576 100644
--- a/eval.c
+++ b/eval.c
@@ -7364,6 +7364,7 @@ void eval_init(void)
   reg_fun(intern(lit("countq"), user_package), func_n2(countq));
   reg_fun(intern(lit("count-if"), user_package), func_n3o(count_if, 2));
   reg_fun(intern(lit("count"), user_package), func_n4o(count, 2));
+  reg_fun(intern(lit("cons-count"), user_package), func_n3o(cons_count, 2));
   reg_fun(intern(lit("posqual"), user_package), func_n2(posqual));
   reg_fun(intern(lit("rposqual"), user_package), func_n2(rposqual));
   reg_fun(intern(lit("posql"), user_package), func_n2(posql));
diff --git a/lib.c b/lib.c
index 580ee468..38028ea7 100644
--- a/lib.c
+++ b/lib.c
@@ -3596,6 +3596,25 @@ val count(val item, val seq, val testfun_in, val keyfun_in)
 
 }
 
+static val cons_count_rec(val item, val tree, val testfun)
+{
+  val hc = if3(funcall2(testfun, item, tree), one, zero);
+
+  if (consp(tree)) {
+    val ac = cons_count_rec(item, us_car(tree), testfun);
+    val dc = cons_count_rec(item, us_cdr(tree), testfun);
+
+    return plus(plus(hc, ac), dc);
+  }
+
+  return hc;
+}
+
+val cons_count(val item, val tree, val testfun_in)
+{
+  return cons_count_rec(item, tree, default_arg(testfun_in, equal_f));
+}
+
 val some_satisfy(val seq, val pred_in, val key_in)
 {
   val pred = default_arg(pred_in, identity_f);
diff --git a/lib.h b/lib.h
index 212a03a0..7fc5c7c4 100644
--- a/lib.h
+++ b/lib.h
@@ -864,6 +864,7 @@ val countql(val obj, val list);
 val countq(val obj, val list);
 val count_if(val pred, val list, val key);
 val count(val item, val seq, val testfun_in, val keyfun_in);
+val cons_count(val item, val tree, val testfun_in);
 val some_satisfy(val list, val pred, val key);
 val all_satisfy(val list, val pred, val key);
 val none_satisfy(val list, val pred, val key);
diff --git a/tests/012/cons.tl b/tests/012/cons.tl
index d72a5d74..98267290 100644
--- a/tests/012/cons.tl
+++ b/tests/012/cons.tl
@@ -24,3 +24,12 @@
   (cons-find "d" '("a" (("b") . "d") "c")) t
   (cons-find "d" '("a" . "d")) t
   (cons-find nil '("a" (("b")) "c")) t)
+
+(mtest
+  (cons-count "abc" "abc") 1
+  (cons-count "abc" "abc" (fun eq)) 0
+  (cons-count "b" '("b" . "b")) 2
+  (cons-count "b" '(3 . "b")) 1
+  (cons-count "b" '("b" . 3)) 1
+  (cons-count "b" '(("b" . "b") ("b" . "b"))) 4
+  (cons-count nil '(1 (2 3 (4)))) 3)
diff --git a/txr.1 b/txr.1
index 818e4155..30893510 100644
--- a/txr.1
+++ b/txr.1
@@ -36112,6 +36112,47 @@ The function returns the count of the number keys for which
 .meta predfun
 returns true.
 
+.coNP Function @ cons-count
+.synb
+.mets (cons-count < obj < tree <> [ test-function ])
+.syne
+.desc
+The
+.code cons-count
+function returns the number of times the object
+.meta obj
+occurs in the
+.code cons
+cell structure
+.metn tree ,
+under the equality imposed by the
+.metn test-function .
+
+If the optional
+.meta test-function
+argument is omitted, it defaults to
+.codn equal .
+
+First,
+.meta obj
+and
+.meta tree
+are compared using
+.metn test-function .
+If they are equal, that counts as one occurrence.
+
+Then, if
+.meta tree
+is a
+.code cons
+cell, the function recurses over the
+.code car
+and
+.code cdr
+fields.
+
+The sum of all these counts is returned.
+
 .coNP Functions @, posq @ posql and @ posqual
 .synb
 .mets (posq < object << sequence )
-- 
cgit v1.2.3