← Back to branch summary

~ubuntu-branches/ubuntu/karmic/maxima/karmic

« back to all changes in this revision

Viewing changes to src/intpol.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Barry deFreese
  • Date: 2006-07-06 17:04:52 UTC
  • mfrom: (1.1.4 upstream)
  • Revision ID: james.westby@ubuntu.com-20060706170452-j9ypoqc1kjfnz221
Tags: 5.9.3-1ubuntu1
* Re-sync with Debian
* Comment out backward-delete-char-untabify in maxima.el (Closes Malone #5273)
* debian/control: build-dep automake -> automake1.9 (Closes BTS: #374663)

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/intpol.lisp
8
8
;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
9
9
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10
10
 
11
 
(in-package "MAXIMA")
 
11
(in-package :maxima)
12
12
;;; Interpolation routine by CFFK.
13
13
(macsyma-module intpol)
14
14
(load-macsyma-macros transm numerm)
15
15
 
16
 
(declare-top (special $intpolrel $intpolabs $intpolerror)
17
 
             (flonum $intpolrel $intpolabs a b c fa fb fc)
 
16
(declare-top (special $find_root_rel $find_root_abs $find_root_error)
 
17
             (flonum $find_root_rel $find_root_abs a b c fa fb fc)
18
18
             (fixnum lin)
19
19
             (notype (interpolate-check flonum flonum flonum flonum))) 
20
20
 
27
27
                                     (t (funcall y z))))
28
28
          )
29
29
 
30
 
(or (boundp '$intpolabs) (setq $intpolabs 0.0)) 
31
 
(or (boundp '$intpolrel) (setq $intpolrel 0.0))
32
 
(or (boundp '$intpolerror) (setq $intpolerror t))
 
30
(or (boundp '$find_root_abs) (setq $find_root_abs 0.0)) 
 
31
(or (boundp '$find_root_rel) (setq $find_root_rel 0.0))
 
32
(or (boundp '$find_root_error) (setq $find_root_error t))
33
33
 
34
 
(defun $interpolate_subr (f left right)
 
34
(defun $find_root_subr (f left right)
35
35
  (bind-tramp1$
36
36
   f f
37
37
   (prog (a b c fa fb fc (lin 0))
41
41
      (or (> b a) (setq a (prog2 nil b (setq b a))))
42
42
      (setq fa (fcall$ f a)
43
43
            fb (fcall$ f b))
44
 
      (or (> (abs fa) $intpolabs) (return a))
45
 
      (or (> (abs fb) $intpolabs) (return b))
 
44
      (or (> (abs fa) $find_root_abs) (return a))
 
45
      (or (> (abs fb) $find_root_abs) (return b))
46
46
      (and (> (*$ fa fb) 0.0)
47
 
           (cond ((eq $intpolerror t)
 
47
           (cond ((eq $find_root_error t)
48
48
                  (merror "function has same sign at endpoints~%~M"
49
49
                          `((mlist)
50
50
                            ((mequal) ((f) ,a) ,fa)
51
51
                            ((mequal) ((f) ,b) ,fb))))
52
 
                 (t (return $intpolerror))))
 
52
                 (t (return $find_root_error))))
53
53
      (and (> fa 0.0)
54
54
           (setq fa (prog2 nil fb (setq fb fa)) a (prog2 nil b (setq b a))))
55
55
      (setq lin 0.)
73
73
      (go falsi))))
74
74
 
75
75
(defun interpolate-check (a c b fc)
76
 
  (not (and (prog2 nil (> (abs fc) $intpolabs) (setq fc (max (abs a) (abs b))))
77
 
            (> (abs (-$ b c)) (*$ $intpolrel fc))
78
 
            (> (abs (-$ c a)) (*$ $intpolrel fc)))))
 
76
  (not (and (prog2 nil (> (abs fc) $find_root_abs) (setq fc (max (abs a) (abs b))))
 
77
            (> (abs (-$ b c)) (*$ $find_root_rel fc))
 
78
            (> (abs (-$ c a)) (*$ $find_root_rel fc)))))
79
79
 
80
80
 
81
81
 
84
84
  (setq form (cdr form))
85
85
  (cond ((= (length form) 3)
86
86
         (cond (translp
87
 
                `(($interpolate_subr) ,@form))
 
87
                `(($find_root_subr) ,@form))
88
88
               (t
89
89
                `((mprog) ((mlist) ((msetq) $numer t))
90
 
                  (($interpolate_subr)  ,@form)))))
 
90
                  (($find_root_subr)  ,@form)))))
91
91
        ((= (length form) 4)
92
92
         (destructuring-let (((exp var . bnds) form))
93
93
           (setq exp (sub ($lhs exp) ($rhs exp)))
94
94
           (cond (translp
95
 
                  `(($interpolate_subr)
 
95
                  `(($find_root_subr)
96
96
                    ((lambda-i) ((mlist) ,var)
97
97
                     (($modedeclare) ,var $float)
98
98
                     ,exp)
99
99
                    ,@bnds))
100
100
                 (t
101
101
                  `((mprog) ((mlist) ((msetq) $numer t))
102
 
                    (($interpolate_subr)
 
102
                    (($find_root_subr)
103
103
                     ((lambda) ((mlist) ,var) ,exp)
104
104
                     ,@bnds))))))
105
105
        (t (merror "wrong number of args to `interpolate'"))))
106
106
 
107
 
(defmspec $interpolate (form)
 
107
(defmspec $find_root (form)
108
108
  (meval (interpolate-macro form nil)))
109
109
 
110
 
(def-translate-property $interpolate (form)
 
110
(def-translate-property $find_root (form)
111
111
  (let (($tr_numer t))
112
112
    (translate (interpolate-macro form t))))
113
113