# pkhuong/rational-simplex

Switch branches/tags
Nothing to show
Fetching contributors…
Cannot retrieve contributors at this time
90 lines (86 sloc) 2.88 KB
 (defun one-newton-step (x f df) (let* ((fx (pull-bits (funcall f x))) (dfx (pull-bits (funcall df x)))) (values (and (/= dfx 0) (pull-bits (- x (/ fx dfx)))) fx x))) ;; try to bracket a root of f. (defun initial-newton (lo hi f df) (declare (optimize debug)) (let* ((*precision* 64) (lo (round-to-float lo)) (hi (round-to-float hi)) (slo (signum (pull-bits (funcall f lo)))) (shi (signum (pull-bits (funcall f hi)))) (x (/ (+ lo hi) 2))) (block nil (cond ((zerop slo) (return (values lo lo))) ((zerop shi) (return (values hi hi))) ((/= slo shi) (return (values lo hi)))) (loop repeat 32 do (multiple-value-bind (x2 fx) (one-newton-step (pull-bits x) f df) (cond ((/= (signum fx) slo) (return (if (and x2 (< x2 x)) (values lo x) (values x hi)))) ((not x2) (return)) ((>= x2 hi) (return)) ((<= x2 lo) (return)) (t (setf x x2)))))))) (defun bracketed-newton (lo hi f df) (let* ((*precision* 64) (lo (pull-bits lo)) (hi (pull-bits hi)) (slo (signum (pull-bits (funcall f lo)))) (shi (signum (pull-bits (funcall f hi)))) (x (/ (+ lo hi) 2))) (block nil (cond ((zerop slo) (return lo)) ((zerop shi) (return hi)) ((<= (abs (- (float-bits lo) (float-bits hi))) 1) (return x))) (loop for i upfrom 1 do (let ((*precision* (min (max (ash 1 i) 64) 1024)) (newtonp t)) (multiple-value-bind (x2 fx) (and (plusp (mod i 3)) (one-newton-step (pull-bits x) f df)) (when (or (not x2) (>= x2 (max hi lo)) (<= x2 (min hi lo))) (setf newtonp nil x (/ (+ lo hi) 2) x2 x fx (pull-bits (funcall f x)))) (when (zerop fx) (return x)) (let ((sx (signum fx))) (cond ((= sx shi) (setf hi x)) ((= sx slo) (setf lo x)))) (setf x (if newtonp (pull-bits x2) (/ (+ lo hi) 2))) (when (<= (abs (- (float-bits lo) (float-bits hi))) 1) (return x)))))))) (defun newton (lo hi f df) (multiple-value-bind (lo hi) (initial-newton (round-to-float lo) (round-to-float hi) f df) (and lo hi (bracketed-newton lo hi f df))))