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