From 65189fb5a549a4149db9a6b59bd89d2d8009b89b Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Fri, 29 Nov 2013 23:15:48 -0800
Subject: * eval.c (eval_init): New functions countqual, countql, countq and
 count_if registered as intrinsics.

* lib.c (countqual, countql, countq, count_if): New functions.

* lib.h (countqual, countql, countq, count_if): Declared.

* txr.1: New functions documented.
---
 ChangeLog | 11 +++++++++++
 eval.c    |  4 ++++
 lib.c     | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++
 lib.h     |  4 ++++
 txr.1     | 33 +++++++++++++++++++++++++++++++++
 5 files changed, 103 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index 0dac1905..ba8fd507 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2013-11-29  Kaz Kylheku  <kaz@kylheku.com>
+
+	* eval.c (eval_init): New functions countqual, countql, countq
+	and count_if registered as intrinsics.
+
+	* lib.c (countqual, countql, countq, count_if): New functions.
+
+	* lib.h (countqual, countql, countq, count_if): Declared.
+
+	* txr.1: New functions documented.
+
 2013-11-29  Kaz Kylheku  <kaz@kylheku.com>
 
 	* configure (config_flags): New variable, allowing us to
diff --git a/eval.c b/eval.c
index c6073f0a..f40e6b89 100644
--- a/eval.c
+++ b/eval.c
@@ -2249,6 +2249,10 @@ void eval_init(void)
   reg_fun(intern(lit("remove-if*"), user_package), func_n3o(remove_if_lazy, 2));
   reg_fun(intern(lit("keep-if*"), user_package), func_n3o(keep_if_lazy, 2));
   reg_fun(intern(lit("tree-find"), user_package), func_n3o(tree_find, 2));
+  reg_fun(intern(lit("countqual"), user_package), func_n2(countqual));
+  reg_fun(intern(lit("countql"), user_package), func_n2(countql));
+  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("some"), user_package), func_n3o(some_satisfy, 2));
   reg_fun(intern(lit("all"), user_package), func_n3o(all_satisfy, 2));
   reg_fun(intern(lit("none"), user_package), func_n3o(none_satisfy, 2));
diff --git a/lib.c b/lib.c
index 0dba8f8f..6a59ecd3 100644
--- a/lib.c
+++ b/lib.c
@@ -783,6 +783,57 @@ val tree_find(val obj, val tree, val testfun)
   return nil;
 }
 
+val countqual(val obj, val list)
+{
+  val count = zero;
+
+  for (; list; list = cdr(list))
+    if (equal(car(list), obj))
+      count = plus(count, one);
+
+  return count;
+}
+
+val countql(val obj, val list)
+{
+  val count = zero;
+
+  for (; list; list = cdr(list))
+    if (eql(car(list), obj))
+      count = plus(count, one);
+
+  return count;
+}
+
+val countq(val obj, val list)
+{
+  val count = zero;
+
+  for (; list; list = cdr(list))
+    if (eq(car(list), obj))
+      count = plus(count, one);
+
+  return count;
+}
+
+val count_if(val pred, val list, val key)
+{
+  val count = zero;
+
+  if (!key)
+    key = identity_f;
+
+  for (; list; list = cdr(list)) {
+    val subj = funcall1(key, car(list));
+    val satisfies = funcall1(pred, subj);
+
+    if (satisfies)
+      count = plus(count, one);
+  }
+
+  return count;
+}
+
 val some_satisfy(val list, val pred, val key)
 {
   if (!key)
diff --git a/lib.h b/lib.h
index c4a7f2df..5dee93b4 100644
--- a/lib.h
+++ b/lib.h
@@ -398,6 +398,10 @@ val remqual_lazy(val obj, val list);
 val remove_if_lazy(val pred, val list, val key);
 val keep_if_lazy(val pred, val list, val key);
 val tree_find(val obj, val tree, val testfun);
+val countqual(val obj, val list);
+val countql(val obj, val list);
+val countq(val obj, val list);
+val count_if(val pred, val list, val key);
 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/txr.1 b/txr.1
index 45780d73..c38de95c 100644
--- a/txr.1
+++ b/txr.1
@@ -6626,6 +6626,21 @@ Examples:
 
   [(remql* 13 (range 1)) 0..100]
 
+.SS Functions countqual, countql and countq
+
+.TP
+Syntax:
+
+  (countq <object> <list>)
+  (countql <object> <list>)
+  (countqual <object> <list>)
+
+.TP
+Description
+
+The countq, countql and countqual functions count the number of objects
+in <list> which are eq, eql or equal to <object>, and return the count.
+
 .SH APPLICATIVE LIST PROCESSING
 
 .SS Functions remove-if, keep-if, remove-if* and keep-if*
@@ -6676,6 +6691,24 @@ Examples:
              '(("abcd" 4) ("defg" 5)))
   -> (("defg 5))
 
+.SS Function count-if
+
+.TP
+Syntax:
+
+  (count-if <predicate-function> <list> : <key-function>)
+
+.TP
+Description:
+
+The countove-if function counts the numer of elements of <list> which satisfy
+<predicate-function> and returns the count.
+
+The optional <key-function> specifies how each element from the <list> is
+transformed to an argument to <predicate-function>. If this argument is omitted
+or specified as nil, then the predicate function is applied to the elements
+directly, a behavior which is identical to <key-function> being (fun identity).
+
 .SS Function tree-find
 
 .TP
-- 
cgit v1.2.3