AutoLISP: X Shape Wall Intersection Clean Up

Link to AutoCAD Tips

This is the last of the wall intersection clean up routines that I have. This one does X-shape (cross shape) intersections.

Command to start:

  • WALL-X <enter>

This routine acts the same as the others
in that it lets you simply make a selection set of the crossing objects first and then specify the outside of the walls (shown below).

You can also simply use the default setting which lets you simply make a selection window over the intersection and the routine will clean up the intersections for you (shown below).

~enjoy
(defun c:wall-x (/ >90 @work dists edata etype fuzzy get getslope head i l0
merge neatx1 nukenz perp perps pt0 pt1 pt2 pt3 pt4 pt5 pt6
slope sort ss ssfunc tail wall1 wall2 walls work
)
(setq clayer nil)
(princ "\nLoading -")
(setq @WORK '("\\" "|" "/" "-"))
(defun WORK ()
; Backspace
(prompt "\010")
(setq @work (append (cdr @work) (list (princ (car @work)))))
)
(work)
(defun NUKENZ (x)
(cdr (reverse (cdr x)))
)
(work)
(defun NEATX1 (dist1 dist2)
(cond
((cdr dist1)
(work)
(neatx2
; 1st wall - line 1
(nth (cadar dist1) wall1)
; 1st wall - line 2
(nth (cadr (last dist1)) wall1)
; 2nd wall - line 1
(nth (cadar dist2) wall2)
; 2nd wall - line 2
(nth (cadr (last dist2)) wall2)
)
(neatx1 (nukenz dist1) (nukenz dist2))
)
(T (princ "\rComplete."))
)
)
(work)
(defun NEATX2 (a1 a2 b1 b2)
(mapcar
'(lambda (x l1 l2)
(work)
(setq
pt1 (cadr l1)
pt2 (caddr l1)
pt3 (cadr l2)
pt4 (caddr l2)
)
(foreach
l0
x
(setq
pt5 (cadr l0)
pt6 (caddr l0)
)
(command
".BREAK" (car l0)
(inters pt5 pt6 pt1 pt2)
(inters pt5 pt6 pt3 pt4)
)
)
)
(list (list a1 a2) (list b1 b2))
(list b1 a1)
(list b2 a2)
)
)
(work)
(defun GET (key alist)
(if (atom key)
(cdr (assoc key alist))
(mapcar '(lambda (x) (cdr (assoc x alist))) key)
)
)
(work)
(defun FUZZY (x y)
(< (abs (- x y)) 1.0e-6)
)
(work)
(defun SORT (x)
(work)
(cond
((null (cdr x)) x)
(T
(merge
(sort (head x (1- (length x))))
(sort (tail x (1- (length x))))
)
)
)
)
(work)
(defun MERGE (a b)
(work)
(cond
((null a) b)
((null b) a)
((< (caar a) (caar b))
(cons (car a) (merge (cdr a) b))
)
(t (cons (car b) (merge a (cdr b))))
)
)
(work)
(defun HEAD (l n)
(cond
((minusp n) nil)
(t (cons (car l) (head (cdr l) (- n 2))))
)
)
(work)
(defun TAIL (l n)
(cond
((minusp n) l)
(t (tail (cdr l) (- n 2)))
)
)
(work)
(defun GETSLOPE (pt1 pt2 / x)
; Vertical?
(if (fuzzy (setq x (abs (- (car pt1) (car pt2)))) 0.0)
; Yes, return NIL
nil
; No, compute slope
(rtos (/ (abs (- (cadr pt1) (cadr pt2))) x) 2 4)
)
)
(work)
(defun ETYPE (edata match)
(member (get 0 edata) (if (listp match) match (list match)))
)
(work)
(defun SSFUNC (ss func / i ename)
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(apply func nil)
)
)
(work)
(defun PERP (pt0 pt1 pt2)
(inters pt1 pt2 pt0 (polar pt0 (+ (angle pt1 pt2) >90) 1.0) nil)
)
;---------------
; Main Function
;---------------
(setq >90 (/ pi 2))
; Stuff Gary will want to fix...
(setvar "CmdEcho" 0)
(setvar "BlipMode" 0)
(princ "\rLoaded. ")
(while
(progn
(initget "Select")
(setq pt0 (getpoint "\nSelect objects/<First corner>: "))
)
(setq
dists nil
perps nil
walls nil
)
(cond
((eq (type pt0) 'LIST)
(initget 33)
(setq
pt1 (getcorner pt0 "\nOther corner: ")
ss (ssget "C" pt0 pt1)
)
)
(T
(while
(progn
(princ "\nSelect objects: ")
(command ".SELECT" "Au" pause)
(not (setq ss (ssget "P")))
)
(print "No objects selected, try again.")
)
(initget 1)
(setq pt0 (getpoint "\nPoint to outside of wall: "))
)
)
(princ "\nWorking ")
(command ".UNDO" "Group")
(ssfunc ss
'(lambda ()
(work)
(setq edata (entget ename))
; Issa LINE entity, fall thru
(if (etype edata "LINE")
(setq
; Get relevant groups
edata (get '(-1 10 11) edata)
slope (getslope (cadr edata) (caddr edata))
walls
; Does this slope already exist in walls list
(if (setq temp (assoc slope walls))
; Yes, add new line info to assoc group
(subst (append temp (list edata)) temp walls)
; Nope, add new assoc group w/line info
(cons (cons slope (list edata)) walls)
)
)
)
)
)
(cond
((< (length walls) 2)
(princ "\rerror: Use MEND to join colinear walls.")
)
((> (length walls) 2)
(princ "\rerror: Only two walls may be cleaned.")
)
((not (apply '= (mapcar 'length walls)))
(princ "\rerror: Walls have unequal number of lines.")
)
(T
;-------------------------------
; Create List of Perpendiculars
;-------------------------------
(setq perps
(mapcar
'(lambda (x)
(work)
(mapcar
'(lambda (y)
(work)
(perp pt0 (cadr y) (caddr y))
)
(cdr x)
)
)
walls
)
)
;--------------------------
; Create List of Distances
;--------------------------
(setq dists
(mapcar
'(lambda (x)
(work)
(setq i 0)
(mapcar
'(lambda (y)
(work)
; Create list of distances (with pointers to WALLS)
(list
; Compute distances
(distance pt0 y)
; Key
(setq i (1+ i))
)
)
x
)
)
; List of perpendicular points
perps
)
)
; Sort distance index
(setq dists (mapcar 'sort dists))
; Clean intersections
(setq wall1 (car walls) wall2 (cadr walls))
(neatx1 (car dists) (cadr dists))
)
)
(command ".UNDO" "End")
)
;----------------------------
; Restore enviroment, memory
;----------------------------
(princ)
;---< End Of File >---
)
(princ)
About these ads

About AutoCAD Tips

This blog serves as a knowledge base for myself so that I can reference tips & tricks that I have learned and also refer others to it as well. I hope that this blog helps you learn at least one tip to make your drafting experience better. I am currently unemployed and I am located in the Denver Metro Area. If you would like to find out more about my and see samples of my work, please visit www.gregbattin.weebly.com
This entry was posted in AutoLISP, AutoLISP: Modify. Bookmark the permalink.

2 Responses to AutoLISP: X Shape Wall Intersection Clean Up

  1. Tassos Ringas says:

    Hi,
    I have tried the other wall cleanup (t & l) commands and they work like a charm, both in Acad 2012 and 2015!
    This one however only works in 2012, I get a VVC: Internal Error when running it in 2015.
    I have found that it has something to do with command arguments in mapcar, and that they need to be changed into command-s:

    http://docs.autodesk.com/ACDMAC/2014/ENU/index.html?url=files/GUID-5C9DC003-3DD2-4770-95E7-7E19A4EE19A1.htm,topicNumber=d30e351208

    and

    http://knowledge.autodesk.com/support/autocad-mep/troubleshooting/caas/discussion/t5/Visual-LISP-AutoLISP-and-General/Lisp-Problems-in-2015/td-p/4992168.html

    However, I can’t understand which one needs to be changed. Can you look into it?

    Thanks in advance,

    Tassos Ringas

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s