;---------------------------------------------------------------------------------
; Sistema para simular el mundo de los bloques
;
; __________________________________
; Version: 1 <<< el razonamiento lo pone el usuario >>>
; ----------------------------------
; iniciar la ejecuciOn con: (inicio)
;---------------------------------------------------------------------------------
; Palabras que componen las acciones a ejecutar ...
; PON SOBRE LIBERA
; Ejemplos:
;
; PON bloque SOBRE bloque
; LIBERA bloque
; (bloque = cuadro, triangulo, rectangulo, circulo, mesa)
;---------------------------------------------------------------------------------
;---------------------------------------------------------------------------------
; D I S P L A Y
;---------------------------------------------------------------------------------
(setf Display (make-array '(36 43):initial-element '_)) ; Espacio muestral
; (alto ancho)
;---------------------------------------------------------------------------------
; Mostrar el contenido de la matriz de ceros y unos
;---------------------------------------------------------------------------------
(defun MuestraCuadricula () Display )
;---------------------------------------------------------------------------------
; F U N C I O N D E I N I C I O
;---------------------------------------------------------------------------------
(defun inicio()
(CreaFiguras)
(ColocaFiguras)
(loop
(print (MuestraCuadricula))
(print "Accion a realizar: ") (setq Accion (Lee_Frase))
(if (eql (nth 0 Accion) 'FIN) (return) ) ; "fin"
(Realiza Accion) ; "pon A sobre B"
)
)
;---------------------------------------------------------------------------------
; S E L L E V A A C A B O L A A C C I O N
;---------------------------------------------------------------------------------
; PON ------ SOBRE ------
; LIBERA ------
(defun Realiza (Accion)
(cond
( (eql (nth 0 Accion) 'libera) ; "Libera A"
(Libera (nth 1 Accion))
)
( (eql (nth 3 Accion) 'Mesa) ; "pon A sobre MESA"
(PonEnMesa (nth 1 Accion))
)
; se trata de un "PON A SOBRE B"
; -------------------------------
; Si los 2 bloques estan libres se realiza el movimiento
; ------------------------------------------------------
( (and (eql (eval `(EB ,(nth 1 Accion))) 'nada) (eql (eval `(EB ,(nth 3 Accion))) 'nada) )
(Borra (nth 1 Accion)) ; Caracter de borrado
(ActualizaValores (nth 1 Accion) (nth 3 Accion))
)
( t (print "Movimiento no valido")
)
)
)
(defun PonEnMesa (Bloque)
(cond
; Ya estA el bloque sobre MESA
; ----------------------------
( (eql (eval `(ES ,Bloque)) 'Mesa) (print "Ya esta sobre la mesa ...") )
; El bloque es libre y si hay espacio en la mesa
; ----------------------------------------------
( (and (eql (eval `(EB ,Bloque)) 'nada) (MesaLibre?) )
(setq MesaNew '()) ; para actualizar MESA
(Borra Bloque) ; se borra de donde esta
(mEB (string (ES (eval bloque))) 'nada) ; El soporte ahora EstaBajo NADA -libre-
(setq NoMas 0)
(dolist (Posicion Mesa)
(when (and (eql (nth 2 Posicion) 'Libre) (= NoMas 0))
(setq NoMas 1)
(mXX (String Bloque) (nth 0 Posicion))
(mYY (String Bloque) (nth 1 Posicion))
(mES (String Bloque) 'Mesa) ; Ahora, Bloque EstaSobre MESA
(mVer (String Bloque) '1)
(setq Posicion (list (nth 0 Posicion) (nth 1 Posicion) Bloque)) ; se cambia LIBRE por BLOQUE
)
(setq MesaNew (append MesaNew (list Posicion)))
)
(setq Mesa MesaNew)
(ColocaFiguras)
)
)
)
; Se libera a un bloque no importando donde estE
; ----------------------------------------------
(defun Libera (Bloque)
(when (eql (eval `(EB ,Bloque)) 'Nada) 'ok ) ; caso base
(unless (eql (eval `(EB ,Bloque)) 'Nada) ; Como no es libre
(Libera (eval `(EB ,bloque)))
(PonEnMesa (eval `(EB ,bloque)))
)
)
(defun ActualizaValores (BloqueA BloqueB)
(mVer (String BloqueA) '1) ; Caracter de pintura
(mXX (String BloqueA) (- (eval `(XX ,BloqueB)) 7)) ; Se actualiza A en X
(mYY (String BloqueA) (eval `(YY ,BloqueB))) ; Se actualiza A en Y
(mEB (String BloqueB) BloqueA) ; B EstaBajo A y B EstaSobre lo mismo -bloque o mesa-
(when (eql (eval `(ES ,BloqueA)) 'Mesa) ; Si A EstaSobre MESA
(LiberaMesa BloqueA) ; se libera MESA de A
)
(unless (eql (eval `(ES ,BloqueA)) 'Mesa) ; Si A no EstaSobre MESA
(mEB (String (eval `(ES ,BloqueA))) 'nada)
)
(mES (String BloqueA) BloqueB) ; A EstaSobre B y A EstaBajo lo mismo -nada-
(ColocaFiguras)
)
(defun Borra (Bloque)
(mVer (String Bloque) '_) ; Caracter de borrado
(ColocaFiguras) ; Borra la figura A
)
; Se crea otra lista para Mesa cambiando BLOQUE por LIBRE
; -------------------------------------------------------
(defun LiberaMesa (Bloque)
(setq MesaNew '())
(dolist (Posicion Mesa)
(if (eql (nth 2 Posicion) Bloque)
(setq Posicion (list (nth 0 Posicion) (nth 1 Posicion) 'Libre))
)
(setq MesaNew (append MesaNew (list Posicion)))
)
(setq Mesa MesaNew)
)
; Se revisa si hay espacio en la mesa
; -----------------------------------
(defun MesaLibre? ()
(setq ok nil)
(dolist (Posicion Mesa)
(if (eql (nth 2 Posicion) 'Libre)
(setq ok t)
)
)
ok
)
;---------------------------------------------------------------------------------
; SE CREAN LOS NUEVOS TIPOS DE DATO
;---------------------------------------------------------------------------------
(defstruct Triangulo
(x 29) (y 1)
(Long 6) (ver 1)
(EstaSobre 'mesa) (EstaBajo 'nada)
)
(defstruct Cuadro
(x 29) (y 10)
(Long 6) (ver 1)
(EstaSobre 'mesa) (EstaBajo 'nada)
)
(defstruct Rectangulo
(x 29) (y 19)
(Long 10) (ver 1)
(EstaSobre 'mesa) (EstaBajo 'nada)
)
(defstruct Circulo
(x 29) (y 32)
(Long 6) (ver 1)
(EstaSobre 'mesa) (EstaBajo 'nada)
)
; Valores de mesa: BloqueX o Libre
; ( (x y bloque) (x y bloque) (x y bloque) (x y bloque) )
; -------------------------------------------------------
(setq Mesa '( (29 1 Triangulo) (29 10 Cuadro) (29 19 Rectangulo) (29 32 Circulo) ) )
;---------------------------------------------------------------------------------
; A C C E S O A L O S D A T O S
;---------------------------------------------------------------------------------
(defmethod xx ((bloque Cuadro)) (Cuadro-x Cuadro) )
(defmethod xx ((bloque Circulo)) (Circulo-x Circulo) )
(defmethod xx ((bloque Rectangulo)) (Rectangulo-x Rectangulo) )
(defmethod xx ((bloque Triangulo)) (Triangulo-x Triangulo) )
(defmethod yy ((bloque Cuadro)) (Cuadro-y Cuadro) )
(defmethod yy ((bloque Circulo)) (Circulo-y Circulo) )
(defmethod yy ((bloque Rectangulo)) (Rectangulo-y Rectangulo) )
(defmethod yy ((bloque Triangulo)) (Triangulo-y Triangulo) )
(defmethod Ver ((bloque Cuadro)) (Cuadro-Ver Cuadro) )
(defmethod Ver ((bloque Circulo)) (Circulo-Ver Circulo) )
(defmethod Ver ((bloque Rectangulo)) (Rectangulo-Ver Rectangulo) )
(defmethod Ver ((bloque Triangulo)) (Triangulo-Ver Triangulo) )
(defmethod ES ((bloque Cuadro)) (Cuadro-EstaSobre Cuadro) )
(defmethod ES ((bloque Circulo)) (Circulo-EstaSobre Circulo) )
(defmethod ES ((bloque Rectangulo)) (Rectangulo-EstaSobre Rectangulo) )
(defmethod ES ((bloque Triangulo)) (Triangulo-EstaSobre Triangulo) )
(defmethod EB ((bloque Cuadro)) (Cuadro-EstaBajo Cuadro) )
(defmethod EB ((bloque Circulo)) (Circulo-EstaBajo Circulo) )
(defmethod EB ((bloque Rectangulo)) (Rectangulo-EstaBajo Rectangulo) )
(defmethod EB ((bloque Triangulo)) (Triangulo-EstaBajo Triangulo) )
;---------------------------------------------------------------------------------
; M O D I F I C A C I O N D E L O S D A T O S
;---------------------------------------------------------------------------------
(defun mxx (Bloque X) ; Modifica x
(if (string-equal Bloque "Cuadro") (setf (Cuadro-x Cuadro) X) )
(if (String-equal Bloque "Circulo") (setf (Circulo-x Circulo) X) )
(if (String-equal Bloque "Triangulo") (setf (Triangulo-x Triangulo) X) )
(if (String-equal Bloque "Rectangulo") (setf (Rectangulo-x Rectangulo) X) )
)
(defun myy (Bloque Y) ; Modifica y
(if (string-equal Bloque "Cuadro") (setf (Cuadro-y Cuadro) Y) )
(if (String-equal Bloque "Circulo") (setf (Circulo-y Circulo) Y) )
(if (String-equal Bloque "Triangulo") (setf (Triangulo-y Triangulo) Y) )
(if (String-equal Bloque "Rectangulo") (setf (Rectangulo-y Rectangulo) Y) )
)
(defun mVer (Bloque Ver) ; Modifica Ver
(if (string-equal Bloque "Cuadro") (setf (Cuadro-Ver Cuadro) Ver) )
(if (String-equal Bloque "Circulo") (setf (Circulo-Ver Circulo) Ver) )
(if (String-equal Bloque "Triangulo") (setf (Triangulo-Ver Triangulo) Ver) )
(if (String-equal Bloque "Rectangulo") (setf (Rectangulo-Ver Rectangulo) Ver) )
)
(defun mES (Bloque ES) ; Modifica EstaSobre
(if (string-equal Bloque "Cuadro") (setf (Cuadro-EstaSobre Cuadro) ES) )
(if (String-equal Bloque "Circulo") (setf (Circulo-EstaSobre Circulo) ES) )
(if (String-equal Bloque "Triangulo") (setf (Triangulo-EstaSobre Triangulo) ES) )
(if (String-equal Bloque "Rectangulo") (setf (Rectangulo-EstaSobre Rectangulo) ES) )
)
(defun mEB (Bloque EB) ; Modifica EstaBajo
(if (string-equal Bloque "Cuadro") (setf (Cuadro-EstaBajo Cuadro) EB) )
(if (String-equal Bloque "Circulo") (setf (Circulo-EstaBajo Circulo) EB) )
(if (String-equal Bloque "Triangulo") (setf (Triangulo-EstaBajo Triangulo) EB) )
(if (String-equal Bloque "Rectangulo") (setf (Rectangulo-EstaBajo Rectangulo) EB) )
)
;===================================================================================================
;===================================================================================================
; A R E A D E D I B U J O
;===================================================================================================
;===================================================================================================
;---------------------------------------------------------------------------------
; SE MANDA LLAMAR AL MODULO DE GRAFICACION
; X=renglon Y=columna
;---------------------------------------------------------------------------------
(defun CreaFiguras ()
(setf Triangulo (make-Triangulo))
(setf Cuadro (make-Cuadro))
(setf Rectangulo (make-Rectangulo))
(setf Circulo (make-Circulo))
)
(defun ColocaFiguras ()
(Dibuja Cuadro) (Dibuja Triangulo)
(Dibuja Rectangulo) (Dibuja Circulo)
)
;___________________________________________________________________
; Dibuja el Circulo
; X es hacia abajo
; Y es hacia la derecha
;___________________________________________________________________
(defmethod Dibuja ((figura Circulo))
(setq contorno '(2 1 0 0 1 2))
(setq largo '(4 6 8 8 6 4))
(dotimes (k 6)
(dotimes (r (nth k largo))
(setf (aref Display (+ (Circulo-x Circulo) k) (+ (+ (Circulo-y Circulo) (nth k contorno)) r)) (Circulo-Ver Circulo)) ; Contorno
)
)
)
; Dibuja el Cuadro
;___________________________________________________________________
(defmethod Dibuja ((figura Cuadro))
(dotimes (k 6)
(setf (aref Display (Cuadro-x Cuadro) (+ (Cuadro-y Cuadro) k)) (Cuadro-Ver Cuadro)) ; Parte superior
(setf (aref Display (+ (Cuadro-x Cuadro) 5) (+ (Cuadro-y Cuadro) k)) (Cuadro-Ver Cuadro)) ; Parte inferior
)
(dotimes (k 5)
(setf (aref Display (+ (Cuadro-x Cuadro) k) (Cuadro-y Cuadro)) (Cuadro-Ver Cuadro)) ; Parte izquierda
(setf (aref Display (+ (Cuadro-x Cuadro) k) (+ (Cuadro-y Cuadro) 5)) (Cuadro-Ver Cuadro)) ; Parte derecha
)
)
;___________________________________________________________________
; Dibuja el RectAngulo
;___________________________________________________________________
(defmethod Dibuja ((figura Rectangulo))
(dotimes (k 10)
(setf (aref Display (Rectangulo-x Rectangulo) (+ (Rectangulo-y Rectangulo) k)) (Rectangulo-Ver Rectangulo)) ; Parte superior
(setf (aref Display (+ (Rectangulo-x Rectangulo) 5) (+ (Rectangulo-y Rectangulo) k)) (Rectangulo-Ver Rectangulo)) ; Parte inferior
)
(dotimes (k 5)
(setf (aref Display (+ (Rectangulo-x Rectangulo) k) (Rectangulo-y Rectangulo)) (Rectangulo-Ver Rectangulo)) ; Parte izquierda
(setf (aref Display (+ (Rectangulo-x Rectangulo) k) (+ (Rectangulo-y Rectangulo) 9)) (Rectangulo-Ver Rectangulo)) ; Parte derecha
)
)
;___________________________________________________________________
; Dibuja el TriAngulo
;___________________________________________________________________
(defmethod Dibuja ((figura Triangulo))
(setf renglon 0)
(dotimes (k 5)
(setf (aref Display (+ (Triangulo-x Triangulo) renglon) (+ (Triangulo-y Triangulo) renglon)) (Triangulo-Ver Triangulo)) ; DIAGONAL
(setf (aref Display (+ (Triangulo-x Triangulo) renglon) (Triangulo-y Triangulo)) (Triangulo-Ver Triangulo)) ; VERTICAL
(setf renglon (+ renglon 1))
)
(dotimes (k 6)
(setf (aref Display (+ (Triangulo-x Triangulo) 5) (+ (Triangulo-y Triangulo) k)) (Triangulo-Ver Triangulo)) ; BASE
)
)
;===================================================================================================
;===================================================================================================
; A L G U N A S H E R R A M I E N T A S E X T R A S
;===================================================================================================
;===================================================================================================
;________________________________________________________________________
; Se introduce una cadena de texto y la convierte a una lista de palabras
;------------------------------------------------------------------------
;
; FUNCIONES QUE SE UTILIZAN
; string-trim Recorta los caracteres extremos indicados entre comillas
; with-input-from-string Convierte una cadena de texto en una lista de palabras
; construyendo una variable flujo entre la cadena y READ
(defun Lee_Frase ()
(with-input-from-string (Cadena (string-trim " ." (read-line)))
(do ((Palabra (read Cadena nil) (read Cadena nil)) (oracion nil))
((not Palabra) (return (reverse oracion)))
(push Palabra oracion)
)
)
)