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$
  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 (tree)
  77   (let ((result '()))
  78     (labels ((scan (item)
  79                (if (consp item)
  80                    (map nil #'scan item)
  81                    (push item result))))
  82       (scan tree))
  83     (nreverse result)))
  84
  85 ;;; Keyword functions
  86
  87 ;; ECL doesn't allow FOR clauses after UNTIL.
  88 #-ecl
  89 (defun remove-keyword (key arglist)
  90   (loop for sublist = arglist then rest until (null sublist)
  91         for (elt arg . rest) = sublist
  92         unless (eq key elt) append (list elt arg)))
  93
  94 (defun remove-keywords (key-names args)
  95   (loop for ( name val ) on args by #'cddr
  96         unless (member (symbol-name name) key-names
  97                        :key #'symbol-name :test 'equal)
  98         append (list name val)))
  99
 100 (defun mapappend (func seq)
 101   (apply #'append (mapcar func seq)))
 102
 103 (defun mapcar-append-string-nontailrec (func v)
 104   "Concatenate results of mapcar lambda calls"
 105   (aif (car v)
 106        (concatenate 'string (funcall func it)
 107                     (mapcar-append-string-nontailrec func (cdr v)))
 108        ""))
 109
 110
 111 (defun mapcar-append-string (func v &optional (accum ""))
 112   "Concatenate results of mapcar lambda calls"
 113   (aif (car v)
 114        (mapcar-append-string
 115         func
 116         (cdr v)
 117         (concatenate 'string accum (funcall func it)))
 118        accum))
 119
 120 (defun mapcar2-append-string-nontailrec (func la lb)
 121   "Concatenate results of mapcar lambda call's over two lists"
 122   (let ((a (car la))
 123         (b (car lb)))
 124     (if (and a b)
 125       (concatenate 'string (funcall func a b)
 126                    (mapcar2-append-string-nontailrec func (cdr la) (cdr lb)))
 127       "")))
 128
 129 (defun mapcar2-append-string (func la lb &optional (accum ""))
 130   "Concatenate results of mapcar lambda call's over two lists"
 131   (let ((a (car la))
 132         (b (car lb)))
 133     (if (and a b)
 134         (mapcar2-append-string func (cdr la)  (cdr lb)
 135                                (concatenate 'string accum (funcall func a b)))
 136       accum)))
 137
 138 (defun append-sublists (list)
 139   "Takes a list of lists and appends all sublists"
 140   (let ((results (car list)))
 141     (dolist (elem (cdr list) results)
 142       (setq results (append results elem)))))
 143
 144
 145 ;; alists and plists
 146
 147 (defun alist-elem-p (elem)
 148   (and (consp elem) (atom (car elem)) (atom (cdr elem))))
 149
 150 (defun alistp (alist)
 151   (when (listp alist)
 152     (dolist (elem alist)
 153       (unless (alist-elem-p elem)
 154         (return-from alistp nil)))
 155     t))
 156
 157 (defmacro update-alist (akey value alist &key (test '#'eql) (key '#'identity))
 158   "Macro to support below (setf get-alist)"
 159   (let ((elem (gensym "ELEM-"))
 160         (val (gensym "VAL-")))
 161     `(let ((,elem (assoc ,akey ,alist :test ,test :key ,key))
 162            (,val ,value))
 163        (cond
 164         (,elem
 165          (setf (cdr ,elem) ,val))
 166         (,alist
 167          (setf (cdr (last ,alist)) (list (cons ,akey ,val))))
 168          (t
 169           (setf ,alist (list (cons ,akey ,val)))))
 170        ,alist)))
 171
 172 (defun get-alist (key alist &key (test #'eql))
 173   (cdr (assoc key alist :test test)))
 174
 175 (defun (setf get-alist) (value key alist &key (test #'eql))
 176   "This won't work if the alist is NIL."
 177   (update-alist key value alist :test test)
 178   value)
 179
 180 (defun alist-plist (alist)
 181   (apply #'append (mapcar #'(lambda (x) (list (car x) (cdr x))) alist)))
 182
 183 (defun plist-alist (plist)
 184   (do ((alist '())
 185        (pl plist (cddr pl)))
 186       ((null pl) alist)
 187     (setq alist (acons (car pl) (cadr pl) alist))))
 188
 189 (defmacro update-plist (pkey value plist &key (test '#'eql))
 190   "Macro to support below (setf get-alist)"
 191   (let ((pos (gensym)))
 192     `(let ((,pos (member ,pkey ,plist :test ,test)))
 193        (if ,pos
 194            (progn
 195              (setf (cadr ,pos) ,value)
 196              ,plist)
 197          (setf ,plist (append ,plist (list ,pkey ,value)))))))
 198
 199
 200 (defun unique-slot-values (list slot &key (test 'eql))
 201   (let ((uniq '()))
 202     (dolist (item list (nreverse uniq))
 203       (let ((value (slot-value item slot)))
 204         (unless (find value uniq :test test)
 205           (push value uniq))))))
 206
 207
 208