Capítulo 14.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 14: La entidad Spline

(defun ax-spline (lista-puntos / tg-ini tg-fin puntos matriz-pts) 
  (setq tg-ini     (vlax-3d-point '(0 0 0))
        tg-fin     (vlax-3d-point '(0 0 0))
        puntos     (apply 'append lista-puntos)
        matriz-pts (vlax-make-safearray 
                     vlax-vbDouble
                     (cons 0 (1- (length puntos))))
        matriz-pts (vlax-safearray-fill matriz-pts puntos))
  (vla-AddSpline 
    (espacio-actual *aevl:dibujo*)
    matriz-pts
    tg-ini
    tg-fin))
		;;;Listado 14.1. Función que crea una entidad SPLINE aplicando el método AddSpline.

(defun ent-spline-FP (lista-puntos) 
  (entmake 
    (append 
      (list '(0 . "SPLINE") 
            '(100 . "AcDbEntity")
            '(100 . "AcDbSpline")
            '(71 . 3)
            (cons 74 (length lista-puntos)))
      (mapcar '(lambda (x) (cons 11 x)) lista-puntos))))
		;;;Listado 14.2. Función que crea una Spline por Puntos de Ajuste.

(defun vector-nudos (vc grado sujeta / numero centro vector i) 
  (setq numero (+ grado vc 1)
        grado  (if sujeta 
                 (1+ grado)
                 grado)
        centro (- numero (* grado 2))
        i      0)
  (repeat grado (setq vector (cons 0 vector)))
  (repeat centro 
    (setq i (1+ i))
    (setq vector (cons i vector)))
  (repeat grado (setq vector (cons (1+ i) vector)))
  (reverse vector))
		;;;Listado 14.3. Función que crea el vector de nudos.

(defun ent-spline-VC (lista-puntos grado sujeta / vc k-vec) 
  (setq vc    (length lista-puntos)
		        k-vec (vector-nudos vc grado sujeta))
  (entmake 
    (append 
      (list '(0 . "SPLINE") 
            '(100 . "AcDbEntity")
            '(100 . "AcDbSpline")
            (cons 71 grado)
            (cons 72 (length k-vec))
            (cons 73 vc)
            '(74 . 0)
            '(42 . 0.0000001)
            '(43 . 0.0000001))
      (mapcar '(lambda (k) (cons 40 k)) k-vec)
      (mapcar '(lambda (x) (cons 10 x)) lista-puntos))))
		;;;Listado 14.4. Función que crea una Spline por el método de Vértices de Control.

(defun vc-helice (centro radio-base radio-sup altura resolucion vueltas torsion / 
		                   n-ver ang incang incrad ang val-z f-rad rad-v vertice vertices) 
  (setq paso   (/ (float altura) (* vueltas resolucion))
        n-ver  (* vueltas resolucion)
        incang (/ pi (/ resolucion 2.0))
        incrad (/ 
                 (float (- radio-sup radio-base))
                 (* vueltas resolucion))
        ang    (- 0.0 incang)
        val-z  (- (nth 2 centro) (/ paso 2))
        f-rad  (cos (/ pi resolucion))
		        rad-v  (- (/ radio-base f-rad) incrad))
  (repeat (+ n-ver 2) 
    (setq vertice  (polar centro ang rad-v)
          vertice  (list (nth 0 vertice) (nth 1 vertice) val-z)
          vertices (cons vertice vertices)
          ang      (if (= torsion 1) 
                     (+ ang incang)
                     (- ang incang))
          rad-v    (+ rad-v incrad)
          val-z    (+ val-z paso)))
  (reverse vertices))
		;;;Listado 14.5. Cálculo de los vértices de control para la hélice.

(defun ent-helix-VC (lista-puntos grado sujeta centro-base radio-base radio-sup 
		                     vueltas paso torsion / cv k-vec) 
  (setq cv    (length lista-puntos)
		        k-vec (vector-nudos cv grado sujeta))
  (entmake 
    (append 
      (list '(0 . "HELIX") 
            '(100 . "AcDbEntity")
            '(100 . "AcDbSpline")
            (cons 71 grado)
            (cons 72 (length k-vec))
            (cons 73 cv)
            '(74 . 0)
            '(42 . 0.0000001)
            '(43 . 0.0000001))
      (mapcar '(lambda (k) (cons 40 k)) k-vec)
      (mapcar '(lambda (x) (cons 10 x)) lista-puntos)
      (list '(100 . "AcDbHelix") 
            (cons 10 centro-base)
            (cons 11 (polar centro-base 0.0 radio-base))
            '(12 0.0 0.0 1.0)
            (cons 40 radio-sup)
            (cons 41 vueltas)
            (cons 42 paso)
            (cons 290 torsion)
            (cons 280 1)))))
		;;;Listado 14.6. Función que crea una entidad HELIX mediante entmake.

(defun datos-spline-helice (/) 
  (initget 1)
  (setq centro-base (getpoint "\nCentro de la Base: "))
  (initget (+ 1 2 4))
  (setq radio-base (getdist centro-base "\nRadio de la Base: "))
  (initget (+ 1 2 4))
  (setq radio-sup (getdist centro-base "\nRadio Superior: "))
  (initget (+ 1 2 4))
  (setq altura (getdist centro-base "\nAltura de la Hélice: "))
  (initget (+ 1 2 4))
  (setq vueltas (getint "\nNúmero de vueltas: "))
  (initget "Horaria Antihoraria")
  (setq torsion (getkword "\nSentido de torsión [Horaria/Antihoraria] <Antihoraria>:" ))
  (if (or (null torsion) (= torsion "Antihoraria")) 
    (setq torsion 1)
    (setq torsion 0))
  (initget (+ 1 2 4))
  (setq resolucion (getint "\nNúmero de vértices para cada vuelta: ")))
		;;;Listado 14.7. Función de entrada de datos para la Hélice.

(defun C:ENT-HELICE (/ centro-base radio-base radio-sup altura resolucion vueltas 
                    torsion lista-puntos) 
  (datos-spline-helice)
  (setq lista-puntos (vc-helice centro-base radio-base radio-sup altura resolucion 
		                                vueltas torsion))
  (ent-helix-VC lista-puntos 3 nil centro-base radio-base radio-sup vueltas paso 
                torsion)
  (princ))
		;;;Listado 14.8. Función principal C:ENT-HELIX

(defun helix->spline (ename /) 
  (cond 
    ((entmake 
       (subst '(0 . "SPLINE") 
              '(0 . "HELIX")
              (reverse 
                (cdr 
                  (member '(100 . "AcDbHelix") 
                          (reverse (entget ename)))))))
     (entdel ename)
     (entlast))))
		;;;Listado 14.9. Conversión de una entidad HELIX en una SPLINE.