r10151: updates

[kmrcl.git] / lists.lisp

diff --git a/lists.lisp b/lists.lisp
index 6b0edb27b7550344f33ed1826fc70d4b531936cf..dfa9d386d25d5c9f100c317372442b3ef15adcff 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.4 2003/05/11 21:51:43 kevin Exp $
+;;;; $Id$

 ;;;;
 ;;;; 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,19 +16,25 @@
 ;;;; (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"
   (if (listp obj) obj (list obj)))
 
 
 (defun mklist (obj)
   "Make into list if atom"
   (if (listp obj) obj (list obj)))
 

+(defun map-and-remove-nils (fn lst)
+  "mao a list by function, eliminate elements where fn returns nil"
+  (let ((acc nil))
+    (dolist (x lst (nreverse acc))
+      (let ((val (funcall fn x)))
+        (when val (push val acc))))))
+

 (defun filter (fn lst)
   "Filter a list by function, eliminate elements where fn returns nil"
   (let ((acc nil))
     (dolist (x lst (nreverse acc))
 (defun filter (fn lst)
   "Filter a list by function, eliminate elements where fn returns nil"
   (let ((acc nil))
     (dolist (x lst (nreverse acc))

-      (let ((val (funcall fn x)))
-        (if val (push val acc))))))
+      (when (funcall fn x)
+        (push x 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"


@@ -36,13 +42,15 @@
     (unless (find elem l1)
       (setq l1 (append l1 (list elem))))))
 
     (unless (find elem l1)
       (setq l1 (append l1 (list elem))))))
 

-(defun remove-tree-if (pred tree)
+(defun remove-from-tree-if (pred tree &optional atom-processor)

   "Strip from tree of atoms that satistify predicate"
   (if (atom tree)
       (unless (funcall pred tree)
   "Strip from tree of atoms that satistify predicate"
   (if (atom tree)
       (unless (funcall pred tree)

-       tree)
-    (let ((car-strip (remove-tree-if pred (car tree)))
-         (cdr-strip (remove-tree-if pred (cdr tree))))
+       (if atom-processor
+           (funcall atom-processor tree)
+         tree))
+    (let ((car-strip (remove-from-tree-if pred (car tree) atom-processor))
+         (cdr-strip (remove-from-tree-if pred (cdr tree) atom-processor)))

       (cond
        ((and car-strip (atom (cadr tree)) (null cdr-strip))
        (list car-strip))
       (cond
        ((and car-strip (atom (cadr tree)) (null cdr-strip))
        (list car-strip))


@@ -128,3 +136,68 @@
     (dolist (elem (cdr list) results)
       (setq results (append results elem)))))
 
     (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 "ELEM-"))
+       (val (gensym "VAL-")))
+    `(let ((,elem (assoc ,akey ,alist :test ,test :key ,key))
+          (,val ,value))
+       (cond
+       (,elem
+        (setf (cdr ,elem) ,val))
+       (,alist
+        (setf (cdr (last ,alist)) (list (cons ,akey ,val))))
+        (t
+         (setf ,alist (list (cons ,akey ,val)))))
+       ,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))
+  "This won't work if the alist is NIL."
+  (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 pl)))
+      ((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)))))))
+
+
+(defun unique-slot-values (list slot &key (test 'eql))
+  (let ((uniq '()))
+    (dolist (item list (nreverse uniq))
+      (let ((value (slot-value item slot)))
+       (unless (find value uniq :test test)
+         (push value uniq))))))
+
+
+