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.2 2003/05/02 22:30:26 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
  22 (defun mklist (obj)
  23   "Make into list if atom"
  24   (if (listp obj) obj (list obj)))
  25
  26 (defun filter (fn lst)
  27   "Filter a list by function, eliminate elements where fn returns nil"
  28   (let ((acc nil))
  29     (dolist (x lst)
  30       (let ((val (funcall fn x)))
  31         (if val (push val acc))))
  32     (nreverse acc)))
  33
  34 (defun appendnew (l1 l2)
  35   "Append two lists, filtering out elem from second list that are already in first list"
  36   (dolist (elem l2)
  37     (unless (find elem l1)
  38       (setq l1 (append l1 (list elem)))))
  39   l1)
  40
  41
  42
  43 (defun remove-tree-if (pred tree)
  44   "Strip from tree of atoms that satistify predicate"
  45   (if (atom tree)
  46       (unless (funcall pred tree)
  47         tree)
  48     (let ((car-strip (remove-tree-if pred (car tree)))
  49           (cdr-strip (remove-tree-if pred (cdr tree))))
  50       (cond
  51        ((and car-strip (atom (cadr tree)) (null cdr-strip))
  52         (list car-strip))
  53        ((and car-strip cdr-strip)
  54         (cons car-strip cdr-strip))
  55        (car-strip
  56         car-strip)
  57        (cdr-strip
  58         cdr-strip)))))
  59
  60 (defun find-tree (sym tree)
  61   "Finds an atom as a car in tree and returns cdr tree at that positions"
  62   (if (or (null tree) (atom tree))
  63       nil
  64     (if (eql sym (car tree))
  65         (cdr tree)
  66       (aif (find-tree sym (car tree))
  67           it
  68         (aif (find-tree sym (cdr tree))
  69             it
  70             nil)))))
  71
  72 (defun flatten (lis)
  73   (cond ((atom lis) lis)
  74         ((listp (car lis))
  75          (append (flatten (car lis)) (flatten (cdr lis))))
  76         (t (append (list (car lis)) (flatten (cdr lis))))))
  77
  78 ;;; Keyword functions
  79
  80 (defun remove-keyword (key arglist)
  81   (loop for sublist = arglist then rest until (null sublist)
  82         for (elt arg . rest) = sublist
  83         unless (eq key elt) append (list elt arg)))
  84
  85 (defun remove-keywords (key-names args)
  86   (loop for ( name val ) on args by #'cddr
  87         unless (member (symbol-name name) key-names
  88                        :key #'symbol-name :test 'equal)
  89         append (list name val)))
  90
  91