some more AutoLISP goodies

some AutoLISP snippets from various authors:
From: Vladimir Nesterovsky

(defun sel2lst( sel / n l)
  (repeat (setq n (sslength sel))
    (setq n (1- n) l (cons (ssname ss n) l))))
The sel2lst function is SELection-t(w)o-LiST. I also have (and often use) the opposite --
(defun lst2sel(l / ss)(setq ss (ssadd))(foreach e l (ssadd e ss)))
But here's something really nice (I think) ---
;; General GET{ key(s) list(s) } function
;; Created (1995) by Vladimir Nesterovsky
;; e-mail me for any questions or comments
;;      at vnestr@netvision.net.il
;; YOU MAY USE THIS FUNCTION AS IT IS FOR ANY PURPOSE
;; AT YOUR OWN RISK IF YOU RETAIN THIS NOTICE COMPLETE
;; AND UNALTERED. NO WARRANTIES GIVEN WHATSOEVER.
(defun get (k l)      ;;;;; GET KEY(s) FROM LIST(s)
  (if (atom (caar l)) ;; l is ASSOC'able list
    (cond             ;; use this l!
      ((atom k)       ;; k is a key
        (cdr(Assoc k l))
      )
      ((and (cdr k)(atom (cdr k))) ;; '(0 . 8) -->> ("layer" . "ENTITY")
        (cons (get (car k) l) (cdr (assoc (cdr k) l)))
      )
      (T              ;; k is a list of something - get inside
        (mapcar '(lambda(subk)(get subk l)) k)
      )
    )                 ;; else - get inside list
    (mapcar '(lambda(subl)(get k subl)) l)
))
I use it a lot. For example, to get all blocks in file with some additional info - it's just one line of code, like
 (get '(2 8 10 (41 42 43) 50) (mapcar 'entget (sel2lst(ssget"X"'((0 . "INSERT"))))))
--- voila!
;;Here is the routine that checks substring presence in second
;;string and returns it's index(base 1) if so, or nil.
;; Created (1995) by Vladimir Nesterovsky
;; e-mail me for any questions or comments
;;      at vnestr@netvision.net.il
;; YOU MAY USE THIS FUNCTION AS IT IS FOR ANY PURPOSE
;; AT YOUR OWN RISK IF YOU RETAIN THIS NOTICE COMPLETE
;; AND UNALTERED. NO WARRANTIES GIVEN WHATSOEVER.
(defun isinstr( ssub sall / lsub lall i n ret) ;; the best LISP version (??)
  (setq lall (strlen sall)
        lsub (strlen ssub)
  )
  (cond
    ((> lsub lall) nil)
    ((< lsub lall)
      (setq i 1 n (1+ (- lall lsub)))
      (while (and (not ret) (<= i n))
        (if (= ssub (substr sall i lsub))
          (setq ret i)
          (setq i (1+ i))
        )
      )
      ret
    )
    (T
      (if (= ssub sall) 1)
)))

(defun cdnr ( n l )
  (repeat n (setq l (cdr l))))

;;
;; (C.) 1996 by Vladimir Nesterovsky
;; USE THESE FUNCTIONS FOR ANY NON-PROFITABLE PURPOSE WHILE
;; KEEPING THIS NOTICE. NO WARRANTIES ARE GIVEN WHATSOEVER.
;;

;; strtol convert string of chars into list of 1-char strings
(defun strtol ( s / lst c )
  (repeat (setq c (strlen s))
    (Setq lst (cons (substr s c 1) lst)
          c   (1- c)
  ))
  lst
)

;; helper function
(defun strp(s)(and(='STR(type s))(/= s "")))

;; STRTOK  - break strng on char if it's in chs (char-string).
;; Like "C" strtok() break string to tokens delimited by one
;;   OR MORE chars.
;; parse free format -- no empty tokens --
;;   (strtok " 1,,  2,  3,")->{"1" "2" "3"}
(defun strtok(strng chs / len c l s cnt chsl )
  (setq chsl (strtol chs))
  (setq len (strlen strng) s "" cnt (1+ len))
  (while (> (setq cnt (1- cnt)) 0)
    (setq c (substr strng cnt 1))
    (if (member c chsl)
      (if (strp s)
        (setq l (cons s l) s "")
      )
      (setq s (strcat c s))
    )
  )
  (if (strp s)
    (cons s l)
    l
  )
)

If you want to catch null tokens too, like
 "1,,3,4" -->> { "1" "" "3" "4" }, you'll need this:

;;STRPARSE FOR PARSING STRING (and keeping null tokens)
(defun strparse(strng chs / len c l s chsl cnt );;delim==one-of-chs.
  (setq chsl (strtol chs))
  (setq len (strlen strng) s "" cnt (1+ len))
  (while (> (setq cnt (1- cnt)) 0)
    (setq c (substr strng cnt 1))
    (if (member c chsl)
      (if (/= cnt len);; "1,2," -> ("1" "2") and not ("1" "2" "")
        (setq l (cons s l) s "")
      )
      (setq s (strcat c s))
    )
  )
  (cons s l)   ;; ",1,2" -> ("" "1" "2")
)

So now, armed with this string manipulation functions, you may
 (setq line (read-line file)
       lst  (strtok line ", ")
       nums (mapcar 'atoi lst))
etc.

;;gather strings from list together again
(defun strlgather(strl delims)
  (substr
    (apply'strcat(mapcar'(lambda(s)(strcat delims s))strl))
    (1+ (strlen delims))))

Thanks Vladimir!


From: Reini Urban

;;; ADJOIN - adds element to list, if not already in it
(defun adjoin (item l)
  (cond ((member item l) l)
        (t (cons item l))))

;;; TAIL - list l without the first n elements
(defun tail (l n)
  (cond ((zerop n) l)
        (t (tail (cdr l) (1- n)))))

;;; HEAD - list of only the first n elements
;;; (including) the n-th element, base 0
(defun head (l n) (head-rek l nil n))
(defun head-rek (l x n)
  (cond ((zerop n) (reverse x))
        (t (head-rek (cdr l) (cons (car l) x) (1- n)))))

;;; POS - position of the first pt in pts, -1 if not found
(defun pos (pt pts)
  (- (length pts) (length (member pt pts))))

;;; RPOS - position of the last pt in pts, -1 if not found
(defun rpos (pt pts)
  (1- (length (member pt (reverse pts)))))

;;; MEMB - member with equal's uncertainty check (diff: real number)
(defun memb (ele lst diff)
  (if lst
    (if (equal ele (car lst) diff)
      lst
      (memb ele (cdr lst) diff))))

;;; RPLACE - replaces the n-th element with new, base 0
(defun rplace (lst n new)
  (append (head lst (1- n)) (list new) (tail lst n)))

;;; REMOVE - Non-destructive way to remove an item from a list/tree.
;;; recursive, double elements allowed
(defun remove (item from)
  (cond
    ((atom from) from)
    ((equal (car from) item)
      (remove item (cdr from)))
    (T (cons (car from) (remove item (cdr from))))))
That was from me. It's also in the Recursion text. There's room left for some string routines...

Douglas Wilson <dougw@amgen.com>

(defun list-transpose (l) (apply 'mapcar (cons 'list l)))

From: Sergei Volkov

(defun remove (expr lst)
   (apply 'append (subst nil (list expr) (mapcar 'list lst)))
)

Send me more!

© by the authors