share/contrib/simplifying.lisp

   1 ;;; simplifying.lisp
   2 ;;; Maxima-level user-defined simplifying functions
   3 ;;; Copyright 2007-2019 by Stavros Macrakis macrakis@alum.mit.edu
   4 ;;; Licensed under the GNU Lesser General Public License version 3 (LGPLv3)
   5 ;;;
   6 ;;; For example, suppose we want to write a step function stepfn(x)
   7 ;;; which is 0 for x<- and 1 for x>0.
   8 ;;;
   9 ;;; /* Define simplifying function */
  10 ;;; simp_stepfn(x):=
  11 ;;;   block([prederror:false],
  12 ;;;      if is(x<=0)=true then 0
  13 ;;;      elseif is(x>0)=true then 1
  14 ;;;      else simpfuncall('stepfn,x))$
  15 ;;; /* Declare stepfn to be simplifying */
  16 ;;; simplifying('stepfn,'simp_stepfn)$
  17 ;;;
  18 ;;; /* Test simple cases */
  19 ;;; stepfn(-x^2);      /* 0 */
  20 ;;; stepfn(x^2+1);     /* 1 */
  21 ;;; ex: stepfn(x^2);   /* stepfn(x^2) -- no simplifications apply */
  22 ;;; assume(x>0)$
  23 ;;; ex;                /* Assumptions not consulted */
  24 ;;; resimplify(ex):=expand(ex,0,0)$
  25 ;;; /* Force resimplification */
  26 ;;; resimplify(ex);    /* 1 */
  27 ;;; forget(x>0)$
  28 ;;; resimplify(ex);    /* stepfn(x^2) */
  29
  30 ;;; Utilities
  31
  32 (defun defined-functionp (ex)
  33   (cond ((null ex) nil)
  34         ((symbolp ex)
  35          (if (or (fboundp ex)
  36                  (safe-mgetl ex '(mexpr mmacro)))
  37              t))
  38         ((and (not (atom ex))
  39               (eq (caar ex) 'lambda))
  40          t)
  41         (t nil)))
  42
  43 (defmacro mwarn (str &rest args)
  44   `(mtell ,(concatenate 'string "Warning: " str) ,@args))
  45
  46 \f
  47 ;;; Declare a user Maxima function to be a simplifying function
  48 ;;; simplifying(f,g) -- uses g as the simplifier
  49 ;;; simplifying(f,false) -- removes simplifying property
  50 ;;;
  51 ;;; You can override built-in simplifiers, but it is not recommended
  52
  53 (defun $simplifying (f simplifier)
  54   (if (not (symbolp f))
  55       (merror "Simplifying function ~M must be a symbol" f))
  56   (if (and simplifier (not (defined-functionp simplifier)))
  57       (mwarn "simplifier function ~M is not defined" simplifier))
  58   (if (and (get f 'operators) (not (get f 'user-simplifying)))
  59       (mwarn "~M is overriding built-in simplifier for ~M" simplifier f))
  60   (setf (get f 'user-simplifying) simplifier)
  61   (setf (get f 'operators) (if simplifier #'user-simplifying nil))
  62   f)
  63
  64 ;;; Create the expression fun(args...) and mark it as simplified.
  65 ;;; Thus, simpfuncall(sin,0) => sin(0), not 0, but resimplifying with
  66 ;;; expand(simpfuncall(sin,0)) does simplify to 0.
  67 ;;; It is generally not recommended to use this for functions with
  68 ;;; built-in simplifiers. (i.e. be very careful)
  69
  70 (defun $simpfuncall (fun &rest args) (simpfunmake fun args))
  71
  72 (defun $simpfunmake (fun args)
  73   (simpfunmake fun
  74                (if ($listp args)
  75                    (cdr args)
  76                  (merror "Bad second argument to `simpfunmake': ~M" args))))
  77
  78 (defun simpfunmake (fun args)
  79   ;; Code copied from (updated) $funmake
  80   (if (not (or (and (symbolp fun)
  81                     (not (member fun '(t nil $%e $%pi $%i))))
  82                ($subvarp fun)
  83                (and (stringp fun) (getopr0 fun))
  84                (and (not (atom fun)) (eq (caar fun) 'lambda))))
  85       (merror "Bad first argument to `simpfuncall/make': ~M" fun))
  86   (simpcons (getopr fun) args))
  87
  88 (defmfun simpcons (op args)
  89   (if (symbolp op)
  90       `((,op simp) ,@args)
  91     `((mqapply simp) ,op ,@args)))
  92
  93 ;;; The generic simplifying function for user simplification functions
  94 (defun user-simplifying (l ignore simpflag)
  95   (declare (ignore ignore))
  96   (let* ((op (caar l))
  97          (simplifier (get op 'user-simplifying))
  98          ;; args are (re)simplified *outside* the simplification fnc
  99          (args (mapcar #'(lambda (i) (simpcheck i simpflag)) (cdr l))))
 100     (let ( ;; args have already been resimplified if necessary
 101           (dosimp nil))
 102       (declare (special dosimp))
 103       (if (defined-functionp simplifier)
 104           (mapply simplifier args op)
 105         (simpcons op args)))))