srfi-1 delete and delete!

* srfi-1 delete and delete!
@ 2003-06-22  0:17 Kevin Ryde
  2003-07-08  0:12 ` Kevin Ryde
  0 siblings, 1 reply; 4+ messages in thread
From: Kevin Ryde @ 2003-06-22  0:17 UTC (permalink / raw)

This is new srfi-1 delete and delete!, as threatened.  They avoid the
non-tail-recursions in the current code, and delete saves consing by
tail sharing, as the spec allows.

For the two-arg case the plain core delete/delete! is called, so
there's no loss of efficiency when using the srfi-1 module.  The
current core delete doesn't do tail sharing, I wonder if that's
something it (and friends) could get.

Code and test cases below, for contemplation.  delete! is a warmed
over copy of the core code, delete is new.

SCM_DEFINE (scm_srfi1_delete, "delete", 2, 1, 0,
            (SCM x, SCM lst, SCM pred),
	    "Return a list containing the elements of @var{lst} but with\n"
	    "those equal to @var{x} deleted.  The returned elements will be\n"
	    "in the same order as they were in @var{lst}.\n"
	    "\n"
	    "Equality is determined by @var{pred}, or @code{equal?} if not\n"
	    "given.  An equality call is made just once for each element,\n"
	    "but the order in which the calls are made on the elements is\n"
	    "unspecified.\n"
	    "\n"
	    "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
	    "given @var{x} is first.  This means for instance elements\n"
	    "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
	    "\n"
	    "@var{lst} is not modified, but the returned list might share a\n"
	    "common tail with @var{lst}.")
#define FUNC_NAME s_scm_srfi1_delete
{
  scm_t_trampoline_2 equal_p;
  SCM  ret, *p, keeplst;

  if (SCM_UNBNDP (pred))
    return scm_delete (x, lst);

  equal_p = scm_trampoline_2 (pred);
  SCM_ASSERT (equal_p, pred, SCM_ARG3, FUNC_NAME);

  /* ret is the return list being constructed.  p is where to append to it,
     initially &ret then the SCM_CDRLOC of the last pair.  lst progresses as
     elements are considered.

     Elements to be retained are not immediately copied, instead keeplst is
     the last pair in lst which is to be retained but not yet copied.  When
     there's no more deletions, *p can be set to keeplst to share the
     remainder of the original lst.  (The entire original lst if there's no
     deletions at all.)  */

  keeplst = lst;
  ret = SCM_EOL;
  p = &ret;

  for ( ; SCM_CONSP (lst); lst = SCM_CDR (lst))
    {
      if (! SCM_FALSEP (equal_p (pred, x, SCM_CAR (lst))))
        {
          /* delete this element, so copy from keeplst (inclusive) to lst
             (exclusive) onto ret */
          while (keeplst != lst)
            {
              SCM c = scm_cons (SCM_CAR (keeplst), SCM_EOL);
              *p = c;
              p = SCM_CDRLOC (c);
              keeplst = SCM_CDR (keeplst);
            }

          keeplst = SCM_CDR (lst);
        }
    }

  /* final retained elements */
  *p = keeplst;

  /* demand that lst was a proper list */
  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");

  return ret;
}
#undef FUNC_NAME

SCM_DEFINE (scm_srfi1_delete_x, "delete!", 2, 1, 0,
            (SCM x, SCM lst, SCM pred),
	    "Return a list containing the elements of @var{lst} but with\n"
	    "those equal to @var{x} deleted.  The returned elements will be\n"
	    "in the same order as they were in @var{lst}.\n"
	    "\n"
	    "Equality is determined by @var{pred}, or @code{equal?} if not\n"
	    "given.  An equality call is made just once for each element,\n"
	    "but the order in which the calls are made on the elements is\n"
	    "unspecified.\n"
	    "\n"
	    "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
	    "given @var{x} is first.  This means for instance elements\n"
	    "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
	    "\n"
	    "@var{lst} may be modified to construct the returned list.")
#define FUNC_NAME s_scm_srfi1_delete_x
{
  scm_t_trampoline_2 equal_p;
  SCM walk;
  SCM *prev;

  if (SCM_UNBNDP (pred))
    return scm_delete_x (x, lst);

  equal_p = scm_trampoline_2 (pred);
  SCM_ASSERT (equal_p, pred, SCM_ARG3, FUNC_NAME);

  for (prev = &lst, walk = lst;
       SCM_CONSP (walk);
       walk = SCM_CDR (walk))
    {
      if (! SCM_FALSEP (equal_p (pred, x, SCM_CAR (walk))))
	*prev = SCM_CDR (walk);
      else
	prev = SCM_CDRLOC (walk);
    }

  /* demand the input was a proper list */
  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk), walk, SCM_ARG2, FUNC_NAME,
                   "list");
  return lst;
}
#undef FUNC_NAME

(define (ref-delete x lst . proc)
  "Reference implemenation of srfi-1 `delete'."
  (set! proc (if (null? proc) equal? (car proc)))
  (do ((ret '())
       (lst lst (cdr lst)))
      ((null? lst)
       (reverse! ret))
    (if (not (proc x (car lst)))
	(set! ret (cons (car lst) ret)))))

;;
;; delete and delete!
;;

(let ()	
  ;; Call (PROC lst) for all lists of length up to 6, with all combinations
  ;; of elements to be retained (numbers 0 upwards) or deleted (#f).
  (define (test-lists proc)
    (do ((n 0 (1+ n)))
	((>= n 6))
      (do ((limit (ash 1 n))
	   (i 0 (1+ i)))
	  ((>= i limit))
	(let ((lst '()))
	  (do ((bit 0 (1+ bit)))
	      ((>= bit n))
	    (set! lst  (cons (if (logbit? bit i) bit #f) lst)))
	  (proc lst)))))

  (define (common-tests delete-proc)
    (pass-if-exception "too few args" exception:wrong-num-args
      (delete-proc 0))

    (pass-if-exception "too many args" exception:wrong-num-args
      (delete-proc 0 '() equal? 99))

    (pass-if "empty"
      (eq? '() (delete-proc 0 '())))

    (pass-if "equal? (default)"
      (equal? '((1) (3)) (delete-proc '(2) '((1) (2) (3)))))

    (pass-if "eq?"
      (equal? '((1) (2) (3)) (delete-proc '(2) '((1) (2) (3)) eq?)))

    (pass-if "called arg order"
      (equal? '(1 2 3)
	      (delete-proc 3 '(1 2 3 4 5) <))))

  (with-test-prefix "delete"
    (common-tests delete)

    (test-lists
     (lambda (lst)
       (let ((lst-copy (list-copy lst)))
	 (with-test-prefix lst-copy
	   (pass-if "result"
	     (equal? (delete     #f lst)
		     (ref-delete #f lst)))
	   (pass-if "non-destructive"
	     (equal? lst-copy lst)))))))  

  (with-test-prefix "delete!"
    (common-tests delete!)

    (test-lists
     (lambda (lst)
       (pass-if lst
	 (equal? (delete!    #f lst)
		 (ref-delete #f lst)))))))

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

^ permalink raw reply	[flat|nested] 4+ messages in thread