; <==========================================================================>
; <================ PROGRAMA DE BUSQUEDA GENERAL ============================>
; <================ Fecha: Noviembre de 1997 ==========================>
; <==========================================================================>
; <==========================================================================>
; <================ Arreglos de entrada y salida ============================>
; <==========================================================================>
(setq in (make-array '(3 3)))
(setq out (make-array '(3 3)))
; <==========================================================================>
; <============= matrices de entrada ========================================>
; <==========================================================================>
;(setf (aref in 0 0) 2) (setf (aref in 0 1) 4) (setf (aref in 0 2) 5)
;(setf (aref in 1 0) 1) (setf (aref in 1 1) 7) (setf (aref in 1 2) 8)
;(setf (aref in 2 0) 6) (setf (aref in 2 1) 3) (setf (aref in 2 2) 0)
(setf (aref in 0 0) 1) (setf (aref in 0 1) 2) (setf (aref in 0 2) 3)
(setf (aref in 1 0) 4) (setf (aref in 1 1) 5) (setf (aref in 1 2) 6)
(setf (aref in 2 0) 0) (setf (aref in 2 1) 7) (setf (aref in 2 2) 8)
; <==========================================================================>
; <==========================================================================>
(setf (aref out 0 0) 1) (setf (aref out 0 1) 2) (setf (aref out 0 2) 3)
(setf (aref out 1 0) 4) (setf (aref out 1 1) 5) (setf (aref out 1 2) 6)
(setf (aref out 2 0) 7) (setf (aref out 2 1) 8) (setf (aref out 2 2) 0)
; <================ verifica si 2 arreglos son iguales ======================>
; <================ entran 2 arreglos =======================================>
; <================ de igualdad o no ==================================>
(defun match (arr_in arr_out)
(dolist (row '(0 1 2))
(dolist (col '(0 1 2))
(if (not (equal (aref arr_in row col)(aref arr_out row col))) (return-from match nil))
)
)
(return-from match t)
)
; <========== rutina principal ==============================================>
; <========== llamada: (JUEGO) ==============================================>
; <========== regresa: el arreglo ordenado ==================================>
(defun juego()
(setf lista (list in))
(setf fin 0)
(loop
(if (match (nth (- (mp lista) 1) lista) out) (print 'ya_se_ordeno))
(if (match (nth (- (mp lista) 1) lista) out)
(return-from juego (nth (- (mp lista) 1) lista)))
(setf lista (filtra (expande lista (mp lista))))
(print lista)
(setf fin (+ 1 fin))
)
)
; <========== expande el nodo ===============================================>
; <========== regresa la lista expandida sin duplicados =====================>
(defun expande (lista mejor)
(setf parte_ini nil)
(setf parte_nodo (nth (- mejor 1) lista))
(do ((n (- mejor 1) (- n 1))) ((= n 0))
(setf parte_ini (append parte_ini (list (car lista))))
(setf lista (cdr lista))
)
(return-from expande (append (mueve parte_nodo) parte_ini (cdr lista)))
)
; <========== realiza un append =============================================>
; <========== recibe 1 lista ================================================>
; <========== regresa una lista sin duplicados ==============================>
(defun filtra (lista)
(setf temp nil)
(dolist (nodo lista temp)
(if (not (member nodo temp :test #'equal))
(setf temp (append (list nodo) temp)))
)
(return-from filtra temp)
)
; <========== genera lista de nuevos nodos ==================================>
; <========== recibe: un arreglo ============================================>
(defun mueve (nodo)
(setf new_lista nil)
(setf blanco (busca_blanco nodo))
; <========= R E N G L O N E S ======================>
(if (= 0 (car blanco))
(setf new_lista (adjoin (swapx nodo 1 blanco) new_lista :test #'equal)))
(if (= 1 (car blanco))
(setf new_lista (adjoin (swapx nodo 0 blanco) new_lista :test #'equal)))
(if (= 1 (car blanco))
(setf new_lista (adjoin (swapx nodo 2 blanco) new_lista :test #'equal)))
(if (= 2 (car blanco))
(setf new_lista (adjoin (swapx nodo 1 blanco) new_lista :test #'equal)))
; <========= C O L U M N A S ======================>
(if (= 0 (car (cdr blanco)))
(setf new_lista (adjoin (swapy nodo 1 blanco) new_lista :test #'equal)))
(if (= 1 (car (cdr blanco)))
(setf new_lista (adjoin (swapy nodo 0 blanco) new_lista :test #'equal)))
(if (= 1 (car (cdr blanco)))
(setf new_lista (adjoin (swapy nodo 2 blanco) new_lista :test #'equal)))
(if (= 2 (car (cdr blanco)))
(setf new_lista (adjoin (swapy nodo 1 blanco) new_lista :test #'equal)))
(return-from mueve new_lista)
)
; <============== intercambia por renglon los cuadritos =====================>
; <============== regresa: un arreglo con los datos intercambiados ==========>
(defun swapx (nodo x blanco)
(setf copia (make-array '(3 3)))
(dolist (row '(0 1 2))
(dolist (col '(0 1 2))
(setf (aref copia row col) (aref nodo row col))
)
)
(rotatef (aref copia x (car (cdr blanco))) (aref copia (car blanco) (car (cdr blanco))))
(return-from swapx copia)
)
; <============== intercambia por columna los cuadritos =====================>
; <============== regresa: un arreglo con los datos intercambiados ==========>
(defun swapy (nodo y blanco)
(setf copia (make-array '(3 3)))
(dolist (row '(0 1 2))
(dolist (col '(0 1 2))
(setf (aref copia row col) (aref nodo row col))
)
)
(rotatef (aref copia (car blanco) y) (aref copia (car blanco) (car (cdr blanco))))
(return-from swapy copia)
)
; <============== recibe un arreglo =========================================>
(defun busca_blanco (nodo)
(dolist (row '(0 1 2))
(dolist (col '(0 1 2))
(if (eq (aref nodo row col) 0) (return-from busca_blanco (list row col)))
)
)
)
; <========== rutina del mejor primero. =====================================>
; <========== recibe una lista ==============================================>
(defun mp (lista)
(setf x 0)
(setf nnodo 0)
(setf respuesta 1)
(dolist (nodo lista respuesta)
(setf nnodo (+ nnodo 1))
(setf x1 (cuenta nodo))
(if (> x1 x) (setf respuesta nnodo))
(if (> x1 x) (setf x x1))
)
(return-from mp respuesta)
)
; <============ cuenta los elementos correctamente posicionados =============>
; <============ recibe un arreglo ===========================================>
(defun cuenta (arreglo)
(setf ok 0)
(dolist (row '(0 1 2))
(dolist (col '(0 1 2))
(if (equal (aref arreglo row col)(aref out row col)) (setf ok (+ ok 1)))
)
)
(return-from cuenta ok)
)
; <============ muestra los elementos de una lista ==========================>
; <============ recibe una lista ============================================>
; <============ regresa FIN =================================================>
(defun show (lista)
(dolist (nodo lista 'fin)(print nodo)))
; <========================= F I N ==========================================>