1 665c255d 2023-08-04 jrmu (defvar *tolerance* 0.00001)
 2 665c255d 2023-08-04 jrmu (defun fixed-point (f first-guess)
 3 665c255d 2023-08-04 jrmu   (labels (
 4 665c255d 2023-08-04 jrmu 	   (close-enough? (v1 v2)
 5 665c255d 2023-08-04 jrmu 			  (< (abs (- v1 v2)) *tolerance*))
 6 665c255d 2023-08-04 jrmu 	   (try (guess)
 7 665c255d 2023-08-04 jrmu 		(let ((next (funcall f guess)))
 8 665c255d 2023-08-04 jrmu 		  (if (close-enough? guess next)
 9 665c255d 2023-08-04 jrmu 		      next
10 665c255d 2023-08-04 jrmu 		    (try next)))))
11 665c255d 2023-08-04 jrmu 	  (try first-guess)))
12 665c255d 2023-08-04 jrmu (defun average (a b)
13 665c255d 2023-08-04 jrmu   (/ (+ a b) 2))
14 665c255d 2023-08-04 jrmu 
15 665c255d 2023-08-04 jrmu (defun dampen-sqrt (x)
16 665c255d 2023-08-04 jrmu   (fixed-point
17 665c255d 2023-08-04 jrmu    (lambda (y)
18 665c255d 2023-08-04 jrmu      (average y (/ x y)))
19 665c255d 2023-08-04 jrmu    1.0))
20 665c255d 2023-08-04 jrmu 
21 665c255d 2023-08-04 jrmu (defun dampen-root (x n)
22 665c255d 2023-08-04 jrmu   (fixed-point
23 665c255d 2023-08-04 jrmu    (lambda (y)
24 665c255d 2023-08-04 jrmu      (average y (/ x (expt y (1- n)))))
25 665c255d 2023-08-04 jrmu    1.0))
26 665c255d 2023-08-04 jrmu (defun repeated-dampen-root (x nroot nrepeat)
27 665c255d 2023-08-04 jrmu   (fixed-point-of-transform
28 665c255d 2023-08-04 jrmu    (lambda (y) (average y (/ x (expt y (1- nroot)))))
29 665c255d 2023-08-04 jrmu    (repeated #'average-damp nrepeat)
30 665c255d 2023-08-04 jrmu    1.0))
31 665c255d 2023-08-04 jrmu (print (repeated-dampen-root 2 4 2))