Переделать под Common Lisp

;*******************************************
;;;; Поиск в ширину для задачи о кувшинах. *
;*******************************************************
; Используя ёмкости B S, вернуть R. Например 5 3 -> 4. *
;*******************************************************
;;; Действия. Наполнить/опорожнить/перелить.
(defun PourBig (big state)
  (cons (+ big (car state)) (cdr state)))
(defun PourSmall (small state)
  (cons (car state) (+ small (cdr state))))
 
(defun EmptyBig (state)
  (cons 0 (cdr state)))
(defun EmptySmall (state)
  (cons (car state) 0))
 
(defun Big->Small (small state)
  (let* ((b (car state))
         (s (cdr state))
         (balance (- small s)))
    (if (<= balance b)
        (cons (- b balance) (+ s balance))
        (cons 0 (+ b s)))))
(defun Small->Big (big state)
  (let* ((b (car state))
         (s (cdr state))
         (balance (- big b)))
    (if (<= balance s)
        (cons (+ b balance) (- s balance))
        (cons (+ b s) 0))))
 
;;; Порождение вариантов переливаний.
(defun variation (big small state &optional (order nil))
  (let ((b (car state))
        (s (cdr state))
        (result nil)    ; результат новые состояния
        (bs (Big->Small small state)) ; для сравнения состояний после B->S
        (sb (Small->Big big state))   ; для сравнения состояний после S->B
       )
    ;; проверки для переливаний
    (if (= b 0    ) (push (PourBig big state) result))
    (if (= s 0    ) (push (PourSmall small state) result))
    (if (= b big  ) (push (EmptyBig state) result))
    (if (= s small) (push (EmptySmall state) result))
    (unless (equal bs state) (push bs result)) ; если переливание B->S изменило состояние
    (unless (equal sb state) (push sb result)) ; если переливание S->B изменило состояние
  ;; удалить переливание обратно
  (setq result (set-difference result (list order) :test 'equal))
  ;; удалить заполнение обоих ёмкостей
  (set-difference result (list (cons big small)) :test 'equal)
))
 
;;; Очередь для путей.
(defun make-queue () (cons nil nil))
 
(defun enqueue (obj q)
  (if (null (car q))
      (setf (cdr q) (setf (car q) (list obj)))
      (setf (cddr q) (list obj)
            (cdr q) (cddr q)))
  (car q))
 
(defun dequeue (q) (pop (car q)))
 
;;; Поиск.
(defun Bfs (cap1 cap2 start end)
  (let ((queue (make-queue)))
    (enqueue (list start) queue)  
    (loop
      (let* ((path (dequeue queue)) ; путь
             (order (cadr path))    ; предыдущее состояние
             (node (car path))      ; текущий узел
             (b (car node))         ; сосотояние 1-й ёмкости
             (s (cdr node))         ; сосотояние 2-й ёмкости
            )
        ;; условие выхода
        (cond
          ;; если состояние повторилось, решения нет
          ((member node (cdr path) :test #'equal)
           (return (error "Задача не может быть решена.")))
          ;; если цель найдена вернуть путь
          ((or (eq end b) (eq end s))
           (return (nreverse path))))
      ;; добавление новых цепочек путей в хвост очереди.
      (mapcar #'(lambda (n)
                  (enqueue (cons n path) queue))
              (variation cap1 cap2 node order))))))
 
;;; Печать результата.
(defun printAction (cap1 cap2 goal act)
  (format t "Начальное состояние:~8d~4d~%" (caar act) (cdar act))
  (do ((act act (cdr act)))
      ((null (cdr act)) (format t "~A~%" goal))
    (let* ((a1 (car act))  ; предидущее состояние
           (b1 (car a1))   ; к-во 1-й ёмкости
           (b2 (cdr a1))   ; к-во 2-й ёмкости
           (a2 (cadr act)) ; следующее состояние
           (s1 (car a2))   ; к-во 1-й ёмкости
           (s2 (cdr a2))   ; к-во 2-й ёмкости
          )
      (cond
        ((and (> b1 s1) (< b2 s2))
         (format t "Перелить из 1-го во 2-й:~4d~4d~%" s1 s2))
        ((and (< b1 s1) (> b2 s2))
         (format t "Перелить из 2-го в 1-й:~5d~4d~%" s1 s2))
        ((= s1 cap1) (format t "Налить в 1-й:~15d~4d~%" s1 s2))
        ((= s2 cap2) (format t "Налить во 2-й:~14d~4d~%" s1 s2))
        ((= s1 0)    (format t "Вылить из 1-го:~13d~4d~%" s1 s2))
        ((= s2 0)    (format t "Вылить из 2-го:~13d~4d~%" s1 s2))
      ))))
 
;;; Решение.
(defun Main (jugs goal)
  (let* ((capacity1 (car  jugs)) ; 1-я ёмкость
         (capacity2 (cadr jugs)) ; 2-я ёмкость
         (order (cons 0 0))      ; порядок со стартового состояния
        )
    (let ((solution (Bfs capacity1 capacity2 order goal)))
      (printAction capacity1 capacity2 goal solution)
      (format t "Количество операций:  ~A" (length solution))
      (values))))
 
> (Main '(5 3) 4)

 
(defun Fills (row k &optional (stay (first row))
 
                              (step (round (sqrt 
(length row))))
                              (gets (gethash stay *ht*))
                              (stack (list stay)))
  (cond
    ((> (caar stack) (round (sqrt (length *b*))))
 "This task has no solution.")
    ((= k (length stack)) stack)
    ((< (length stack) (1- (car stay)))
     (Fills row k (list (caar stack) (1+ (cadar stack)
)) step
              (let (g) (mapc (lambda (x) (setq g (union
 g (gethash x *ht*))))
                             (cdr stack)) g) (cdr stack)
))
    ((> (cadr stay) step)
     (Fills (nthcdr step row) k (list (1+ (car stay)) 1)
 step gets stack))
    ((member stay gets :test #'equal)
     (Fills (cdr row) k (list (car stay) (1+ (cadr stay)
)) step gets stack))
    (t (Fills (cdr row) k stay step (union gets (gethash
 stay *ht*)) (cons stay stack)))))
 
(defun Form (ls n &optional acc (m n))
  (cond
    ((null ls) (if (plusp m) (nreverse acc) ()))
    ((= m 1) (cons (nreverse (cons (car ls) acc)) (Form 
(cdr ls) n () n)))
    (t (Form (cdr ls) n (cons (car ls) acc) (1- m)))))
 
(defun Prin-Board (board cells)
  (let ((num (round (sqrt (length board)))) acc)
    (format t "~&~{~{~A ~}~%~%~}" 
      (Form (mapcar (lambda (x)
         (if (member x cells :test 'equal) 'Queen x))
 board) num))))
 
(defparameter *b* (make-board 8))
 
(defparameter *ht* (make-hash-table :test #'equal))
 
(Fill-Table *b*)