(defmacro SPADCALL (&rest L) (let ((args (butlast l)) (fn (car (last l))) (gi (gensym))) ;; (values t) indicates a single return value `(let ((,gi ,fn)) (the (values t) (funcall (the #-(or :genera :lispworks) (function ,(make-list (length l) :initial-element t) t) #+(or :genera :lispworks)function (car ,gi)) ,@args (cdr ,gi)))))) (defmacro qrefelt (vec ind) `(svref ,vec ,ind)) (defmacro DEF-DF-BINOP (name op) `(defmacro ,name (x y) `(the double-float (,',op (the double-float ,x) (the double-float ,y))))) ;;; (DEF-DF-BINOP ADD-DF +) ;;; (DEF-DF-BINOP MUL-DF *) ;;; (DEF-DF-BINOP MAX-DF MAX) ;;; (DEF-DF-BINOP MIN-DF MIN) (DEF-DF-BINOP SUB-DF -) (DEF-DF-BINOP DIV-DF /) (defmacro DEF-DF-UNOP (name op) `(defmacro ,name (x) `(the double-float (,',op (the double-float ,x))))) (DEF-DF-UNOP MINUS-DF -) (defvar vv) (setf vv (make-array '(5))) (defun d1(x $) (cond ((null x) nil) ((consp x) (let* ((x0 (car x)) (r (cdr x))(i (car x0)) (v (cdr x0))) (cond ((eql i 0) nil) (t (cons (cons (- i 1) (* i v)) (d1 r $)))))) ) ) (defun d2(x y z $) (* (* 1.0d0 x) (expt (* 1.0d0 z) y))) ;; (defun f3(x $) 1.2193579171839963d0) (defun f3(x $) x) ;;; (defun f4(x y $) -7.211118079999995d0) (defun f4(x y $) (cond ((null x) 0.0d0) ((consp x) (let* ((x0 (car x)) (r (cdr x))(i (car x0)) (v (cdr x0))) (cond ((eql i 0) v) (t (+ (* (expt y i) v) (f4 r y $)))))) ) ) (setf (aref vv 1) (list (function d1))) (setf (aref vv 2) (list (function d2))) (setf (aref vv 3) (list (function f3))) (setf (aref vv 4) (list (function f4))) (DEFUN |ACPLTTS;newtonApprox1;Sup2Df;1| (|f| |a0| $) (let (|newApprox| |fa| |Df|) (progn (setf |Df| (SPADCALL |f| (QREFELT $ 1))) (setf |fa| (MINUS-DF (SPADCALL (SPADCALL 12193579171839963 -16 10 (QREFELT $ 2)) (QREFELT $ 3)))) (setf |newApprox| (SUB-DF |a0| (DIV-DF |fa| (SPADCALL |Df| |a0| (QREFELT $ 4))))) (values |newApprox|)))) (setf pol '((3 . -1d0) (1 . 1d0) (0 . 1.6543999999999996d0))) ;;; (|ACPLTTS;newtonApprox1;Sup2Df;1| pol 1.6543999999999996d0 vv)