;;; Module adt-abr.rkt - Livre "Premiers Cours de Programmation avec Scheme" (Ellipses ed, 2010) ;;; Doit etre sauvegarde comme 'langage determine par le source' ! ;;; Racket > v5.0 ;;; "Arbres Binaires de Recherche Equilibres" (portant des nombres reels) ;;; Tous les elements sont distincts, comparables avec une relation d'ordre strict notee < ;;; Implementation concrete avec des listes. On ne maintient pas la hauteur des noeuds. #lang racket (provide abr-vide abr-vide? abr-racine abr-fg abr-fd abr-insertion liste->abr abr-member? abr-max abr-suppression) (define-syntax show ; un petit utilitaire pour tester (syntax-rules () ((show expr) (printf "> ~a\n==> ~a\n" 'expr expr)))) (define (abr-vide) empty) ; ligne 224 chap. 9 du livre PCPS, ligne 224 (define (abr-vide? A) (empty? A)) (define (make-abr r Ag Ad) ; construction d'un noeud. On suppose que (list r Ag Ad)) ; les verifications d'abr ont ete faites en amont (define (abr-racine A) (if (abr-vide? A) (error 'abr-racine "arbre vide") (first A))) (define (abr-fg A) (if (abr-vide? A) (error 'abr-fg "arbre vide") (second A))) (define (abr-fd A) (if (abr-vide? A) (error 'abr-fd "arbre vide") (third A))) (define ABR-TEST (make-abr 12 (make-abr 8 (make-abr 5 empty empty) (make-abr 10 (make-abr 9 empty empty) empty)) (make-abr 20 (make-abr 15 empty (make-abr 18 empty empty)) empty))) ;(show ABR-TEST) ;;; BONUS : affichage d'un ABR avec indentation (define (abr-print A) (local [(define (print-with-spaces n x) ; affiche x apres n espaces et va a la ligne (printf "~a~a\n" (build-string n (lambda (i) #\space)) x)) (define (aux A m) ; m = marge, nombre d'espaces en tete (if (abr-vide? A) (print-with-spaces m "") (begin (print-with-spaces m (abr-racine A)) (aux (abr-fg A) (+ m 2)) (aux (abr-fd A) (+ m 2)))))] (aux A 3))) ;(printf "Voici ABR-TEST :\n") ;(abr-print ABR-TEST) ; ------------------ appartenance d'un element a un ABR (define (abr-member? x A <) ; on passe la relation d'ordre strict, ligne 245 (if (abr-vide? A) false (local [(define r (abr-racine A)) (define Ag (abr-fg A)) (define Ad (abr-fd A))] (cond ((< x r) (abr-member? x Ag <)) ((< r x) (abr-member? x Ad <)) (else true))))) ;(show (abr-member? 20 ABR-TEST <)) ;(show (abr-member? 13 ABR-TEST <)) ; ------------------ insertion d'un nouvel element aux feuilles (define (abr-insertion-f x A <) ; insertion de x aux feuilles de l'abr A, ligne 254 (if (abr-vide? A) (make-abr x (abr-vide) (abr-vide)) (local [(define r (abr-racine A)) (define Ag (abr-fg A)) (define Ad (abr-fd A))] (cond ((< x r) (make-abr r (abr-insertion-f x Ag <) Ad)) ((< r x) (make-abr r Ag (abr-insertion-f x Ad <))) (else A))))) ; on ne rajoute pas x, il est deja la ! ;(show (abr-insertion-f 11 ABR-TEST <)) ;(abr-print (abr-insertion-f 11 ABR-TEST <)) ; l'equilibrage par AVL (define (hauteur A) ; ligne 265 (if (abr-vide? A) 0 (+ 1 (max (hauteur (abr-fg A)) (hauteur (abr-fd A)))))) ;(show (hauteur ABR-TEST)) (define (pente A) ; ligne 270 (- (hauteur (abr-fg A)) (hauteur (abr-fd A)))) ;(show (pente (abr-fg ABR-TEST))) ;(show (pente (abr-fd ABR-TEST))) ;(printf "On voit que ABR-TEST n'est pas equilibre ! D'ailleurs :\n") (define (avl? A) ; A est un ABR, ligne 272 (or (abr-vide? A) (and (<= (abs (pente A)) 1) (avl? (abr-fg A)) (avl? (abr-fd A))))) ;(show (avl? ABR-TEST)) (define (abr-insertion x AVL <) ; insertion equilibrante dans un AVL, ligne 283 (if (abr-vide? AVL) (make-abr x (abr-vide) (abr-vide)) (local [(define r (abr-racine AVL)) (define Ag (abr-fg AVL)) (define Ad (abr-fd AVL))] (cond ((< x r) (equilibrer (make-abr r (abr-insertion x Ag <) Ad))) ((> x r) (equilibrer (make-abr r Ag (abr-insertion x Ad <)))) (else AVL))))) (define (equilibrer AVLD) ; AVLD non vide, ligne 294 (local [(define r (abr-racine AVLD)) (define Ag (abr-fg AVLD)) (define Ad (abr-fd AVLD))] (case (pente AVLD) ((-1 0 1) AVLD) ; il est deja equilibre ! ((-2) (case (pente Ad) ((-1 0) (rotg AVLD)) ((1) (rotg (make-abr r Ag (rotd Ad)))))) ((2) (case (pente Ag) ((0 1) (rotd AVLD)) ((-1) (rotd (make-abr r (rotg Ag) Ad)))))))) (define (rotd AVLD) ; rotation droite d'un AVLD, ligne 306 (make-abr (abr-racine (abr-fg AVLD)) (abr-fg (abr-fg AVLD)) (make-abr (abr-racine AVLD) (abr-fd (abr-fg AVLD)) (abr-fd AVLD)))) (define (rotg AVLD) ; rotation gauche d'un AVLD, ligne 312 (make-abr (abr-racine (abr-fd AVLD)) (make-abr (abr-racine AVLD) (abr-fg AVLD) (abr-fg (abr-fd AVLD))) (abr-fd (abr-fd AVLD)))) (define (liste->abr L <) ; L est une liste de reels tous distincts, ligne 318 (if (empty? L) (abr-vide) (abr-insertion (first L) (liste->abr (rest L) <) <))) ;(printf "Je transforme la liste (1 2 3 4 5 6 7) en AVL :\n") ;(define AVL-TEST (liste->abr '(1 2 3 4 5 6 7) <)) ;(show AVL-TEST) ;(show (avl? AVL-TEST)) (define (abr-max AVL <) ; AVL non vide, retourne ( ), ligne 322 (local [(define r (abr-racine AVL)) (define Ag (abr-fg AVL)) (define Ad (abr-fd AVL))] (if (abr-vide? Ad) (list r Ag) (local [(define HR (abr-max Ad <))] ; HR = (m1 A1) (list (first HR) (equilibrer (make-abr r Ag (second HR)))))))) ;(local [(define AM (abr-max AVL-TEST <))] ; (printf "Le maximum de AVL-TEST est ~a et apres suppression on obtient ~a\n" (first AM) (second AM))) (define (abr-suppression x AVL <) ; retourne l'AVL sans l'element x, ligne 333 (if (abr-vide? AVL) AVL (local [(define r (abr-racine AVL)) (define Ag (abr-fg AVL)) (define Ad (abr-fd AVL))] (cond ((< x r) (equilibrer (make-abr r (abr-suppression x Ag <) Ad))) ((< r x) (equilibrer (make-abr r Ag (abr-suppression x Ad <)))) ; l'element a supprimer est donc a la racine ! ((abr-vide? Ag) Ad) (else (local [(define S (abr-max Ag <))] (equilibrer (make-abr (first S) (second S) Ad)))))))) ;(show AVL-TEST) ;(printf "Je supprime 4 dans AVL-TEST et le resultat est encore equilibre :\n") ;(show (abr-suppression 4 AVL-TEST <)) ;;; ========== SOLUTIONS DE L'EXERCICE 9.12.13 =========== ; a) (define (abr-insertion-r x A <) ; insertion a la racine ! (if (abr-vide? A) (make-abr x (abr-vide) (abr-vide)) (local [(define r (abr-racine A)) (define Ag (abr-fg A)) (define Ad (abr-fd A))] (cond ((< x r) (local [(define B (abr-insertion-r x Ag <))] (make-abr x (abr-fg B) (make-abr r (abr-fd B) Ad)))) ((< r x) (local [(define B (abr-insertion-r x Ad <))] (make-abr x (make-abr r (abr-fg A) (abr-fg B)) (abr-fd B)))) (else A))))) ; deja present, pas de duplication ! ;(show ABR-TEST) ;(printf "Insertion de 10 a la racine :\n") ;(show (abr-insertion-r 10 ABR-TEST <)) ; b) Pour calculer le minimum d'un ABR, inspirez-vous du calcul du maximum... ; c) (define (elements A bas haut <) ; les elements de A qui sont dans [bas, haut] (local [(define (aux A L) ; L = resultat jusqu'a present (if (abr-vide? A) L (local [(define r (abr-racine A)) (define Ag (abr-fg A)) (define Ad (abr-fd A))] (cond ((< r bas) (aux Ad L)) ((< haut r) (aux Ag L)) (else (aux Ag (cons r (aux Ad L))))))))] (aux A empty))) (show ABR-TEST) (printf "Elements entre 5 et 10 inclus :\n") (show (elements ABR-TEST 5 10 <)) ; d) (define (tri-par-AVL L) ; L est une lsite de nombres reels distincts (local [(define (infixe A) ; parcours infixe (if (abr-vide? A) empty (append (infixe (abr-fg A)) (list (abr-racine A)) (infixe (abr-fd A)))))] (infixe (liste->abr L <)))) ;(show (tri-par-AVL '(8 3 5 2 7 9 1 4 0 6))) ; e) classique. Si n = 2^h, alors h = log(n)... ; f) CPS sur un arbre avec une continuation à deux variables