src/zero.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 1982 Massachusetts Institute of Technology         ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package :maxima)
  12
  13 (macsyma-module zero)
  14
  15 (declare-top (special $numer $listconstvars varlist genvar))
  16
  17 (defmfun $zeroequiv (exp var)
  18   (declare (special var ))
  19   (prog (r s v varlist genvar)
  20      (declare (special s v))
  21      (setq exp (specrepcheck exp))
  22      (setq r (let ($listconstvars) ($listofvars exp)))
  23      (if (and (cdr r) (or (cddr r) (not (alike1 (cadr r) var))))
  24          (return '$dontknow))
  25      (setq exp ($exponentialize exp))
  26      (setq r (sdiff exp var))
  27      (if (isinop r '%derivative) (return '$dontknow))
  28      ($rat r)
  29      (setq r ($rat exp))
  30      (setq s (car r))
  31      (setq v (ratnumerator (cdr r)))
  32      (return (zeroequiv1 v))))
  33
  34 (defun zeroequiv1 (v)
  35   (declare (special var v s))
  36   (prog (v1 v2 coeff deg)
  37      (declare (special v1 v2))
  38      (if (atom v) (return (equal v 0)))
  39      coeffloop (if (null (cdr v)) (return t))
  40      (setq deg (cadr v))
  41      (if (equal deg 0) (return (zeroequiv1 (caddr v))))
  42      (setq coeff (caddr v))
  43      (when (zeroequiv1 coeff)
  44        (setq v (cons (car v) (cdddr v)))
  45        (go coeffloop))
  46      (setq v1 ($rat (sdiff (ratdisrep (cons s (cons v (caddr v)))) var)))
  47      (setq v2 (cadr ($rat (ratdisrep v1))))
  48      (if (equal (pdegree v2 (car v)) (cadr v))
  49          (return (zeroequiv2 v)))
  50      (if (< (pdegree v2 (car v)) (cadr v))
  51          (return (if (zeroequiv1 v2) (zeroequiv2 v))))
  52      (return '$dontknow)))
  53
  54 (defun zeroequiv2 (v)
  55   (declare (special var v s))
  56   (prog (r r1 r2)
  57      (declare (special r1 r2))
  58      (setq r (sin (* 1e-3 (random 1000.))))
  59      (setq v (maxima-substitute r var (ratdisrep (cons s (cons v 1)))))
  60      (setq v (meval '(($ev) v $numer)))
  61      (cond ((and (numberp v) (< (abs v) (* r 1e-2)))
  62             (return t))
  63            ((numberp v) (return nil)))
  64      (if (and (free v '$%i) (not (isinop v '%log)))
  65          (return '$dontknow))
  66      (setq r1 ($realpart v))
  67      (setq r1 (meval '(($ev) r1 $numer)))
  68      (if (not (numberp r1)) (return '$dontknow))
  69      (setq r2 ($imagpart v))
  70      (setq r2 (meval '(($ev) r2 $numer)))
  71      (if (not (numberp r2)) (return '$dontknow))
  72      (cond ((and (< (abs r1) (* r 1e-2))
  73                  (< (abs r2) (* r 1e-2)))
  74             (return t))
  75            (t (return nil)))))