← Back to branch summary

~ubuntu-branches/ubuntu/quantal/cl-kmrcl/quantal

« back to all changes in this revision

Viewing changes to lists.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Kevin M. Rosenberg
  • Date: 2004-06-12 08:14:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040612081446-7fylzj3qe93x2ugp
Tags: upstream-1.73
Import upstream version 1.73

Show diffs side-by-side

added added

removed removed

Lines of Context:
lists.lisp
 
1
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 
2
;;;; *************************************************************************
 
3
;;;; FILE IDENTIFICATION
 
4
;;;;
 
5
;;;; Name:          lists.lisp
 
6
;;;; Purpose:       Functions for lists for KMRCL package
 
7
;;;; Programmer:    Kevin M. Rosenberg
 
8
;;;; Date Started:  Apr 2000
 
9
;;;;
 
10
;;;; $Id: lists.lisp 8573 2004-01-29 23:30:50Z kevin $
 
11
;;;;
 
12
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 
13
;;;;
 
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
;;;; *************************************************************************
 
18
 
 
19
(in-package #:kmrcl)
 
20
 
 
21
(defun mklist (obj)
 
22
  "Make into list if atom"
 
23
  (if (listp obj) obj (list obj)))
 
24
 
 
25
(defun map-and-remove-nils (fn lst)
 
26
  "mao a list by function, eliminate elements where fn returns nil"
 
27
  (let ((acc nil))
 
28
    (dolist (x lst (nreverse acc))
 
29
      (let ((val (funcall fn x)))
 
30
        (when val (push val acc))))))
 
31
 
 
32
(defun filter (fn lst)
 
33
  "Filter a list by function, eliminate elements where fn returns nil"
 
34
  (let ((acc nil))
 
35
    (dolist (x lst (nreverse acc))
 
36
      (when (funcall fn x)
 
37
        (push x acc)))))
 
38
 
 
39
(defun appendnew (l1 l2)
 
40
  "Append two lists, filtering out elem from second list that are already in first list"
 
41
  (dolist (elem l2 l1)
 
42
    (unless (find elem l1)
 
43
      (setq l1 (append l1 (list elem))))))
 
44
 
 
45
(defun remove-from-tree-if (pred tree &optional atom-processor)
 
46
  "Strip from tree of atoms that satistify predicate"
 
47
  (if (atom tree)
 
48
      (unless (funcall pred tree)
 
49
        (if atom-processor
 
50
            (funcall atom-processor tree)
 
51
          tree))
 
52
    (let ((car-strip (remove-from-tree-if pred (car tree) atom-processor))
 
53
          (cdr-strip (remove-from-tree-if pred (cdr tree) atom-processor)))
 
54
      (cond
 
55
       ((and car-strip (atom (cadr tree)) (null cdr-strip))
 
56
        (list car-strip))
 
57
       ((and car-strip cdr-strip)
 
58
        (cons car-strip cdr-strip))
 
59
       (car-strip
 
60
        car-strip)
 
61
       (cdr-strip
 
62
        cdr-strip)))))
 
63
 
 
64
(defun find-tree (sym tree)
 
65
  "Finds an atom as a car in tree and returns cdr tree at that positions"
 
66
  (if (or (null tree) (atom tree))
 
67
      nil
 
68
    (if (eql sym (car tree))
 
69
        (cdr tree)
 
70
      (aif (find-tree sym (car tree))
 
71
          it
 
72
        (aif (find-tree sym (cdr tree))
 
73
            it
 
74
            nil)))))
 
75
 
 
76
(defun flatten (lis)
 
77
  (cond ((atom lis) lis)
 
78
        ((listp (car lis))
 
79
         (append (flatten (car lis)) (flatten (cdr lis))))
 
80
        (t (append (list (car lis)) (flatten (cdr lis))))))
 
81
 
 
82
;;; Keyword functions
 
83
 
 
84
(defun remove-keyword (key arglist)
 
85
  (loop for sublist = arglist then rest until (null sublist)
 
86
        for (elt arg . rest) = sublist
 
87
        unless (eq key elt) append (list elt arg)))
 
88
 
 
89
(defun remove-keywords (key-names args)
 
90
  (loop for ( name val ) on args by #'cddr
 
91
        unless (member (symbol-name name) key-names 
 
92
                       :key #'symbol-name :test 'equal)
 
93
        append (list name val)))
 
94
 
 
95
(defun mapappend (func seq)
 
96
  (apply #'append (mapcar func seq)))
 
97
 
 
98
(defun mapcar-append-string-nontailrec (func v)
 
99
  "Concatenate results of mapcar lambda calls"  
 
100
  (aif (car v)
 
101
       (concatenate 'string (funcall func it)
 
102
                    (mapcar-append-string-nontailrec func (cdr v)))
 
103
       ""))
 
104
 
 
105
 
 
106
(defun mapcar-append-string (func v &optional (accum ""))
 
107
  "Concatenate results of mapcar lambda calls"  
 
108
  (aif (car v)
 
109
       (mapcar-append-string 
 
110
        func 
 
111
        (cdr v) 
 
112
        (concatenate 'string accum (funcall func it)))
 
113
       accum))
 
114
 
 
115
(defun mapcar2-append-string-nontailrec (func la lb)
 
116
  "Concatenate results of mapcar lambda call's over two lists"  
 
117
  (let ((a (car la))
 
118
        (b (car lb)))
 
119
    (if (and a b)
 
120
      (concatenate 'string (funcall func a b)
 
121
                   (mapcar2-append-string-nontailrec func (cdr la) (cdr lb)))
 
122
      "")))
 
123
  
 
124
(defun mapcar2-append-string (func la lb &optional (accum ""))
 
125
  "Concatenate results of mapcar lambda call's over two lists"  
 
126
  (let ((a (car la))
 
127
        (b (car lb)))
 
128
    (if (and a b)
 
129
        (mapcar2-append-string func (cdr la)  (cdr lb)
 
130
                               (concatenate 'string accum (funcall func a b)))
 
131
      accum)))
 
132
 
 
133
(defun append-sublists (list)
 
134
  "Takes a list of lists and appends all sublists"
 
135
  (let ((results (car list)))
 
136
    (dolist (elem (cdr list) results)
 
137
      (setq results (append results elem)))))
 
138
 
 
139
 
 
140
;; alists and plists
 
141
 
 
142
(defun alist-elem-p (elem)
 
143
  (and (consp elem) (atom (car elem)) (atom (cdr elem))))
 
144
 
 
145
(defun alistp (alist)
 
146
  (when (listp alist)
 
147
    (dolist (elem alist)
 
148
      (unless (alist-elem-p elem)
 
149
        (return-from alistp nil)))
 
150
    t))
 
151
 
 
152
(defmacro update-alist (akey value alist &key (test '#'eql) (key '#'identity))
 
153
  "Macro to support below (setf get-alist)"
 
154
  (let ((elem (gensym)))
 
155
    `(let ((,elem (assoc ,akey ,alist :test ,test :key ,key)))
 
156
       (if ,elem
 
157
           (progn
 
158
             (setf (cdr ,elem) ,value)
 
159
             ,alist)
 
160
         (setf ,alist (acons ,akey ,value ,alist))))))
 
161
 
 
162
(defun get-alist (key alist &key (test #'eql))
 
163
  (cdr (assoc key alist :test test)))
 
164
 
 
165
(defun (setf get-alist) (value key alist &key (test #'eql))
 
166
  "This doesn't work to add a field which alist value is only modified locally"
 
167
  (update-alist key value alist :test test)
 
168
  value)
 
169
 
 
170
(defun alist-plist (alist)
 
171
  (apply #'append (mapcar #'(lambda (x) (list (car x) (cdr x))) alist)))
 
172
 
 
173
(defun plist-alist (plist)
 
174
  (do ((alist '())
 
175
       (pl plist (cddr pl)))
 
176
      ((null pl) alist)
 
177
    (setq alist (acons (car pl) (cadr pl) alist))))
 
178
 
 
179
(defmacro update-plist (pkey value plist &key (test '#'eql))
 
180
  "Macro to support below (setf get-alist)"
 
181
  (let ((pos (gensym)))
 
182
    `(let ((,pos (member ,pkey ,plist :test ,test)))
 
183
       (if ,pos
 
184
           (progn
 
185
             (setf (cadr ,pos) ,value)
 
186
             ,plist)
 
187
         (setf ,plist (append ,plist (list ,pkey ,value)))))))
 
188
 
 
189