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,v 1.8 2003/07/05 02:32:08 kevin Exp $
  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 filter (fn lst)
  26   "Filter 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 appendnew (l1 l2)
  33   "Append two lists, filtering out elem from second list that are already in first list"
  34   (dolist (elem l2 l1)
  35     (unless (find elem l1)
  36       (setq l1 (append l1 (list elem))))))
  37
  38 (defun remove-tree-if (pred tree)
  39   "Strip from tree of atoms that satistify predicate"
  40   (if (atom tree)
  41       (unless (funcall pred tree)
  42         tree)
  43     (let ((car-strip (remove-tree-if pred (car tree)))
  44           (cdr-strip (remove-tree-if pred (cdr tree))))
  45       (cond
  46        ((and car-strip (atom (cadr tree)) (null cdr-strip))
  47         (list car-strip))
  48        ((and car-strip cdr-strip)
  49         (cons car-strip cdr-strip))
  50        (car-strip
  51         car-strip)
  52        (cdr-strip
  53         cdr-strip)))))
  54
  55 (defun find-tree (sym tree)
  56   "Finds an atom as a car in tree and returns cdr tree at that positions"
  57   (if (or (null tree) (atom tree))
  58       nil
  59     (if (eql sym (car tree))
  60         (cdr tree)
  61       (aif (find-tree sym (car tree))
  62           it
  63         (aif (find-tree sym (cdr tree))
  64             it
  65             nil)))))
  66
  67 (defun flatten (lis)
  68   (cond ((atom lis) lis)
  69         ((listp (car lis))
  70          (append (flatten (car lis)) (flatten (cdr lis))))
  71         (t (append (list (car lis)) (flatten (cdr lis))))))
  72
  73 ;;; Keyword functions
  74
  75 (defun remove-keyword (key arglist)
  76   (loop for sublist = arglist then rest until (null sublist)
  77         for (elt arg . rest) = sublist
  78         unless (eq key elt) append (list elt arg)))
  79
  80 (defun remove-keywords (key-names args)
  81   (loop for ( name val ) on args by #'cddr
  82         unless (member (symbol-name name) key-names
  83                        :key #'symbol-name :test 'equal)
  84         append (list name val)))
  85
  86 (defun mapappend (func seq)
  87   (apply #'append (mapcar func seq)))
  88
  89 (defun mapcar-append-string-nontailrec (func v)
  90   "Concatenate results of mapcar lambda calls"
  91   (aif (car v)
  92        (concatenate 'string (funcall func it)
  93                     (mapcar-append-string-nontailrec func (cdr v)))
  94        ""))
  95
  96
  97 (defun mapcar-append-string (func v &optional (accum ""))
  98   "Concatenate results of mapcar lambda calls"
  99   (aif (car v)
 100        (mapcar-append-string
 101         func
 102         (cdr v)
 103         (concatenate 'string accum (funcall func it)))
 104        accum))
 105
 106 (defun mapcar2-append-string-nontailrec (func la lb)
 107   "Concatenate results of mapcar lambda call's over two lists"
 108   (let ((a (car la))
 109         (b (car lb)))
 110     (if (and a b)
 111       (concatenate 'string (funcall func a b)
 112                    (mapcar2-append-string-nontailrec func (cdr la) (cdr lb)))
 113       "")))
 114
 115 (defun mapcar2-append-string (func la lb &optional (accum ""))
 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         (mapcar2-append-string func (cdr la)  (cdr lb)
 121                                (concatenate 'string accum (funcall func a b)))
 122       accum)))
 123
 124 (defun append-sublists (list)
 125   "Takes a list of lists and appends all sublists"
 126   (let ((results (car list)))
 127     (dolist (elem (cdr list) results)
 128       (setq results (append results elem)))))
 129
 130
 131 ;; alists and plists
 132
 133 (defun alist-elem-p (elem)
 134   (and (consp elem) (atom (car elem)) (atom (cdr elem))))
 135
 136 (defun alistp (alist)
 137   (when (listp alist)
 138     (dolist (elem alist)
 139       (unless (alist-elem-p elem)
 140         (return-from alistp nil)))
 141     t))
 142
 143 (defmacro update-alist (akey value alist &key (test '#'eql) (key '#'identity))
 144   "Macro to support below (setf get-alist)"
 145   (let ((elem (gensym)))
 146     `(let ((,elem (assoc ,akey ,alist :test ,test :key ,key)))
 147        (if ,elem
 148            (progn
 149              (setf (cdr ,elem) ,value)
 150              ,alist)
 151         (setf ,alist (acons ,akey ,value ,alist))))))
 152
 153 (defun get-alist (key alist &key (test #'eql))
 154   (cdr (assoc key alist :test test)))
 155
 156 (defun (setf get-alist) (value key alist &key (test #'eql))
 157   (update-alist key value alist :test test)
 158   value)
 159
 160 (defun alist-plist (alist)
 161   (apply #'append (mapcar #'(lambda (x) (list (car x) (cdr x))) alist)))
 162
 163 (defun plist-alist (plist)
 164   (do ((alist '())
 165        (pl plist (cddr plist)))
 166       ((null pl) alist)
 167     (setq alist (acons (car pl) (cadr pl) alist))))
 168
 169 (defmacro update-plist (pkey value plist &key (test '#'eql))
 170   "Macro to support below (setf get-alist)"
 171   (let ((pos (gensym)))
 172     `(let ((,pos (member ,pkey ,plist :test ,test)))
 173        (if ,pos
 174            (progn
 175              (setf (cadr ,pos) ,value)
 176              ,plist)
 177          (setf ,plist (append ,plist (list ,pkey ,value)))))))
 178
 179