Capítulo 5.lsp

		;;;Código fuente del libro "Experto AutoCAD con Visual LISP"
		;;; (c) Ediciones ARTUAL, S.L. Barcelona, España.
		;;; (c) 2012-2020 Reinaldo Togores. Todos los derechos reservados
		;;; Se permite su uso mencionando la obra y su autor.
		;;;Capítulo 5.  Funciones definidas por el usuario.

		;;;5.2  Cargar y ejecutar funciones de usuario.------------------

(defun cap-i-cua (x y z) (strcat x y z y x))
		;;;Listado 5.1. Código de la función CAP-I-CUA.

		;;;5.3  Variables globales y locales.----------------------------

(defun mensaje-1 (/ x) 
  (setq x "SEGUNDA")
  (princ. "\n Mensaje-1 asigna a x ")
  (princ. x)
  (princ. "\n Pero z sigue ")
  (princ. z))

(defun mensaje-2 (/ x) 
  (setq x "TERCERA")
  (princ "\n Mensaje-2 asigna a x ")
  (princ x)
  (princ "\n Pero z sigue ")
  (princ z))

(defun mensajes (/ x z) 
  (setq x "PRIMERA"
        z "SIN CAMBIOS")
  (princ "\n mensajes asigna a la variable x ")
  (princ x)
  (princ "\n y a la variable z ")
  (princ z)
  (mensaje-1)
  (mensaje-2)
  (princ "\n y de regreso a mensajes, x contiene ")
  (princ x)
  (princ "\n y como siempre, z ")
  (princ z)
  (princ))
		;;;Listado 5.2. Demostración con variables locales.

		;;;5.4  Predicados y Condicionales.------------------------------

(defun par-punteado-p (arg) 
  (and (vl-consp arg) (atom (cdr arg))))
;;;Listado 5.3. Predicado PAR-PUNTEADO-P.

(defun stringp (arg) 
  (eq (type arg) 'STR))
;;;Listado 5.4. Predicado STRINGP.

(defun lista? (arg / resultado) 
  (if (listp arg) 
    (setq resultado "Sí")
    (setq resultado "No"))
  (princ (strcat resultado " es una lista"))
  (princ))
		;;;Listado 5.5. Función LISTA? con asignación a variables locales.

(defun lista? (arg) 
  (princ 
    (strcat 
      (if (listp arg) 
        "Sí"
        "No")
      " es una lista"))
  (princ))
		;;;Listado 5.6. Función LISTA? sin variables locales.

(defun tipo? (arg) 
  (cond 
    ((listp arg)
     (princ arg)
     (princ " es una lista"))
    ((vl-symbolp arg)
     (princ arg)
     (princ " es un símbolo"))
    ((and (numberp arg) (zerop arg))
     (princ arg)
     (princ " es el número cero"))
    ((and (numberp arg) (minusp arg))
     (princ arg)
     (princ " es un número negativo"))
    ((numberp arg)
     (princ arg)
     (princ " es un número positivo"))
    (t
     (princ "no sabemos qué es ")
     (princ arg)))
  (princ))
;;;Listado 5.7. Función TIPO?.

(defun ordena-lista (lista funcion) 
  (mapcar '(lambda (x) (nth x lista)) 
          (vl-sort-i lista funcion)))
		;;;Listado 5.8. Función para ordenar listas.

(defun ordena-puntos (lista-puntos coordenada) 
  (mapcar 
    '(lambda (x) (nth x lista-puntos))
    (vl-sort-i 
      lista-puntos
      '(lambda (x y) 
         (< (nth coordenada x) (nth coordenada y))))))
		;;;Listado 5.9. Ordenar lista de puntos según una de sus coordenadas.

(defun ordena-cadenas (cadena funcion) 
  (apply 'strcat 
         (mapcar 'chr 
                 (ordena-lista 
                   (vl-string->list cadena)
                   funcion))))
		;;;Listado 5.10. Función que ordena cadenas de caracteres.

(defun ordena-frase (frase funcion) 
  (ordena-lista 
    (mapcar 'vl-princ-to-string 
            (read (strcat "(" frase ")")))
    funcion))
		;;;Listado 5.11. Función que ordena las palabras en una frase.

		;;;Actualización: la función en el Listado 5.12 puede entrar en un bucle sin fin en caso
		;;;de que la nueva cadena contenga los mismos caracteres que la antigua, como en
		;;;sustituir "x" con "xx". Eso puede evitarse usando el siguiente código:
(defun sustituye  (nuevo viejo cadena / pos)
  (while (setq pos (vl-string-search viejo cadena pos))
    (setq cadena (vl-string-subst nuevo viejo cadena pos)
          pos (+ pos (strlen nuevo))))
  cadena)
		;;;Listado 5.12. Sustitución de caracteres en una cadena.

(defun ordenar-frases-como-cadenas (frase / lista-frase) 
  (acad_strlsort 
    (setq lista-frase (read 
                        (strcat "(\"" 
		                                (sustituye "\"\"" " " frase)
                                "\")")))))
		;;;Listado 5.13. Función para ordenar palabras contenidas en frases.


		;;;5.5  Recursión---------------------------------------------------

(defun factorial (n) 
  (cond 
    ((zerop n) 1)
    (t (* n (factorial (- n 1))))))
;;;Listado 5.14. Factorial de un número.

(defun cuenta-miembros (elem lista) 
  (cond 
    ((null (member elem lista)) 0)
    (t
     (+ 1 
        (cuenta-miembros elem (cdr (member elem lista)))))))
		;;;Listado 5.15. Función para contar miembros de una lista.

(defun miembro (elem lista) 
  (cond 
    ((null lista) nil)
    ((equal (car lista) elem) lista)
    (t (miembro elem (cdr lista)))))
		;;;Listado 5.16. Definición recursiva de la función member.

(defun aplana (lista) 
  (cond 
    ((atom lista) (list lista))
    (t
     (append 
       (aplana (car lista))
       (aplana (cdr lista))))))
		;;;Listado 5.17. Función para aplanar listas anidadas.

(defun aplana (lista) 
  (cond 
    ((null lista) nil)
    ((atom lista) (list lista))
    (t
     (append 
       (aplana (car lista))
       (aplana (cdr lista))))))
		;;;Listado 5.18. Función aplana eliminando términos nil.

		;;;5.6  Iteración----------------------------------------------------

(defun fibonacci (cuantos / serie prox) 
  (setq serie '(1)
        prox  1)
  (repeat (- cuantos 1) 
    (setq serie (cons prox serie)
          prox  (+ (car serie) (cadr serie))))
  (reverse serie))
		;;;Listado 5.19. Función FIBONACCI implementada con REPEAT.

(defun cap-i-cua-p (cadena / cont resultado) 
  (setq cont      0
        resultado t)
  (repeat (/ (strlen cadena) 2) 
    (if 
      (not 
        (equal 
          (strcase (substr cadena (1+ cont) 1))
          (strcase 
            (substr cadena (- (strlen cadena) cont) 1))))
      (setq resultado nil))
    (setq cont (1+ cont)))
  resultado)
		;;;Listado 5.20. Predicado CAP-I-CUA-P (usando repeat).

(defun imprime-lista (lista /) 
  (foreach term lista (print term))
  (princ))
		;;;Listado 5.21. Impresión de lista (con FOREACH).

(defun imprime-lista (lista /) 
  (mapcar 'print lista)
  (princ))
		;;;Listado 5.22. Impresión de lista (con MAPCAR).

(defun cuadrados-1 (lista) 
  (mapcar '(lambda (term) (* term term)) lista))
		;;;Listado 5.23. Cuadrados de una lista (con mapcar).

(defun cuadrados-2 (lista) 
  (cond 
    ((null lista) nil)
    (t
     (cons (* (car lista) (car lista)) 
           (cuadrados-2 (cdr lista))))))
		;;;Listado 5.24. Cuadrados de una lista (recursiva).

(defun cuadrados-3 (lista / resultado) 
  (setq resultado nil)
  (foreach term lista 
    (setq resultado (cons (* term term) resultado)))
  (reverse resultado))
		;;;Listado 5.25. Cuadrados de una lista (foreach).

(defun cuenta-entidades (/ cont ent) 
  (setq cont 0
        ent  (entnext))
  (while ent 
    (setq cont (1+ cont)
          ent  (entnext ent)))
  cont)
;;;Listado 5.26. Conteo de entidades.

(defun cap-i-cua-p (cadena / cont resultado) 
  (setq cont      0
        resultado t)
  (while (and (<= cont (/ (strlen cadena) 2)) resultado) 
    (if 
      (not 
        (equal (substr cadena (1+ cont) 1) 
               (substr cadena (- (strlen cadena) cont) 1)))
      (setq resultado nil))
    (setq cont (1+ cont)))
  resultado)
		;;;Listado 5.27. Predicado CAP-I-CUA-P (con while).

(defun lista-nombres (tabla / nombre tmp) 
  (setq tmp (cons (cdr (assoc 2 (tblnext tabla t))) tmp))
  (while (setq nombre (cdr (assoc 2 (tblnext tabla)))) 
    (setq tmp (cons nombre tmp)))
  (acad_strlsort tmp))
		;;;Listado 5.28. Obtención de los nombres de elementos contenidos en las tablas de símbolos.