;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Programme support du MOOC programmation récursive ;;; Copyright (C) 2013 Christian.Queinnec@paracamplus.com ;;; ;;; This program is free software: you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation, either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program. If not, see . ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; MOOC Programmation récursive http://programmation-recursive.net/ ;;; Ce code est écrit en Bigloo http://www-sop.inria.fr/mimosa/fp/Bigloo/ ;;; il procure quelques fonctions et macros correspondant au dialecte ;;; Scheme enseigné dans le MOOC Programmation récursive et permettant ;;; de travailler les exercices en Bigloo plutôt que dans son navigateur ;;; avec MrScheme (dû à Frédéric Peschanski frederic.peschanski@lip6.fr) ;;; L'apport principal de ce fichier est de procurer une implantation ;;; de la forme (verifier ...) qui permet d'écrire des tests et une ;;; implantation des barrières d'abstraction des arbres binaires ou ;;; généraux. ;;; Ce fichier doit être évalué avant de commencer à travailler les ;;; exercices. Lorsque votre solution à un exercice est au point, vous ;;; pourrez alors la copier dans MrScheme afin d'obtenir un rapport de ;;; correction. ;;; Pour utiliser ce fichier, indiquez simplement en première ligne ;;; (load "./li101.bgl") ;;; en adaptant le chemin vers ce fichier si d'aventure il n'est ;;; pas dans le répertoire courant, celui où vous avez lancé Bigloo. ;;; Une implantation simpliste de la forme verifier. ;;; Elle n'indique pas le test defaillant, etc. (define-syntax verifier (syntax-rules (=> -> ERREUR) ((verifier f) "OK") ((verifier f exp => ERREUR rest ...) (begin (display (list 'checking 'exp)) (newline) (if (with-handler handler2string (begin exp #f) ) (verifier f rest ...) "L'erreur attendue n'est pas survenue!?" ) ) ) ((verifier f exp -> ERREUR rest ...) (begin (display (list 'checking 'exp)) (newline) (if (with-handler handler2string (begin exp #f) ) (verifier f rest ...) "L'erreur attendue n'est pas survenue!?" ) ) ) ((verifier f exp => value rest ...) (begin (display (list 'checking 'exp)) (newline) (let ((v (with-handler handler2string (list exp) ))) (if (string? v) (li101-error "Erreur" v) (if (equal? (car v) 'value) (verifier f rest ...) (li101-error "Pas la valeur attendue" (car v)) ) ) ) ) ) ((verifier f exp -> value rest ...) (begin (display (list 'checking 'exp)) (newline) (let ((v (with-handler handler2string (list exp) ))) (if (string? v) (li101-error "Erreur" v) (if (equal? (car v) 'value) (verifier f rest ...) (li101-error "Pas la valeur attendue" (car v)) ) ) ) ) ) ) ) ;;; handler2string: Exception -> String (define (handler2string e) (with-access::&error e (msg obj) (let ((msg (string-append (->string msg) " " (->string obj)))) ;(display msg); DEBUG msg ) ) ) ;;; Adaptation a Bigloo (define (li101-error code . msgs) (let ((s (apply ->string* msgs))) ;(display `("RAISING: " , code ,s));DEBUG (error 'li101-error (->string* "ERREUR " code) s) ) ) ;;; Quelques utilitaires: (define (->string* . o*) (with-output-to-string (lambda () (for-each (lambda (o) (display " ") (display o) ) o* )) ) ) (define (->string o) (define (convert c) (cond ((char=? c #\<) (string->list "<")) ((char=? c #\>) (string->list ">")) (else (list c)) ) ) (let* ((msg (with-output-to-string (lambda () (display o) )))) (list->string (append-map convert (string->list msg) ) ) ) ) (define (andmap pred L) (if (pair? L) (and (pred (car L)) (andmap pred (cdr L)) ) #t ) ) ;;; Une implantation des arbres (define (ab-vide) (vector '**EmptyBinTree**) ) (define (ab? ab) (and (vector? ab) (let ((vl (vector-length ab))) (or (= 1 vl) (= 4 vl)) ) (memq (vector-ref ab 0) '(**BinTree** **EmptyBinTree**) ) ) ) (define (ab-noeud tag left right) (if (ab? left) (if (ab? right) (vector '**BinTree** tag left right) (li101-error 1150 'ab-noeud "Fils droit non arbre binaire!") ) (li101-error 1151 'ab-noeud "Fils gauche non arbre binaire!") ) ) (define (ab-noeud? ab) (if (ab? ab) (= 4 (vector-length ab)) (li101-error 1152 'ab-noeud? "Pas un arbre binaire" ab) ) ) (define (ab-etiquette ab) (and (ab-noeud? ab) (vector-ref ab 1) ) ) (define (ab-gauche ab) (and (ab-noeud? ab) (vector-ref ab 2) ) ) (define (ab-droit ab) (and (ab-noeud? ab) (vector-ref ab 3) ) ) (define (ab-affiche ab) (if (ab? ab) (begin (pp ab) #t) ; pour ne pas rendre #unspecified (li101-error 1153 'ab-affiche "Pas un arbre binaire" ab) ) ) ;;; bibliotheque arbres generaux (define (ag-noeud tag forest) (if (andmap ag? forest) (vector '**GeneralTree** tag forest) (li101-error 1154 'ag-noeud "Un terme de la forêt n'est pas un arbre général") ) ) (define (ag? ag) (and (vector? ag) (= 3 (vector-length ag)) (eq? (vector-ref ag 0) '**GeneralTree**) ) ) (define (ag-etiquette ag) (if (ag? ag) (vector-ref ag 1) (li101-error 1155 'ag-etiquette "Pas un arbre général" ag) ) ) (define (ag-foret ag) (if (ag? ag) (vector-ref ag 2) (li101-error 1156 'ag-etiquette "Pas un arbre général" ag) ) ) (define (ag-affiche ag) (if (ag? ag) (begin (pp ag) #t) ; pour ne pas rendre #unspecified (li101-error 1157 'ag-affiche "Pas un arbre général" ag) ) ) ;;; some other utilities ;(define (filter p L) ; (if (pair? L) ; (if (p (car L)) ; (cons (car L) (filter p (cdr L))) ; (filter p (cdr L)) ) ; L ) ) ;;; end of li101.bgl