Capítulo 22.lsp

		;;;Código fuente del libro "Experto AutoCAD con Visual LISP"
		;;; (c) 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 22. DCL: La Interfaz Gráfica del Usuario.

(defun inicia-dialogo (nombredialogo archivodcl /) 
  (if (not *Posicion*) 
    (setq *Posicion* '(-1 -1)))
  (if (= -1 (setq dcl_id (load_dialog archivodcl))) 
    (alert (strcat "No se encuentra el archivo\nde diálogo " archivodcl))
    (if (not (new_dialog nombredialogo dcl_id "" *Posicion*)) 
      (alert 
        (strcat "No se encuentra la \ndefinición de diálogo " 
                nombredialogo))
      t)))
		;;;Listado 22.2. Función para iniciar un diálogo cualquiera.

(defun inicia-imagen (clave imagen) 
  (start_image clave)
  (fill_image 0 0 (dimx_tile "img") (dimy_tile "img") -2)
  (slide_image 0 0 (dimx_tile clave) (dimy_tile clave) imagen)
  (end_image)) 
		;;;Listado 22.3. Función que carga una imagen SLD en un diálogo.

(defun formato-param (clave valor /) 
  (set_tile clave (rtos (abs (atof valor)) 2 2))) 
		;;;Listado 22.4. Función que comprueba y da formato al valor introducido en la casilla 

(defun param-edit (clave valor razon / forma) 
  (formato-param clave valor)
  (if (or (= razon 1) (= razon 2)) 
    (cond 
      ((= (get_tile "nor") "1") ;caso Normal
       (test-normal clave))
      ((= (get_tile "nor") "0") ; otros casos
       (setq forma (form-sel))
       (test-otros forma))))) 
		;;;Listado 22.5. Acción de respuesta a las casillas de edición de parámetros.

(defun test-otros (forma / rad-a dim-x dim-y rad-c) 
  (cond 
    ((= forma "esf")
     (setq rad-a (atof (get_tile "ra")))
     (if (<= rad-a 0) 
       (setq ok nil)
       (progn (setq ok t) 
              (set_tile "dx" (rtos rad-a 2 2))
              (set_tile "dy" (rtos (* rad-a 2) 2 2)))))
    ((= forma "bar")
     (setq dim-x (atof (get_tile "dx"))
           dim-y (atof (get_tile "dy")))
     (if (or (<= dim-x 0) (<= dim-y 0)) 
       (setq ok nil)
       (setq ok t)))
    ((= forma "tub")
     (setq dim-x (atof (get_tile "dx"))
           dim-y (atof (get_tile "dy"))
           rad-c (atof (get_tile "rc")))
     (if (or (<= dim-x 0) (<= dim-y 0) (<= rad-c 0)) 
       (setq ok nil)
       (setq ok t))))
  (if ok 
    (progn (mode_tile "accept" 0) (set_tile "error" ""))
    (progn (mode_tile "accept" 1) 
           (set_tile "error" 
                     "Los parámetros deben ser mayores que 0")))) 
;;;Listado 22.6. Función test-otros.

(defun test-1 (rad-a /) 
  (if (<= rad-a 0) 
    (progn (setq msj "RadioAcuerdo debe ser mayor que 0") 
           (setq ok1 nil))
    (setq ok1 t))) 

(defun test-2 (rad-a dim-y /) 
  (if (> (* rad-a 2) dim-y) 
    (progn 
      (setq msj (strcat "DimY debe ser mayor que " 
                        (rtos (* rad-a 2) 2 2)))
      (setq ok2 nil))
    (setq ok2 t))) 

(defun test-3 (rad-a dim-x) 
  (if (> rad-a dim-x) 
    (progn 
      (setq msj (strcat "DimX debe ser mayor que " 
                        (rtos rad-a 2 2)))
      (setq ok3 nil))
    (setq ok3 t))) 
		;;;Listado 22.7. Funciones de prueba test-1, test-2 y test-3.

(defun test-normal (clave / dim-x dim-y rad-a msj ok1 ok2 ok3) 
  (setq dim-x (atof (get_tile "dx"))
        dim-y (atof (get_tile "dy"))
        rad-a (atof (get_tile "ra")))
  (test-1 rad-a)
  (test-2 rad-a dim-y)
  (test-3 rad-a dim-x)
  (cond 
    ((= clave "ra") (test-1 rad-a))
    ((= clave "dx") (test-3 rad-a dim-x))
    ((= clave "dy") (test-2 rad-a dim-y)))
  (if (and ok1 ok2 ok3) 
    (progn (mode_tile "accept" 0) (set_tile "error" ""))
    (progn (mode_tile "accept" 1) (set_tile "error" msj)))) 
;;;Listado 22.8. Función test-normal.

(defun ops-forma (clave valor / dim-x dim-y rad-a rad-c) 
  (cond 
    ((and (= clave "nor") (= valor "1")) ; FORMA NORMAL
     (setq dim-x (atof (get_tile "dx"))
           dim-y (atof (get_tile "dy"))
           rad-a (atof (get_tile "ra")))
     (mode_tile "dx" 0)
     (mode_tile "dy" 0)
     (mode_tile "ra" 0)
     (mode_tile "rc" 0)
     (if (= rad-a 0) 
       (set_tile "ra" (rtos (/ dim-x 2) 2 2)))
     (if (< dim-y (* rad-a 2)) 
       (set_tile "dy" (rtos (* rad-a 2) 2 2)))
     (inicia-imagen "img" "./img/nor")
     (test-normal "dx"))
    ((and (= clave "esf") (= valor "1")) ; FORMA ESFERA
     (setq dim-x (atof (get_tile "dx"))
           rad-a (atof (get_tile "ra")))
     (if (= rad-a 0) 
       (progn (set_tile "ra" (get_tile "dx")) 
              (setq rad-a dim-x))
       (set_tile "dx" (get_tile "ra")))
     (set_tile "dy" (rtos (* rad-a 2) 2 2))
     (set_tile "rc" "0.00")
     (mode_tile "dx" 1)
     (mode_tile "dy" 1)
     (mode_tile "ra" 0)
     (mode_tile "rc" 1)
     (inicia-imagen "img" "./img/esf")
     (test-otros clave))
    ((and (= clave "bar") (= valor "1")) ; FORMA BARRA
     (set_tile "ra" "0.00")
     (set_tile "rc" "0.00")
     (mode_tile "dx" 0)
     (mode_tile "dy" 0)
     (mode_tile "ra" 1)
     (mode_tile "rc" 1)
     (inicia-imagen "img" "./img/bar")
     (test-otros clave))
    ((and (= clave "tub") (= valor "1")) ; FORMA TUBO
     (setq rad-c (atof (get_tile "rc")))
     (set_tile "ra" "0.00")
     (if (= rad-c 0) 
       (set_tile "rc" (get_tile "dx")))
     (mode_tile "dx" 0)
     (mode_tile "dy" 0)
     (mode_tile "ra" 1)
     (mode_tile "rc" 0)
     (inicia-imagen "img" "./img/tub")
     (test-otros clave)))
  ;;;Listado 22.9. Función de respuesta a las casillas de selección de forma predefinida.

  (defun form-sel (/) 
    (cond 
      ((= (get_tile "nor") "1") "nor")
      ((= (get_tile "esf") "1") "esf")
      ((= (get_tile "bar") "1") "bar")
      ((= (get_tile "tub") "1") "tub"))
    ;;;Listado 22.10. Detectar el radio_button seleccionado para la forma predefinida.

    (defun sel-rotacion (clave valor razon / forma) 
      (cond 
        ((= clave "ang")
         (if (or (= razon 3) (= razon 2) (= razon 1)) 
           (set_tile "inf" valor)))
        ((= clave "inf")
         (if (or (= razon 2) (= razon 1)) 
           (if (numberp (read valor)) 
             (set_tile "ang" valor)
             (set_tile "inf" (get_tile "ang"))))))
      (setq forma (form-sel))
      (if (= forma "nor") 
        (test-normal "ra")
        (test-otros forma)))
    ;;;Listado 22.11. Función de respuesta asociada al cursor deslizante.

    (defun tipo-modelo (/) 
      (if (= (get_tile "sol") "1") 
        "_SO"
        "_SU"))
    ;;;Listado 22.12. Función que determina el tipo de modelo a crear.
    
    (defun asigna-acciones (/) 
      (action_tile "nor" "(ops-forma $key $value)")
      (action_tile "esf" "(ops-forma $key $value)")
      (action_tile "bar" "(ops-forma $key $value)")
      (action_tile "tub" "(ops-forma $key $value)")
      (action_tile "dx" "(param-edit $key $value $reason)")
      (action_tile "dy" "(param-edit $key $value $reason)")
      (action_tile "ra" "(param-edit $key $value $reason)")
      (action_tile "rc" "(param-edit $key $value $reason)")
      (action_tile 
        "ang"
        "(sel-rotacion $key $value $reason)")
      (action_tile 
        "inf"
        "(sel-rotacion $key $value $reason)")
      (action_tile 
        "accept"
        "(setq dim-x (atof (get_tile \"dx\"))
		               dim-y (atof (get_tile \"dy\"))
		               rad-a (atof (get_tile \"ra\"))
		               rad-c (atof (get_tile \"rc\"))
		               ang-r (atof (get_tile \"ang\"))
               forma (form-sel)
               tipo (tipo-modelo)
		               *Posicion* (done_dialog 1)))")
      (action_tile 
        "cancel"
        "(setq *Posicion* (done_dialog 0))"))
    ;;;Listado 22.13. Asignación de acciones a los componentes.



    (defun dialogo-param (/ accion) 
      (setvar "DIMZIN" 1)
      (if (inicia-dialogo "parametrico" "./dcl/parametrico.dcl") 
        (progn (inicia-imagen "img" "./img/nor") 
               (asigna-acciones)
               (setq accion (start_dialog))
               (if (= accion 1) 
		                 (dib-param tipo dim-x dim-y rad-a rad-c ang-r))
               (unload_dialog dcl_id))))
    ;;;Listado 22.14. Función que activa el cuadro de diálogo.

    (defun curv (ang /) 
      (/ (sin (/ ang 4)) (cos (/ ang 4))))
    ;;;Listado 22.15. Función para el cálculo el factor de curvatura (bulge).

    (defun perfil-rev (max-x med-x max-y min-y rad-c / pts) 
      (setq pts (list (list rad-c min-y) 
                      (list med-x min-y)
                      (list max-x (+ min-y rad-a))
                      (list max-x (- max-y rad-a))
                      (list med-x max-y)
                      (list rad-c max-y)))
      (if 
        (entmake 
          (list '(0 . "LWPOLYLINE") 
                '(100 . "AcDbEntity")
                '(100 . "AcDbPolyline")
                (cons 90 (length pts))
                '(70 . 1)
                (cons 10 (nth 0 pts))
                (cons 10 (nth 1 pts))
                (cons 42 (curv (/ pi 2)))
                (cons 10 (nth 2 pts))
                (cons 10 (nth 3 pts))
                (cons 42 (curv (/ pi 2)))
                (cons 10 (nth 4 pts))
                (cons 10 (nth 5 pts))
                '(210 0.0 0.0 1.0)))
        (setq perfil (entlast))))
    ;;;Listado 22.16. Función que dibuja el perfil como una LWPOLYLINE.

    (defun dib-param (modo dim-x dim-y rad-a rad-c ang-r / max-y min-y max-x med-x 
                      pts perfil) 
      (setq max-y (/ dim-y 2)
            min-y (- max-y)
            max-x (+ rad-c dim-x)
            med-x (- max-x rad-a))
		      (perfil-rev max-x med-x max-y min-y rad-c) ; Perfiles
      (if perfil 
        (progn 
          (if (= modo "_SU")  ; Modelo
            (progn (setvar "SURFACEMODELINGMODE" 0) 
                   (setvar "SURFACEASSOCIATIVITY" 1)
                   (vl-cmdf "_AutoConstrain" perfil "")))
          (vl-cmdf "_REVOLVE" "_MOde" modo perfil "" "_Y" ang-r)
          (ax-SOsup))))
    ;;;Listado 22.17. Función que crea el modelo.

    (defun C:DCL-PARAM (/ *error*) 
      (defun *error* () 
        (cmd-salir)
        (command-s "_UNDO" "_End"))
      (cmd-entrar)
      (command-s "_UNDO" "_Begin")
      (if (= (getvar "WORLDUCS") 0) 
        (vl-cmdf "_UCS" "_W"))
      (dialogo-param)
      (command-s "_UNDO" "_End")
      (cmd-salir))
    ;;;Listado 22.18. Función principal C:DCL-PARAM.