1;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;; 2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3;;; The data in this file contains enhancments. ;;;;; 4;;; ;;;;; 5;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;; 6;;; All rights reserved ;;;;; 7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; 9;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 11(in-package :maxima) 12 13(macsyma-module mutils) 14 15;;; General purpose Macsyma utilities. This file contains runtime functions 16;;; which perform operations on Macsyma functions or data, but which are 17;;; too general for placement in a particular file. 18;;; 19;;; Every function in this file is known about externally. 20 21;;; This function searches for the key in the left hand side of the input list 22;;; of the form [x,y,z...] where each of the list elements is a expression of 23;;; a binary operand and 2 elements. For example x=1, 2^3, [a,b] etc. 24;;; The key checked againts the first operand and and returns the second 25;;; operand if the key is found. 26;;; If the key is not found it either returns the default value if supplied or 27;;; false. 28;;; Author Dan Stanger 12/1/02 29 30(defmfun $assoc (key ielist &optional default) 31 (let ((elist (if (listp ielist) 32 (margs ielist) 33 (merror 34 (intl:gettext "assoc: second argument must be a list; found: ~:M") 35 ielist)))) 36 (if (and (listp elist) 37 (every #'(lambda (x) (and (listp x) (= 3 (length x)))) elist)) 38 (let ((found (find key elist :test #'alike1 :key #'second))) 39 (if found (third found) default)) 40 (merror (intl:gettext "assoc: every list element must be an expression with two arguments; found: ~:M") ielist)))) 41 42;;; (ASSOL item A-list) 43;;; 44;;; Like ASSOC, but uses ALIKE1 as the comparison predicate rather 45;;; than EQUAL. 46;;; 47;;; Meta-Synonym: (ASS #'ALIKE1 ITEM ALIST) 48 49(defun assol (item alist) 50 (dolist (pair alist) 51 (if (alike1 item (car pair)) (return pair)))) 52 53(defun assolike (item alist) 54 (cdr (assol item alist))) 55 56;;; (MEMALIKE X L) 57;;; 58;;; Searches for X in the list L, but uses ALIKE1 as the comparison predicate 59;;; (which is similar to EQUAL, but ignores header flags other than the ARRAY 60;;; flag) 61;;; 62;;; Conceptually, the function is the same as 63;;; 64;;; (when (find x l :test #'alike1) l) 65;;; 66;;; except that MEMALIKE requires a list rather than a general sequence, so the 67;;; host lisp can probably generate faster code. 68(defun memalike (x l) 69 (do ((l l (cdr l))) 70 ((null l)) 71 (when (alike1 x (car l)) (return l)))) 72 73;;; Return the first duplicate element of the list LIST, or NIL if there 74;;; are no duplicates present in LIST. The function KEY is applied to 75;;; each element of the list before comparison (or uses the element itself 76;;; if KEY is NIL), and the comparison is done with the function TEST. 77;;; 78;;; This was written with "small" lists in mind. The original use case 79;;; was finding duplicates in parameter lists of functions, etc. 80;;; - Kris Katterjohn 06/2017 81(defun find-duplicate (list &key (test #'eql) key) 82 (declare (optimize (speed 3))) 83 (declare (type (or function null) key) 84 (type function test)) 85 (let ((seen nil)) 86 (dolist (e list) 87 (let ((i (if key (funcall key e) e))) 88 (when (member i seen :test test) 89 (return-from find-duplicate e)) 90 (push i seen))))) 91 92;;; Return a Maxima gensym. 93;;; 94;;; N.B. Maxima gensyms are interned, so they are not Lisp gensyms. 95;;; This function can return the same symbol multiple times, it can 96;;; return a symbol that was created and used elsewhere, etc. 97;;; 98;;; Maxima produces some expressions that contain Maxima gensyms, so 99;;; the use of uninterned symbols instead can cause confusion (since 100;;; these print like any other symbol). 101(defmfun $gensym (&optional x) 102 (typecase x 103 (null 104 (intern (symbol-name (gensym "$G")) :maxima)) 105 (string 106 (intern 107 (symbol-name (gensym (format nil "$~a" (maybe-invert-string-case x)))) 108 :maxima)) 109 ((integer 0) 110 (let ((*gensym-counter* x)) 111 (intern (symbol-name (gensym "$G")) :maxima))) 112 (t 113 (merror 114 (intl:gettext 115 "gensym: Argument must be a nonnegative integer or a string. Found: ~M") x)))) 116