src/mutils.lisp

   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 nonatomic expression; found: ~:M")
  35                      ielist))))
  36     (if (every #'(lambda (x) (and (listp x) (= 3 (length x)))) elist)
  37         (let ((found (find key elist :test #'alike1 :key #'second)))
  38           (if found (third found) default))
  39         (merror (intl:gettext "assoc: every argument must be an expression of two parts; found: ~:M") ielist))))
  40
  41 ;;; (ASSOL item A-list)
  42 ;;;
  43 ;;;  Like ASSOC, but uses ALIKE1 as the comparison predicate rather
  44 ;;;  than EQUAL.
  45 ;;;
  46 ;;;  Meta-Synonym:      (ASS #'ALIKE1 ITEM ALIST)
  47
  48 (defun assol (item alist)
  49   (dolist (pair alist)
  50     (if (alike1 item (car pair)) (return pair))))
  51
  52 (defun assolike (item alist)
  53   (cdr (assol item alist)))
  54
  55 ;;; (MEMALIKE X L)
  56 ;;;
  57 ;;;  Searches for X in the list L, but uses ALIKE1 as the comparison predicate
  58 ;;;  (which is similar to EQUAL, but ignores header flags other than the ARRAY
  59 ;;;  flag)
  60 ;;;
  61 ;;;  Conceptually, the function is the same as
  62 ;;;
  63 ;;;    (when (find x l :test #'alike1) l)
  64 ;;;
  65 ;;;  except that MEMALIKE requires a list rather than a general sequence, so the
  66 ;;;  host lisp can probably generate faster code.
  67 (defun memalike (x l)
  68   (do ((l l (cdr l)))
  69       ((null l))
  70     (when (alike1 x (car l)) (return l))))
  71
  72 ;;; Return the first duplicate element of the list LIST, or NIL if there
  73 ;;; are no duplicates present in LIST.  The function KEY is applied to
  74 ;;; each element of the list before comparison (or uses the element itself
  75 ;;; if KEY is NIL), and the comparison is done with the function TEST.
  76 ;;;
  77 ;;; This was written with "small" lists in mind.  The original use case
  78 ;;; was finding duplicates in parameter lists of functions, etc.
  79 ;;;    - Kris Katterjohn 06/2017
  80 (defun find-duplicate (list &key (test #'eql) key)
  81   (declare (optimize (speed 3)))
  82   (declare (type (or function null) key)
  83            (type function test))
  84   (let ((seen nil))
  85     (dolist (e list)
  86       (let ((i (if key (funcall key e) e)))
  87         (when (member i seen :test test)
  88           (return-from find-duplicate e))
  89         (push i seen)))))
  90
  91 ;;; Return a Maxima gensym.
  92 ;;;
  93 ;;; N.B. Maxima gensyms are interned, so they are not Lisp gensyms.
  94 ;;; This function can return the same symbol multiple times, it can
  95 ;;; return a symbol that was created and used elsewhere, etc.
  96 ;;;
  97 ;;; Maxima produces some expressions that contain Maxima gensyms, so
  98 ;;; the use of uninterned symbols instead can cause confusion (since
  99 ;;; these print like any other symbol).
 100 (defmfun $gensym (&optional x)
 101   (typecase x
 102     (null
 103      (intern (symbol-name (gensym "$G")) :maxima))
 104     (string
 105      (intern
 106        (symbol-name (gensym (format nil "$~a" (maybe-invert-string-case x))))
 107        :maxima))
 108     ((integer 0)
 109      (let ((*gensym-counter* x))
 110        (intern (symbol-name (gensym "$G")) :maxima)))
 111     (t
 112      (merror
 113        (intl:gettext
 114          "gensym: Argument must be a nonnegative integer or a string. Found: ~M") x))))