;;;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.
