BUSQUEDA.LSP

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 	PROGRAMA QUE IMPLEMENTA UNA BUSQUEDA GENERAL
;;
;;	Autor: Ing. J. Rafael R. Ochoa
;;
;;	Materia: SISTEMAS EXPERTOS
;;
;;	MAESTRIA EN SISTEMAS COMPUTACIONALES
;;
;;
;;	Noviembre 1997
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun carga ()
	(load "c:\\rafa\\busqueda.lsp"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  		   el comienzo del juego de los
;;   		   8 cuadritos.
;;     	Regresa: Las fichas que se encuentran 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun juego ()
  	(print "Ingrese los elementos que componen el tablero")
	(print "Se trata de 8 fichas (1 - 8) y un espacio en")
	(print "blanco (B) Cada uno de los tres renglones consta")
	(print "de tres elementos separados por un ENTER")
	(setq inicio (forma_arreglo))
	(print "Ahora dame las posiciones finales de las fichas")
	(setq final (forma_arreglo))
	(print "Las fichas que se encuentran en posicion equivocada son: ")
	(checa_posicion inicio final)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;	Funciones: FORMA_ARREGLO y PREGUNTA
;;   	           ya sea el arreglo inicial
;;    		   como el final
;;     	Regresa: Un nuevo ARREGLO DE 3x3
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun forma_arreglo ()
	(setq x 0)
	(setq arreglo (make-array '(3 3)))
  	(loop
		(if (eq x 3) (return arreglo))
		(format t "~%Renglon ~a: " (+ x 1))
	 	(setq y 0)
			(loop
				(if (eq y 3) (return))
				(setf (aref arreglo x y) (pregunta))
				(setq y (1+ y))) 
		(setq x (1+ x))))

(defun pregunta ()
	(read))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;	Recibe: Un ARREGLO inicial => "a_i" y un
;;		ARREGLO final (goal) => "a_f"
;; 	Proposito: Determinar la cantidad de 
;;     	Regresa: Un NUMERO
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun checa_posicion (a_i a_f)
	(setq x 0)
	(setq mal 0)
	(loop
		(if (eq x 3) (return mal))
		(setq y 0)
		(loop
			(if (eq y 3) (return))
			(if (not (equal (aref a_i x y) (aref a_f x y))) 
			    (setq mal (1+ mal)))
			(setq y (1+ y)))
		(setq x (1+ x))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;	Recibe: Un arreglo => "arreglo"
;;    		   del "blanco"
;;     	Regresa: Una LISTA DE DOS ELEMENTOS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun busca-blanco (arreglo)
  (dolist (i '(0 1 2))
    (dolist (j '(0 1 2))
      (if (eq (aref arreglo i j) 'b)
	  (return-from busca-blanco (list i j))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;	Recibe: Un arreglo => "arreglo"
;; 	Proposito: Determinar los movimientos 
;;   	           disponibles de acuerdo a la
;;  	Regresa: Una LISTA con los movimientos 
;;    		 permitidos
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun genera-mvtos (arreglo)
  (let ((loc (busca-blanco arreglo)))
    (cond
     ((equal loc '(0 0)) '(l u))
     ((equal loc '(0 1)) '(r l u))
     ((equal loc '(0 2)) '(r u))
     ((equal loc '(1 0)) '(d l u))
     ((equal loc '(1 1)) '(l r u d))
     ((equal loc '(1 2)) '(d r u))
     ((equal loc '(2 0)) '(d l))
     ((equal loc '(2 1)) '(l d r))
     ((equal loc '(2 2)) '(d r)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;		=> "loc-b" y el sentido del 
;; 		movimiento (una LETRA) => "dir"
;;   	Regresa: Una LISTA con la ficha a mover
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun quien-mueve? (loc-b dir)
  (cond
    ((equal dir 'r) (list (first loc-b) (1- (second loc-b))))
    ((equal dir 'l)  (list (first loc-b) (1+ (second loc-b))))
    ((equal dir 'u)  (list (1- (first loc-b)) (second loc-b)))
    ((equal dir 'd)  (list (1+ (first loc-b)) (second loc-b)))))
    
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;	Recibe: Un arreglo => "arreglo" y la 
;; 	Proposito: Ejecuta el swap
;;   	Regresa: Un nuevo ARREGLO con una nueva
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun mueve (arreglo dir)
  (let* ((loc-b (busca-blanco arreglo))
	 (quien (quien-mueve? loc-b dir))
    	(nvo-arreglo (make-array '(3 3)))
	 (renglon 0)
	(columna 0))
	(loop
		(setq columna 0)
	 	(loop
	 		(setf (aref nvo-arreglo renglon columna) 
		       		(aref arreglo renglon columna))
		 	(incf columna)
		 	(when (eq columna 3) (return)))
		 (incf renglon)
		 (when (eq renglon 3) (return)))
	(rotatef (aref nvo-arreglo (first loc-b) (second loc-b))
		 (aref nvo-arreglo (first quien) (second quien)))
	nvo-arreglo))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;	Recibe: Un arreglo => "arreglo"
;;   	Regresa: Una LISTA DE ARREGLOS con todos
;;		 las posibilidades de movimientos
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun expand (arreglo)
  (let* ((movimientos (genera-mvtos arreglo)))
    (mapcar #'(lambda (dir)
		(mueve arreglo dir))
		movimientos)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;busqueda_general (problema estrategia fn)
;;	nodos=estado_inicial(problema)
;;	loop
;; 		if empty(nodos) return fail
;; 		nodo=estrategia(nodos)
;;		if goal(nodo) return nodo
;; 		else nodos=fn(nodos,expand(nodo))
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;BFS (problema)
;; 	return busqueda_general(problema,primero,append)
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;