srfi-1 count

srfi-1 count

[Kevin Ryde]

[-- Attachment #1: Type: text/plain, Size: 102 bytes --]

        * srfi-1.c, srfi-1.h, srfi-1.scm (count): Rewrite in C, avoiding
        non-tail recursion.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: count.c --]
[-- Type: text/x-csrc, Size: 3352 bytes --]

SCM scm_srfi1_count (SCM pred, SCM lst1, SCM rest);


SCM_DEFINE (scm_srfi1_count, "count", 2, 0, 1,
            (SCM pred, SCM lst1, SCM rest),
	    "Return a count of the number of times @var{pred} returns true\n"
	    "when called on elements from the given lists.\n"
	    "\n"
	    "@var{pred} is called with @var{N} parameters @code{(@var{pred}\n"
	    "@var{elem1} @dots{} @var{elemN})}, each element being from the\n"
	    "corresponding @var{lst1} @dots{} @var{lstN}.  The first call is\n"
	    "with the first element of each list, the second with the second\n"
	    "element from each, and so on.\n"
	    "\n"
	    "Counting stops when the end of the shortest list is reached.\n"
	    "At least one list must be non-circular.")
#define FUNC_NAME s_scm_srfi1_count
{
  long  count;
  SCM_VALIDATE_REST_ARGUMENT (rest);

  count = 0;

  if (SCM_NULLP (rest))
    {
      /* one list */
      scm_t_trampoline_1 pred_tramp;
      pred_tramp = scm_trampoline_1 (pred);
      SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);

      for ( ; SCM_CONSP (lst1); lst1 = SCM_CDR (lst1))
        count += ! SCM_FALSEP (pred_tramp (pred, SCM_CAR (lst1)));

    end_lst1:
      SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst1), lst1, SCM_ARG2, FUNC_NAME,
                       "list");
    }
  else if (SCM_CONSP (rest) && SCM_NULLP (SCM_CDR (rest)))
    {
      /* two lists */
      scm_t_trampoline_2 pred_tramp;
      SCM lst2;

      pred_tramp = scm_trampoline_2 (pred);
      SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);

      lst2 = SCM_CAR (rest);
      for (;;)
        {
          if (! SCM_CONSP (lst1))
            goto end_lst1;
          if (! SCM_CONSP (lst2))
            {
              SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst2), lst2, SCM_ARG3,
                               FUNC_NAME, "list");
              break;
            }
          count += ! SCM_FALSEP (pred_tramp
                                 (pred, SCM_CAR (lst1), SCM_CAR (lst2)));
          lst1 = SCM_CDR (lst1);
          lst2 = SCM_CDR (lst2);
        }
    }
  else
    {
      /* three or more lists */
      SCM  lstlst, args, l, a, lst;
      int  argnum;

      /* lstlst is a list of the list arguments */
      lstlst = scm_cons (lst1, rest);

      /* args is the argument list to pass to pred, same length as lstlst,
         re-used for each call */
      args = SCM_EOL;
      for (l = lstlst; SCM_CONSP (l); l = SCM_CDR (l))
        args = scm_cons (SCM_BOOL_F, args);

      for (;;)
        {
          /* first elem of each list in lstlst into args, and step those
             lstlst entries onto their next element */
          for (l = lstlst, a = args, argnum = 2;
               SCM_CONSP (l);
               l = SCM_CDR (l), a = SCM_CDR (a), argnum++)
            {
              lst = SCM_CAR (l);  /* list argument */
              if (! SCM_CONSP (lst))
                {
                  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst,
                                   argnum, FUNC_NAME, "list");
                  goto done;
                }
              SCM_SETCAR (a, SCM_CAR (lst));  /* arg for pred */
              SCM_SETCAR (l, SCM_CDR (lst));  /* keep rest of lst */
            }

          count += ! SCM_FALSEP (scm_apply (pred, args, SCM_EOL));
        }
    }
 done:
  return SCM_MAKINUM (count);
}
#undef FUNC_NAME



[-- Attachment #3: count.tes --]
[-- Type: application/octet-stream, Size: 6280 bytes --]

(define-module (x y)
  #:use-module (srfi srfi-1)
  #:use-module (test-suite lib))

;;
;; count
;;

(with-test-prefix "count"
  (pass-if-exception "no args" exception:wrong-num-args
    (count))
  
  (pass-if-exception "one arg" exception:wrong-num-args
    (count noop))
  
  (with-test-prefix "one list"
    (define (or1 x)
      x)
    
    (pass-if "empty list" (= 0 (count or1 '())))
    
    (pass-if-exception "pred arg count 0" exception:wrong-type-arg
      (count (lambda () x) '(1 2 3)))
    (pass-if-exception "pred arg count 2" exception:wrong-type-arg
      (count (lambda (x y) x) '(1 2 3)))
    
    (pass-if-exception "improper 1" exception:wrong-type-arg
      (count or1 1))
    (pass-if-exception "improper 2" exception:wrong-type-arg
      (count or1 '(1 . 2)))
    (pass-if-exception "improper 3" exception:wrong-type-arg
      (count or1 '(1 2 . 3)))
    
    (pass-if (= 0 (count or1 '(#f))))
    (pass-if (= 1 (count or1 '(#t))))
    
    (pass-if (= 0 (count or1 '(#f #f))))
    (pass-if (= 1 (count or1 '(#f #t))))
    (pass-if (= 1 (count or1 '(#t #f))))
    (pass-if (= 2 (count or1 '(#t #t))))
    
    (pass-if (= 0 (count or1 '(#f #f #f))))
    (pass-if (= 1 (count or1 '(#f #f #t))))
    (pass-if (= 1 (count or1 '(#t #f #f))))
    (pass-if (= 2 (count or1 '(#t #f #t))))
    (pass-if (= 3 (count or1 '(#t #t #t)))))
  
  (with-test-prefix "two lists"
    (define (or2 x y)
      (or x y))
    
    (pass-if "arg order"
      (= 1 (count (lambda (x y)
		    (and (= 1 x)
			 (= 2 y)))
		  '(1) '(2))))
    
    (pass-if "empty lists" (= 0 (count or2 '() '())))
    
    (pass-if-exception "pred arg count 0" exception:wrong-type-arg
      (count (lambda () #t) '(1 2 3) '(1 2 3)))
    (pass-if-exception "pred arg count 1" exception:wrong-type-arg
      (count (lambda (x) x) '(1 2 3) '(1 2 3)))
    (pass-if-exception "pred arg count 3" exception:wrong-type-arg
      (count (lambda (x y z) x) '(1 2 3) '(1 2 3)))
    
    (pass-if-exception "improper first 1" exception:wrong-type-arg
      (count or2 1 '(1 2 3)))
    (pass-if-exception "improper first 2" exception:wrong-type-arg
      (count or2 '(1 . 2) '(1 2 3)))
    (pass-if-exception "improper first 3" exception:wrong-type-arg
      (count or2 '(1 2 . 3) '(1 2 3)))
    
    (pass-if-exception "improper second 1" exception:wrong-type-arg
      (count or2 '(1 2 3) 1))
    (pass-if-exception "improper second 2" exception:wrong-type-arg
      (count or2 '(1 2 3) '(1 . 2)))
    (pass-if-exception "improper second 3" exception:wrong-type-arg
      (count or2 '(1 2 3) '(1 2 . 3)))
    
    (pass-if (= 0 (count or2 '(#f) '(#f))))
    (pass-if (= 1 (count or2 '(#t) '(#f))))
    (pass-if (= 1 (count or2 '(#f) '(#t))))
    
    (pass-if (= 0 (count or2 '(#f #f) '(#f #f))))
    (pass-if (= 1 (count or2 '(#t #f) '(#t #f))))
    (pass-if (= 2 (count or2 '(#t #t) '(#f #f))))
    (pass-if (= 2 (count or2 '(#t #f) '(#f #t))))
    
    (with-test-prefix "stop shortest"
      (pass-if (= 2 (count or2 '(#t #f #t) '(#f #t))))
      (pass-if (= 2 (count or2 '(#t #f #t #t) '(#f #t))))
      (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t))))
      (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t #t))))))
  
  (with-test-prefix "three lists"
    (define (or3 x y z)
      (or x y z))
    
    (pass-if "arg order"
      (= 1 (count (lambda (x y z)
		    (and (= 1 x)
			 (= 2 y)
			 (= 3 z)))
		  '(1) '(2) '(3))))
    
    (pass-if "empty lists" (= 0 (count or3 '() '() '())))
    
    ;; currently bad pred argument gives wrong-num-args when 3 or more
    ;; lists, as opposed to wrong-type-arg for 1 or 2 lists
    (pass-if-exception "pred arg count 0" exception:wrong-num-args
      (count (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3)))
    (pass-if-exception "pred arg count 2" exception:wrong-num-args
      (count (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) ))
    (pass-if-exception "pred arg count 4" exception:wrong-num-args
      (count (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3)))
    
    (pass-if-exception "improper first 1" exception:wrong-type-arg
      (count or3 1 '(1 2 3) '(1 2 3)))
    (pass-if-exception "improper first 2" exception:wrong-type-arg
      (count or3 '(1 . 2) '(1 2 3) '(1 2 3)))
    (pass-if-exception "improper first 3" exception:wrong-type-arg
      (count or3 '(1 2 . 3) '(1 2 3) '(1 2 3)))
    
    (pass-if-exception "improper second 1" exception:wrong-type-arg
      (count or3 '(1 2 3) 1 '(1 2 3)))
    (pass-if-exception "improper second 2" exception:wrong-type-arg
      (count or3 '(1 2 3) '(1 . 2) '(1 2 3)))
    (pass-if-exception "improper second 3" exception:wrong-type-arg
      (count or3 '(1 2 3) '(1 2 . 3) '(1 2 3)))
    
    (pass-if-exception "improper third 1" exception:wrong-type-arg
      (count or3 '(1 2 3) '(1 2 3) 1))
    (pass-if-exception "improper third 2" exception:wrong-type-arg
      (count or3 '(1 2 3) '(1 2 3) '(1 . 2)))
    (pass-if-exception "improper third 3" exception:wrong-type-arg
      (count or3 '(1 2 3) '(1 2 3) '(1 2 . 3)))
    
    (pass-if (= 0 (count or3 '(#f) '(#f) '(#f))))
    (pass-if (= 1 (count or3 '(#t) '(#f) '(#f))))
    (pass-if (= 1 (count or3 '(#f) '(#t) '(#f))))
    (pass-if (= 1 (count or3 '(#f) '(#f) '(#t))))
    
    (pass-if (= 0 (count or3 '(#f #f) '(#f #f) '(#f #f))))
    
    (pass-if (= 1 (count or3 '(#t #f) '(#f #f) '(#f #f))))
    (pass-if (= 1 (count or3 '(#f #t) '(#f #f) '(#f #f))))
    (pass-if (= 1 (count or3 '(#f #f) '(#t #f) '(#f #f))))
    (pass-if (= 1 (count or3 '(#f #f) '(#f #t) '(#f #f))))
    (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#t #f))))
    (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#f #t))))
    
    (pass-if (= 2 (count or3 '(#t #t) '(#f #f) '(#f #f))))
    (pass-if (= 2 (count or3 '(#f #f) '(#t #t) '(#f #f))))
    (pass-if (= 2 (count or3 '(#f #f) '(#f #f) '(#t #t))))
    (pass-if (= 2 (count or3 '(#f #f) '(#t #f) '(#f #t))))
    
    (with-test-prefix "stop shortest"
      (pass-if (= 0 (count or3 '() '(#t #t #t) '(#t #t))))
      (pass-if (= 0 (count or3 '(#t #t #t) '() '(#t #t))))
      (pass-if (= 0 (count or3 '(#t #t #t) '(#t #t) '())))
      
      (pass-if (= 1 (count or3 '(#t) '(#t #t #t) '(#t #t))))
      (pass-if (= 1 (count or3 '(#t #t #t) '(#t) '(#t #t))))
      (pass-if (= 1 (count or3 '(#t #t #t) '(#t #t) '(#t)))))))


[-- Attachment #4: Type: text/plain, Size: 142 bytes --]

_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-devel

Re: srfi-1 count

[Stephen Compall]

Kevin Ryde <user42@zip.com.au> writes:

>           "Return a count of the number of times @var{pred} returns true\n"

Perhaps "non-@code{#f}" instead of "true"?  Or is this a convention in
the manual?

--
Stephen Compall or s11 or sirian

	"You boys lookin' for trouble?"
	"Sure.  Whaddya got?"
		-- Marlon Brando, "The Wild Ones"

event security e-cash Etacs Crowell CBNRC Reno ASO Serbian espionage
basement Ruby Ridge SAFE covert video AMW top secret


_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-devel

Re: srfi-1 count

[Kevin Ryde]

Stephen Compall <s11@member.fsf.org> writes:
>
> Perhaps "non-@code{#f}" instead of "true"?

I think "true" reads best.

> Or is this a convention in the manual?

The "Booleans" node notes it, maybe an index entry for "True" if you
think it could be hard to find.


_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-devel