;;; TOURS DE HANOI
;;; Fichier myhanoi.drs / 28 mars 1999
;;; (DrScheme, version 101)

(define (programme-hanoi n)
  (affiche-tiges)
  (affiche-tour n)
  (hanoi n 't1 't2 't3))

(define (hanoi n x y z)
  (cond ((= n 0) 'fin)
        (else (hanoi (- n 1) x z y)
              (deplace n x y)
              (hanoi (- n 1) z y x))))



;;; Le probleme subtil des tours de Hanoi (trouver l'ordre de deplacement des disques) 
;;; est entierement  resolu par les deux premieres fonctions: 
;;; - (programme-hanoi n) est la fonction principale qui lance le programme
;;; - (hanoi n x y z) est une mysterieuse fonction  "recursive" (voir cours sur la recursion) 
;;; Le reste n'est que du detail graphique





;;; ==================================================================
;;; FONCTIONS GRAPHIQUES (pour l'animation des disques)
;;; Tracage des 3 tiges, et de la tour sur la tige de gauche:

(require-library "graphics.ss" "graphics")
(open-graphics)
(define w (open-viewport "" 710 350))
(define y-base 300) (define y-haut 80)
(define x-tige1 125) (define x-tige2 355) (define x-tige3 585)

;;; ai = position courante du disque superieur du socle ti
;;; On utilise l'affectation set! pour la mise a jour des ai
(define a1 (- y-base 20)) (define a2 (- y-base 20)) (define a3 (- y-base 20))


(define (affiche-tiges)
  ((clear-viewport w))
  ((draw-string w) (make-posn 290 20) "T O U R S   D E   H A N O I")
  (set! a1 (- y-base 20)) (set! a2 (- y-base 20)) (set! a3 (- y-base 20)) 
  (tige x-tige1) (tige x-tige2) (tige x-tige3))

(define (tige x-milieu)
  (rect (- x-milieu 2) (- y-base 198) 4 200 "orange")
  (rect (- x-milieu 105) (+ y-base 2) 210 4 "orange"))

(define (rect x y largeur hauteur couleur)
  ((draw-solid-rectangle w) (make-posn x y) largeur hauteur couleur))

(define (affiche-tour n) (actualise 't1 (- (* n 20))) (tour n))
		     
(define (tour n)
  (cond ((= n 0) 'ok)
	(else (trace-disque n 20 (+ a1 (* n 20)))
	      (tour (- n 1)))))

(define (trace-disque n x y) (disque n x y "blue"))
(define (efface-disque n x y) (disque n x y "white"))

(define (disque n x y couleur)
  (let* ((rayon-disque (* n 10))
	 (distance-bord (- 100 rayon-disque)))
    (rect x y distance-bord 20 "white")
    (rect (+ x distance-bord) y rayon-disque 20 couleur)
    (rect (+ x distance-bord rayon-disque 10) y rayon-disque 20 couleur)
    (rect (+ x distance-bord (* 2 rayon-disque) 10) y distance-bord 20 "white")))

;;; Deplacement d'un disque:

(define (deplace n ta tb)
  (monte n (+ (pos-y ta) 20) y-haut (pos-x ta))
  (avance n (pos-x ta) (pos-x tb))
  (descend n y-haut (pos-y tb) (pos-x tb))
  (actualise ta 20)
  (actualise tb -20))

(define (actualise tige inc)
  (case tige
    ((t1) (set! a1 (+ a1 inc)))
    ((t2) (set! a2 (+ a2 inc)))
    ((t3) (set! a3 (+ a3 inc)))))

(define (pos-y tige)
  (case tige ((t1) a1) ((t2) a2) ((t3) a3)))

(define (pos-x tige)
  (case tige ((t1) (- x-tige1 105)) ((t2) (- x-tige2 105)) ((t3) (- x-tige3 105))))

(define d 1)

(define (monte n y1 y2 x)
  (cond ((<= y1 y2) ())
        (else (bouge-disque n x y1 0 (- d))
              (monte n (- y1 d) y2 x))))

(define (avance n x1 x2) (if (< x1 x2) (droite n x1 x2) (gauche n x1 x2)))

(define (droite n x1 x2)
  (cond ((>= x1 x2) ())
        (else (bouge-disque n x1 y-haut d 0)
              (droite n (+ x1 d) x2))))

(define (gauche n x1 x2)
  (cond ((<= x1 x2) ())
        (else (bouge-disque n x1 y-haut (- d) 0)
              (gauche n (- x1 d) x2))))

(define (descend n y1 y2 x)
  (cond ((>= y1 y2) ())
        (else (bouge-disque n x y1 0 d)
              (descend n (+ y1 d) y2 x))))

(define (bouge-disque n x y incrx incry)
  (efface-disque n x y)
  (trace-disque n (+ x incrx) (+ y incry)))