; .EnTete "Le-Lisp (c) version 15.2" " " "Les Tours de Hanoi"
; .EnPied " " "%" " "
; .Chapitre 9 "Les Tours de Hanoi"
;
; .Centre "*****************************************************************"
; .Centre " Ce fichier est en lecture seule hors du projet ALE de l'INRIA.  "
; .Centre " Il est maintenu par ILOG SA, 2 Avenue Gallie'ni, 94250 Gentilly "
; .Centre " (c) Le-Lisp est une marque de'pose'e de l'INRIA                 "
; .Centre "*****************************************************************"

; .Centre "$Header: hanoi.ll,v 4.1 88/01/13 12:20:02 kuczynsk Rel $"

(unless (>= (version) 15.2)
        (error 'load  'erricf 'hanoi))

; Tous les symboles pre'ce'de's de : seront cre'e's
; dans le package HANOI.

(defvar #:sys-package:colon 'hanoi)

; Ce programme, simulant une tour de Hanoi, permet de tester
; les fonctions principales du terminal virtuel.

(de :nieme-disque (n)
    ; retourne le <n>ie`me disque
    (nth n
      '(#"          |          "
        #"         *|*         "
        #"        **|**        "
        #"       ***|***       "
        #"      ****|****      "
        #"     *****|*****     "
        #"    ******|******    "
        #"   *******|*******   "
        #"  ********|********  "
        #" *********|********* "
        #"====================="
        #"                     "))))

(de hanoi (n)
    (unless n
            (print "Combien de disque ")
            (setq n (read)))
    (unless (and (numberp n) (> n 0) (< n 10))
            (error 'hanoi 'erroob n))
    (let ((a1 '(10))        ; contenu de la 1ere aiguille
          (a2 '(10))        ; contenu de la 2eme aiguille
          (a3 '(10))        ; contenu de la 3eme aiguille
          (nmv 0))          ; nombre de mouvements
         (typrologue)
         (tycls)
         (putprop 'a1 2 'pos)
         (putprop 'a2 27 'pos)
         (putprop 'a3 52 'pos)
         (let ((n n)) (repeat n (newl a1 n) (decr n)))
         (tycot 28 1 '#"Les Tours de Hanoi")
         (:affiche 'a1)
         (:affiche 'a2)
         (:affiche 'a3)
         (:moteur n 'a1 'a3 'a2)
         (tycursor 0 (1- (tyymax)))
         (tyepilogue)
         (tyflush)
         'hanoi)))

(de :moteur (n dep arr int)
    (when (> n 0)
          (:moteur (1- n) dep int arr)
          (:bouge n dep arr)
          (:moteur (1- n) int arr dep))))

(de :bouge (n dep arr)
    (tycursor 18 5)
    (tyo (explode (incr nmv)) " : je bouge le disque " (explode n)
         " de " (explode dep) " vers " (explode arr))
    (:monte n (getprop dep 'pos) (- 10 (length (eval dep))))
    (:avance n (getprop dep 'pos) (getprop arr 'pos))
    (:descend n (getprop arr 'pos) (- 10 (length (eval arr))))
    (tyflush)
    (set dep (cdr (eval dep)))
    (set arr (cons n (eval arr))))))

(de :affiche (a)
    ; :affiche toute l'aiguille "a"
    (let ((y 21)
          (l (reverse (eval a)))
          (x (getprop a 'pos)))
         (repeat 10
                 (tyco x (decr y) (:nieme-disque (or (nextl l) 0))))
         (tyco (+ x 10) 21 (explode a))))

(de :monte (n x nb)
    ; disque "n" en "x" "nb" fois
    (let ((y (+ nb 10)))
         (repeat (1+ nb)
                 (tyco x y (:nieme-disque n))
                 (tyco x (1+ y) (:nieme-disque 0))
                 (decr y))))))))))

(de :descend (n x nb)
    ; disque "n" en "x" "nb" fois
    (let ((y 11))
         (tyco x 10 (:nieme-disque 11))
         (repeat (1- nb)
                 (tyco x y (:nieme-disque 0))
                 (tyco x (incr y) (:nieme-disque n))))))

(de :avance (n x1 x2)
    ; avance horizontalement le disque "n" de "x1" vers "x2"
    (if (> x1 x2)
        (repeat (- x1 x2) (tyco (decr x1) 10 (:nieme-disque n))))
        (repeat (- x2 x1) (tyco (incr x1) 10 (:nieme-disque n))))))))

(de hanoiend ()
    (mapc 'remob (oblist '#.#:sys-package:colon))
    (libautoload hanoi hanoi)
    'hanoiend)