;;;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.
