;;;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 20: Superficies de Procedimiento y NURBS
(defun datos-nurbs (/ nombre)
(initget 1)
(setq nombre (getstring "\nFunción para calcular la superficie:"))
(while (not (setq ecuacion (car (atoms-family 0 (list nombre)))))
(prompt
(strcat "\nLa función " nombre " no está definida!"))
(initget 1)
(setq nombre (getstring "\nFunción para calcular la superficie:")))
(initget 1)
(setq centro (getpoint "\nCentro de la superficie:"))
(initget (+ 1 2 4))
(setq dim-x (getdist centro "\nDimensión en X:"))
(initget (+ 1 2 4))
(setq dim-y (getdist centro "\nDimensión en Y:"))
(initget (+ 1 2 4))
(setq dim-z (getdist centro "\nDimensión en Z:"))
(initget (+ 1 2 4))
(setq n-sec (getint "\nNúmero de secciones transversales:"))
(initget (+ 1 2 4))
(setq n-pts (getint "\nNúmero de puntos de ajuste:"))
(initget 1 "Cuerda Raíz Uniforme")
(setq param (getkword
"\nParametrización [Cuerda/Raíz cuadrada/Uniforme]: "))
(cond
((= param "Cuerda") (setq param (+ 8 32 1024)))
((= param "Raíz") (setq param (+ 8 64 1024)))
((= param "Uniforme") (setq param (+ 8 128 1024)))))
;;;Listado 20.1. Solicitud de datos al usuario para la superficie NURBS por SOLEVADO.
(defun calc-secc
(dim-x dim-y dim-z ecuacion n-sec n-pts / xmin ymin d-sec d-pts x0 y0
seccion secciones)
(setq xmin (- (/ dim-x 2))
ymin (- (/ dim-y 2))
d-sec (/ dim-y (1- n-sec))
d-pts (/ dim-x (1- n-pts))
x0 xmin
y0 ymin)
(repeat n-sec
(setq x0 xmin
seccion nil)
(repeat n-pts
(setq seccion (cons (list x0 y0) seccion))
(setq x0 (+ x0 d-pts)))
(setq secciones (cons (reverse seccion) secciones))
(setq y0 (+ y0 d-sec)))
(coord-z (reverse secciones) ecuacion dim-z))
;;;Listado 20.2. Función que calcula las coordenadas de los puntos de ajuste.
(defun ent-secc (lista-puntos cod70 vec-normal)
(entmake
(append
(list '(0 . "SPLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbSpline")
(cons 70 cod70)
'(71 . 3)
(cons 74 (length lista-puntos))
(cons 210 vec-normal))
(mapcar '(lambda (x) (cons 11 x)) lista-puntos))))
;;;Listado 20.3. Función que crea la sección transversal como SPLINE.
(defun C:SUP-NURBS (/ *error* mtrans dim-x dim-y ecuacion dim-z n-sec n-pts
param secciones c-secc obj i xmin ymin)
(defun *error* ()
(cmd-salir)
(vla-EndUndoMark *aevl:dibujo*))
(vla-StartUndoMark *aevl:dibujo*)
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-matriz-scp))))
(t (setq mtrans nil)))
(setvar "SURFACEMODELINGMODE" 1)
(datos-nurbs)
(setq secciones (calc-secc dim-x dim-y dim-z ecuacion n-sec n-pts)
c-secc (ssadd))
(foreach secc secciones
(if (ent-secc secc param '(0.0 -1.0 0.0))
(ssadd (entlast) c-secc)))
(cmd-entrar)
(vl-cmdf "_loft" "_mode" "_surface" c-secc "" "")
(if
(= (vla-get-ObjectName (vlax-ename->vla-object (entlast)))
"AcDbNurbSurface")
(progn (setq obj (vlax-ename->vla-object (entlast)))
(if (> (getvar "DELOBJ") 0)
(progn (setq i 0)
(repeat (sslength c-secc)
(entdel (ssname c-secc i))
(setq i (1+ i)))))
(if mtrans
(vla-TransformBy obj mtrans))
(ax-traslacion obj (trans centro 1 0 t))
(vla-put-CvHullDisplay obj 1)
(ax-SOsup))
(progn
(vla-ZoomWindow
*aevl:acad*
(vlax-3d-point (list xmin ymin))
(vlax-3d-point (mapcar '- (list xmin ymin))))
(alert
(strcat "\nError construyendo la superficie."
"\nCompruebe bucles intersecantes"))))
(cmd-salir))
;;;Listado 20.4. Función principal C:SUP-NURBS.
(defun ent-perfil (elev alto ancho capa / x y)
(setq x (/ ancho 2.0)
y (- alto x))
(entmake
(list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 8 capa)
(cons 38 elev)
'(90 . 4) ;Número de vértices
'(70 . 1) ;Indica polilíea cerrada (1)
(list 10 x 0.0) ;Coord. primer vértice (SCO)
'(42 . 0.0) ;Curvatura del segmento recto
'(91 . 0) ;Fin de datos del vértice 1
(list 10 x y) ;Coord. segundo vértice (SCO)
'(42 . 1.0) ;Curvatura del segmento curvo
'(91 . 0) ;Fin de datos del vértice 2
(list 10 (- x) y) ;Coord.tercer vértice (SCO)
'(42 . 0.0) ;Curvatura del segmento recto
'(91 . 0) ;Fin de datos del vértice 3
(list 10 (- x) 0.0) ;Coord.cuarto vértice (SCO)
'(42 . 0.0) ;Curvatura del segmento recto
'(91 . 0) ;Fin de datos vértice 4
'(210 0.0 1.0 0.0) ;Vector normal
)))
;;;Listado 20.5. Función que crea el perfil para la superficie de procedimiento.
(defun datos-sup-aso (/)
(initget (+ 1 2 4))
(setq n (getint "\nNúmero de Perfiles:"))
(initget (+ 1 2 4))
(setq intervalo (getreal "\nDistancia entre perfiles:"))
(initget (+ 1 2 4))
(setq alto (getreal "\nAltura:"))
(initget (+ 1 2 4))
(while (>= (setq ancho (getreal "\nAnchura:")) (* alto 2))
(prompt
(strcat "\nLa anchura debe ser < "
(rtos (* alto 2.0) 2 2)))
(initget (+ 1 2 4)))
(initget 1)
(setq id (getstring "\nID de la Superficie:")))
;;;Listado 20.6. Solicitud de los datos para la creación de los perfiles.
(defun ax-trans-scp (col-scp origen pt-eje-x pt-eje-y nombre / sis-coord scp-actual)
(setq sis-coord (vl-catch-all-apply
'vla-add
(list col-scp
(vlax-3d-point origen)
(vlax-3d-point pt-eje-x)
(vlax-3d-point pt-eje-y)
nombre)))
(cond
((vl-catch-all-error-p sis-coord)
(prompt
(strcat "\nERROR:" (vl-catch-all-error-message sis-coord))))
(t
(setq scp-actual (vl-catch-all-apply
'vla-put-ActiveUCS
(list *aevl:dibujo* sis-coord)))
(if (vl-catch-all-error-p scp-actual)
(prompt
(strcat "\nERROR:"
(vl-catch-all-error-message sis-coord)))))))
;;;Listado 20.7. Función que establece el SCP correcto antes de aplicar las restricciones.
(defun crea-perfiles (lista-origen alto ancho capa id / col-scp pt-o pt-x pt-y nom
i p1 p2 resdim)
(setq col-scp (vla-get-UserCoordinateSystems *aevl:dibujo*))
(foreach elev lista-origen
(ent-perfil elev alto ancho capa)
(setq perfiles (cons (entlast) perfiles)))
(setq perfiles (reverse perfiles))
(ax-vista '(-1 0 0) t)
(vla-ZoomScaled *aevl:acad* 0.9 acZoomScaledRelative)
(setvar "PERSPECTIVE" 0)
(setq i 0)
(foreach perfil perfiles
(setq pt-o (list 0 (nth i lista-origen) 0)
pt-x (list 100 (nth i lista-origen) 0)
pt-y (list 0 (nth i lista-origen) 100)
nom (strcat "SCP-" (itoa i))
i (1+ i))
(ax-trans-scp col-scp pt-o pt-x pt-y nom)
(vl-cmdf "_AutoConstrain" perfil "")
(vl-cmdf "_GcFix" (osnap '(0 0 0) "_mid"))
(setq p1 (osnap (list 0 alto 0) "_qua")
p2 (list 0 (/ alto 3.0) 0))
(vl-cmdf "_DcRadius" p1 p2 "")
(setq resdim (vl-catch-all-apply
'vlax-ename->vla-object
(list (entlast))))
(cond
((vl-catch-all-error-p resdim)
(prompt (strcat "\nERROR:" (vl-catch-all-error-message))))
(t
(vla-get-DimConstrName resdim)
(vla-put-DimConstrName resdim (strcat id "_rad" (itoa i)))
(vla-put-DimConstrDesc
resdim
(strcat "Superficie " id "; Radio perfil " (itoa i)))))))
;;;Listado 20.8. Creación de los perfiles con sus restricciones geométricas y dimensionales.
(defun crea-sup-aso (perfiles /)
(setvar "SURFACEASSOCIATIVITY" 1)
(setvar "SURFACEMODELINGMODE" 0)
(vla-put-ActiveLayer
*aevl:dibujo*
(ax-capa
(vla-get-layers *aevl:dibujo*)
(strcat id "_SUPERFICIE")
"4"
"Continuous"))
(vl-cmdf "_LOFT" "_MOde" "_SUrface")
(foreach perfil perfiles (vl-cmdf perfil))
(vl-cmdf "" "_Cross"))
;;;Listado 20.9. Función que crea la superficie asociativa.
(defun val (i n /)
(if (zerop (logand 1 i))
(+ (/ n 2.0))
(- (/ n 2.0))))
;;;Listado 20.10. Función que calcula el valor a asignar a la restricción dimensional.
(defun mod-rest (/ rdims i n rdim pos valor-actual increm)
(if
(setq rdims (ssget
"X"
(list
'(0 . "DIMENSION")
'(8 . "*ADSK_CONSTRAINTS")
(cons 1 (strcat id "_rad*")))))
(progn
(setq i 0
n (sslength rdims))
(repeat n
(setq rdim (ssname rdims i)
pos (cdr (assoc 10 (entget rdim)))
rdim (vlax-ename->vla-object rdim)
valor-actual (atof (vla-get-DimConstrValue rdim))
increm (val i valor-actual)
i (1+ i))
(vla-put-DimConstrExpression
rdim
(rtos (+ valor-actual increm)))))
(alert "\nError modificando restricciones.")))
;;;Listado 20.11. Función que modifica las restricciones dimensionales.
(defun C:SUP-ASO (/ *error* n intervalo alto ancho lista-origen perfiles)
(defun *error* ()
(cmd-salir)
(vla-EndUndoMark *aevl:dibujo*)
(command-s "_U"))
(vla-StartUndoMark *aevl:dibujo*)
(cmd-entrar)
(if (= (getvar "WORLDUCS") 0)
(vl-cmdf "_UCS" "_W"))
(datos-sup-aso)
(setq i 0)
(repeat n
(setq lista-origen (cons (* intervalo i) lista-origen)
i (1+ i)))
(crea-perfiles
(reverse lista-origen)
alto
ancho
(strcat id "_PERFIL")
id)
(crea-sup-aso perfiles)
(mod-rest)
(cmd-salir)
(ax-SOsup)
(vla-EndUndoMark *aevl:dibujo*))
;;;Listado 20.12. Función principal C:SUP-ASO.
(defun cmd-conv-param (id / rdims i)
(if (= (getvar "BLOCKEDITOR") 1)
(progn
(setq rdims (ssget
"X"
(list
'(0 . "DIMENSION")
'(8 . "*ADSK_CONSTRAINTS")
(cons 1 (strcat id "_rad*"))))
i 0)
(repeat (sslength rdims)
(vl-cmdf "_bcparameter"
"_Convert"
(ssname rdims i)
"")
(setq i (1+ i))))))
;;;Listado 20.13. Función que convierte las restricciones en parámetros si se trabaja en el Editor de Bloques.
(defun C:SUP-ASO-BLOQUE (/ *error* n intervalo alto ancho lista-origen perfiles)
(defun *error* ()
(cmd-salir)
(vla-EndUndoMark *aevl:dibujo*)
(command-s "_U"))
(vla-startundomark *aevl:dibujo*)
(cmd-entrar)
(if (= (getvar "WORLDUCS") 0)
(vl-cmdf "_UCS" "_W"))
(datos-sup-aso)
(vl-cmdf "_BEDIT" id "")
(setq i 0)
(repeat n
(setq lista-origen (cons (* intervalo i) lista-origen)
i (1+ i)))
(crea-perfiles
(reverse lista-origen)
alto
ancho
(strcat id "_PERFIL")
id)
(crea-sup-aso perfiles)
(mod-rest)
(cmd-conv-param id)
(vl-cmdf "_BCLOSE" "_Save")
(vl-cmdf "_INSERT" id "0,0" "1.0" "1.0" "0")
(cmd-salir)
(ax-SOsup)
(vla-EndUndoMark *aevl:dibujo*))
;;;Listado 20.14. C:SUP-ASO-BLQ con la conversión de restricciones a parámetros.
