;;; Source code from the book "AutoCAD expert's Visual LISP"
;;; (c) Ediciones ARTUAL, S.L. Barcelona, España.
;;; Copyright © 2012-2020 by Reinaldo N. Togores. All rights reserved.
;;; Use of this code is allowed mentioning the book and its author.
;;;Chapter 5. User-defined functions.
;;;5.2 Loading and executing user functions.------------------
(defun palindrome (x y z) (strcat x y z y x))
;;;Listing 5.1. Code for the PALINDROME function.
;;;5.3.Global and local variables.
(defun message-1 (/ x)
(setq x "SECOND")
(princ. "\n message-1 assigns to x ")
(princ. x)
(princ. "\n But z is still ")
(princ. z))
(defun message-2 (/ x)
(setq x "THIRD")
(princ "\n message-2 assigns to x ")
(princ x)
(princ "\n But z is still ")
(princ z))
(defun messages (/ x z)
(setq x "FIRST"
z "UNCHANGED")
(princ "\n messages assigns to the variable x ")
(princ x)
(princ "\n and to the variable z ")
(princ z)
(message-1)
(message-2)
(princ "\n and on returning to messages, x contains ")
(princ x)
(princ "\n and z, as always ")
(princ z)
(princ))
;;;Listing 5.2. Demonstration with local variables.
;;;5.4.Predicates and Conditionals.
(defun dotted-pair-p (arg)
(and (vl-consp arg) (cdr arg) (atom (cdr arg))))
;;;Listing 5.3. DOTTED-PAIR-P predicate.
(defun stringp (arg)
(eq (type arg) 'STR))
;;;Listing 5.4. STRINGP predicate.
(defun is-list? (arg / result)
(if (listp arg)
(setq result "Yes, it's")
(setq result "No, it's not"))
(princ (strcat result " a list"))
(princ))
;;;Listing 5.5. IS-LIST? function with local variables.
(defun is-list? (arg)
(princ
(strcat
(if (listp arg)
"Yes, it's"
"No, it's not")
" a list"))
(princ))
;;;Listing 5.6. IS-LIST? function without local variables.
(defun type? (arg)
(cond
((listp arg)
(princ arg)
(princ " is a list"))
((vl-symbolp arg)
(princ arg)
(princ " is a symbol"))
((and (numberp arg) (zerop arg))
(princ arg)
(princ " is number zero"))
((and (numberp arg) (minusp arg))
(princ arg)
(princ " is a negative number"))
((numberp arg)
(princ arg)
(princ " is a positive number"))
(t
(princ arg)
(princ " is an unknown type ")))
(princ))
;;;Listing 5.7. TYPE? function.
(defun sort-list (lst func)
(mapcar '(lambda (x) (nth x lst))
(vl-sort-i lst func)))
;;;Listing 5.8. List sorting function.
(defun sort-points (point-list coord)
(mapcar
'(lambda (x) (nth x point-list))
(vl-sort-i
point-list
'(lambda (x y)
(< (nth coord x) (nth coord y))))))
;;;Listing 5.9. Sorting a list of points by one of its coordinates.
(defun sort-string (string func)
(apply 'strcat
(mapcar 'chr
(sort-list
(vl-string->list string)
func))))
;;;Listing 5.10. Function that sorts strings.
(defun sort-phrase (phrase func)
(sort-list
(mapcar 'vl-princ-to-string
(read (strcat "(" phrase ")")))
func))
;;;Listing 5.11. Function that sorts the words in a sentence.
;;;Update: the function in Listing 5.12 may enter an endless loop in case
;;;that the new string contains the same characters as the old one, as in
;;;replacing "x" with "xx". That can be avoided using the following code:
(defun replace (new old string / pos)
(while (setq pos (vl-string-search old string pos))
(setq string (vl-string-subst new old string pos)
pos (+ pos (strlen new))))
string)
;;;Listing 5.12. Replacement of characters in a string.
(defun sort-phrases-as-strings (phrase / search-list)
(acad_strlsort
(setq search-list (read
(strcat "(\""
(replace "\"\"" " " phrase)
"\")")))))
;;;Listing 5.13. Function for ordering words in sentences.
;;;5.5 Recursion---------------------------------------------------
(defun factorial (n)
(cond
((zerop n) 1)
(t (* n (factorial (- n 1))))))
;;;Listing 5.14. Factorial of a number.
(defun member-count (item lst)
(cond
((null (member item lst)) 0)
(t
(+ 1
(member-count item (cdr (member item lst)))))))
;;;Listing 5.15. Function that counts list members.
(defun rec-member (item lst)
(cond
((null lst) nil)
((equal (car lst) item) lst)
(t (rec-member item (cdr lst)))))
;;;Listing 5.16. Recursive definition of the member function.
(defun flatten (lst)
(cond
((atom lst) (list lst))
(t
(append
(flatten (car lst))
(flatten (cdr lst))))))
;;;Listing 5.17. Function to flatten nested lists.
(defun flatten (lst)
(cond
((null lst) nil)
((atom lst) (list lst))
(t
(append
(flatten (car lst))
(flatten (cdr lst))))))
;;;Listing 5.18. Flatten function removing nil terms.
;;;5.6.Iteration
(defun fibonacci (total / series next)
(setq series '(1)
next 1)
(repeat (- total 1)
(setq series (cons next series)
next (+ (car series) (cadr series))))
(reverse series))
;;;Listing 5.19. Fibonacci function implemented with REPEAT.
(defun palindrome-p (string / count result)
(setq count 0
result t)
(repeat (/ (strlen string) 2)
(if
(not
(equal
(strcase (substr string (1+ count) 1))
(strcase
(substr string (- (strlen string) count) 1))))
(setq result nil))
(setq count (1+ count)))
result)
;;;Listing 5.20. PALINDROME-P predicate (using repeat).
(defun print-list (lst /)
(foreach term lst (print term))
(princ))
;;;Listing 5.21. Printing of a list (using FOREACH).
(defun print-list (lst /)
(mapcar 'print lst)
(princ))
;;;Listing 5.22. Printing a list (using MAPCAR).
(defun squares-1 (lst)
(mapcar '(lambda (term) (* term term)) lst))
;;;Listing 5.23. Squares of a list (using mapcar).
(defun squares-2 (lst)
(cond
((null lst) nil)
(t
(cons (* (car lst) (car lst))
(squares-2 (cdr lst))))))
;;;Listing 5.24. Squares of a list (recursive).
(defun squares-3 (lst / result)
(setq result nil)
(foreach term lst
(setq result (cons (* term term) result)))
(reverse result))
;;;Listing 5.25. Squares of a list (using foreach).
(defun count-ents (/ count ent)
(setq count 0
ent (entnext))
(while ent
(setq count (1+ count)
ent (entnext ent)))
count)
;;;Listing 5.26. Counting drawing entities.
(defun palindrome-p (string / count result)
(setq count 0
result t)
(while (and (<= count (/ (strlen string) 2)) result)
(if
(not
(equal (substr string (1+ count) 1)
(substr string (- (strlen string) count) 1)))
(setq result nil))
(setq count (1+ count)))
result)
;;;Listing 5.27. PALINDROME-P predicate (with while).
(defun names-list (table / name tmp)
(setq tmp (cons (cdr (assoc 2 (tblnext table t))) tmp))
(while (setq name (cdr (assoc 2 (tblnext table))))
(setq tmp (cons name tmp)))
(acad_strlsort tmp))
;;;Listing 5.28. Obtaining the names of items in symbol tables.
No comments:
Post a Comment