✍ Á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: 23-01-2017 [09:20]


GNU/Emacs

1999-2017 (ç) Tiago Charters de Azevedo

São permitidas cópias textuais parciais/integrais em qualquer meio com/sem alterações desde que se mantenha este aviso.

Verbatim copying and redistribution of this entire page are permitted provided this notice is preserved.