- Home
- /
- Architecture, Engineering & Construction
- /
- AutoCAD Forums
- /
- Visual LISP, AutoLISP and General Customization Forum
- /
- Re: 3d Faces down to zero level
Announcements
Announcement: We’re aware of an issue affecting starting a new topic from category pages and creating new blog posts. New topics can still be started directly from the relevant board. Learn more here.
3d Faces down to zero level
Options
- Subscribe to RSS Feed
- Mark Topic as New
- Mark Topic as Read
- Float this Topic for Current User
- Bookmark
- Subscribe
- Mute
- Printer Friendly Page
3d Faces down to zero level
Advocate
4,399 Views
36 Replies
Replies (36)
- « Previous
-
- 1
- 2
- Next »
Message 21 of 37
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
@carlos_m_gil_p wrote:Hello marko_ribar
How are you.
You know you found a new error.
Watch in the DWG.
Thousand thanks.
Hi carlos, I only today saw bug... Here is my revision... Hope this helps...
;;; ;;;
;;; by Nolo en Hispacad ;;;
;;; ;;;
(defun c:xxx1 (/ _vl-position massoclst deldu sentido solod
3cdp ent-3dcara intercc unique ; funciones
;; variables
ss se ssep ssnew ssmaxl x name
listap lp ld d d1 d2 p
p1 p2 plano names siguiente pro
pro2 siguientes old 3dfl 3dfdl ptdptl
ptdl ptdln ptdlnn ptdptlp ptdlp ptdlpa p3p
p1p p2p *tol* s i 3df 3dfrl
3df1 3df2 pt1 pt2 pt3 pt4 nnames
nnamesp 3dfrlp pt11 pt12 pt13 pt14 pt21
pt22 pt23 pt24 d1l d2l ddl
)
(defun unique ( l )
(or *tol* (setq *tol* 1e-6))
(if l (cons (car l) (unique (vl-remove-if '(lambda ( x ) (equal x (car l) *tol*)) (cdr l)))))
)
;; (_vl-position 3.29 '(1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8 9.9) 0.01 nil) => 2 (!k => nil) ;;
(defun _vl-position ( e l tol k )
(if (null k)
(setq k 0)
)
(if (not (equal e (car l) tol))
(progn
(setq k (1+ k))
(if (cdr l)
(_vl-position e (cdr l) tol k)
(setq k nil)
)
)
k
)
)
(defun massoclst ( key lst )
(if (assoc key lst) (cons (assoc key lst) (massoclst key (cdr (member (assoc key lst) lst)))))
)
;; funciones utilizadas
;; eliminar duplicados en lista
(defun deldu (lista / num)
;; By Nolo
(vl-remove
nil
(mapcar '(lambda (a / n)
(if (not (_vl-position (setq n (vl-position a lista)) num 1e-6 nil))
(progn (setq num (append num (list n))) a)
nil
)
)
lista
)
)
)
;;;; devuelve -1 0 1 segun alineación de los puntos a b c Tony Tanzillo
(defun sentido (a b c / r) ; de Tony Tanzillo modificada por Nolo
(setq r (- (* (- (car b) (car a)) (- (cadr c) (cadr a)))
(* (- (cadr b) (cadr a)) (- (car c) (car a)))
)
)
(if (equal r 0.0 0.00001)
0
(setq r (fix (/ r (abs r))))
)
)
;;; sacar solo datos duplicados en lista
(defun solod (lista / res)
;; By NOLO
(foreach a lista
(if (and (_vl-position a (cdr (member a lista)) 1e-6 nil) (not (_vl-position a res 1e-6 nil)))
(setq res (cons a res))
)
)
res
) ; centro de varios puntos en 3d
(defun 3cdp (pl / n) ; by ymg
(setq n (length pl))
(mapcar '(lambda (a) (/ a n)) (apply 'mapcar (cons '+ pl)))
)
;;;; dibujar cara 3d
(defun ent-3dcara (vertices)
;; TOGORES
(entmake (list '(0 . "3DFACE")
'(100 . "AcDbEntity")
'(100 . "AcDbFace")
(cons 10 (nth 0 vertices))
(cons 11 (nth 1 vertices))
(cons 12 (nth 2 vertices))
(if (nth 3 vertices)
(cons 13 (nth 3 vertices))
(cons 13 (nth 2 vertices))
)
)
)
)
;;intersección de dos circulos con un punto de referencia pref para validar una solución
(defun intercc (c1 r1 c2 r2 pref / salfa calfa d an p3)
;; TOGORES modificada por NOLO
(setq d (distance c1 c2)
an (angle c1 c2)
calfa (/ (- (+ (expt r1 2) (expt d 2)) (expt r2 2)) 2 r1 d)
salfa (sqrt (abs (- 1 (expt calfa 2))))
;;; problema raiz cuadrada en algunos valores negativos ???
;;; Problem, square root, in some negative values ???
)
(setq p3 (polar c1 (+ an (atan salfa calfa)) r1))
(if (and pref (= (sentido c1 c2 p3) (sentido c1 c2 pref)))
(setq p3 (polar c1 (- an (atan salfa calfa)) r1))
p3
)
)
;;;;;;;;;;;;;;;;; programa ;;;;;;;;;;;;;;;;;;
(setq *tol* 1e-6)
;; selección por ventana o crosing
(princ "\nSelect 3DFACES to unfold...")
(setq s (ssget '((0 . "3DFACE"))))
(repeat (setq i (sslength s))
(setq 3df (ssname s (setq i (1- i))))
(mapcar 'set '(pt1 pt2 pt3 pt4) (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (vl-position (car x) '(10 11 12 13))) (entget 3df))))
(if (and (not (equal pt1 pt2 *tol*)) (not (equal pt2 pt3 *tol*)) (not (equal pt3 pt4 *tol*)) (not (equal pt4 pt1 *tol*)))
(progn
(setq 3df1 (entmakex (list '(0 . "3DFACE") (cons 10 pt1) (cons 11 pt1) (cons 12 pt2) (cons 13 pt3))))
(setq 3df2 (entmakex (list '(0 . "3DFACE") (cons 10 pt3) (cons 11 pt3) (cons 12 pt4) (cons 13 pt1))))
(setq 3dfrl (cons (list (cdr (assoc 5 (entget 3df1))) (cdr (assoc 5 (entget 3df2)))) 3dfrl))
(ssdel 3df s)
(ssadd 3df1 s)
(ssadd 3df2 s)
)
)
)
(setq ss (ssadd))
(repeat (setq i (sslength s))
(ssadd (ssname s (setq i (1- i))) ss)
)
(setq
;; conjunto selección
sse (vl-remove-if-not
'(lambda (a) (= (type a) 'ename))
(apply 'append (ssnamex ss))
)
;; lista con entidades
ssep (mapcar
'(lambda (x / e)
(setq e (entget x))
(cons
(cdr (assoc 5 e))
;; lista con hadled de entidad y puntos
(unique
(mapcar 'cdr
(vl-remove-if-not
'(lambda (a) (vl-position (car a) '(10 11 12 13)))
e
)
)
)
)
)
sse
)
)
;; buscamos colindancias y las guardamo en una nueva lista
;; lista con handled entidad, perímetro y colindantes
(setq
ssnew (mapcar
'(lambda (x / ladosx 2lados contiguos i)
(list
(car x)
;;; nombre entidad
(apply
'+
(mapcar 'distance
(cdr x)
(append (cdr (cdr x)) (list (car (cdr x))))
)
)
;; perímetrto
(setq ladosx (mapcar
'(lambda (a)
;; por cada 10 11 12 13 de x
(mapcar
'car
(vl-remove-if-not
'(lambda (b)
;; los que tiene un punto próximo
(vl-remove
nil
(mapcar '(lambda (c)
(equal (distance c a)
0.
0.0001
)
)
(cdr b)
)
)
)
(vl-remove x ssep)
)
)
)
(cdr x)
)
2lados (solod (apply 'append ladosx))
;; recoger solo cuando hay dos puntos sobre la entidad
contiguos ;; identificar con un número las coordendas para no guardad los puntos enteros
(mapcar
'(lambda (a / i)
(setq i -1)
(cons a
(vl-remove
nil
(mapcar '(lambda (b)
(setq i (1+ i))
(if (_vl-position a b 1e-6 nil)
i
)
)
ladosx
)
)
)
)
2lados
)
)
)
)
ssep
)
)
;; ordenar por número de lados y perímetro
(setq ssmaxl (car
;;; la entidad de mayor número de lados y perímetro
(setq ssnew
(vl-sort
ssnew
'(lambda (a b)
;; lista ordenada
(if (eq (length (last a)) (length (last b)))
(> (cadr a) (cadr b))
(> (length (last a)) (length (last b)))
)
)
)
)
)
)
(setq 3dfl (mapcar 'cdr ssep))
(setq 3dfdl (mapcar '(lambda (x) (mapcar '(lambda (p1 p2) (list p1 (distance p1 p2) p2)) x (append (cdr x) (list (car x))) )) 3dfl))
(setq ptdptl (apply 'append 3dfdl))
(setq ptdl (append (mapcar '(lambda (x) (list (car x) (cadr x))) ptdptl) (mapcar '(lambda (x) (list (caddr x) (cadr x))) ptdptl)))
(foreach ptd ptdl
(setq ptdln (cons (massoclst (car ptd) ptdl) ptdln))
)
(foreach ptd ptdln
(if (not (_vl-position (caar ptd) (mapcar 'car ptdlnn) 1e-6 nil))
(setq ptdlnn (cons (cons (caar ptd) (apply 'append (mapcar 'cdr ptd))) ptdlnn))
)
)
;; crear la primera cara aplanada desde ssmaxl
(setq name (car ssmaxl)
;; nombre primera entidad a dibujar
x (assoc name ssep)
;; datos de la entidad
listap (mapcar 'set '(p1 p2 p3) (cdr x))
ld (mapcar 'set
'(d d1 d2)
(mapcar 'distance (list p1 p2 p3) (list p2 p3 p1))
)
)
;|
;; entrada de datos
(setq p1 (getpoint "\nDonde pongo la primera entidad ? : ")
ang (angle p1 (getpoint "\nGiro para crear entidad : " p1))
p2 (polar p1 ang d)
p3 (intercc p1 d2 p2 d1 nil)
)
|;
(setq p1 (list (car p1) (cadr p1)))
(setq p2 (polar p1 (angle p1 p2) d))
(setq p3 (intercc p1 d2 p2 d1 nil))
;; dibujar la primera
(ent-3dcara (setq plano (list p1 p2 p3)))
(setq nnamesp (cons (cdr (assoc 5 (entget (entlast)))) nnamesp))
(setq ptdptlp (mapcar '(lambda (p1 p2) (list p1 (distance p1 p2) p2)) plano (append (cdr plano) (list (car plano)))))
(setq ptdlp (unique (append (mapcar '(lambda (x) (list (car x) (cadr x))) ptdptlp) (mapcar '(lambda (x) (list (caddr x) (cadr x))) ptdptlp))))
;; inicializarlistas para iterar
(setq ya (list (list name
;; lista con nombre endidad 3d
(cdr (assoc 5 (entget (entlast))))
;; nombre 2d
plano
;; puntos dibujados en 2d
)
)
names (mapcar 'car ssep)
;; lista solos con nombres
siguientes '()
;;; lista vacía para agrupar en orden
)
(setq nnames (cons name nnames))
;;;;;; bucle principal ;;;;;
(while (setq names (vl-remove name names))
;; mientras me quedan nombres guardados
(princ (strcat "\nBase para iterar " name))
;; nombre entidad dxf 5
;; buscamos colindantes
(setq x (last (assoc name ssnew))
;; nombre y datos entidades colindantes
plano (last (assoc name ya))
;; puntos de la entidad plana guardados en ya
origen (cdr (assoc name ssep))
;; puntos en el espacio de la entidad base
pref (3cdp plano)
;; referencia para dibujar p3
)
(foreach a x
(princ (strcat "\nComprobando " (car a)))
(if (_vl-position (car a) (mapcar 'car ya) 1e-6 nil)
;; si ya esta dibujada
(princ "\nDesarrollo ya dibujado ...")
(progn
(setq lp (cdr (assoc (car a) ssep))
;; sacamos tres puntos 3d del colindante
listap (mapcar 'set
'(p1 p2)
;; puntos de la linea colindantes
(mapcar '(lambda (b) (nth b origen)) (cdr a))
)
lp (vl-remove-if '(lambda (b) (_vl-position b listap 1e-6 nil)) lp)
p3 (car lp)
;; tercer punto
;; controlamos con un flag el sentido de giro
;|
flag (sentido (setq pro (3cdp listap)
pro (list (car pro) (cadr pro))
)
(setq
pro2 (inters
pro
(polar pro (+ (angle p1 p2) (/ pi 2)) 1)
;;; ojo aqui
(setq p (list (car p3) (cadr p3)))
(polar p (angle p1 p2) 1)
nil
)
)
p
)
|;
ld (mapcar 'set
'(d d1 d2)
(mapcar 'distance (list p1 p1 p2) (list p2 p3 p3))
)
)
;;; en teoría debería coincidir la seguencia de puntos en el espacio y en el plano
;; pero pudiera ser que no, así que lo sacamos igualando distancias d
(if (setq lp plano
lp (mapcar '(lambda (a b) (cons (distance a b) (list a b)))
lp
(append (cdr lp) (list (car lp)))
)
lp (vl-remove-if-not
'(lambda (a) (equal (car a) d 0.00001))
lp
)
)
(setq lp (car lp)
p1p (cadr lp)
p2p (last lp)
)
;; asignamos p1 y p2 por distancia d
;|
(setq p1 (nth (cadr a) plano)
p2 (nth (last a) plano)
)
;; asignamos p1 y p2 por secuencia en x
|;
)
(if (null ptdlpa) (setq ptdlpa (unique ptdlp)))
(cond
( (_vl-position d1 (assoc p1 ptdlnn) 1e-6 nil)
(if (vl-every '(lambda (x) (_vl-position x (assoc p1 ptdlnn) 1e-6 nil)) (apply 'append (mapcar 'cdr (massoclst p1p ptdlpa))))
;; calculas el punto del plano
(setq p3p (intercc p1p d1 p2p d2 pref)
listap (list p1p p2p p3p)
)
(setq p3p (intercc p2p d1 p1p d2 pref)
listap (list p1p p2p p3p)
)
)
)
;||;
( (_vl-position d2 (assoc p1 ptdlnn) 1e-6 nil)
(if (vl-every '(lambda (x) (_vl-position x (assoc p1 ptdlnn) 1e-6 nil)) (apply 'append (mapcar 'cdr (massoclst p1p ptdlpa))))
;; calculas el punto del plano
(setq p3p (intercc p1p d2 p2p d1 pref)
listap (list p1p p2p p3p)
)
(setq p3p (intercc p2p d2 p1p d1 pref)
listap (list p1p p2p p3p)
)
)
)
;||;
( t
(if (vl-every '(lambda (x) (_vl-position x (assoc p1 ptdlnn) 1e-6 nil)) (apply 'append (mapcar 'cdr (massoclst p1p ptdlpa))))
;; calculas el punto del plano
(setq p3p (intercc p1p d1 p2p d2 pref)
listap (list p1p p2p p3p)
)
(setq p3p (intercc p2p d1 p1p d2 pref)
listap (list p1p p2p p3p)
)
)
)
)
;|
;; corregimos con el flag por si se hubiera girado por la raiz cuadrada
(if (/= flag
(sentido (setq pro (3cdp (list p1 p2)))
(setq pro2
(inters pro
(polar pro (+ (angle p1 p2) (/ pi 2)) 1)
p3
(polar p3 (angle p1 p2) 1)
nil
)
)
p3
)
)
(setq p3 (intercc p1 d2 p2 d1 pref)
listap (list p1 p2 p3)
)
)
|;
(setq ptdptlp (mapcar '(lambda (p1 p2) (list p1 (distance p1 p2) p2)) listap (append (cdr listap) (list (car listap)))))
(setq ptdlpn (unique (append (mapcar '(lambda (x) (list (car x) (cadr x))) ptdptlp) (mapcar '(lambda (x) (list (caddr x) (cadr x))) ptdptlp))))
(setq ptdlpa (unique (append ptdlpn ptdlpa)))
(if
(equal ;; comprobación
(apply '+ (mapcar 'distance listap (list p2p p3p p1p)))
(cadr (assoc (car a) ssnew))
0.0001
)
(print (list (setq color "BYLAYER") "Suma perímetros OK"))
(print (list (setq color "2") "Suma perímetros MAL"))
)
;; centros alineados con p3
;; dibujamos
(setvar 'cecolor color)
(ent-3dcara (setq listap (list p1p p2p p3p)))
(setq nnamesp (cons (cdr (assoc 5 (entget (entlast)))) nnamesp))
(setq nnames (cons (vl-some '(lambda ( x ) (if (vl-every '(lambda ( y ) (_vl-position y x 1e-6 nil)) (list p1 p2 p3)) (car x))) ssep) nnames))
(setvar 'cecolor "BYLAYER")
;; añadimo los ya dibujados a lista ya
(setq ya (cons (list (car a)
(cdr (assoc 5 (entget (entlast))))
listap
)
ya
)
)
;; añadimos las entidades obtenidas de la lista x en siguientes
(if (not (_vl-position (car a) siguientes 1e-6 nil))
(setq siguientes (cons (car a) siguientes))
)
); fin progn
); fin if
); fin foreach
;; hacemos name igual al primer siguiente
(setq name (car siguientes)
siguientes (cdr siguientes)
)
;;;; (getstring "\nContinuar : ") ;; para comprobaciones
)
;; fin while
(setq nnames (reverse nnames))
(setq nnamesp (reverse nnamesp))
(setq 3dfrlp (mapcar '(lambda ( x ) (list (nth (vl-position (car x) nnames) nnamesp) (nth (vl-position (cadr x) nnames) nnamesp))) 3dfrl))
(foreach pair 3dfrlp
(mapcar 'set '(pt11 pt12 pt13 pt14) (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (vl-position (car x) '(10 11 12 13))) (entget (handent (car pair))))))
(mapcar 'set '(pt21 pt22 pt23 pt24) (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (vl-position (car x) '(10 11 12 13))) (entget (handent (cadr pair))))))
(setq d1l (vl-remove 0.0 (mapcar '(lambda ( a b ) (distance a b)) (list pt11 pt12 pt13 pt14) (list pt12 pt13 pt14 pt11))))
(setq d2l (vl-remove 0.0 (mapcar '(lambda ( a b ) (distance a b)) (list pt21 pt22 pt23 pt24) (list pt22 pt23 pt24 pt21))))
(setq ddl (unique (append d1l d2l)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (unique (append (list pt11 pt12 pt13 pt14) (list pt21 pt22 pt23 pt24))))
(cond
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt1 pt2) (distance pt2 pt3) (distance pt3 pt4) (distance pt4 pt1)))
nil
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt2 pt1) (distance pt1 pt3) (distance pt3 pt4) (distance pt4 pt2)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt2 pt1 pt3 pt4))
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt1 pt3) (distance pt3 pt2) (distance pt2 pt4) (distance pt4 pt1)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt1 pt3 pt2 pt4))
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt1 pt2) (distance pt2 pt4) (distance pt4 pt3) (distance pt3 pt1)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt1 pt2 pt4 pt3))
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt4 pt2) (distance pt2 pt3) (distance pt3 pt1) (distance pt1 pt4)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt4 pt2 pt3 pt1))
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt3 pt2) (distance pt2 pt1) (distance pt1 pt4) (distance pt4 pt3)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt3 pt2 pt1 pt4))
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt1 pt4) (distance pt4 pt3) (distance pt3 pt2) (distance pt2 pt1)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt1 pt4 pt3 pt2))
)
)
(entmake (list '(0 . "3DFACE") (cons 10 pt1) (cons 11 pt2) (cons 12 pt3) (cons 13 pt4)))
(entdel (handent (car pair)))
(entdel (handent (cadr pair)))
(entdel (handent (nth (vl-position (car pair) nnamesp) nnames)))
(entdel (handent (nth (vl-position (cadr pair) nnamesp) nnames)))
)
(princ "\nTerminado ...")
(princ)
)
;;fin defun
Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 22 of 37
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Here is my latest revision of Nolo's code... Should unfold 3dfaces with correct redistribution of vertices of unfolded 3dfaces... Only thing is that it's unreliable if 3dfaces (triangles) have equal sides ( 2 or even 3 sides ) as the code is using for now centroid - gravity center of triangles for calculating correct copy dispositions of vertices... But in the most cases as like with your one it should do the job... (c:foldline) is correct and can be applied on such unfolded 3dfaces...
Regards, HTH., M.R.
(I know that now this may be late, but try it - I am using it already...)
Link for (c:foldline) - for understanding what I was talking ab. :
https://www.theswamp.org/index.php?topic=43121.0
;;; ;;;
;;; by Nolo en Hispacad ;;;
;;; ;;;
(defun c:xxx1 (/ _vl-position massoclst sentido solod
3cdp ent-3dcara intercc unique ; funciones
;; variables
ss se ssep ssnew ssmaxl x name
listap lp ld d d1 d2 p
p1 p2 plano names siguiente pro
pro2 siguientes old 3dfl 3dfdl ptdptl
ptdl ptdln ptdlnn ptdptlp ptdlp ptdlpa p3p
p1p p2p *tol* s i 3df 3dfrl
3df1 3df2 pt1 pt2 pt3 pt4 nnames
nnamesp 3dfrlp pt11 pt12 pt13 pt14 pt21
pt22 pt23 pt24 d1l d2l ddl
elst elstdst dsts dstr
)
(defun unique ( l )
(or *tol* (setq *tol* 1e-6))
(if l (cons (car l) (unique (vl-remove-if '(lambda ( x ) (equal x (car l) *tol*)) l))))
)
;; (_vl-position 3.29 '(1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8 9.9) 0.01 nil) => 2 (!k => nil) ;;
(defun _vl-position ( e l tol k )
(if (null k)
(setq k 0)
)
(if (not (equal e (car l) tol))
(progn
(setq k (1+ k))
(if (cdr l)
(_vl-position e (cdr l) tol k)
(setq k nil)
)
)
k
)
)
(defun massoclst ( key lst )
(if (assoc key lst) (cons (assoc key lst) (massoclst key (cdr (member (assoc key lst) lst)))))
)
;;;; devuelve -1 0 1 segun alineación de los puntos a b c Tony Tanzillo
(defun sentido (a b c / r) ; de Tony Tanzillo modificada por Nolo
(setq r (- (* (- (car b) (car a)) (- (cadr c) (cadr a)))
(* (- (cadr b) (cadr a)) (- (car c) (car a)))
)
)
(if (equal r 0.0 0.00001)
0
(setq r (fix (/ r (abs r))))
)
)
;;; sacar solo datos duplicados en lista
(defun solod (lista / res)
;; By NOLO
(foreach a lista
(if (and (_vl-position a (cdr (member a lista)) *tol* nil) (not (_vl-position a res *tol* nil)))
(setq res (cons a res))
)
)
res
) ; centro de varios puntos en 3d
(defun 3cdp (pl / n) ; by ymg
(setq n (length pl))
(mapcar '(lambda (a) (/ a n)) (apply 'mapcar (cons '+ pl)))
)
;;;; dibujar cara 3d
(defun ent-3dcara (vertices)
;; TOGORES
(entmake (list '(0 . "3DFACE")
'(100 . "AcDbEntity")
'(100 . "AcDbFace")
(cons 10 (nth 0 vertices))
(cons 11 (nth 1 vertices))
(cons 12 (nth 2 vertices))
(if (nth 3 vertices)
(cons 13 (nth 3 vertices))
(cons 13 (nth 2 vertices))
)
)
)
)
;;intersección de dos circulos con un punto de referencia pref para validar una solución
(defun intercc (c1 r1 c2 r2 pref / salfa calfa d an p3)
;; TOGORES modificada por NOLO
(setq d (distance c1 c2)
an (angle c1 c2)
calfa (/ (- (+ (expt r1 2) (expt d 2)) (expt r2 2)) 2 r1 d)
salfa (sqrt (abs (- 1 (expt calfa 2))))
;;; problema raiz cuadrada en algunos valores negativos ???
;;; Problem, square root, in some negative values ???
)
(setq p3 (polar c1 (+ an (atan salfa calfa)) r1))
(if (and pref (= (sentido c1 c2 p3) (sentido c1 c2 pref)))
(setq p3 (polar c1 (- an (atan salfa calfa)) r1))
p3
)
)
;;;;;;;;;;;;;;;;; programa ;;;;;;;;;;;;;;;;;;
(setq *tol* 1e-6)
;; selección por ventana o crosing
(princ "\nSelect 3DFACES to unfold...")
(setq s (ssget '((0 . "3DFACE"))))
(repeat (setq i (sslength s))
(setq 3df (ssname s (setq i (1- i))))
(mapcar 'set '(pt1 pt2 pt3 pt4) (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (vl-position (car x) '(10 11 12 13))) (entget 3df))))
(if (and (not (equal pt1 pt2 *tol*)) (not (equal pt2 pt3 *tol*)) (not (equal pt3 pt4 *tol*)) (not (equal pt4 pt1 *tol*)))
(progn
(setq 3df1 (entmakex (list '(0 . "3DFACE") (cons 10 pt1) (cons 11 pt1) (cons 12 pt2) (cons 13 pt3))))
(setq 3df2 (entmakex (list '(0 . "3DFACE") (cons 10 pt3) (cons 11 pt3) (cons 12 pt4) (cons 13 pt1))))
(setq 3dfrl (cons (list (cdr (assoc 5 (entget 3df1))) (cdr (assoc 5 (entget 3df2)))) 3dfrl))
(ssdel 3df s)
(ssadd 3df1 s)
(ssadd 3df2 s)
)
)
)
(setq ss (ssadd))
(repeat (setq i (sslength s))
(ssadd (ssname s (setq i (1- i))) ss)
)
(setq elst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq elstdst (mapcar '(lambda ( x ) (list (distance (car x) (3cdp (unique (list (car x) (cadr x) (caddr x) (cadddr x))))) (distance (cadr x) (3cdp (unique (list (car x) (cadr x) (caddr x) (cadddr x))))) (distance (caddr x) (3cdp (unique (list (car x) (cadr x) (caddr x) (cadddr x))))) (distance (cadddr x) (3cdp (unique (list (car x) (cadr x) (caddr x) (cadddr x))))))) (mapcar '(lambda ( y ) (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (vl-position (car x) '(10 11 12 13))) (entget y)))) elst)))
(setq
;; conjunto selección
sse (vl-remove-if-not
'(lambda (a) (= (type a) 'ename))
(apply 'append (ssnamex ss))
)
;; lista con entidades
ssep (mapcar
'(lambda (x / e)
(setq e (entget x))
(cons
(cdr (assoc 5 e))
;; lista con hadled de entidad y puntos
(unique
(mapcar 'cdr
(vl-remove-if-not
'(lambda (a) (vl-position (car a) '(10 11 12 13)))
e
)
)
)
)
)
sse
)
)
;; buscamos colindancias y las guardamo en una nueva lista
;; lista con handled entidad, perímetro y colindantes
(setq
ssnew (mapcar
'(lambda (x / ladosx 2lados contiguos i)
(list
(car x)
;;; nombre entidad
(apply
'+
(mapcar 'distance
(cdr x)
(append (cdr (cdr x)) (list (car (cdr x))))
)
)
;; perímetrto
(setq ladosx (mapcar
'(lambda (a)
;; por cada 10 11 12 13 de x
(mapcar
'car
(vl-remove-if-not
'(lambda (b)
;; los que tiene un punto próximo
(vl-remove
nil
(mapcar '(lambda (c)
(equal (distance c a)
0.
0.0001
)
)
(cdr b)
)
)
)
(vl-remove x ssep)
)
)
)
(cdr x)
)
2lados (solod (apply 'append ladosx))
;; recoger solo cuando hay dos puntos sobre la entidad
contiguos ;; identificar con un número las coordendas para no guardad los puntos enteros
(mapcar
'(lambda (a / i)
(setq i -1)
(cons a
(vl-remove
nil
(mapcar '(lambda (b)
(setq i (1+ i))
(if (_vl-position a b *tol* nil)
i
)
)
ladosx
)
)
)
)
2lados
)
)
)
)
ssep
)
)
;; ordenar por número de lados y perímetro
(setq ssmaxl (car
;;; la entidad de mayor número de lados y perímetro
(setq ssnew
(vl-sort
ssnew
'(lambda (a b)
;; lista ordenada
(if (eq (length (last a)) (length (last b)))
(> (cadr a) (cadr b))
(> (length (last a)) (length (last b)))
)
)
)
)
)
)
(setq 3dfl (mapcar 'cdr ssep))
(setq 3dfdl (mapcar '(lambda (x) (mapcar '(lambda (p1 p2) (list p1 (distance p1 p2) p2)) x (append (cdr x) (list (car x))) )) 3dfl))
(setq ptdptl (apply 'append 3dfdl))
(setq ptdl (append (mapcar '(lambda (x) (list (car x) (cadr x))) ptdptl) (mapcar '(lambda (x) (list (caddr x) (cadr x))) ptdptl)))
(foreach ptd ptdl
(setq ptdln (cons (massoclst (car ptd) ptdl) ptdln))
)
(foreach ptd ptdln
(if (not (_vl-position (caar ptd) (mapcar 'car ptdlnn) *tol* nil))
(setq ptdlnn (cons (cons (caar ptd) (apply 'append (mapcar 'cdr ptd))) ptdlnn))
)
)
;; crear la primera cara aplanada desde ssmaxl
(setq name (car ssmaxl)
;; nombre primera entidad a dibujar
x (assoc name ssep)
;; datos de la entidad
listap (mapcar 'set '(p1 p2 p3) (cdr x))
ld (mapcar 'set
'(d d1 d2)
(mapcar 'distance (list p1 p2 p3) (list p2 p3 p1))
)
)
(setq p1 (list (car p1) (cadr p1)))
(setq p2 (polar p1 (angle p1 p2) d))
(setq p3 (intercc p1 d2 p2 d1 nil))
;; dibujar la primera
(ent-3dcara (setq plano (list p1 p2 p3)))
(setq nnamesp (cons (cdr (assoc 5 (entget (entlast)))) nnamesp))
(setq ptdptlp (mapcar '(lambda (p1 p2) (list p1 (distance p1 p2) p2)) plano (append (cdr plano) (list (car plano)))))
(setq ptdlp (unique (append (mapcar '(lambda (x) (list (car x) (cadr x))) ptdptlp) (mapcar '(lambda (x) (list (caddr x) (cadr x))) ptdptlp))))
;; inicializarlistas para iterar
(setq ya (list (list name
;; lista con nombre endidad 3d
(cdr (assoc 5 (entget (entlast))))
;; nombre 2d
plano
;; puntos dibujados en 2d
)
)
names (mapcar 'car ssep)
;; lista solos con nombres
siguientes '()
;;; lista vacía para agrupar en orden
)
(setq nnames (cons name nnames))
;;;;;; bucle principal ;;;;;
(while (setq names (vl-remove name names))
;; mientras me quedan nombres guardados
(princ (strcat "\nBase para iterar " name))
;; nombre entidad dxf 5
;; buscamos colindantes
(setq x (last (assoc name ssnew))
;; nombre y datos entidades colindantes
plano (last (assoc name ya))
;; puntos de la entidad plana guardados en ya
origen (cdr (assoc name ssep))
;; puntos en el espacio de la entidad base
pref (3cdp plano)
;; referencia para dibujar p3
)
(foreach a x
(princ (strcat "\nComprobando " (car a)))
(if (_vl-position (car a) (mapcar 'car ya) *tol* nil)
;; si ya esta dibujada
(princ "\nDesarrollo ya dibujado ...")
(progn
(setq lp (cdr (assoc (car a) ssep))
;; sacamos tres puntos 3d del colindante
listap (mapcar 'set
'(p1 p2)
;; puntos de la linea colindantes
(mapcar '(lambda (b) (nth b origen)) (cdr a))
)
lp (vl-remove-if '(lambda (b) (_vl-position b listap *tol* nil)) lp)
p3 (car lp)
ld (mapcar 'set
'(d d1 d2)
(mapcar 'distance (list p1 p1 p2) (list p2 p3 p3))
)
)
;;; en teoría debería coincidir la seguencia de puntos en el espacio y en el plano
;; pero pudiera ser que no, así que lo sacamos igualando distancias d
(if (setq lp plano
lp (mapcar '(lambda (a b) (cons (distance a b) (list a b)))
lp
(append (cdr lp) (list (car lp)))
)
lp (vl-remove-if-not
'(lambda (a) (equal (car a) d 0.00001))
lp
)
)
(setq lp (car lp)
p1p (cadr lp)
p2p (last lp)
)
)
(if (null ptdlpa) (setq ptdlpa (unique ptdlp)))
(cond
( (_vl-position d1 (assoc p1 ptdlnn) *tol* nil)
(if (vl-every '(lambda (x) (_vl-position x (assoc p1 ptdlnn) *tol* nil)) (apply 'append (mapcar 'cdr (massoclst p1p ptdlpa))))
;; calculas el punto del plano
(setq p3p (intercc p1p d1 p2p d2 pref)
listap (list p1p p2p p3p)
)
(setq p3p (intercc p2p d1 p1p d2 pref)
listap (list p1p p2p p3p)
)
)
)
;||;
( (_vl-position d2 (assoc p1 ptdlnn) *tol* nil)
(if (vl-every '(lambda (x) (_vl-position x (assoc p1 ptdlnn) *tol* nil)) (apply 'append (mapcar 'cdr (massoclst p1p ptdlpa))))
;; calculas el punto del plano
(setq p3p (intercc p1p d2 p2p d1 pref)
listap (list p1p p2p p3p)
)
(setq p3p (intercc p2p d2 p1p d1 pref)
listap (list p1p p2p p3p)
)
)
)
;||;
( t
(if (vl-every '(lambda (x) (_vl-position x (assoc p1 ptdlnn) *tol* nil)) (apply 'append (mapcar 'cdr (massoclst p1p ptdlpa))))
;; calculas el punto del plano
(setq p3p (intercc p1p d1 p2p d2 pref)
listap (list p1p p2p p3p)
)
(setq p3p (intercc p2p d1 p1p d2 pref)
listap (list p1p p2p p3p)
)
)
)
)
(setq ptdptlp (mapcar '(lambda (p1 p2) (list p1 (distance p1 p2) p2)) listap (append (cdr listap) (list (car listap)))))
(setq ptdlpn (unique (append (mapcar '(lambda (x) (list (car x) (cadr x))) ptdptlp) (mapcar '(lambda (x) (list (caddr x) (cadr x))) ptdptlp))))
(setq ptdlpa (unique (append ptdlpn ptdlpa)))
(if
(equal ;; comprobación
(apply '+ (mapcar 'distance listap (list p2p p3p p1p)))
(cadr (assoc (car a) ssnew))
0.0001
)
(print (list (setq color "BYLAYER") "Suma perímetros OK"))
(print (list (setq color "2") "Suma perímetros MAL"))
)
;; centros alineados con p3
;; dibujamos
(setvar 'cecolor color)
(setq dsts (list (distance p1p (3cdp (list p1p p2p p3p))) (distance p2p (3cdp (list p1p p2p p3p))) (distance p3p (3cdp (list p1p p2p p3p)))))
(vl-some '(lambda ( x )
(if
(and
(_vl-position (car dsts) x *tol* nil)
(_vl-position (cadr dsts) x *tol* nil)
(_vl-position (caddr dsts) x *tol* nil)
)
(setq dstr x)
)
) elstdst
)
(cond
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p1p p2p p3p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p1p p3p p2p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p2p p1p p3p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p3p p1p p2p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p2p p3p p1p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p3p p2p p1p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p1p p1p p2p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p1p p1p p3p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p1p p2p p1p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p1p p3p p1p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p2p p1p p1p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p3p p1p p1p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p2p p1p p3p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p2p p3p p1p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p1p p2p p3p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p3p p2p p1p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p1p p3p p2p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p3p p1p p2p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p2p p2p p1p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p2p p2p p3p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p2p p1p p2p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p2p p3p p2p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p1p p2p p2p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p3p p2p p2p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p3p p2p p1p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p3p p1p p2p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p2p p3p p1p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p1p p3p p2p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p2p p1p p3p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p1p p2p p3p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p3p p3p p2p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p3p p3p p1p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p3p p2p p3p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p3p p1p p3p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p2p p3p p3p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p1p p3p p3p))
)
)
(setq nnamesp (cons (cdr (assoc 5 (entget (entlast)))) nnamesp))
(setq nnames (cons (vl-some '(lambda ( x ) (if (vl-every '(lambda ( y ) (_vl-position y x *tol* nil)) (list p1 p2 p3)) (car x))) ssep) nnames))
(setvar 'cecolor "BYLAYER")
;; añadimo los ya dibujados a lista ya
(setq ya (cons (list (car a)
(cdr (assoc 5 (entget (entlast))))
listap
)
ya
)
)
;; añadimos las entidades obtenidas de la lista x en siguientes
(if (not (_vl-position (car a) siguientes *tol* nil))
(setq siguientes (cons (car a) siguientes))
)
); fin progn
); fin if
); fin foreach
;; hacemos name igual al primer siguiente
(setq name (car siguientes)
siguientes (cdr siguientes)
)
;;;; (getstring "\nContinuar : ") ;; para comprobaciones
)
;; fin while
(setq nnames (reverse nnames))
(setq nnamesp (reverse nnamesp))
(setq 3dfrlp (mapcar '(lambda ( x ) (list (nth (vl-position (car x) nnames) nnamesp) (nth (vl-position (cadr x) nnames) nnamesp))) 3dfrl))
(foreach pair 3dfrlp
(mapcar 'set '(pt11 pt12 pt13 pt14) (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (vl-position (car x) '(10 11 12 13))) (entget (handent (car pair))))))
(mapcar 'set '(pt21 pt22 pt23 pt24) (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (vl-position (car x) '(10 11 12 13))) (entget (handent (cadr pair))))))
(setq d1l (vl-remove 0.0 (mapcar '(lambda ( a b ) (distance a b)) (list pt11 pt12 pt13 pt14) (list pt12 pt13 pt14 pt11))))
(setq d2l (vl-remove 0.0 (mapcar '(lambda ( a b ) (distance a b)) (list pt21 pt22 pt23 pt24) (list pt22 pt23 pt24 pt21))))
(setq ddl (unique (append d1l d2l)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (unique (append (list pt11 pt12 pt13 pt14) (list pt21 pt22 pt23 pt24))))
(cond
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt1 pt2) (distance pt2 pt3) (distance pt3 pt4) (distance pt4 pt1)))
nil
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt2 pt1) (distance pt1 pt3) (distance pt3 pt4) (distance pt4 pt2)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt2 pt1 pt3 pt4))
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt1 pt3) (distance pt3 pt2) (distance pt2 pt4) (distance pt4 pt1)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt1 pt3 pt2 pt4))
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt1 pt2) (distance pt2 pt4) (distance pt4 pt3) (distance pt3 pt1)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt1 pt2 pt4 pt3))
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt4 pt2) (distance pt2 pt3) (distance pt3 pt1) (distance pt1 pt4)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt4 pt2 pt3 pt1))
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt3 pt2) (distance pt2 pt1) (distance pt1 pt4) (distance pt4 pt3)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt3 pt2 pt1 pt4))
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt1 pt4) (distance pt4 pt3) (distance pt3 pt2) (distance pt2 pt1)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt1 pt4 pt3 pt2))
)
)
(entmake (list '(0 . "3DFACE") (cons 10 pt1) (cons 11 pt2) (cons 12 pt3) (cons 13 pt4)))
(entdel (handent (car pair)))
(entdel (handent (cadr pair)))
(entdel (handent (nth (vl-position (car pair) nnamesp) nnames)))
(entdel (handent (nth (vl-position (cadr pair) nnamesp) nnames)))
)
(princ "\nTerminado ...")
(princ)
)
;;fin defun
Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 23 of 37
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Hello Brother how are you.
Sorry for my delay in answering.
I was doing several tests.
But I found that the same error still exists in the example given.
Could you try it on this dwg?
I also found this lisp Tailors, it has unfold, but it does not make them united.
In case it serves anything.
And you want to check it out.
Thanks.
AutoCAD 2026.1.1
Visual Studio Code 1.105.1
AutoCAD AutoLISP Extension 1.6.3
Windows 10 - 22H2 (64 bits)
Message 24 of 37
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Are you sure you use newest code I posted...
It unfolded for me...
M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 25 of 37
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Hello how are you.
If I use the new code.
Here I attach the error and how it would be correct.
AutoCAD 2026.1.1
Visual Studio Code 1.105.1
AutoCAD AutoLISP Extension 1.6.3
Windows 10 - 22H2 (64 bits)
Message 26 of 37
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
No, it's not error... Everything is done as computation was intended... It is just unusual way faces are unfolded, but if you check all dimensions are correct... I know - your setup is planar and just one 3dface was folded, so you copied and then just draw that one 3dface unfolded, but in fact there is no way you can program a code that will assume that situation... Nolo's code is good and unfolding is done correctly in terms of math and coding... The result is unexpected, so what, lisp was doing on the other hand exactly what should for unfolding to be connected in one lattice structure...
Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 27 of 37
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Hi brother.
I know all dimensions are fine.
But the order of the faces are the problem.
Well an error like that, would be reflected in costs.
And it is what must be prevented.
AutoCAD 2026.1.1
Visual Studio Code 1.105.1
AutoCAD AutoLISP Extension 1.6.3
Windows 10 - 22H2 (64 bits)
Message 28 of 37
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
@carlos_m_gil_p wrote:Hi brother.
I know all dimensions are fine.
But the order of the faces are the problem.
Well an error like that, would be reflected in costs.
And it is what must be prevented.
I've explained you... It can't be prevented...
Sorry, but that's the fact...
Even if the concept of the code would be completely different, for ex. using "ALIGN" command in 3D applied on copies of reference 3DFACES, there is no way you could program CAD to make decision where should 3rd point fall in plane, i.e. there are 2 solutions (points of intersection of 2 circles with different centers on common edge and different radius values each representing adjacent edge of 3dface distance)...
Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 29 of 37
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
And if all triangles are always drawn in the same direction.
Could that help for the location of the third point?
Thank you for your help.
AutoCAD 2026.1.1
Visual Studio Code 1.105.1
AutoCAD AutoLISP Extension 1.6.3
Windows 10 - 22H2 (64 bits)
Message 30 of 37
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
@carlos_m_gil_p wrote:
And if all triangles are always drawn in the same direction.
Could that help for the location of the third point?
Thank you for your help.
It could lead to some sort of simplification of problem, but I forgot to tell you another thing - if center of circles and circles of common edge should be at swapped place - there are actually 4 solutions where 3rd point should fall ( 2 points of 1st position and 2 points of swapped positions of circles )... So, how would you program solution for such problem? If you can answer to this, then coding is just a matter of dummy process...
For a my humble suggestion : if last posted code doesn't satisfy, try using previous by me (c:XXX) with only one branch for procession... It worked for me on your example, but branching should be then be solved separately - each branch and then at the end aligning them each into one whole composition of branched unfolded lattice structure...
Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 31 of 37
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Hi, Carlos... I think I fixed it... The only problem were (assoc) functions - it needed to be included tolerances...
;;; ;;;
;;; by Nolo en Hispacad ;;;
;;; ;;;
(defun c:unfold3dfaces (/ ;; funciones
_vl-position massoclst unique
3cdp solod ent-3dcara intercc sentido
;; variables
ptdstslst ptdst ptassoclst ptdstslstn ptassocdstsn ptdstsassoclst
ss se ssep ssnew ssmaxl x name
listap lp ld d d1 d2 p
p1 p2 plano names siguiente pro
pro2 siguientes old p3 origen ya
ptdlnn ptdptlp ptdlp ptdlpa p3p pref a
p1p p2p *tol* s i 3df 3dfrl
3df1 3df2 pt1 pt2 pt3 pt4 nnames
nnamesp 3dfrlp pt11 pt12 pt13 pt14 pt21
pt22 pt23 pt24 d1l d2l ddl
elst elstdst dsts dstr
)
;;; (unique '(1 1 2 3 3 4 5)) => '(1 2 3 4 5)
(defun unique ( l )
(or *tol* (setq *tol* 1e-6))
(if l (cons (car l) (unique (vl-remove-if '(lambda ( x ) (equal x (car l) *tol*)) l))))
)
;;; (_vl-position 3.29 '(1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8 9.9) 0.01 nil) => 2 (!k => nil) ;;
(defun _vl-position ( e l tol k )
(if (null k)
(setq k 0)
)
(if (not (equal e (car l) tol))
(progn
(setq k (1+ k))
(if (cdr l)
(_vl-position e (cdr l) tol k)
(setq k nil)
)
)
k
)
)
;;; (massoclst 10 '((10 0 0 0) (10 0 0 1) (10 0 1 0) (10 1 0 0) (11 0 0 0) (11 0 0 1) (11 0 1 0) (11 1 0 0))) => '((10 0 0 0) (10 0 0 1) (10 0 1 0) (10 1 0 0))
(defun massoclst ( key lst )
(or *tol* (setq *tol* 1e-6))
(if (vl-member-if '(lambda ( x ) (equal key (car x) *tol*)) lst) (cons (car (vl-member-if '(lambda ( x ) (equal key (car x) *tol*)) lst)) (massoclst key (cdr (vl-member-if '(lambda ( x ) (equal key (car x) *tol*)) lst)))))
)
;;; devuelve -1 0 1 segun alineación de los puntos a b c Tony Tanzillo
(defun sentido (a b c / r) ; de Tony Tanzillo modificada por Nolo
(setq r (- (* (- (car b) (car a)) (- (cadr c) (cadr a)))
(* (- (cadr b) (cadr a)) (- (car c) (car a)))
)
)
(if (equal r 0.0 0.00001)
0
(setq r (fix (/ r (abs r))))
)
)
;;; sacar solo datos duplicados en lista
(defun solod (lista / res)
;; By NOLO
(foreach a lista
(if (and (_vl-position a (cdr (member a lista)) *tol* nil) (not (_vl-position a res *tol* nil)))
(setq res (cons a res))
)
)
res
)
;;; centro de varios puntos en 3d
;;; (3cp (list p1 p2 p3)) => (mapcar '/ (mapcar '+ p1 p2 p3) (list 3.0 3.0 3.0))
;;; (3cp (list p1 p2 p3 p4 p5)) => (mapcar '/ (mapcar '+ p1 p2 p3 p4 p5) (list 5.0 5.0 5.0))
;;; (3cp (list (list x1 y1 z1 l1 m1) (list x2 y2 z2 l2 m2)) => (mapcar '/ (mapcar '+ (list x1 y1 z1 l1 m1) (list x2 y2 z2 l2 m2)) (list 2.0 2.0 2.0 2.0 2.0))
(defun 3cdp ( pl / n ) ; by ymg
(setq n (length pl))
(mapcar '(lambda ( a ) (/ a n)) (apply 'mapcar (cons '+ pl)))
)
;;; dibujar cara 3d
;;; (ent-3dcara (list v1 v2 v3 v4)) => 3DFACE (v1 v2 v3 v4)
;;; (ent-3dcara (list v1 v2 v3)) => 3DFACE (v1 v2 v3 v1)
(defun ent-3dcara (vertices)
;; TOGORES
(entmake (list '(0 . "3DFACE")
'(100 . "AcDbEntity")
'(100 . "AcDbFace")
(cons 10 (nth 0 vertices))
(cons 11 (nth 1 vertices))
(cons 12 (nth 2 vertices))
(if (nth 3 vertices)
(cons 13 (nth 3 vertices))
(cons 13 (nth 0 vertices))
)
)
)
)
;;; intersección de dos circulos con un punto de referencia pref para validar una solución
(defun intercc ( c1 r1 c2 r2 pref / salfa calfa d an p3 )
;; TOGORES modificada por NOLO
(setq d (distance c1 c2)
an (angle c1 c2)
calfa (/ (- (+ (expt r1 2) (expt d 2)) (expt r2 2)) 2 r1 d)
salfa (sqrt (abs (- 1 (expt calfa 2))))
;;; problema raiz cuadrada en algunos valores negativos ???
;;; Problem, square root, in some negative values ???
)
(setq p3 (polar c1 (+ an (atan salfa calfa)) r1))
(if (and pref (= (sentido c1 c2 p3) (sentido c1 c2 pref)))
(setq p3 (polar c1 (- an (atan salfa calfa)) r1))
p3
)
)
;;;;;;;;;;;;;;;;; programa ;;;;;;;;;;;;;;;;;;
(setq *tol* 1e-6)
;; selección por ventana o crosing
(princ "\nSelect 3DFACES to unfold...")
(setq s (ssget '((0 . "3DFACE"))))
(repeat (setq i (sslength s))
(setq 3df (ssname s (setq i (1- i))))
(mapcar 'set '(pt1 pt2 pt3 pt4) (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (vl-position (car x) '(10 11 12 13))) (entget 3df))))
(if (and (not (equal pt1 pt2 *tol*)) (not (equal pt2 pt3 *tol*)) (not (equal pt3 pt4 *tol*)) (not (equal pt4 pt1 *tol*)))
(progn
(setq 3df1 (entmakex (list '(0 . "3DFACE") (cons 10 pt1) (cons 11 pt1) (cons 12 pt2) (cons 13 pt3))))
(setq ptdstslst (cons (list pt1 (distance pt1 pt2)) ptdstslst))
(setq ptdstslst (cons (list pt2 (distance pt2 pt1)) ptdstslst))
(setq ptdstslst (cons (list pt2 (distance pt2 pt3)) ptdstslst))
(setq ptdstslst (cons (list pt3 (distance pt3 pt2)) ptdstslst))
(setq ptdstslst (cons (list pt3 (distance pt3 pt1)) ptdstslst))
(setq ptdstslst (cons (list pt1 (distance pt1 pt3)) ptdstslst))
(setq 3df2 (entmakex (list '(0 . "3DFACE") (cons 10 pt3) (cons 11 pt3) (cons 12 pt4) (cons 13 pt1))))
(setq ptdstslst (cons (list pt3 (distance pt3 pt4)) ptdstslst))
(setq ptdstslst (cons (list pt4 (distance pt4 pt3)) ptdstslst))
(setq ptdstslst (cons (list pt4 (distance pt4 pt1)) ptdstslst))
(setq ptdstslst (cons (list pt1 (distance pt1 pt4)) ptdstslst))
(setq ptdstslst (cons (list pt1 (distance pt1 pt3)) ptdstslst))
(setq ptdstslst (cons (list pt3 (distance pt3 pt1)) ptdstslst))
(setq 3dfrl (cons (list (cdr (assoc 5 (entget 3df1))) (cdr (assoc 5 (entget 3df2)))) 3dfrl))
(ssdel 3df s)
(ssadd 3df1 s)
(ssadd 3df2 s)
)
)
(setq ptdstslst (cons (list pt1 (distance pt1 pt2)) ptdstslst))
(setq ptdstslst (cons (list pt2 (distance pt2 pt1)) ptdstslst))
(setq ptdstslst (cons (list pt2 (distance pt2 pt3)) ptdstslst))
(setq ptdstslst (cons (list pt3 (distance pt3 pt2)) ptdstslst))
(setq ptdstslst (cons (list pt3 (distance pt3 pt4)) ptdstslst))
(setq ptdstslst (cons (list pt4 (distance pt4 pt3)) ptdstslst))
(setq ptdstslst (cons (list pt4 (distance pt4 pt1)) ptdstslst))
(setq ptdstslst (cons (list pt1 (distance pt1 pt4)) ptdstslst))
)
(setq ptdstslst (vl-remove-if '(lambda ( x ) (equal (cadr x) 0.0 *tol*)) ptdstslst))
(setq ptdstslst (unique ptdstslst))
(while (setq ptdst (car ptdstslst))
(setq ptassoclst (massoclst (car ptdst) ptdstslst))
(foreach ptdstassoc ptassoclst
(setq ptdstslst (vl-remove ptdstassoc ptdstslst))
)
(setq ptdstslstn (cons ptassoclst ptdstslstn))
)
(foreach ptassoclst ptdstslstn
(setq ptassocdstsn (cons (caar ptassoclst) (mapcar 'cadr ptassoclst)))
(setq ptdstsassoclst (cons ptassocdstsn ptdstsassoclst))
)
(setq ss (ssadd))
(repeat (setq i (sslength s))
(ssadd (ssname s (setq i (1- i))) ss)
)
(setq elst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq elstdst (mapcar '(lambda ( x ) (list (distance (car x) (3cdp (unique (list (car x) (cadr x) (caddr x) (cadddr x))))) (distance (cadr x) (3cdp (unique (list (car x) (cadr x) (caddr x) (cadddr x))))) (distance (caddr x) (3cdp (unique (list (car x) (cadr x) (caddr x) (cadddr x))))) (distance (cadddr x) (3cdp (unique (list (car x) (cadr x) (caddr x) (cadddr x))))))) (mapcar '(lambda ( y ) (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (vl-position (car x) '(10 11 12 13))) (entget y)))) elst)))
(setq
;; conjunto selección
sse (vl-remove-if-not
'(lambda ( a ) (= (type a) 'ename))
(apply 'append (ssnamex ss))
)
;; lista con entidades
ssep (mapcar
'(lambda ( x / e )
(setq e (entget x))
(cons
(cdr (assoc 5 e))
;; lista con hadled de entidad y puntos
(unique
(mapcar 'cdr
(vl-remove-if-not
'(lambda ( a ) (vl-position (car a) '(10 11 12 13)))
e
)
)
)
)
)
sse
)
)
;; buscamos colindancias y las guardamo en una nueva lista
;; lista con handled entidad, perímetro y colindantes
(setq
ssnew (mapcar
'(lambda ( x / ladosx 2lados contiguos i )
(list
(car x)
;;; nombre entidad
(apply
'+
(mapcar 'distance
(cdr x)
(append (cdr (cdr x)) (list (car (cdr x))))
)
)
;; perímetrto
(setq ladosx (mapcar
'(lambda ( a )
;; por cada 10 11 12 13 de x
(mapcar
'car
(vl-remove-if-not
'(lambda ( b )
;; los que tiene un punto próximo
(vl-remove
nil
(mapcar '(lambda ( c )
(equal (distance c a)
0.
0.0001
)
)
(cdr b)
)
)
)
(vl-remove x ssep)
)
)
)
(cdr x)
)
2lados (solod (apply 'append ladosx))
;; recoger solo cuando hay dos puntos sobre la entidad
contiguos ;; identificar con un número las coordendas para no guardad los puntos enteros
(mapcar
'(lambda ( a / i )
(setq i -1)
(cons a
(vl-remove
nil
(mapcar '(lambda ( b )
(setq i (1+ i))
(if (_vl-position a b *tol* nil)
i
)
)
ladosx
)
)
)
)
2lados
)
)
)
)
ssep
)
)
;; ordenar por número de lados y perímetro
(setq ssmaxl (car
;;; la entidad de mayor número de lados y perímetro
(setq ssnew
(vl-sort
ssnew
'(lambda ( a b )
;; lista ordenada
(if (eq (length (last a)) (length (last b)))
(> (cadr a) (cadr b))
(> (length (last a)) (length (last b)))
)
)
)
)
)
)
(setq ptdlnn ptdstsassoclst)
;; crear la primera cara aplanada desde ssmaxl
(setq name (car ssmaxl)
;; nombre primera entidad a dibujar
x (assoc name ssep)
;; datos de la entidad
listap (mapcar 'set '(p1 p2 p3) (cdr x))
ld (mapcar 'set
'(d d1 d2)
(mapcar 'distance (list p1 p2 p3) (list p2 p3 p1))
)
)
(setq p1 (list (car p1) (cadr p1)))
(setq p2 (polar p1 (angle p1 p2) d))
(setq p3 (intercc p1 d2 p2 d1 nil))
;; dibujar la primera
(ent-3dcara (setq plano (list p1 p2 p3)))
(setq nnamesp (cons (cdr (assoc 5 (entget (entlast)))) nnamesp))
(setq ptdptlp (mapcar '(lambda ( p1 p2 ) (list p1 (distance p1 p2) p2)) plano (append (cdr plano) (list (car plano)))))
(setq ptdlp (unique (append (mapcar '(lambda ( x ) (list (car x) (cadr x))) ptdptlp) (mapcar '(lambda ( x ) (list (caddr x) (cadr x))) ptdptlp))))
;; inicializarlistas para iterar
(setq ya (list (list name
;; lista con nombre endidad 3d
(cdr (assoc 5 (entget (entlast))))
;; nombre 2d
plano
;; puntos dibujados en 2d
)
)
names (mapcar 'car ssep)
;; lista solos con nombres
siguientes '()
;;; lista vacía para agrupar en orden
)
(setq nnames (cons name nnames))
;;;;;; bucle principal ;;;;;
(while (setq names (vl-remove name names))
;; mientras me quedan nombres guardados
(princ (strcat "\nBase para iterar " name))
;; nombre entidad dxf 5
;; buscamos colindantes
(setq x (last (assoc name ssnew))
;; nombre y datos entidades colindantes
plano (last (assoc name ya))
;; puntos de la entidad plana guardados en ya
origen (cdr (assoc name ssep))
;; puntos en el espacio de la entidad base
pref (3cdp plano)
;; referencia para dibujar p3
)
(foreach a x
(princ (strcat "\nComprobando " (car a)))
(if (_vl-position (car a) (mapcar 'car ya) *tol* nil)
;; si ya esta dibujada
(princ "\nDesarrollo ya dibujado ...")
(progn
(setq lp (cdr (assoc (car a) ssep))
;; sacamos tres puntos 3d del colindante
listap (mapcar 'set
'(p1 p2)
;; puntos de la linea colindantes
(mapcar '(lambda ( b ) (nth b origen)) (cdr a))
)
lp (vl-remove-if '(lambda ( b ) (_vl-position b listap *tol* nil)) lp)
p3 (car lp)
ld (mapcar 'set
'(d d1 d2)
(mapcar 'distance (list p1 p1 p2) (list p2 p3 p3))
)
)
;;; en teoría debería coincidir la seguencia de puntos en el espacio y en el plano
;; pero pudiera ser que no, así que lo sacamos igualando distancias d
(if (setq lp plano
lp (mapcar '(lambda ( a b ) (cons (distance a b) (list a b)))
lp
(append (cdr lp) (list (car lp)))
)
lp (vl-remove-if-not
'(lambda ( a ) (equal (car a) d 0.00001))
lp
)
)
(setq lp (car lp)
p1p (cadr lp)
p2p (last lp)
)
)
(if (null ptdlpa) (setq ptdlpa (unique ptdlp)))
(cond
( (_vl-position d1 (car (vl-member-if '(lambda ( x ) (equal (car x) p1 *tol*)) ptdlnn)) *tol* nil)
(if (vl-every '(lambda ( x ) (_vl-position x (car (vl-member-if '(lambda ( x ) (equal (car x) p1 *tol*)) ptdlnn)) *tol* nil)) (apply 'append (mapcar 'cdr (massoclst p1p ptdlpa))))
;; calculas el punto del plano
(setq p3p (intercc p1p d1 p2p d2 pref)
listap (list p1p p2p p3p)
)
(setq p3p (intercc p2p d1 p1p d2 pref)
listap (list p1p p2p p3p)
)
)
)
( (_vl-position d2 (car (vl-member-if '(lambda ( x ) (equal (car x) p1 *tol*)) ptdlnn)) *tol* nil)
(if (vl-every '(lambda ( x ) (_vl-position x (car (vl-member-if '(lambda ( x ) (equal (car x) p1 *tol*)) ptdlnn)) *tol* nil)) (apply 'append (mapcar 'cdr (massoclst p1p ptdlpa))))
;; calculas el punto del plano
(setq p3p (intercc p1p d2 p2p d1 pref)
listap (list p1p p2p p3p)
)
(setq p3p (intercc p2p d2 p1p d1 pref)
listap (list p1p p2p p3p)
)
)
)
( t
(if (vl-every '(lambda ( x ) (_vl-position x (car (vl-member-if '(lambda ( x ) (equal (car x) p1 *tol*)) ptdlnn)) *tol* nil)) (apply 'append (mapcar 'cdr (massoclst p1p ptdlpa))))
;; calculas el punto del plano
(setq p3p (intercc p1p d1 p2p d2 pref)
listap (list p1p p2p p3p)
)
(setq p3p (intercc p2p d1 p1p d2 pref)
listap (list p1p p2p p3p)
)
)
)
)
(setq ptdptlp (mapcar '(lambda ( p1 p2 ) (list p1 (distance p1 p2) p2)) listap (append (cdr listap) (list (car listap)))))
(setq ptdlpn (unique (append (mapcar '(lambda ( x ) (list (car x) (cadr x))) ptdptlp) (mapcar '(lambda ( x ) (list (caddr x) (cadr x))) ptdptlp))))
(setq ptdlpa (unique (append ptdlpn ptdlpa)))
(if
(equal ;; comprobación
(apply '+ (mapcar 'distance listap (list p2p p3p p1p)))
(cadr (assoc (car a) ssnew))
0.0001
)
(print (list (setq color "BYLAYER") "Suma perímetros OK"))
(print (list (setq color "2") "Suma perímetros MAL"))
)
;; centros alineados con p3
;; dibujamos
(setvar 'cecolor color)
(setq dsts (list (distance p1p (3cdp (list p1p p2p p3p))) (distance p2p (3cdp (list p1p p2p p3p))) (distance p3p (3cdp (list p1p p2p p3p)))))
(vl-some '(lambda ( x )
(if
(and
(_vl-position (car dsts) x *tol* nil)
(_vl-position (cadr dsts) x *tol* nil)
(_vl-position (caddr dsts) x *tol* nil)
)
(setq dstr x)
)
) elstdst
)
(cond
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p1p p2p p3p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p1p p3p p2p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p2p p1p p3p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p3p p1p p2p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p2p p3p p1p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p3p p2p p1p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p1p p1p p2p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p1p p1p p3p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p1p p2p p1p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p1p p3p p1p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p2p p1p p1p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p3p p1p p1p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p2p p1p p3p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p2p p3p p1p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p1p p2p p3p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p3p p2p p1p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p1p p3p p2p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p3p p1p p2p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p2p p2p p1p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p2p p2p p3p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p2p p1p p2p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p2p p3p p2p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p1p p2p p2p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p3p p2p p2p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p3p p2p p1p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p3p p1p p2p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p2p p3p p1p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p1p p3p p2p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p2p p1p p3p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p1p p2p p3p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p3p p3p p2p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p3p p3p p1p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p3p p2p p3p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p3p p1p p3p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p2p p3p p3p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p1p p3p p3p))
)
)
(setq nnamesp (cons (cdr (assoc 5 (entget (entlast)))) nnamesp))
(setq nnames (cons (vl-some '(lambda ( x ) (if (vl-every '(lambda ( y ) (_vl-position y x *tol* nil)) (list p1 p2 p3)) (car x))) ssep) nnames))
(setvar 'cecolor "BYLAYER")
;; añadimo los ya dibujados a lista ya
(setq ya (cons (list (car a)
(cdr (assoc 5 (entget (entlast))))
listap
)
ya
)
)
;; añadimos las entidades obtenidas de la lista x en siguientes
(if (not (_vl-position (car a) siguientes *tol* nil))
(setq siguientes (cons (car a) siguientes))
)
); fin progn
); fin if
); fin foreach
;; hacemos name igual al primer siguiente
(setq name (car siguientes)
siguientes (cdr siguientes)
)
)
;; fin while
(setq nnames (reverse nnames))
(setq nnamesp (reverse nnamesp))
(setq 3dfrlp (mapcar '(lambda ( x ) (list (nth (vl-position (car x) nnames) nnamesp) (nth (vl-position (cadr x) nnames) nnamesp))) 3dfrl))
(foreach pair 3dfrlp
(mapcar 'set '(pt11 pt12 pt13 pt14) (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (vl-position (car x) '(10 11 12 13))) (entget (handent (car pair))))))
(mapcar 'set '(pt21 pt22 pt23 pt24) (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (vl-position (car x) '(10 11 12 13))) (entget (handent (cadr pair))))))
(setq d1l (vl-remove 0.0 (mapcar '(lambda ( a b ) (distance a b)) (list pt11 pt12 pt13 pt14) (list pt12 pt13 pt14 pt11))))
(setq d2l (vl-remove 0.0 (mapcar '(lambda ( a b ) (distance a b)) (list pt21 pt22 pt23 pt24) (list pt22 pt23 pt24 pt21))))
(setq ddl (unique (append d1l d2l)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (unique (append (list pt11 pt12 pt13 pt14) (list pt21 pt22 pt23 pt24))))
(cond
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt1 pt2) (distance pt2 pt3) (distance pt3 pt4) (distance pt4 pt1)))
nil
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt2 pt1) (distance pt1 pt3) (distance pt3 pt4) (distance pt4 pt2)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt2 pt1 pt3 pt4))
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt1 pt3) (distance pt3 pt2) (distance pt2 pt4) (distance pt4 pt1)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt1 pt3 pt2 pt4))
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt1 pt2) (distance pt2 pt4) (distance pt4 pt3) (distance pt3 pt1)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt1 pt2 pt4 pt3))
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt4 pt2) (distance pt2 pt3) (distance pt3 pt1) (distance pt1 pt4)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt4 pt2 pt3 pt1))
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt3 pt2) (distance pt2 pt1) (distance pt1 pt4) (distance pt4 pt3)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt3 pt2 pt1 pt4))
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt1 pt4) (distance pt4 pt3) (distance pt3 pt2) (distance pt2 pt1)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt1 pt4 pt3 pt2))
)
)
(entmake (list '(0 . "3DFACE") (cons 10 pt1) (cons 11 pt2) (cons 12 pt3) (cons 13 pt4)))
(entdel (handent (car pair)))
(entdel (handent (cadr pair)))
(entdel (handent (nth (vl-position (car pair) nnamesp) nnames)))
(entdel (handent (nth (vl-position (cadr pair) nnamesp) nnames)))
)
(princ "\nTerminado ...")
(princ)
)
;;fin defunI hope that now everything is fine... I am not quite 100% sure, but it worked for me on your example, so if you find something else, inform me...
Regards, M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 32 of 37
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Unfortunately, I thought I solved it, but new issue appeared... That's why I said I am not 100% sure... But on the other hand, maybe someone doesn't find this so much problematic... Look in attached DWG... My latest code unfolded everything fine except this what is shown in DWG...
Sorry, I don't have patience any more, maybe someone else will solve and this in the future...
Regards, M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 33 of 37
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
I solved and this problem... It turned out that I have to change something in regard to sub functions, so I've excluded Nolo's and added mine... On particular DWG I posted in previous post issue was between else and tolerance factor - so I have strict tolerance even more from 1e-6 to 1e-8... This solution is now different in the fact that in some cases it may draw everything mirrored, but that's not real problem, you just mirror complete unfolded solution in WCS plane and you get correct lattice in plane... So now I am pretty sure that that's as good as it could be... I hope I'll get at least a kudo for this if you are still following me... If you have some questions, or again if something else appears, inform me... So finally I hope you're now satisfied...
;;; ;;;
;;; by Nolo en Hispacad ;;;
;;; ;;;
(defun c:unfold3dfaces (/ ;; funciones
_vl-position massoclst unique
3cdp solod ent-3dcara LM:int-ci-ci ptinsidetriangle-p
;; variables
ptdstslst ptdst ptassoclst ptdstslstn ptassocdstsn ptdstsassoclst
ss se ssep ssnew ssmaxl x name
listap lp ld d d1 d2 p
p1 p2 plano names siguiente pro
pro2 siguientes old p3 origen ya
ptdlnn ptdptlp ptdlp ptdlpa p3p p3p1 p3p2
p1p p2p *tol* s i 3df 3dfrl
3df1 3df2 pt1 pt2 pt3 pt4 nnames
nnamesp 3dfrlp pt11 pt12 pt13 pt14 pt21
pt22 pt23 pt24 d1l d2l ddl
elst elstdst dsts dstr
)
;;; (unique '(1 1 2 3 3 4 5)) => '(1 2 3 4 5)
(defun unique ( l )
(or *tol* (setq *tol* 1e-6))
(if l (cons (car l) (unique (vl-remove-if '(lambda ( x ) (equal x (car l) *tol*)) l))))
)
;;; (_vl-position 3.29 '(1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8 9.9) 0.01 nil) => 2 (!k => nil) ;;
(defun _vl-position ( e l tol k )
(if (null k)
(setq k 0)
)
(if (not (equal e (car l) tol))
(progn
(setq k (1+ k))
(if (cdr l)
(_vl-position e (cdr l) tol k)
(setq k nil)
)
)
k
)
)
;;; (massoclst 10 '((10 0 0 0) (10 0 0 1) (10 0 1 0) (10 1 0 0) (11 0 0 0) (11 0 0 1) (11 0 1 0) (11 1 0 0))) => '((10 0 0 0) (10 0 0 1) (10 0 1 0) (10 1 0 0))
(defun massoclst ( key lst )
(or *tol* (setq *tol* 1e-6))
(if (vl-member-if '(lambda ( x ) (equal key (car x) *tol*)) lst) (cons (car (vl-member-if '(lambda ( x ) (equal key (car x) *tol*)) lst)) (massoclst key (cdr (vl-member-if '(lambda ( x ) (equal key (car x) *tol*)) lst)))))
)
;|
;;; devuelve -1 0 1 segun alineación de los puntos a b c Tony Tanzillo
(defun sentido (a b c / r) ; de Tony Tanzillo modificada por Nolo
(setq r (- (* (- (car b) (car a)) (- (cadr c) (cadr a)))
(* (- (cadr b) (cadr a)) (- (car c) (car a)))
)
)
(if (equal r 0.0 0.00001)
0
(setq r (fix (/ r (abs r))))
)
)
|;
;;; sacar solo datos duplicados en lista
(defun solod (lista / res)
;; By NOLO
(foreach a lista
(if (and (_vl-position a (cdr (member a lista)) *tol* nil) (not (_vl-position a res *tol* nil)))
(setq res (cons a res))
)
)
res
)
;;; centro de varios puntos en 3d
;;; (3cp (list p1 p2 p3)) => (mapcar '/ (mapcar '+ p1 p2 p3) (list 3.0 3.0 3.0))
;;; (3cp (list p1 p2 p3 p4 p5)) => (mapcar '/ (mapcar '+ p1 p2 p3 p4 p5) (list 5.0 5.0 5.0))
;;; (3cp (list (list x1 y1 z1 l1 m1) (list x2 y2 z2 l2 m2)) => (mapcar '/ (mapcar '+ (list x1 y1 z1 l1 m1) (list x2 y2 z2 l2 m2)) (list 2.0 2.0 2.0 2.0 2.0))
(defun 3cdp ( pl / n ) ; by ymg
(setq n (length pl))
(mapcar '(lambda ( a ) (/ a n)) (apply 'mapcar (cons '+ pl)))
)
;;; dibujar cara 3d
;;; (ent-3dcara (list v1 v2 v3 v4)) => 3DFACE (v1 v2 v3 v4)
;;; (ent-3dcara (list v1 v2 v3)) => 3DFACE (v1 v2 v3 v1)
(defun ent-3dcara ( vertices )
;; TOGORES
(entmake (list '(0 . "3DFACE")
'(100 . "AcDbEntity")
'(100 . "AcDbFace")
(cons 10 (nth 0 vertices))
(cons 11 (nth 1 vertices))
(cons 12 (nth 2 vertices))
(if (nth 3 vertices)
(cons 13 (nth 3 vertices))
(cons 13 (nth 0 vertices))
)
)
)
)
;|
;;; intersección de dos circulos con un punto de referencia pref para validar una solución
(defun intercc ( c1 r1 c2 r2 pref / salfa calfa d an p3 )
;; TOGORES modificada por NOLO
(setq d (distance c1 c2)
an (angle c1 c2)
calfa (/ (- (+ (expt r1 2) (expt d 2)) (expt r2 2)) 2 r1 d)
salfa (sqrt (abs (- 1 (expt calfa 2))))
;;; problema raiz cuadrada en algunos valores negativos ???
;;; Problem, square root, in some negative values ???
)
(setq p3 (polar c1 (+ an (atan salfa calfa)) r1))
(if (and pref (= (sentido c1 c2 p3) (sentido c1 c2 pref)))
(setq p3 (polar c1 (- an (atan salfa calfa)) r1))
p3
)
)
|;
;; 2-Circle Intersection (trans version) - Lee Mac
;; Returns the point(s) of intersection between two circles
;; with centres c1,c2 and radii r1,r2
(defun LM:int-ci-ci ( c1 r1 c2 r2 / *n* *d1* *x* *z* )
(if
(and
(< (setq *d1* (distance c1 c2)) (+ r1 r2))
(< (abs (- r1 r2)) *d1*)
)
(progn
(setq *n* (mapcar '- c2 c1))
(setq c1 (trans c1 0 *n*))
(setq *z* (/ (- (+ (* r1 r1) (* *d1* *d1*)) (* r2 r2)) (+ *d1* *d1*)))
(if (equal *z* r1 1e-8)
(list (trans (list (car c1) (cadr c1) (+ (caddr c1) *z*)) *n* 0))
(progn
(setq *x* (sqrt (- (* r1 r1) (* *z* *z*))))
(list
(trans (list (- (car c1) *x*) (cadr c1) (+ (caddr c1) *z*)) *n* 0)
(trans (list (+ (car c1) *x*) (cadr c1) (+ (caddr c1) *z*)) *n* 0)
)
)
)
)
)
)
;; (ptinsidetriangle-p '(0 0 0) '(-1 -1 0) '(1 -1 0) '(0 1 0)) => T
(defun ptinsidetriangle-p ( pt p1 p2 p3 )
(and
(not
(or
(inters pt p1 p2 p3)
(inters pt p2 p1 p3)
(inters pt p3 p1 p2)
)
)
(not
(or
(> (+ (distance pt p1) (distance pt p2)) (+ (distance p3 p1) (distance p3 p2)))
(> (+ (distance pt p2) (distance pt p3)) (+ (distance p1 p2) (distance p1 p3)))
(> (+ (distance pt p3) (distance pt p1)) (+ (distance p2 p3) (distance p2 p1)))
)
)
)
)
;;;;;;;;;;;;;;;;; programa ;;;;;;;;;;;;;;;;;;
(setq *tol* 1e-8)
;; selección por ventana o crosing
(princ "\nSelect 3DFACES to unfold...")
(setq s (ssget '((0 . "3DFACE"))))
(repeat (setq i (sslength s))
(setq 3df (ssname s (setq i (1- i))))
(mapcar 'set '(pt1 pt2 pt3 pt4) (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (vl-position (car x) '(10 11 12 13))) (entget 3df))))
(if (and (not (equal pt1 pt2 *tol*)) (not (equal pt2 pt3 *tol*)) (not (equal pt3 pt4 *tol*)) (not (equal pt4 pt1 *tol*)))
(progn
(setq 3df1 (entmakex (list '(0 . "3DFACE") (cons 10 pt1) (cons 11 pt1) (cons 12 pt2) (cons 13 pt3))))
(setq ptdstslst (cons (list pt1 (distance pt1 pt2)) ptdstslst))
(setq ptdstslst (cons (list pt2 (distance pt2 pt1)) ptdstslst))
(setq ptdstslst (cons (list pt2 (distance pt2 pt3)) ptdstslst))
(setq ptdstslst (cons (list pt3 (distance pt3 pt2)) ptdstslst))
(setq ptdstslst (cons (list pt3 (distance pt3 pt1)) ptdstslst))
(setq ptdstslst (cons (list pt1 (distance pt1 pt3)) ptdstslst))
(setq 3df2 (entmakex (list '(0 . "3DFACE") (cons 10 pt3) (cons 11 pt3) (cons 12 pt4) (cons 13 pt1))))
(setq ptdstslst (cons (list pt3 (distance pt3 pt4)) ptdstslst))
(setq ptdstslst (cons (list pt4 (distance pt4 pt3)) ptdstslst))
(setq ptdstslst (cons (list pt4 (distance pt4 pt1)) ptdstslst))
(setq ptdstslst (cons (list pt1 (distance pt1 pt4)) ptdstslst))
(setq ptdstslst (cons (list pt1 (distance pt1 pt3)) ptdstslst))
(setq ptdstslst (cons (list pt3 (distance pt3 pt1)) ptdstslst))
(setq 3dfrl (cons (list (cdr (assoc 5 (entget 3df1))) (cdr (assoc 5 (entget 3df2)))) 3dfrl))
(ssdel 3df s)
(ssadd 3df1 s)
(ssadd 3df2 s)
)
)
(setq ptdstslst (cons (list pt1 (distance pt1 pt2)) ptdstslst))
(setq ptdstslst (cons (list pt2 (distance pt2 pt1)) ptdstslst))
(setq ptdstslst (cons (list pt2 (distance pt2 pt3)) ptdstslst))
(setq ptdstslst (cons (list pt3 (distance pt3 pt2)) ptdstslst))
(setq ptdstslst (cons (list pt3 (distance pt3 pt4)) ptdstslst))
(setq ptdstslst (cons (list pt4 (distance pt4 pt3)) ptdstslst))
(setq ptdstslst (cons (list pt4 (distance pt4 pt1)) ptdstslst))
(setq ptdstslst (cons (list pt1 (distance pt1 pt4)) ptdstslst))
)
(setq ptdstslst (vl-remove-if '(lambda ( x ) (equal (cadr x) 0.0 *tol*)) ptdstslst))
(setq ptdstslst (unique ptdstslst))
(while (setq ptdst (car ptdstslst))
(setq ptassoclst (massoclst (car ptdst) ptdstslst))
(foreach ptdstassoc ptassoclst
(setq ptdstslst (vl-remove ptdstassoc ptdstslst))
)
(setq ptdstslstn (cons ptassoclst ptdstslstn))
)
(foreach ptassoclst ptdstslstn
(setq ptassocdstsn (cons (caar ptassoclst) (mapcar 'cadr ptassoclst)))
(setq ptdstsassoclst (cons ptassocdstsn ptdstsassoclst))
)
(setq ss (ssadd))
(repeat (setq i (sslength s))
(ssadd (ssname s (setq i (1- i))) ss)
)
(setq elst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq elstdst (mapcar '(lambda ( x ) (list (distance (car x) (3cdp (unique (list (car x) (cadr x) (caddr x) (cadddr x))))) (distance (cadr x) (3cdp (unique (list (car x) (cadr x) (caddr x) (cadddr x))))) (distance (caddr x) (3cdp (unique (list (car x) (cadr x) (caddr x) (cadddr x))))) (distance (cadddr x) (3cdp (unique (list (car x) (cadr x) (caddr x) (cadddr x))))))) (mapcar '(lambda ( y ) (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (vl-position (car x) '(10 11 12 13))) (entget y)))) elst)))
(setq
;; conjunto selección
sse (vl-remove-if-not
'(lambda ( a ) (= (type a) 'ename))
(apply 'append (ssnamex ss))
)
;; lista con entidades
ssep (mapcar
'(lambda ( x / e )
(setq e (entget x))
(cons
(cdr (assoc 5 e))
;; lista con hadled de entidad y puntos
(unique
(mapcar 'cdr
(vl-remove-if-not
'(lambda ( a ) (vl-position (car a) '(10 11 12 13)))
e
)
)
)
)
)
sse
)
)
;; buscamos colindancias y las guardamo en una nueva lista
;; lista con handled entidad, perímetro y colindantes
(setq
ssnew (mapcar
'(lambda ( x / ladosx 2lados contiguos i )
(list
(car x)
;;; nombre entidad
(apply
'+
(mapcar 'distance
(cdr x)
(append (cdr (cdr x)) (list (car (cdr x))))
)
)
;; perímetrto
(setq ladosx (mapcar
'(lambda ( a )
;; por cada 10 11 12 13 de x
(mapcar
'car
(vl-remove-if-not
'(lambda ( b )
;; los que tiene un punto próximo
(vl-remove
nil
(mapcar '(lambda ( c )
(equal (distance c a)
0.
0.0001
)
)
(cdr b)
)
)
)
(vl-remove x ssep)
)
)
)
(cdr x)
)
2lados (solod (apply 'append ladosx))
;; recoger solo cuando hay dos puntos sobre la entidad
contiguos ;; identificar con un número las coordendas para no guardad los puntos enteros
(mapcar
'(lambda ( a / i )
(setq i -1)
(cons a
(vl-remove
nil
(mapcar '(lambda ( b )
(setq i (1+ i))
(if (_vl-position a b *tol* nil)
i
)
)
ladosx
)
)
)
)
2lados
)
)
)
)
ssep
)
)
;; ordenar por número de lados y perímetro
(setq ssmaxl (car
;;; la entidad de mayor número de lados y perímetro
(setq ssnew
(vl-sort
ssnew
'(lambda ( a b )
;; lista ordenada
(if (eq (length (last a)) (length (last b)))
(> (cadr a) (cadr b))
(> (length (last a)) (length (last b)))
)
)
)
)
)
)
(setq ptdlnn ptdstsassoclst)
;; crear la primera cara aplanada desde ssmaxl
(setq name (car ssmaxl)
;; nombre primera entidad a dibujar
x (assoc name ssep)
;; datos de la entidad
listap (mapcar 'set '(p1 p2 p3) (cdr x))
ld (mapcar 'set
'(d d1 d2)
(mapcar 'distance (list p1 p2 p3) (list p2 p3 p1))
)
)
(setq p1 (list (car p1) (cadr p1)))
(setq p2 (polar p1 (angle p1 p2) d))
(setq p3 (mapcar '+ '(0 0) (car (LM:int-ci-ci p1 d2 p2 d1))))
;; dibujar la primera
(ent-3dcara (setq plano (list p1 p2 p3)))
(setq nnamesp (cons (cdr (assoc 5 (entget (entlast)))) nnamesp))
(setq ptdptlp (mapcar '(lambda ( p1 p2 ) (list p1 (distance p1 p2) p2)) plano (append (cdr plano) (list (car plano)))))
(setq ptdlp (unique (append (mapcar '(lambda ( x ) (list (car x) (cadr x))) ptdptlp) (mapcar '(lambda ( x ) (list (caddr x) (cadr x))) ptdptlp))))
;; inicializarlistas para iterar
(setq ya (list (list name
;; lista con nombre endidad 3d
(cdr (assoc 5 (entget (entlast))))
;; nombre 2d
plano
;; puntos dibujados en 2d
)
)
names (mapcar 'car ssep)
;; lista solos con nombres
siguientes '()
;;; lista vacía para agrupar en orden
)
(setq nnames (cons name nnames))
;;;;;; bucle principal ;;;;;
(while (setq names (vl-remove name names))
;; mientras me quedan nombres guardados
(princ (strcat "\nBase para iterar " name))
;; nombre entidad dxf 5
;; buscamos colindantes
(setq x (last (assoc name ssnew))
;; nombre y datos entidades colindantes
plano (last (assoc name ya))
;; puntos de la entidad plana guardados en ya
origen (cdr (assoc name ssep))
;; puntos en el espacio de la entidad base
)
(foreach a x
(princ (strcat "\nComprobando " (car a)))
(if (_vl-position (car a) (mapcar 'car ya) *tol* nil)
;; si ya esta dibujada
(princ "\nDesarrollo ya dibujado ...")
(progn
(setq lp (cdr (assoc (car a) ssep))
;; sacamos tres puntos 3d del colindante
listap (mapcar 'set
'(p1 p2)
;; puntos de la linea colindantes
(mapcar '(lambda ( b ) (nth b origen)) (cdr a))
)
lp (vl-remove-if '(lambda ( b ) (_vl-position b listap *tol* nil)) lp)
p3 (car lp)
ld (mapcar 'set
'(d d1 d2)
(mapcar 'distance (list p1 p1 p2) (list p2 p3 p3))
)
)
;;; en teoría debería coincidir la seguencia de puntos en el espacio y en el plano
;; pero pudiera ser que no, así que lo sacamos igualando distancias d
(if (setq lp plano
lp (mapcar '(lambda ( a b ) (cons (distance a b) (list a b)))
lp
(append (cdr lp) (list (car lp)))
)
lp (vl-remove-if-not
'(lambda ( a ) (equal (car a) d 0.00001))
lp
)
)
(setq lp (car lp)
p1p (cadr lp)
p2p (last lp)
)
)
(if (null ptdlpa) (setq ptdlpa (unique ptdlp)))
(cond
( (_vl-position d1 (car (vl-member-if '(lambda ( x ) (equal (car x) p1 *tol*)) ptdlnn)) *tol* nil)
(if (vl-every '(lambda ( x ) (_vl-position x (car (vl-member-if '(lambda ( x ) (equal (car x) p1 *tol*)) ptdlnn)) *tol* nil)) (apply 'append (mapcar 'cdr (massoclst p1p ptdlpa))))
;; calculas el punto del plano
(setq p3p1 (mapcar '+ '(0 0) (car (LM:int-ci-ci p1p d1 p2p d2)))
p3p2 (mapcar '+ '(0 0) (cadr (LM:int-ci-ci p1p d1 p2p d2)))
)
(setq p3p1 (mapcar '+ '(0 0) (car (LM:int-ci-ci p2p d1 p1p d2)))
p3p2 (mapcar '+ '(0 0) (cadr (LM:int-ci-ci p2p d1 p1p d2)))
)
)
(if
(or
(ptinsidetriangle-p p3p1 (car plano) (cadr plano) (caddr plano))
(ptinsidetriangle-p (car (vl-remove p1p (vl-remove p2p plano))) p1p p2p p3p1)
(inters p1p p3p1 p2p (car (vl-remove p1p (vl-remove p2p plano))))
(inters p2p p3p1 p1p (car (vl-remove p1p (vl-remove p2p plano))))
)
(setq p3p p3p2)
(setq p3p p3p1)
)
(setq listap (list p1p p2p p3p))
)
( (_vl-position d2 (car (vl-member-if '(lambda ( x ) (equal (car x) p1 *tol*)) ptdlnn)) *tol* nil)
(if (vl-every '(lambda ( x ) (_vl-position x (car (vl-member-if '(lambda ( x ) (equal (car x) p1 *tol*)) ptdlnn)) *tol* nil)) (apply 'append (mapcar 'cdr (massoclst p1p ptdlpa))))
;; calculas el punto del plano
(setq p3p1 (mapcar '+ '(0 0) (car (LM:int-ci-ci p1p d2 p2p d1)))
p3p2 (mapcar '+ '(0 0) (cadr (LM:int-ci-ci p1p d2 p2p d1)))
)
(setq p3p1 (mapcar '+ '(0 0) (car (LM:int-ci-ci p2p d2 p1p d1)))
p3p2 (mapcar '+ '(0 0) (cadr (LM:int-ci-ci p2p d2 p1p d1)))
)
)
(if
(or
(ptinsidetriangle-p p3p1 (car plano) (cadr plano) (caddr plano))
(ptinsidetriangle-p (car (vl-remove p1p (vl-remove p2p plano))) p1p p2p p3p1)
(inters p1p p3p1 p2p (car (vl-remove p1p (vl-remove p2p plano))))
(inters p2p p3p1 p1p (car (vl-remove p1p (vl-remove p2p plano))))
)
(setq p3p p3p2)
(setq p3p p3p1)
)
(setq listap (list p1p p2p p3p))
)
( t
(if (vl-every '(lambda ( x ) (_vl-position x (car (vl-member-if '(lambda ( x ) (equal (car x) p1 *tol*)) ptdlnn)) *tol* nil)) (apply 'append (mapcar 'cdr (massoclst p1p ptdlpa))))
;; calculas el punto del plano
(setq p3p1 (mapcar '+ '(0 0) (car (LM:int-ci-ci p1p d1 p2p d2)))
p3p2 (mapcar '+ '(0 0) (cadr (LM:int-ci-ci p1p d1 p2p d2)))
)
(setq p3p1 (mapcar '+ '(0 0) (car (LM:int-ci-ci p2p d1 p1p d2)))
p3p2 (mapcar '+ '(0 0) (cadr (LM:int-ci-ci p2p d1 p1p d2)))
)
)
(if
(or
(ptinsidetriangle-p p3p1 (car plano) (cadr plano) (caddr plano))
(ptinsidetriangle-p (car (vl-remove p1p (vl-remove p2p plano))) p1p p2p p3p1)
(inters p1p p3p1 p2p (car (vl-remove p1p (vl-remove p2p plano))))
(inters p2p p3p1 p1p (car (vl-remove p1p (vl-remove p2p plano))))
)
(setq p3p p3p2)
(setq p3p p3p1)
)
(setq listap (list p1p p2p p3p))
)
)
(setq ptdptlp (mapcar '(lambda ( p1 p2 ) (list p1 (distance p1 p2) p2)) listap (append (cdr listap) (list (car listap)))))
(setq ptdlpn (unique (append (mapcar '(lambda ( x ) (list (car x) (cadr x))) ptdptlp) (mapcar '(lambda ( x ) (list (caddr x) (cadr x))) ptdptlp))))
(setq ptdlpa (unique (append ptdlpn ptdlpa)))
(if
(equal ;; comprobación
(apply '+ (mapcar 'distance listap (list p2p p3p p1p)))
(cadr (assoc (car a) ssnew))
0.0001
)
(print (list (setq color "BYLAYER") "Suma perímetros OK"))
(print (list (setq color "2") "Suma perímetros MAL"))
)
;; centros alineados con p3
;; dibujamos
(setvar 'cecolor color)
(setq dsts (list (distance p1p (3cdp (list p1p p2p p3p))) (distance p2p (3cdp (list p1p p2p p3p))) (distance p3p (3cdp (list p1p p2p p3p)))))
(vl-some '(lambda ( x )
(if
(and
(_vl-position (car dsts) x *tol* nil)
(_vl-position (cadr dsts) x *tol* nil)
(_vl-position (caddr dsts) x *tol* nil)
)
(setq dstr x)
)
) elstdst
)
(cond
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p1p p2p p3p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p1p p3p p2p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p2p p1p p3p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p3p p1p p2p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p2p p3p p1p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p3p p2p p1p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p1p p1p p2p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p1p p1p p3p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p1p p2p p1p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p1p p3p p1p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p2p p1p p1p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p3p p1p p1p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p2p p1p p3p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p2p p3p p1p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p1p p2p p3p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p3p p2p p1p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p1p p3p p2p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p3p p1p p2p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p2p p2p p1p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p2p p2p p3p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p2p p1p p2p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p2p p3p p2p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p1p p2p p2p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p3p p2p p2p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p3p p2p p1p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p3p p1p p2p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p2p p3p p1p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p1p p3p p2p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p2p p1p p3p))
)
( (and (equal (car dstr) (caddr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p3p p1p p2p p3p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (cadr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p3p p3p p2p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (car dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p3p p3p p1p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (cadr dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p3p p2p p3p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (caddr dsts) *tol*) (equal (caddr dstr) (car dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p3p p1p p3p))
)
( (and (equal (car dstr) (car dsts) *tol*) (equal (cadr dstr) (cadr dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p1p p2p p3p p3p))
)
( (and (equal (car dstr) (cadr dsts) *tol*) (equal (cadr dstr) (car dsts) *tol*) (equal (caddr dstr) (caddr dsts) *tol*) (equal (cadddr dstr) (caddr dsts) *tol*))
(setq listap (list p1p p2p p3p))
(ent-3dcara (list p2p p1p p3p p3p))
)
)
(setq nnamesp (cons (cdr (assoc 5 (entget (entlast)))) nnamesp))
(setq nnames (cons (vl-some '(lambda ( x ) (if (vl-every '(lambda ( y ) (_vl-position y x *tol* nil)) (list p1 p2 p3)) (car x))) ssep) nnames))
(setvar 'cecolor "BYLAYER")
;; añadimo los ya dibujados a lista ya
(setq ya (cons (list (car a)
(cdr (assoc 5 (entget (entlast))))
listap
)
ya
)
)
;; añadimos las entidades obtenidas de la lista x en siguientes
(if (not (_vl-position (car a) siguientes *tol* nil))
(setq siguientes (cons (car a) siguientes))
)
); fin progn
); fin if
); fin foreach
;; hacemos name igual al primer siguiente
(setq name (car siguientes)
siguientes (cdr siguientes)
)
)
;; fin while
(setq nnames (reverse nnames))
(setq nnamesp (reverse nnamesp))
(setq 3dfrlp (mapcar '(lambda ( x ) (list (nth (vl-position (car x) nnames) nnamesp) (nth (vl-position (cadr x) nnames) nnamesp))) 3dfrl))
(foreach pair 3dfrlp
(mapcar 'set '(pt11 pt12 pt13 pt14) (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (vl-position (car x) '(10 11 12 13))) (entget (handent (car pair))))))
(mapcar 'set '(pt21 pt22 pt23 pt24) (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (vl-position (car x) '(10 11 12 13))) (entget (handent (cadr pair))))))
(setq d1l (vl-remove 0.0 (mapcar '(lambda ( a b ) (distance a b)) (list pt11 pt12 pt13 pt14) (list pt12 pt13 pt14 pt11))))
(setq d2l (vl-remove 0.0 (mapcar '(lambda ( a b ) (distance a b)) (list pt21 pt22 pt23 pt24) (list pt22 pt23 pt24 pt21))))
(setq ddl (unique (append d1l d2l)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (unique (append (list pt11 pt12 pt13 pt14) (list pt21 pt22 pt23 pt24))))
(cond
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt1 pt2) (distance pt2 pt3) (distance pt3 pt4) (distance pt4 pt1)))
nil
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt2 pt1) (distance pt1 pt3) (distance pt3 pt4) (distance pt4 pt2)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt2 pt1 pt3 pt4))
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt1 pt3) (distance pt3 pt2) (distance pt2 pt4) (distance pt4 pt1)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt1 pt3 pt2 pt4))
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt1 pt2) (distance pt2 pt4) (distance pt4 pt3) (distance pt3 pt1)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt1 pt2 pt4 pt3))
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt4 pt2) (distance pt2 pt3) (distance pt3 pt1) (distance pt1 pt4)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt4 pt2 pt3 pt1))
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt3 pt2) (distance pt2 pt1) (distance pt1 pt4) (distance pt4 pt3)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt3 pt2 pt1 pt4))
)
( (vl-every '(lambda ( x ) (vl-position x ddl)) (list (distance pt1 pt4) (distance pt4 pt3) (distance pt3 pt2) (distance pt2 pt1)))
(mapcar 'set '(pt1 pt2 pt3 pt4) (list pt1 pt4 pt3 pt2))
)
)
(entmake (list '(0 . "3DFACE") (cons 10 pt1) (cons 11 pt2) (cons 12 pt3) (cons 13 pt4)))
(entdel (handent (car pair)))
(entdel (handent (cadr pair)))
(entdel (handent (nth (vl-position (car pair) nnamesp) nnames)))
(entdel (handent (nth (vl-position (cadr pair) nnamesp) nnames)))
)
(princ "\nTerminado ...")
(princ)
)
;;fin defunRegards, M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 34 of 37
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
It turns out that and previous code is good - it's just tolerance issue, so if you want without to much mirroring, just use previous one and change first line of program begin paragraph : (setq *tol* 1e-8)...
HTH., M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 35 of 37
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Hi brother.
Thank you very much for your help, time and dedication.
I have no words to thank you for what you do for me.
I will use the latest and published and will be pending to the errors.
I changed the tolerance and it did not work for me, it still makes the mirror.
And let's hope that in the future the mirrors can be improved and not be rotated.
Another question.
How did you project the 3d polyline over the 3dfaces?
Is it a lisp or did you do it by hand?
If it's a lisp, could you share it?
Of heart, thank you very much.
AutoCAD 2026.1.1
Visual Studio Code 1.105.1
AutoCAD AutoLISP Extension 1.6.3
Windows 10 - 22H2 (64 bits)
Message 36 of 37
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
@carlos_m_gil_p wrote:Hi brother.
Thank you very much for your help, time and dedication.
I have no words to thank you for what you do for me.
I will use the latest and published and will be pending to the errors.
I changed the tolerance and it did not work for me, it still makes the mirror.
And let's hope that in the future the mirrors can be improved and not be rotated.
Another question.
How did you project the 3d polyline over the 3dfaces?
Is it a lisp or did you do it by hand?
If it's a lisp, could you share it?
Of heart, thank you very much.
What I wanted to say in my last post was that you continue to use Nolo's version (without LM:int-ci-ci and ptinsidetriangle-p and with sensido and intercc turned on) - you just have to change (setq *tol* 1e-6) to (setq *tol* 1e-8)...
For projecting line of unfolded 3dfaces back to folded 3dfaces and get 3dpolyline, look into this topic, but I suggest that you login as there are animated gifs and pictures showing some actions related to descriptions in posts you may find there :
https://www.theswamp.org/index.php?topic=43121.0
To help you to get folded 3dfaces quickly from 2 3d curves, just use this simple code, I wrote imitating one of the users actually OP doing the same thing in one of animated gifs...
(defun c:23dcurves23dfaces ( / make3df adoc s1 s2 c1 c2 rev1 rev2 n k p1 d1 pl1 p2 d2 pl2 )
(vl-load-com)
(defun make3df ( p1 p2 p3 p4 )
(entmake
(list '(0 . "3DFACE")
(cons 10 p1)
(cons 11 p2)
(cons 12 p3)
(cons 13 p4)
)
)
)
(vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
(setq s1 (entsel "\nPick first 3d curve - side of pick must be correct..."))
(while (or (not s1) (vl-catch-all-error-p (vl-catch-all-apply 'vlax-curve-getstartpoint (list (car s1)))))
(prompt "\nMissed or picked entity is not curve entity type... Try again...")
(setq s1 (entsel "\nPick first 3d curve - side of pick must be correct..."))
)
(setq s2 (entsel "\nPick second 3d curve - side of pick must be correct..."))
(while (or (not s2) (vl-catch-all-error-p (vl-catch-all-apply 'vlax-curve-getstartpoint (list (car s2)))))
(prompt "\nMissed or picked entity is not curve entity type... Try again...")
(setq s2 (entsel "\nPick second 3d curve - side of pick must be correct..."))
)
(if (> (vlax-curve-getdistatpoint (setq c1 (car s1)) (vlax-curve-getclosestpointtoprojection c1 (trans (cadr s1) 1 0) (trans (getvar 'viewdir) 1 0 t))) (/ (vlax-curve-getdistatparam c1 (vlax-curve-getendparam c1)) 2.0))
(setq rev1 t)
)
(if (> (vlax-curve-getdistatpoint (setq c2 (car s2)) (vlax-curve-getclosestpointtoprojection c2 (trans (cadr s2) 1 0) (trans (getvar 'viewdir) 1 0 t))) (/ (vlax-curve-getdistatparam c2 (vlax-curve-getendparam c2)) 2.0))
(setq rev2 t)
)
(initget 7)
(setq n (getint "\nSpecify number of divisions : "))
(setq k 0)
(setq p1 (if rev1 (vlax-curve-getendpoint c1) (vlax-curve-getstartpoint c1)))
(setq d1 (/ (vlax-curve-getdistatparam c1 (vlax-curve-getendparam c1)) (1+ n)))
(setq pl1 (cons p1 pl1))
(repeat n
(setq k (1+ k))
(setq p1 (if rev1 (vlax-curve-getpointatdist c1 (- (vlax-curve-getdistatparam c1 (vlax-curve-getendparam c1)) (* k d1))) (vlax-curve-getpointatdist c1 (* k d1))))
(setq pl1 (cons p1 pl1))
)
(setq p1 (if rev1 (vlax-curve-getstartpoint c1) (vlax-curve-getendpoint c1)))
(setq pl1 (cons p1 pl1))
(setq pl1 (reverse pl1))
(setq k 0)
(setq p2 (if rev2 (vlax-curve-getendpoint c2) (vlax-curve-getstartpoint c2)))
(setq d2 (/ (vlax-curve-getdistatparam c2 (vlax-curve-getendparam c2)) (1+ n)))
(setq pl2 (cons p2 pl2))
(repeat n
(setq k (1+ k))
(setq p2 (if rev2 (vlax-curve-getpointatdist c2 (- (vlax-curve-getdistatparam c2 (vlax-curve-getendparam c2)) (* k d2))) (vlax-curve-getpointatdist c2 (* k d2))))
(setq pl2 (cons p2 pl2))
)
(setq p2 (if rev2 (vlax-curve-getstartpoint c2) (vlax-curve-getendpoint c2)))
(setq pl2 (cons p2 pl2))
(setq pl2 (reverse pl2))
(mapcar '(lambda ( a b c d ) (progn (make3df a a b c) (make3df b b c d))) pl1 pl2 (cdr pl1) (cdr pl2))
(vla-endundomark adoc)
(princ)
)P.S. You can change the code to suit your needs in case you wanted quad and not triangular folded 3DFACES...
Just change line :
(mapcar '(lambda ( a b c d ) (progn (make3df a a b c) (make3df b b c d))) pl1 pl2 (cdr pl1) (cdr pl2))
To :
(mapcar '(lambda ( a b c d ) (make3df a b c d)) pl1 (cdr pl1) (cdr pl2) pl2)
HTH., M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 37 of 37
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Brother, thank you for your prompt response.
I already understood the previous lisp and it works perfect.
Thank you very much.
Enter the link you gave me.
I lined the triangles before that way. Jajajaja.
Thanks for this new lisp. (23dcurves23dfaces)
But I was looking for something like the lisp PROF_3DF_EN.LSP
Although I've just found a mistake. Jajajaja.
I'll post it on the same link.
Thank you very much.
Greetings.
AutoCAD 2026.1.1
Visual Studio Code 1.105.1
AutoCAD AutoLISP Extension 1.6.3
Windows 10 - 22H2 (64 bits)
- « Previous
-
- 1
- 2
- Next »