r4973: Auto commit for Debian build

[kmrcl.git] / lists.lisp

diff --git a/lists.lisp b/lists.lisp
index dee8317518d8312902e52a11381c193d1ddd9384..6b0edb27b7550344f33ed1826fc70d4b531936cf 100644 (file)
--- a/lists.lisp
+++ b/lists.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;

-;;;; $Id: lists.lisp,v 1.1 2003/04/29 00:26:21 kevin Exp $
+;;;; $Id: lists.lisp,v 1.4 2003/05/11 21:51:43 kevin Exp $

 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;


@@ -26,19 +26,15 @@
 (defun filter (fn lst)
   "Filter a list by function, eliminate elements where fn returns nil"
   (let ((acc nil))
 (defun filter (fn lst)
   "Filter a list by function, eliminate elements where fn returns nil"
   (let ((acc nil))

-    (dolist (x lst)
+    (dolist (x lst (nreverse acc))

       (let ((val (funcall fn x)))
       (let ((val (funcall fn x)))

-        (if val (push val acc))))
-    (nreverse acc)))
+        (if val (push val acc))))))

 
 (defun appendnew (l1 l2)
   "Append two lists, filtering out elem from second list that are already in first list"
 
 (defun appendnew (l1 l2)
   "Append two lists, filtering out elem from second list that are already in first list"

-  (dolist (elem l2)
+  (dolist (elem l2 l1)

     (unless (find elem l1)
     (unless (find elem l1)

-      (setq l1 (append l1 (list elem)))))
-  l1)
-
-
+      (setq l1 (append l1 (list elem))))))

 
 (defun remove-tree-if (pred tree)
   "Strip from tree of atoms that satistify predicate"
 
 (defun remove-tree-if (pred tree)
   "Strip from tree of atoms that satistify predicate"


@@ -69,6 +65,12 @@
            it
            nil)))))
 
            it
            nil)))))
 

+(defun flatten (lis)
+  (cond ((atom lis) lis)
+       ((listp (car lis))
+        (append (flatten (car lis)) (flatten (cdr lis))))
+       (t (append (list (car lis)) (flatten (cdr lis))))))
+

 ;;; Keyword functions
 
 (defun remove-keyword (key arglist)
 ;;; Keyword functions
 
 (defun remove-keyword (key arglist)


@@ -82,4 +84,47 @@
                       :key #'symbol-name :test 'equal)
        append (list name val)))
 
                       :key #'symbol-name :test 'equal)
        append (list name val)))
 

+(defun mapappend (func seq)
+  (apply #'append (mapcar func seq)))
+
+(defun mapcar-append-string-nontailrec (func v)
+  "Concatenate results of mapcar lambda calls"  
+  (aif (car v)
+       (concatenate 'string (funcall func it)
+                   (mapcar-append-string-nontailrec func (cdr v)))
+       ""))
+
+
+(defun mapcar-append-string (func v &optional (accum ""))
+  "Concatenate results of mapcar lambda calls"  
+  (aif (car v)
+       (mapcar-append-string 
+       func 
+       (cdr v) 
+       (concatenate 'string accum (funcall func it)))
+       accum))
+
+(defun mapcar2-append-string-nontailrec (func la lb)
+  "Concatenate results of mapcar lambda call's over two lists"  
+  (let ((a (car la))
+       (b (car lb)))
+    (if (and a b)
+      (concatenate 'string (funcall func a b)
+                  (mapcar2-append-string-nontailrec func (cdr la) (cdr lb)))
+      "")))
+  
+(defun mapcar2-append-string (func la lb &optional (accum ""))
+  "Concatenate results of mapcar lambda call's over two lists"  
+  (let ((a (car la))
+       (b (car lb)))
+    (if (and a b)
+       (mapcar2-append-string func (cdr la)  (cdr lb)
+                              (concatenate 'string accum (funcall func a b)))
+      accum)))
+
+(defun append-sublists (list)
+  "Takes a list of lists and appends all sublists"
+  (let ((results (car list)))
+    (dolist (elem (cdr list) results)
+      (setq results (append results elem)))))