Árvore Stern-Brocot

... uma implementação em LISP

Para a construção da árvore de Stern-Brocot precisamos dos mediantes de dois números racionais a/b e c/d. Uma implementação simples dá:

(defun mediant. (a b c d)
  (list (/ a b)
        (/ (+ a c) (+ b d))
        (/ c d)))

;; Example
> (mediant. 0 1 1 1)
(0 1/2 1)

Claro que dá mais jeito ter uma versão para o cálculo do mediante que usa directamente números racionais em vez da sua decomposição, ou seja,

(defun mediant (p q)
  (/ (+ (numerator p) (numerator q))
     (+ (denominator p) (denominator q))))

;; Example
> (mediant 1/2 3/5)
4/7

A ideia agora é ir introduzindo os mediantes entre cada dois números de uma lista de números racionais:

(defun mediant-list (pq-list)
  (cond ((not (cdr pq-list))
         pq-list)
        (pq-list
         (append (list (car pq-list)
                       (mediant (car pq-list) (cadr pq-list)))
                 (mediant-list (cdr pq-list))))))

;; Example
> (mediant-list '(0/1 1/1))
(0 1/2 1)

> (mediant-list '(0/1 1/2 1/1))
(0 1/3 1/2 2/3 1)

fazendo a composição sucessiva partindo de uma lista inicial com dois números (0 1)

> (mediant-list
   (mediant-list
    (mediant-list
     (mediant-list
      (mediant-list '(0 1))))))

(0 1/6 1/5 2/9 1/4 3/11 2/7 3/10 1/3 4/11 3/8 5/13 2/5 5/12 3/7 4/9 1/2 5/9 4/7
 7/12 3/5 8/13 5/8 7/11 2/3 7/10 5/7 8/11 3/4 7/9 4/5 5/6 1)

Para isso precisamos de uma função que trate da composição sucessiva (em geral, para se poder aproveitar para outras coisas no futuro)

(defun nest (function arg n)
  (cond ((= n 0)
         arg)
        (t
         (nest function (funcall function arg) (- n 1)))))

;; Example
> (nest 'cos .5 10)
0.73500633

> ((lambda (x) (+ 1 x)) 1)
2

> (nest (lambda (x) (+ 1 x)) 2 10)
12

> (nest #'mediant-list '(0/1 1/1) 7)
(0 1/8 1/7 2/13 1/6 3/17 2/11 3/16 1/5 4/19 3/14 5/23 2/9 5/22 3/13 4/17 1/4
 5/19 4/15 7/26 3/11 8/29 5/18 7/25 2/7 7/24 5/17 8/27 3/10 7/23 4/13 5/16 1/3
 6/17 5/14 9/25 4/11 11/30 7/19 10/27 3/8 11/29 8/21 13/34 5/13 12/31 7/18 9/23
 2/5 9/22 7/17 12/29 5/12 13/31 8/19 11/26 3/7 10/23 7/16 11/25 4/9 9/20 5/11
 6/13 1/2 7/13 6/11 11/20 5/9 14/25 9/16 13/23 4/7 15/26 11/19 18/31 7/12 17/29
 10/17 13/22 3/5 14/23 11/18 19/31 8/13 21/34 13/21 18/29 5/8 17/27 12/19 19/30
 7/11 16/25 9/14 11/17 2/3 11/16 9/13 16/23 7/10 19/27 12/17 17/24 5/7 18/25
 13/18 21/29 8/11 19/26 11/15 14/19 3/4 13/17 10/13 17/22 7/9 18/23 11/14 15/19
 4/5 13/16 9/11 14/17 5/6 11/13 6/7 7/8 1)

Agora é fácil escrever a versão final ;)

(defun stern-brocot (pq-list n)
  (nest #'mediant-list pq-list n))

;;
> (stern-brocot '(0 1) 6)
(0 1/7 1/6 2/11 1/5 3/14 2/9 3/13 1/4 4/15 3/11 5/18 2/7 5/17 3/10 4/13 1/3
 5/14 4/11 7/19 3/8 8/21 5/13 7/18 2/5 7/17 5/12 8/19 3/7 7/16 4/9 5/11 1/2
 6/11 5/9 9/16 4/7 11/19 7/12 10/17 3/5 11/18 8/13 13/21 5/8 12/19 7/11 9/14
 2/3 9/13 7/10 12/17 5/7 13/18 8/11 11/15 3/4 10/13 7/9 11/14 4/5 9/11 5/6 6/7
 1)

Se quisermos converter os números acima nas suas expansões decimais basta fazer

> (mapcar (lambda (x) (float x)) (stern-brocot '(0 1) 6))
(0.0 0.14285715 0.16666667 0.18181819 0.2 0.21428572 0.22222222 0.23076923 0.25
 0.26666668 0.27272728 0.2777778 0.2857143 0.29411766 0.3 0.30769232 0.33333334
 0.35714287 0.36363637 0.36842105 0.375 0.3809524 0.3846154 0.3888889 0.4
 0.4117647 0.41666666 0.42105263 0.42857143 0.4375 0.44444445 0.45454547 0.5
 0.54545456 0.5555556 0.5625 0.5714286 0.57894737 0.5833333 0.5882353 0.6
 0.6111111 0.61538464 0.61904764 0.625 0.6315789 0.6363636 0.64285713 0.6666667
 0.6923077 0.7 0.7058824 0.71428573 0.7222222 0.72727275 0.73333335 0.75
 0.7692308 0.7777778 0.78571427 0.8 0.8181818 0.8333333 0.85714287 1.0)

Para futura utilização preciso de mais dígitos. Em vez de

> *read-default-float-format*
single-float

ponho

(setf *read-default-float-format* single-float)

Em vez de

> (/ 1 3.0)
0.33333334

obtém-se

> (/ 1 3.0)
0.3333333333333333

Happy hacking!

P.S.

(defun stern-brocot-f (pq-list n)
  (mapcar (lambda (x) (float x)) (stern-brocot pq-list n)))

(defun frac-to-list (p)
  (cddr (map 'list #'digit-char-p (prin1-to-string p))))

Palavras chave/keywords: LISP, Stern-Brocot

Criado/Created: 05-01-2016 [11:09]

Última actualização/Last updated: 10-10-2022 [14:26]

Voltar à página inicial.