1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Functions for lists for KMRCL package
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Apr 2000
12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
14 ;;;; KMRCL users are granted the rights to distribute and use this software
15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
17 ;;;; *************************************************************************
22 "Make into list if atom"
23 (if (listp obj) obj (list obj)))
25 (defun map-and-remove-nils (fn lst)
26 "mao a list by function, eliminate elements where fn returns nil"
28 (dolist (x lst (nreverse acc))
29 (let ((val (funcall fn x)))
30 (when val (push val acc))))))
32 (defun filter (fn lst)
33 "Filter a list by function, eliminate elements where fn returns nil"
35 (dolist (x lst (nreverse acc))
39 (defun appendnew (l1 l2)
40 "Append two lists, filtering out elem from second list that are already in first list"
42 (unless (find elem l1)
43 (setq l1 (append l1 (list elem))))))
45 (defun remove-from-tree-if (pred tree)
46 "Strip from tree of atoms that satistify predicate"
48 (unless (funcall pred tree)
50 (let ((car-strip (remove-from-tree-if pred (car tree)))
51 (cdr-strip (remove-from-tree-if pred (cdr tree))))
53 ((and car-strip (atom (cadr tree)) (null cdr-strip))
55 ((and car-strip cdr-strip)
56 (cons car-strip cdr-strip))
62 (defun find-tree (sym tree)
63 "Finds an atom as a car in tree and returns cdr tree at that positions"
64 (if (or (null tree) (atom tree))
66 (if (eql sym (car tree))
68 (aif (find-tree sym (car tree))
70 (aif (find-tree sym (cdr tree))
75 (cond ((atom lis) lis)
77 (append (flatten (car lis)) (flatten (cdr lis))))
78 (t (append (list (car lis)) (flatten (cdr lis))))))
82 (defun remove-keyword (key arglist)
83 (loop for sublist = arglist then rest until (null sublist)
84 for (elt arg . rest) = sublist
85 unless (eq key elt) append (list elt arg)))
87 (defun remove-keywords (key-names args)
88 (loop for ( name val ) on args by #'cddr
89 unless (member (symbol-name name) key-names
90 :key #'symbol-name :test 'equal)
91 append (list name val)))
93 (defun mapappend (func seq)
94 (apply #'append (mapcar func seq)))
96 (defun mapcar-append-string-nontailrec (func v)
97 "Concatenate results of mapcar lambda calls"
99 (concatenate 'string (funcall func it)
100 (mapcar-append-string-nontailrec func (cdr v)))
104 (defun mapcar-append-string (func v &optional (accum ""))
105 "Concatenate results of mapcar lambda calls"
107 (mapcar-append-string
110 (concatenate 'string accum (funcall func it)))
113 (defun mapcar2-append-string-nontailrec (func la lb)
114 "Concatenate results of mapcar lambda call's over two lists"
118 (concatenate 'string (funcall func a b)
119 (mapcar2-append-string-nontailrec func (cdr la) (cdr lb)))
122 (defun mapcar2-append-string (func la lb &optional (accum ""))
123 "Concatenate results of mapcar lambda call's over two lists"
127 (mapcar2-append-string func (cdr la) (cdr lb)
128 (concatenate 'string accum (funcall func a b)))
131 (defun append-sublists (list)
132 "Takes a list of lists and appends all sublists"
133 (let ((results (car list)))
134 (dolist (elem (cdr list) results)
135 (setq results (append results elem)))))
140 (defun alist-elem-p (elem)
141 (and (consp elem) (atom (car elem)) (atom (cdr elem))))
143 (defun alistp (alist)
146 (unless (alist-elem-p elem)
147 (return-from alistp nil)))
150 (defmacro update-alist (akey value alist &key (test '#'eql) (key '#'identity))
151 "Macro to support below (setf get-alist)"
152 (let ((elem (gensym)))
153 `(let ((,elem (assoc ,akey ,alist :test ,test :key ,key)))
156 (setf (cdr ,elem) ,value)
158 (setf ,alist (acons ,akey ,value ,alist))))))
160 (defun get-alist (key alist &key (test #'eql))
161 (cdr (assoc key alist :test test)))
163 (defun (setf get-alist) (value key alist &key (test #'eql))
164 (update-alist key value alist :test test)
167 (defun alist-plist (alist)
168 (apply #'append (mapcar #'(lambda (x) (list (car x) (cdr x))) alist)))
170 (defun plist-alist (plist)
172 (pl plist (cddr pl)))
174 (setq alist (acons (car pl) (cadr pl) alist))))
176 (defmacro update-plist (pkey value plist &key (test '#'eql))
177 "Macro to support below (setf get-alist)"
178 (let ((pos (gensym)))
179 `(let ((,pos (member ,pkey ,plist :test ,test)))
182 (setf (cadr ,pos) ,value)
184 (setf ,plist (append ,plist (list ,pkey ,value)))))))