;;;Código fuente del libro "Experto AutoCAD con Visual LISP"
;;; (c) 2012 Ediciones ARTUAL, S.L. Barcelona, España.
;;; (c) 2012-2020 Reinaldo Togores. Todos los derechos reservados
;;; Se permite su uso mencionando la obra y su autor.
;;;CapÃtulo 16. Mallas Poligonales y Policara.
(defun cmd-dib-malla (m n lista-coords /)
(cmd-entrar)
(apply 'vl-cmdf (append (list "_3dmesh" m n) lista-coords))
(cmd-salir)
(entlast))
;;;Listado 16.1. Dibujo de la malla Poligonal mediante la función command.
(defun PolygonMesh-cabecera (m n)
(entmake
(list '(0 . "POLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolygonMesh")
'(70 . 16)
(cons 71 m)
(cons 72 n))))
;;;Listado 16.2. Función que genera la cabecera de la Malla Poligonal.
(defun PolygonMesh-vertice (xyz)
(entmake
(list '(0 . "VERTEX")
'(100 . "AcDbEntity")
'(100 . "AcDbVertex")
'(100 . "AcDbPolygonMeshVertex")
(cons 10 xyz)
'(70 . 64))))
;;;Listado 16.3. Función que genera cada entidad vértice de la malla.
(defun ent-seqend ()
(entmake
(list '(0 . "SEQEND")
'(100 . "AcDbEntity"))))
;;;Listado 16.4. Función que genera la entidad Fin-de-secuencia.
(defun ent-dib-pmalla (m n lista-coords /)
(PolygonMesh-cabecera m n)
(foreach pt lista-coords
(PolygonMesh-vertice pt))
(ent-seqend)
(entlast))
;;;Listado 16.5. Dibujo de la malla con entmake.
(defun ax-dib-pmalla (m n lista-coords / matriz-puntos)
(setq lista-coords (apply 'append lista-coords)
matriz-puntos (vlax-make-safearray
vlax-vbDouble
(cons 0 (- (length lista-coords) 1))))
(vlax-safearray-fill matriz-puntos lista-coords)
(vla-Add3dMesh
(espacio-actual *aevl:dibujo*)
m
n
matriz-puntos))
;;;Listado 16.6. Creación de la malla Poligonal con el método Add3dMesh.
(defun datos-pmalla (/)
(initget 1 "Command Entmake Activex")
(setq metodo (getkword "\nMétodo [Command/Entmake/Activex]: "))
(initget 1 "1 2 3")
(setq opcion (getkword "\nEcuación de Superficie [1/2/3]: ")
dimX (getreal "\nDimensión en X: ")
dimY (getreal "\nDimensión en Y: ")
dimZ (getreal "\nDimensión en Z: ")
res (getint "\nResolución de la malla (2 a 256): "))
(while (not (< 1 res 257))
(prompt "\nLa resolución debe ser entre 2 a 256")
(setq res (getint "\nResolución de la malla: ")))
(initget 1 "Ninguno cUadratico Cubico Bezier")
(setq ajuste (getkword
"\nSuavizado [Ninguno/cUadratico/Cubico/Bezier]: "))
(if (/= ajuste "Ninguno")
(progn (initget (+ 1 2 4))
(setq densidad (getint "\nDensidad de suavizado (3 a 200):"))))
(cond
((= ajuste "cUadratico") (setq ajuste acQuadSurfaceMesh))
((= ajuste "Cubico") (setq ajuste acCubicSurfaceMesh))
((= ajuste "Bezier") (setq ajuste acBezierSurfaceMesh))
(t (setq ajuste nil)))
(initget 1)
(setq origen (getpoint "\nCentro de la Malla: ")
pasoX (/ dimX res)
pasoY (/ dimY res)
Xmin (- (/ dimX 2))
Ymin (- (/ dimY 2))))
;;;Listado 16.7. Función que solicita los datos para definición de la malla.
;;; Función f1
(defun f1 (x y /) (cos (sqrt (+ (* x x 2) (* y y)))))
;;; Función f2
(defun f2 (x y /) (sqrt (abs (* x y))))
;;; Función f3
(defun f3 (x y /) (/ (* x y) 10))
;;;Listado 16.8. Funciones para el cálculo de distintas formas de superficie.
(defun op-formula (opcion /)
(cond
((= opcion "1") 'f1)
((= opcion "2") 'f2)
((= opcion "3") 'f3)))
;;;Listado 16.9. Función que decide la fórmula a emplear.
(defun calc-pmalla (formula Xmin Ymin dimz pasoX pasoY res / i j y lst f-altura)
(setq i 0)
(while (< i res)
(setq j 0
y Ymin)
(while (< j res)
(setq lst (cons (list Xmin y (apply formula (list Xmin y)))
lst))
(setq j (1+ j)
y (+ y pasoY)))
(setq i (1+ i)
Xmin (+ Xmin pasoX)))
(setq f-altura (/
dimz
(-
(apply 'max
(mapcar '(lambda (pt) (nth 2 pt)) lst))
(apply 'min
(mapcar '(lambda (pt) (nth 2 pt)) lst))))
lst (mapcar
'(lambda (pt)
(list (nth 0 pt)
(nth 1 pt)
(* f-altura (nth 2 pt))))
lst))
(reverse lst))
;;;Listado 16.10. Función que calcula las coordenadas de los vértices de la malla.
(defun C:POLYMALLA (/ mtrans tiempo metodo dimX dimY res origen pasoX pasoY Xmin Ymin
ajuste densidad lista-coords obj *error*)
(setq tiempo (getvar "millisecs"))
(defun *error* ()
(cmd-salir)
(command-s "_UNDO" "_End"))
(vl-cmdf "._UNDO" "_Begin")
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-matriz-scp))))
(t (setq mtrans nil)))
(datos-pmalla)
(setq lista-coords (calc-pmalla
(op-formula opcion)
Xmin
Ymin
dimZ
pasoX
pasoY
res))
(cond
((= metodo "Command")
(cmd-entrar)
(setq mtrans nil
obj (vlax-ename->vla-object
(cmd-dib-malla res res lista-coords)))
(cmd-salir))
((= metodo "Entmake")
(setq obj (vlax-ename->vla-object
(ent-dib-pmalla res res lista-coords))))
((= metodo "Activex")
(setq obj (ax-dib-pmalla res res lista-coords))))
(if mtrans
(vla-TransformBy obj mtrans))
(ax-traslacion obj (trans origen 1 0 t))
(if ajuste
(progn (vla-put-Type obj ajuste)
(vla-put-MDensity obj densidad)
(vla-put-NDensity obj densidad)))
(vla-update obj)
(ax-SOsup)
(prompt
(strcat "\nTiempo: "
(rtos (- (getvar "millisecs") tiempo) 2 0)
" milisegundos"))
(vl-cmdf "._UNDO" "_End")
(princ))
;;;Listado 16.11. Función principal C:POLYMALLA.
(defun cmd-dib-pcara (lista-puntos lista-caras /)
(vl-cmdf "._pface")
(foreach vert lista-puntos (vl-cmdf vert))
(vl-cmdf "")
(foreach cara lista-caras
(foreach id cara (vl-cmdf id))
(vl-cmdf ""))
(vl-cmdf "")
(entlast))
;;;Listado 16.12 Función que crea la malla Policara mediante el comando PCARA.
(defun def-cara (lista-caras / tmp res vini nvert i)
(foreach cara lista-caras
(setq vini (nth 0 cara)
nvert (length cara)
i 1)
(cond
((= nvert 3)
(setq res (cons (append cara (list (nth 2 cara))) res)))
((= nvert 4) (setq res (cons cara res)))
((> nvert 4)
(repeat (- nvert 2)
(setq tmp nil)
(cond
((= i 1)
(setq tmp (cons
(list vini
(nth i cara)
(nth (setq i (1+ i)) cara)
(- (nth i cara)))
tmp)))
((= i (- nvert 2))
(setq tmp (cons
(list (- vini)
(nth i cara)
(+ (nth (setq i (1+ i)) cara))
(nth i cara))
tmp)))
(t
(setq tmp (cons
(list (- vini)
(nth i cara)
(- (nth (setq i (1+ i)) cara))
(- (nth i cara)))
tmp))))
(setq res (append tmp res))))
(t
(prompt "ERROR: Menos que 3 vertices!")
(exit))))
(reverse res))
;;;Listado 16.13. Discretización de las caras.
(defun policara-cabecera (lista-puntos lista-caras /)
(entmake
(list '(0 . "POLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyFaceMesh")
'(70 . 64)
(cons 71 (length lista-puntos))
(cons 72 (length lista-caras)))))
;;;Listado 16.14. Creación de la entidad cabecera de la malla Policara.
(defun policara-vertices (lista-puntos /)
(foreach vert lista-puntos
(entmake
(list '(0 . "VERTEX")
'(100 . "AcDbEntity")
'(100 . "AcDbVertex")
'(100 . "AcDbPolyFaceMeshVertex")
(cons 10 vert)
'(70 . 192)))))
;;;Listado 16.15. Creación de las entidades VERTEX.
(defun policara-caras (lista-caras /)
(foreach cara lista-caras
(entmake
(list '(0 . "VERTEX")
'(100 . "AcDbEntity")
'(100 . "AcDbFaceRecord")
'(10 0.0 0.0 0.0)
'(70 . 128)
(cons 71 (nth 0 cara))
(cons 72 (nth 1 cara))
(cons 73 (nth 2 cara))
(cons 74 (nth 3 cara))))))
;;;Listado 16.16. Creación de las caras (entidades FaceRecord).
(defun ent-dib-pcara (lista-puntos lista-caras /)
(setq lista-caras (def-cara lista-caras))
(policara-cabecera lista-puntos lista-caras)
(policara-vertices lista-puntos)
(policara-caras lista-caras)
(ent-seqend)
(entlast))
;;;Listado 16.17. Función que dibuja la malla Policara mediante entmake.
(defun ax-dib-pcara (lista-coords lista-caras / matriz-vertices matriz-caras)
(setq lista-coords (apply 'append lista-coords)
matriz-vertices (vlax-make-safearray
vlax-vbDouble
(cons 0 (- (length lista-coords) 1)))
matriz-vertices (vlax-safearray-fill
matriz-vertices
lista-coords)
lista-caras (apply 'append (def-cara lista-caras))
matriz-caras (vlax-make-safearray
vlax-vbInteger
(cons 0 (- (length lista-caras) 1)))
matriz-caras (vlax-safearray-fill matriz-caras lista-caras))
(vla-AddPolyfaceMesh
(espacio-actual *aevl:dibujo*)
matriz-vertices
matriz-caras))
;;;Listado 16.18. Creación de la malla mediante vla-AddPolyfaceMesh.
(defun datos-poliedro (/)
(initget 1 "Command Entmake Activex")
(setq metodo (getkword "\nMétodo [Command/Entmake/Activex]: "))
(initget 1 "Tetraedro Hexaedro Dodecaedro")
(setq clase (getkword
"\nClase [Tetraedro/Hexaedro/Dodecaedro]:")
centro (getpoint "\nCentro del poliedro: ")
radio (getdist centro
"\Radio de la esfera circunscrita: ")))
;;;Listado 16.19. Solicitud de datos al usuario.
(defun op-poliedro (clase /)
(cond
((= clase "Tetraedro")
(setq vertices '((0 0 1)
(0 0.9428 -0.3333)
(-0.8164 -0.4714 -0.3333)
(0.8164 -0.4714 -0.3333))
caras '((1 2 3) (1 3 4) (1 4 2) (2 4 3))))
((= clase "Hexaedro")
(setq vertices '((-0.5773 -0.5773 -0.5773)
(-0.5773 0.5773 -0.5773)
(0.5773 0.5773 -0.5773)
(0.5773 -0.5773 -0.5773)
(-0.5773 -0.5773 0.5773)
(-0.5773 0.5773 0.5773)
(0.5773 0.5773 0.5773)
(0.5773 -0.5773 0.5773))
caras '((1 2 3 4)
(5 6 2 1)
(6 7 3 2)
(7 8 4 3)
(8 5 1 4)
(8 7 6 5))))
((= clase "Dodecaedro")
(setq vertices '((0.5773 -0.1875 0.7946)
(0.3568 0.4911 0.7946)
(-0.3568 0.4911 0.7946)
(-0.5773 -0.1875 0.7946)
(0.0 -0.6070 0.7946)
(0.9341 -0.3035 0.1875)
(0.9341 0.3035 -0.1875)
(0.5773 0.7946 0.1875)
(0.0 0.9822 -0.1875)
(-0.5773 0.7946 0.1875)
(-0.9341 0.3035 -0.1875)
(-0.9341 -0.3035 0.1875)
(-0.5773 -0.7946 -0.1875)
(0.0 -0.9822 0.1875)
(0.5773 -0.7946 -0.1875)
(0.3568 -0.4911 -0.7946)
(0.5773 0.1875 -0.7946)
(0.0 0.6070 -0.7946)
(-0.5773 0.1875 -0.7946)
(-0.3568 -0.4911 -0.7946))
caras '((1 2 3 4 5)
(1 6 7 8 2)
(2 8 9 10 3)
(3 10 11 12 4)
(4 12 13 14 5)
(5 14 15 6 1)
(6 15 16 17 7)
(8 7 17 18 9)
(10 9 18 19 11)
(12 11 19 20 13)
(14 13 20 16 15)
(16 20 19 18 17))))))
;;;Listado 16.20. Carga de datos de vértices y caras para el poliedro.
(defun C:POLIEDRO-PCARA (/ *error* tiempo mtrans metodo clase centro radio obj)
(setq tiempo (getvar "millisecs"))
(defun *error* () (cmd-salir) (command-s "._UNDO" "_End"))
(vl-cmdf "._UNDO" "_Begin")
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-matriz-scp))))
(t (setq mtrans nil)))
(datos-poliedro)
(op-poliedro clase)
(cond
((= metodo "Command")
(cmd-entrar)
(setq mtrans nil
obj (vlax-ename->vla-object
(cmd-dib-pcara vertices caras)))
(cmd-salir))
((= metodo "Entmake")
(setq obj (vlax-ename->vla-object
(ent-dib-pcara vertices caras))))
((= metodo "Activex")
(setq obj (ax-dib-pcara vertices caras))))
;; Transformaciones:
(ax-escala obj (list radio radio radio))
(if mtrans
(vla-TransformBy obj mtrans))
(ax-traslacion obj (trans centro 1 0 t))
(ax-SOsup)
(prompt
(strcat "\nTiempo de ejecución: "
(rtos (- (getvar "millisecs") tiempo) 2 0)
" milisegundos"))
(vl-cmdf "._UNDO" "_End")
(princ))
;;;Listado 16.21. Función Principal C:POLIEDRO-PCARA.
(defun lista-vertices-malla (ent-pmalla suavizado / lista-puntos)
(while
(and (setq ent-pmalla (entnext ent-pmalla))
(/= (cdr (assoc 0 (setq dxf (entget ent-pmalla))))
"SEQEND"))
(cond
(suavizado
(if (/= (logand 8 (cdr (assoc 70 dxf))) 0)
(setq lista-puntos (cons (cdr (assoc 10 dxf))
lista-puntos))))
(t
(if (/= (logand 16 (cdr (assoc 70 dxf))) 0)
(setq lista-puntos (cons (cdr (assoc 10 dxf))
lista-puntos))))))
(reverse lista-puntos))
;;;Listado 16.22. Función que devuelve los vértices producidos por suavizado de una malla poligonal.
(defun cal-z (xyz ecuacion dim-z / z h f-esc)
(while xyz
(setq z (cons (apply ecuacion (list (nth 0 xyz) (nth 1 xyz)))
z)
xyz (cdddr xyz)))
(setq h (- (apply 'max z) (apply 'min z))
f-esc (/ dim-z h))
(reverse (mapcar '(lambda (n) (* n f-esc)) z)))
;;;Listado 16.23. Función para el cálculo del valor de la coordenada Z.
(defun ax-mod-pmalla (obj-pmalla ecuacion dim-z / xyz lst-z i vertices pt)
(setq xyz (vlax-safearray->list
(vlax-variant-value (vla-get-coordinates obj-pmalla)))
lst-z (cal-z xyz ecuacion dim-z)
i 0
nombre (vla-get-ObjectName obj-pmalla))
(cond
((= nombre "AcDbPolygonMesh")
(setq vertices (* (vla-get-MVertexCount obj-pmalla)
(vla-get-NVertexCount obj-pmalla))))
((= (vla-get-ObjectName obj-pmalla) "AcDbPolyFaceMesh")
(setq vertices (vla-get-NumberOfVertices obj-pmalla)))
(t
(prompt
"\nSeleccione una Malla Poligonal o Policara.")
(exit)))
(repeat vertices
(setq pt (vlax-safearray->list
(vlax-variant-value
(vla-get-coordinate obj-pmalla i))))
(vla-put-coordinate
obj-pmalla
i
(vlax-3d-point
(list (nth 0 pt)
(nth 1 pt)
(+ (nth 2 pt) (nth i lst-z)))))
(setq i (1+ i)))
(vla-Update obj-pmalla))
;;;Listado 16.24. Modificación de la posición de los vértices de una malla Poligonal o Policara.
