src/inmis.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 1976, 1983 Massachusetts Institute of Technology      ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package :maxima)
  12 (macsyma-module inmis)
  13
  14 (declare-top (special listofvars))
  15
  16 (defmvar $listconstvars nil
  17   "Causes LISTOFVARS to include %E, %PI, %I, and any variables declared
  18    constant in the list it returns if they appear in exp.  The default is
  19    to omit these." boolean see-also $listofvars)
  20
  21 (defmvar $listdummyvars t)
  22
  23 (defmfun $unknown (f) (catch 'unknown (unknown (specrepcheck f))))
  24
  25 (defun unknown (f)
  26   (and (not (mapatom f))
  27        (cond ((and (eq (caar f) 'mqapply)
  28                    (not (zl-get (caaadr f) 'specsimp)))
  29               (throw 'unknown t))
  30              ((not (zl-get (caar f) 'operators)) (throw 'unknown t))
  31              (t (mapc #'unknown (cdr f)) nil))))
  32
  33 (defmfun $listofvars (e)
  34   (let ((listofvars (ncons '(mlist))))
  35     (when ($ratp e)
  36       (and (member 'trunc (cddar e) :test #'eq) (setq e ($taytorat e)))
  37       (setq e (cons '(mlist)
  38                     (sublis (mapcar #'cons
  39                                     (car (cdddar e))
  40                                     ;; GENSYMLIST
  41                                     (caddar e))
  42                             ;; VARLIST
  43                             (union* (listovars (cadr e))
  44                                     (listovars (cddr e)))))))
  45     (atomvars e)
  46     (if (not $listdummyvars)
  47         (dolist (u (cdr listofvars))
  48           (if (freeof u e)
  49               (setq listofvars (delete u listofvars :count 1 :test #'equal)))))
  50     listofvars))
  51
  52 (defun atomvars (e)
  53   (cond ((and (symbolp e)
  54               (or $listconstvars
  55                   ;; Do not add constants or boolean values to list of vars.
  56                   (and (not ($constantp e))
  57                        (not (member e '(t $true nil $false))))))
  58          (add2lnc e listofvars))
  59         ((atom e))
  60         ((specrepp e) (atomvars (specdisrep e)))
  61         ((member 'array (car e) :test #'eq) (myadd2lnc e listofvars))
  62         (t (mapc #'atomvars (margs e)))))
  63
  64 (defun myadd2lnc (item list)
  65   (and (not (memalike item list)) (nconc list (ncons item))))
  66
  67 ;; Bind variables declared with DEFMVAR to their initial values.
  68 ;; Some initial values are non-Maxima expressions, e.g., (2 3 5 7)
  69 ;; Attempt to handle those as well as Maxima expressions.
  70 ;; No attempt is made to handle variables declare with DEFVAR or by other means.
  71
  72 (defun maybe-reset (key val actually-reset reset-verbose)
  73   (declare (special munbindp))
  74   ; MAYBE DEFMVAR VALUES SHOULD ONLY BE MAXIMA EXPRESSIONS ??
  75   (let ((non-maxima (and (consp val) (not (consp (car val))))))
  76     (when
  77       ; TEST (BOUNDP KEY), OTHERWISE ATTEMPT TO COMPARE VALUES FAILS ...
  78       (and (boundp key)
  79         (if non-maxima
  80           ; Apply EQUALP to non-Maxima expressions.
  81           (not (equalp (symbol-value key) val))
  82           ; Apply ALIKE1 to Maxima expressions.
  83           (not (alike1 (symbol-value key) val))))
  84
  85       (when reset-verbose
  86         ; ATTEMPT TO COPE WITH NON-MAXIMA EXPRESSIONS FOR BENEFIT OF DISPLA
  87         (let ((displa-val (if non-maxima `((mprogn) ,@val) val)))
  88           (displa `((mtext) "reset: bind " ,key " to " ,displa-val))))
  89       (nconc actually-reset (list key))
  90       (let ((munbindp t))
  91         (meval `((msetq) ,key ((mquote) ,val)))))))
  92
  93 (defmspec $reset_verbosely (L)
  94   (reset-do-the-work (cdr L) t))
  95
  96 (defmspec $reset (L)
  97   (reset-do-the-work (cdr L) nil))
  98
  99 (defun reset-do-the-work (args reset-verbose)
 100
 101   (let ((actually-reset (copy-tree '((mlist)))) ($lispdisp t))
 102     (if args
 103       (mapcar
 104         #'(lambda (key)
 105             (multiple-value-bind (val found-p) (gethash key *variable-initial-values*)
 106               (if found-p (maybe-reset key val actually-reset reset-verbose))))
 107         args)
 108
 109       (maphash
 110         #'(lambda (key val)
 111             (maybe-reset key val actually-reset reset-verbose))
 112         *variable-initial-values*))
 113
 114     actually-reset))