;;;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 13: Objetos 3D
(defun ent-plin  (pt-i pt-f norm /)
  (entmake (list '(0 . "LWPOLYLINE")    ;Entidad
                 '(100 . "AcDbEntity")  ;Subclase
                 '(100 . "AcDbPolyline");Subclase
                 '(90 . 2)              ;Número de vértices
                 (cons 10 pt-i)         ;Coordenadas vértice 1
                 '(91 . 1)              ;Id del vértice 1
                 (cons 10 pt-f)         ;Coordenadas vértice 2
                 '(91 . 2)              ;Id del vértice 2
                 (cons 210 norm))))     ;Vector normal
;;;Listado 13.1. Función que dibuja una polilÃnea en el plano frontal.
(defun ent-lin  (pt-i pt-f norm /)
  (entmake (list '(0 . "LINE")          ;Tipo entidad
                 '(100 . "AcDbEntity")  ;Subclase
                 '(100 . "AcDbLine")    ;Subclase
                 (cons 10 pt-i)         ;Vértice 1
                 (cons 11 pt-f)         ;Vértice 2
                 (cons 210 norm))))     ;Vector normal
;;;Listado 13.2. Función de prueba que crea una lÃnea especificando el vector normal.
(defun ax-trans  (pt SC-origen SC-destino como-vector normal-SCO /
                  objeto-Utility args res)
  (vl-load-com)
  (setq objeto-Utility
         (vla-get-Utility
           (vla-get-ActiveDocument
             (vlax-get-acad-object))))
  (if como-vector
    (setq como-vector :vlax-true)
    (setq como-vector :vlax-false))
  (setq args (list objeto-Utility
                   (vlax-3d-point pt)
                   SC-origen
                   SC-destino
                   como-vector))
  (if normal-SCO
    (setq res
           (vl-catch-all-apply
             'vla-TranslateCoordinates
             (append args
               (list (vlax-3d-point normal-SCO)))))
    (setq resÂ
           (vl-catch-all-apply
                'vla-TranslateCoordinates
                args)))
  (if (vl-catch-all-error-p res)
    (prompt (vl-catch-all-error-message res))
    (vlax-safearray->list (vlax-variant-value res))))
;;;Listado 13.3. Función que sustituye a TRANS utilizando el método ActiveX TranslateCoordinates.
;;; Vector A -> B
;;; Argumentos: A, B, listas de tres números reales.Â
(defun vec (A B) (mapcar '- B A))
;;; Suma de vectores
;;; Argumentos: v1, v2, listas de tres números reales.
(defun v+v (v1 v2) (mapcar '+ v1 v2))
;;; Producto ESCALAR (dot product)
;;; Argumentos: v1, v2, listas de tres números reales.
(defun x-esc  (v1 v2)
  (apply '+ (mapcar '* v1 v2)))
;;; Longitud del vector (módulo)
;;; Argumento: v, lista de tres números reales.
(defun m-vec  (v)
  (sqrt (apply '+ (mapcar '* v v))))
;;; Vector unitario
;;; Argumento: v, lista de tres números reales.
(defun v-unit  (v / m)
  (cond ((zerop (setq m (m-vec v))) nil)
        (t (mapcar '(lambda (n) (/ n m)) v))))
;;; Producto VECTORIAL (cross product)
;;; Argumentos: v1, v2, listas de tres números reales.
(defun prod-vec  (v1 v2)
  (list (- (* (cadr v1) (caddr v2))
           (* (cadr v2) (caddr v1)))
        (- (* (car v2) (caddr v1))
           (* (car v1) (caddr v2)))
        (- (* (car v1) (cadr v2))
           (* (car v2) (cadr v1)))))
;;;Listado 13.4. Operaciones Vectoriales.
(defun ax-traslacion  (obj vector)
  (vla-TransformBy
    obj
    (vlax-tmatrix
      (list (list 1.0 0.0 0.0 (nth 0 vector))
            (list 0.0 1.0 0.0 (nth 1 vector))
            (list 0.0 0.0 1.0 (nth 2 vector))
            (list 0.0 0.0 0.0 1.0)))))
;;;Listado 13.5. Función para desplazamiento.
;;; Grados a Radianes
(defun gar (g) (/ (* g pi) 180.0))
;;; Radianes a Grados
(defun rag (r) (* (/ r pi) 180.0))
;;;Listado 13.6. Conversión entre Grados y Radianes.
(defun ax-rot-x  (obj a)
  (setq a (gar a))
  (vla-TransformBy
    obj
    (vlax-tmatrix
      (list (list 1.0 0.0 0.0 0.0)
            (list 0.0 (cos a) (sin a) 0.0)
            (list 0.0 (- (sin a)) (cos a) 0.0)
            (list 0.0 0.0 0.0 1.0)))))
;;;Listado 13.7. Rotación en torno a X.
(defun ax-rot-y  (obj a)
  (setq a (gar a))
  (vla-TransformBy
    obj
    (vlax-tmatrix
      (list (list (cos a) 0.0 (sin a) 0.0)
            (list 0.0 1.0 0.0 0.0)
            (list (- (sin a)) 0.0 (cos a) 0.0)
            (list 0.0 0.0 0.0 1.0)))))
;;;Listado 13.8. Rotación en torno a Y.
(defun ax-rot-z  (obj a)
  (setq a (gar a))
  (vla-TransformBy
    obj
    (vlax-tmatrix
      (list (list (cos a) (- (sin a)) 0.0 0.0)
            (list (sin a) (cos a) 0.0 0.0)
            (list 0.0 0.0 1.0 0.0)
            (list 0.0 0.0 0.0 1.0)))))
;;;Listado 13.9. Rotación en torno a Z.
(defun ax-escala  (obj vector / res)
  (setq res
         (vl-catch-all-apply
           'vla-TransformBy
           (list obj
                 (vlax-tmatrix
                   (list (list (nth 0 vector) 0.0 0.0 0.0)
                         (list 0.0 (nth 1 vector) 0.0 0.0)
                         (list 0.0 0.0 (nth 2 vector) 0.0)
                         (list 0.0 0.0 0.0 1.0))))))
  (if (vl-catch-all-error-p res)
    (prompt "¡Este objeto no puede ser deformado!")))
;;;Listado 13.10. Función para transformación de escala en XYZ.
(defun ax-ciz-x  (obj factor / res)
  (setq res
         (vl-catch-all-apply 'vla-TransformBy
           (list obj
             (vlax-tmatrix
               (list (list 1.0 factor 0.0 0.0)
                     (list 0.0 1.0 0.0 0.0)
                     (list 0.0 0.0 1.0 0.0)
                     (list 0.0 0.0 0.0 1.0))))))
  (if (vl-catch-all-error-p res)
    (prompt "¡Este objeto no puede ser deformado!")))
;;;Listado 13.11. Cizalladura en X.
(defun ax-ciz-y  (obj factor / res)
  (setq res
         (vl-catch-all-apply 'vla-TransformBy
           (list obj
             (vlax-tmatrix
               (list (list 1.0 0.0 0.0 0.0)
                     (list factor 1.0 0.0 0.0)
                     (list 0.0 0.0 1.0 0.0)
                     (list 0.0 0.0 0.0 1.0))))))
  (if (vl-catch-all-error-p res)
    (prompt "¡Este objeto no puede ser deformado!")))
;;;Listado 13.12. Cizalladura en Y.
(defun ax-ciz-z  (obj factor / res)
  (setq res
         (vl-catch-all-apply 'vla-TransformBy
           (list
             obj
             (vlax-tmatrix
               (list (list 1.0 0.0 0.0 0.0)
                     (list 0.0 1.0 0.0 0.0)
                     (list factor factor 1.0 0.0)
                     (list 0.0 0.0 0.0 1.0))))))
  (if (vl-catch-all-error-p res)
    (prompt "¡Este objeto no puede ser deformado!")))
;;;Listado 13.13. Cizalladura en Z.
(defun C:TRANSFORMA
       (/ obj base factor-x factor-y factor-z)
  (if (setq obj
             (vlax-ename->vla-object
               (car
                 (entsel "\nDesigne objeto a transformar: "))))
    (progn (setq base (getpoint "\nPunto base: "))
           (initget (+ 1 2))
           (setq factor-x (getreal "\nFactor de escala X: "))
           (initget (+ 1 2))
           (setq factor-y (getreal "\nFactor de escala Y: "))
           (initget (+ 1 2))
           (setq factor-z (getreal "\nFactor de escala Z: "))
           (ax-traslacion obj (mapcar '- base))
           (ax-escala obj (list factor-x factor-y factor-z))
           (ax-traslacion obj base))
    (prompt "\nNingún objeto designado.")))
;;;Listado 13.14. Comando para transformar con distintas escalas en XYZ.
(defun ax-scp  (nombre origen dirx diry / tmp)
  (setq tmpÂ
         (vla-Add (vla-get-UserCoordinateSystems *aevl:dibujo*)
          (vlax-3d-point '(0 0 0))
          (vlax-3d-point dirx)
          (vlax-3d-point diry)
          nombre))
  (vla-put-Origin tmp (vlax-3d-point origen))
  tmp)
;;;Listado 13.15. Función que añade un nuevo SCP al documento actual.
(defun ax-matriz-scp  (/ nombre ucs-num new-ucs)
  (setq nombre (getvar "UCSNAME"))
  (cond
    ((or (equal nombre "")
         (and (vl-string-search "*" nombre 0)
              (vl-string-search "*" nombre (1- (strlen nombre)))))
     (setq ucs-num (vla-get-Count
                     (vla-get-UserCoordinateSystems
                       *aevl:dibujo*))
           nombre  (strcat "SCP_" (itoa ucs-num)))
     (setq new-ucs (ax-scp nombre
                           (getvar "UCSORG")
                           (getvar "UCSXDIR")
                           (getvar "UCSYDIR")))
     (vla-put-ActiveUCS *aevl:dibujo* new-ucs)
     (list nombre (vla-GetUCSMatrix new-ucs)))
    (t
     (list (vla-get-Name (vla-get-ActiveUCS *aevl:dibujo*))
           (vla-GetUCSMatrix (vla-get-ActiveUCS *aevl:dibujo*))))))
;;;Listado 13.16. Función que devuelve la Matriz de Transformación del SCP actual.
(defun ax-vista  (direccion zoom / vport)
  (setq vport (vla-get-ActiveViewport *aevl:dibujo*))
  (vla-put-Direction vport (vlax-3d-point direccion))
  (vla-put-ActiveViewport *aevl:dibujo* vport)
  (vlax-release-object vport)
  (if zoom
    (vla-ZoomExtents *aevl:acad*))
  (princ))
;;;Listado 13.17. Función que establece la dirección de la vista.
(defun var-vis  ()
  (if (= (getvar "BLOCKEDITOR") 0)
    (progn (setvar "VSFACESTYLE" 2)
           (setvar "VSMONOCOLOR" "RGB:211,76,3")
           (setvar "VSFACECOLORMODE" 1)
           (setvar "VSSHADOWS" 0)
           (setvar "VSHALOGAP" 0)
           (setvar "VSSILHEDGES" 0)
           (setvar "VSINTERSECTIONEDGES" 0)
           (setvar "VSEDGEJITTER" 0)
           (setvar "VSFACEOPACITY" 100)
           (setvar "VSEDGES" 1)
           (setvar "VSEDGECOLOR" "ByEntity")
           (setvar "VSISOONTOP" 0)
           (setvar "VSOBSCUREDEDGES" 0)
           (setvar "VSOCCLUDEDEDGES" 0)
           (setvar "VSINTERSECTIONEDGES" 0)
           (setvar "PERSPECTIVE" 1))))
;;;Listado 13.18. Función que establece un estilo visual personalizado.
(defun ax-sup ()
  (ax-vista '(0 0 1) t)
  (var-vis))
(defun ax-der ()
  (ax-vista '(1 0 0) t)
  (var-vis))
(defun ax-frontal  ()
  (ax-vista '(0 -1 0) t)
  (var-vis))
(defun ax-NEsup  ()
  (ax-vista '(1 1 1) t)
  (var-vis))
(defun ax-NOsup  ()
  (ax-vista '(-1 1 1) t)
  (var-vis))
(defun ax-SOsup  ()
  (ax-vista '(-1 -1 1) t)
  (var-vis))
(defun ax-SEsup  ()
  (ax-vista '(1 -1 1) t)
  (var-vis))
(defun ax-inferior  ()
  (ax-vista '(0 0 -1) t)
  (var-vis))
(defun ax-izquierda  ()
  (ax-vista '(-1 0 0) t)
  (var-vis))
(defun ax-posterior  ()
  (ax-vista '(0 1 0) t)
  (var-vis))
(defun ax-NEinf  ()
  (ax-vista '(1 1 -1) t)
  (var-vis))
(defun ax-NOinf  ()
  (ax-vista '(-1 1 -1) t)
  (var-vis))
(defun ax-SOinf  ()
  (ax-vista '(-1 -1 -1) t)
  (var-vis))
(defun ax-SEinf  ()
  (ax-vista '(1 -1 -1) t)
  (var-vis))
;;;Listado 13.19. Funciones que establecen la visualización 3D.
