r5354: *** empty log message ***

[kmrcl.git] / lists.lisp

diff --git a/lists.lisp b/lists.lisp
index a7ae3d1655f197fd5142a335c0b093e2f91a3ec8..285bb397f426333f8b3eac243144c8704d08eb05 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.3 2003/05/06 01:43:14 kevin Exp $
+;;;; $Id: lists.lisp,v 1.8 2003/07/05 02:32:08 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
 ;;;;


@@ -16,8 +16,7 @@
 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
 ;;;; *************************************************************************
 
 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
 ;;;; *************************************************************************
 

-(in-package :kmrcl)
-
+(in-package #:kmrcl)

 
 (defun mklist (obj)
   "Make into list if atom"
 
 (defun mklist (obj)
   "Make into list if atom"


@@ -26,19 +25,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)))
+        (when 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"


@@ -122,17 +117,63 @@
   (let ((a (car la))
        (b (car lb)))
     (if (and a b)
   (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)))
+       (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)))
       accum)))
 
 (defun append-sublists (list)
   "Takes a list of lists and appends all sublists"
   (let ((results (car list)))

-    (dolist (elem (cdr list))
-      (setq results (append results elem)))
-    results))
+    (dolist (elem (cdr list) results)
+      (setq results (append results elem)))))
+
+
+;; alists and plists
+
+(defun alist-elem-p (elem)
+  (and (consp elem) (atom (car elem)) (atom (cdr elem))))
+
+(defun alistp (alist)
+  (when (listp alist)
+    (dolist (elem alist)
+      (unless (alist-elem-p elem)
+        (return-from alistp nil)))
+    t))
+
+(defmacro update-alist (akey value alist &key (test '#'eql) (key '#'identity))
+  "Macro to support below (setf get-alist)"
+  (let ((elem (gensym)))
+    `(let ((,elem (assoc ,akey ,alist :test ,test :key ,key)))
+       (if ,elem
+          (progn
+            (setf (cdr ,elem) ,value)
+            ,alist)
+       (setf ,alist (acons ,akey ,value ,alist))))))
+
+(defun get-alist (key alist &key (test #'eql))
+  (cdr (assoc key alist :test test)))
+
+(defun (setf get-alist) (value key alist &key (test #'eql))
+  (update-alist key value alist :test test)
+  value)
+
+(defun alist-plist (alist)
+  (apply #'append (mapcar #'(lambda (x) (list (car x) (cdr x))) alist)))
+
+(defun plist-alist (plist)
+  (do ((alist '())
+       (pl plist (cddr plist)))
+      ((null pl) alist)
+    (setq alist (acons (car pl) (cadr pl) alist))))
+
+(defmacro update-plist (pkey value plist &key (test '#'eql))
+  "Macro to support below (setf get-alist)"
+  (let ((pos (gensym)))
+    `(let ((,pos (member ,pkey ,plist :test ,test)))
+       (if ,pos
+          (progn
+            (setf (cadr ,pos) ,value)
+            ,plist)
+        (setf ,plist (append ,plist (list ,pkey ,value)))))))
+