Ханойские башни Common Lisp

Формулировка задачи:

Есть 3 стержня, на один из которых нанизаны 8 дисков, причем диски отличаются размером и лежат меньшее на большем. Задача состоит в том,чтобы перенести пирамиду из n-дисков за наименьшее число ходов. За один раз можно перенести только 1 диск, причем нельзя класть больший на меньший. Все это реализуется с помощью списков и поиска в ширину. На Common Lisp Кто-нибудь знает как это сделать? я нашла такое задание на scheme, но в common lisp переделать не получается на scheme

;;; Создание колышка
(define (peg token count)
 ;; Список p - это "внутренняя структура" колышка
 (let ((p (reverse (generaten count))))
 
 (define (display-peg)
(display token)
 (display ": ")
 (display p)
 (newline))
 
 (define (push-ring! ring)
 (set! p (cons ring p))
 (display-peg))
 
 (define (pop-ring!)
 (let ((ring (car p)))
 (set! p (cdr p))
 (display-peg)
 ring))
 
 (define (peg-token)
 token)
 
 (define (height)
 (length p))
 (lambda (mes)
 (cond ((eq? mes 'display)
(display-peg))
 ((eq? mes 'push-ring)
push-ring!)
 ((eq? mes 'pop-ring)
(pop-ring!))
 ((eq? mes 'token)
(peg-token))
 ((eq? mes 'height)
(height))
(else
error "peg -- неизвестное сообщение" mes)))))
 
;;; Печать колышка
(define (display-peg peg)
 (peg 'display))
 
;;; Поместить кольцо на колышек
(define (push-ring! peg ring)
 ((peg 'push-ring) ring))
 
;;; Изъять кольцо с колышка
(define (pop-ring! peg)
 (peg 'pop-ring))
 
;;; Метка данного колышка
(define (peg-token peg)
 (peg 'token))
 
;;; Высота (число колец) колышка
;;; (для решения задачи так и не понадобилась)
(define (peg-height peg)
 (peg 'height))
 
;;; Вспомогательная функция
;;; создает список из убывающих чисел от number до 1 (включительно)
(define (generaten number)
 (if (= 0 number)
 '()
 (cons number (generaten (- number 1)))))
;;; Функция переноса кольца с колышка peg-from на колышек peg-to
(define (move peg-from peg-to peg)
 (display "Перенос кольца с колышка '")
 (display (peg-token peg-from))
 (display "' на колышек '")
 (display (peg-token peg-to))
 (display "':")
 (newline)
 (push-ring! peg-to (pop-ring! peg-from))
* (display-peg peg))
 
(define (hanoi-tower height)
 (let ((a (peg 'a height))
(b (peg 'b 0))
 (c (peg 'c 0)))
 (display "Состояние колышков до переноса:")
 (newline)
 (display-peg a)
 (display-peg b)
 (display-peg c)
 
 ;;; Вся полезная работа происходит тут
 (let hanoi ((peg-a a)
 (peg-b b)
 (peg-c c)
 (n height))
 (cond ((not (= n 0))
(hanoi peg-a peg-c peg-b (- n 1))
(move peg-a peg-c peg-b)
(hanoi peg-b peg-a peg-c (- n 1))))))
'конец)

вывод
> (hanoi-tower 4)
Состояние колышков до переноса:
a: (1 2 3 4)
b: ()
c: ()
Перенос кольца с колышка 'a' на колышек 'b':
a: (2 3 4)
b: (1)
c: ()
Перенос кольца с колышка 'a' на колышек 'c':
a: (3 4)
c: (2)
b: (1)
Перенос кольца с колышка 'b' на колышек 'c':
b: ()
c: (1 2)
a: (3 4)
Перенос кольца с колышка 'a' на колышек 'b':
a: (4)
b: (3)
c: (1 2)
Перенос кольца с колышка 'c' на колышек 'a':
c: (2)
a: (1 4)
b: (3)
Перенос кольца с колышка 'c' на колышек 'b':
c: ()
b: (2 3)
a: (1 4)
Перенос кольца с колышка 'a' на колышек 'b':
a: (4)
b: (1 2 3)
c: ()
Перенос кольца с колышка 'a' на колышек 'c':
a: ()
c: (4)
b: (1 2 3)
Перенос кольца с колышка 'b' на колышек 'c':
b: (2 3)
c: (1 4)
a: ()
Перенос кольца с колышка 'b' на колышек 'a':
b: (3)
a: (2)
c: (1 4)
Перенос кольца с колышка 'c' на колышек 'a':
c: (4)
a: (1 2)
b: (3)
Перенос кольца с колышка 'b' на колышек 'c':
b: ()
c: (3 4)
a: (1 2)
Перенос кольца с колышка 'a' на колышек 'b':
a: (2)
b: (1)
c: (3 4)
Перенос кольца с колышка 'a' на колышек 'c':
a: ()
c: (2 3 4)
b: (1)
Перенос кольца с колышка 'b' на колышек 'c':
b: ()
c: (1 2 3 4)
a: ()
конец

Решение задачи: «Ханойские башни Common Lisp»

textual
                            Листинг программы 
                        

                            (defn hanoi (n)
    (print "ЗАДАЧА - ханойские башни, n = " n ":" \n)
 
    (defn try-move (f t)
        cond (null? f) false
             (or (null? t) (< (car f) (car t))) (cons (cdr f) (cons (car f) t) nil)
             false)
 
    (defn steps (chain)
        (match (car chain) '(a b c))
        (def vars (cons
            (cond (match (try-move a b) '(f t)) (cons f t c nil) nil)
            (cond (match (try-move a c) '(f t)) (cons f b t nil) nil)
            (cond (match (try-move b a) '(f t)) (cons t f c nil) nil)
            (cond (match (try-move b c) '(f t)) (cons a f t nil) nil)
            (cond (match (try-move c a) '(f t)) (cons t b f nil) nil)
            (cond (match (try-move c b) '(f t)) (cons a t f nil) nil)
            nil))
        (def nexts (filter (lambda (x) not (null? x)) vars))
        (map (lambda (n) cons n chain) (filter (lambda (v) not (elem v chain)) nexts)))
 
    (defn solved? (state)
        (match (car state) '(a b c))
        (and (null? a) (null? b)))
 
    (def start-state (cons (cons (list-from-to 1 n) nil nil nil) nil))
 
    (defn show-line (l) foldl (lambda (x a) print x "  ") 0 l)
    (defn show-res (l i)
        (print \n "Вариант " i ":" \n)
        (defn go (l) cond (null? l) (+ i 1) ((show-line (car l)) (print \n) (go (cdr l)) ))
        (go l))
 
    (print "Поиск в глубину:")
    (show-res (reverse (solve-depth steps solved? start-state)) 1)
 
    (print \n "Поиск в ширину:" \n)
    (foldl (lambda (l a) show-res (reverse l) a) 1 (solve-wide steps solved? start-state)) )
 
(hanoi 4)
                        