This routine is very handy if you need to clean up wall intersections that are L-shaped. The wall intersections do not have to be 90 degrees and they do not have to be orthogonal.
There are 2 options:
(Shown below) When you start the routine (WALL-L), if you enter S for “Select objects” you must first select the wall objects and then you specify the area for the “Inside corner” with a single click.
The Second Option (shown below) which is also the default option:
Start the command (WALL-L <enter>) and then make a selection window (selection type doesn’t matter). What matters is that your first pick determines the “Inside corner”
(defun c:wall-l (/ >90 @work ang1 ang2 dists edata eqpnt etype fuzzy get
getslope head merge perp perps pt0 pt1 neatl slope sort
ss ssfunc tail temp 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 NEATL (dist1 dist2 / line1 line2 pt1 pt2 pt3 pt4 ipt pp1 pp2 x y
group edata enm)
(mapcar
'(lambda (x y)
(work)
(setq
x (cadr x)
y (cadr y)
line1 (nth x (car walls))
line2 (nth y (cadr walls))
pt1 (cadr line1)
pt2 (caddr line1)
pt3 (cadr line2)
pt4 (caddr line2)
pp1 (nth (1- x) (car perps))
pp2 (nth (1- y) (cadr perps))
ipt (inters pt1 pt2 pt3 pt4 nil)
)
(mapcar
'(lambda (enm pt1 pt2 pp)
(work)
(setq
ang1 (angle pp ipt)
ang2 (angle pt1 pt2)
group (if (eqpnt (polar ipt ang1 1.0) (polar ipt ang2 1.0)) 11 10)
edata (entget enm)
)
(entmod (subst (cons group ipt) (assoc group edata) edata))
)
(list (car line1) (car line2))
(list pt1 pt3)
(list pt2 pt4)
(list pp1 pp2)
)
)
dist1
dist2
)
)
(work)
(defun FUZZY (x y)
(< (abs (- x y)) 1.0e-6)
)
(work)
(defun EQPNT (p1 p2)
(< (distance p1 p2) 1.0e-6)
)
(work)
(defun GET (key alist)
(if (atom key)
(cdr (assoc key alist))
(mapcar '(lambda (x) (cdr (assoc x alist))) key)
)
)
(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)
)
(setq >90 (/ pi 2))
(setvar "CmdEcho" 0)
(princ "\rLoaded. ")
(while
(progn
(initget "Select")
(setq pt0 (getpoint "\nSelect objects/<Inside corner>: "))
)
(setq
dists nil
perps nil
walls nil
)
(cond
((eq (type pt0) 'LIST)
(initget 33)
(setq
pt1 (getcorner pt0 "\nOutside 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 inside 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
(neatl (car dists) (cadr dists))
(princ "\rComplete.")
)
)
(command ".UNDO" "End")
)
;----------------------------
; Restore enviroment, memory
;----------------------------
(princ)
; ----< End Of File >----
)
(princ)
AutoCAD Tips 