Capítulo 16.lsp

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