lisp-para-generar-progresivas-de-un-alineamiento

Ir abajo

lisp-para-generar-progresivas-de-un-alineamiento Empty lisp-para-generar-progresivas-de-un-alineamiento

Mensaje por Luis Alberto Benitez el Mar Sep 24, 2019 3:45 pm

encontre un lisp para generar Progresivas pero tiene un tiempo limitado


(princ "\nRutina para Dibujar Progresivas en Alineamientos 2D")
(princ "\nEscriba \"PROGRESIVAS\" para ejecutar rutina.")
(princ"\nPara reiniciar escriba \"RESET_PROGRESIVAS\"")
(princ "\n*** Ver 1.0, Febrero-2002    by M.Santillán ***\n")


(princ)


(defun c:progresivas ()
 (progresivas)
 )

(vl-load-com)
(defun progresivas (/ obj  dia
     #dias  prog
     gap  ucs
     cdate  prec_dcl
     font_list  manlio
     escala  esp_prin
     esp_sec  cmdecho
     char_width  dwgprefix
     dwgname  file_progresivas
     esp_inter  radio_ubica1
     radio_ubica2  toggle_progs
     toggle_marcas  fmto_progresivas
     progresivas_cfg  l_precision
     cfg-name  cfg-instal
     f_rutina  periodo
     dcl_progresivas_pto1
     dcl_progresivas_pto2
     dcl_progresivas_pto3
     dcl_progresivas_pto4
     dcl_progresivas_pto5
     dcl_progresivas_pto6
     dcl_progresivas_pto7
     dcl_progresivas_pto8
     dcl_progresivas_pto9
     dcl_progresivas_pto10
     nombre_layer_no_permitido)
 (setq cmdecho (getvar "cmdecho"))
 (variables)
 (if (setq #dias (verifica-inicio rutina f_rutina))
   (progn
     (if (< #dias 2)
(setq dia " día ")
(setq dia " días ")
)
     (if (< #dias 6.0)
(alert (strcat "Le quedan "
      (rtos #dias 2 0)
      dia
      "para seguir usando la rutina")
      )
)
     (setvar "cmdecho" 0)
     (command "_undo" "Inicio")
     (crea_font_layer '((0 "ROMANS") (0 "ROMAND")) 2)
     (if (dcl_control_progresivas1)
(progn
 (grafica-progs
   obj
   prog
   fmto_progresivas
   esp_prin
   esp_sec
   (- 1  (* 2 radio_ubica1))
   marcas
   (- 1 (* 2 radio_ubica2))
   l_precision
   )
 (graba_cfg progresivas_cfg);; graba configuracion
 )
)
     (command "_undo" "Fin")
     (setvar "cmdecho" cmdecho)
   )
 )
 (princ)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; VARIABLES DE CONTROL GENERAL DE INICIO ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun variables ( / a b indice)
 (setq prec_dcl 3
char_width 0.94
esp_inter 2.0
font_list (acad_strlsort (stilo "STYLE" nil))
nombre_layer_no_permitido "*<*,*>*,*/*,*\\*,*\"*,*:*,*`?*,*`**,*|*,*`,*,*=*,*'*"
rutina "progresivas"
progresivas_cfg (findfile (strcat rutina ".ini"))
manlio "by M.Santillán"
dwgprefix (getvar "dwgprefix")
dwgname (getvar "dwgname")
dwgname (substr dwgname 1 (- (strlen dwgname) 4))
periodo 10
cdate (getvar "cdate")
cfg-name "Appdata/Progresivas"
f_rutina (findfile (strcat rutina ".vlx")))
 (if (not f_rutina)
   (setq f_rutina (findfile (strcat rutina ".arx")))
   )
 (if (not f_rutina)
   (setq f_rutina (findfile (strcat rutina ".lsp")))
   )
 (if progresivas_cfg
   (progn
     (setq indice (open progresivas_cfg "r")
   ;; LEE UCS
   a (read-line indice)
   a (read-line indice)
   a (read-line indice)
   a (read-line indice)
   b (eval (read (strcat "(setq " a " )")))
   ;; LEE PROGRESIVA INICIAL
   a (read-line indice)
   a (read-line indice)
   a (read-line indice)
   b (eval (read (strcat "(setq " a ")")))
   ;; LEE LISTA DE PRECISION
   a (read-line indice)
   a (read-line indice)
   a (read-line indice)
   b (eval (read (strcat "(setq " a ")")))
   ;; LEE ESCALA
   a (read-line indice)
   a (read-line indice)
   a (read-line indice)
   b (eval (read (strcat "(setq " a ")")))
   ;; LEE DATOS DE ESPACIAMIENTOS
   a (read-line indice)
   a (read-line indice)
   a (read-line indice)
   b (eval (read (strcat "(setq " a ")")))
   ;; LEE LISTA DE MARCAS
   a (read-line indice)
   a (read-line indice)
   a (read-line indice)
   b (eval (read (strcat "(setq " a ")")))
   ;; LEE FORMATOS
   a (read-line indice)
   a (read-line indice)
   a (read-line indice)
   a (strcat a " ")
   )
     (repeat 9
(setq a (strcat a (read-line indice)))
)
     (eval (read (strcat "(setq " a ")")))
     (setq
;; LEE CONTROL DE ARCHIVOS DE DATOS
a (read-line indice)
a (read-line indice)
a (read-line indice)
b (eval (read (strcat "(setq " a ")")))
a (read-line indice)
b (eval (read (strcat "(setq " a ")")))
a (read-line indice)
b (eval (read (strcat "(setq " a ")")))
a (read-line indice)
b (eval (read (strcat "(setq " a ")")))
;; LEE PUNTOS DE PRESENTACION DE DCLs
a (read-line indice)
a (read-line indice)
)
     (repeat 10
(setq a (strcat "(setq " (read-line indice) ")"))
(eval (read a))
)
     (close indice)
     );end progn if
   (progn
     (setq escala (escala_ini)
   fmto_progresivas (carga_datos_progresivas)
   esp_prin 50.0
   esp_sec 10.0
   l_precision (precision_ini); precisión (progs coord_x coord_y)
   toggle_progs 1
   toggle_marcas 0
   dcl_progresivas_pto1 '(-1 -1)
   dcl_progresivas_pto2 '(-1 -1)
   dcl_progresivas_pto3 '(-1 -1)
   dcl_progresivas_pto4 '(-1 -1)
   dcl_progresivas_pto5 '(-1 -1)
   dcl_progresivas_pto6 '(-1 -1)
   dcl_progresivas_pto7 '(-1 -1)
   dcl_progresivas_pto8 '(-1 -1)
   dcl_progresivas_pto9 '(-1 -1)
   dcl_progresivas_pto10 '(-1 -1)
   ucs 0; control del toggle para ucs
   radio_ubica1 0
   radio_ubica2 0
   toggle_regla 1
   toggle_marcas 0
   prog 0.0
   gap (* 1.0 char_width (nth 2 (nth 2 fmto_progresivas)))
   )
     (if f_rutina
(setq progresivas_cfg (strcat (nth 0 (lee f_rutina ".")) ".ini"))
)
     ); end progn then
   )
 )


;;; SISTEMA DE SEGURIDAD DE RUTINA ;;;
(defun verifica-inicio (rutina f_rutina / acadexe a b f_rutina cfg-fecha)
 (setq acadexe (time (vl-file-systime (findfile "acad.exe")))
cfg-instal (eval (read (strcat "'(" (getcfg cfg-name) ")")))
)
 (if cfg-instal
   (setq cfg-fecha (nth 1 cfg-instal)
 periodo (nth 2 cfg-instal)
 cfg-instal (nth 0 cfg-instal))
   (setq cfg-instal cdate
 cfg-fecha cdate)
   )
 (if f_rutina
   (progn
     (setq b (opera-fecha
(fix cdate)
(fix (setq f_rutina (time (vl-file-systime f_rutina))))
periodo)
   a (opera-fecha (fix cfg-fecha) (fix cfg-instal) periodo))
     (if (or (<= a 0.0)
     (and (<= a 0.0)
 b
 ))
(setq a (alert
 "Tiempo Límite de Prueba Finalizado\n\t\t     M.Santillán"))
)
     (if (or (> acadexe cdate); fecha autocad > fecha actual
     (> f_rutina cdate); fecha rutina > fecha actual
     (> cfg-instal cdate); fecha de instalacion > fecha actual
     (> cfg-fecha cdate); fecha de cfg > fecha actual
     )
(setq a
      (alert
(strcat
  "Ha modificado la fecha de su sistema. Para ejecutar"
  "\nla rutina es necesario que corrija la hora y fecha"
  "\nde su computador                    ...."
  )
)
     )
)
     )
   (setq a
  (alert (strcat
   "Ubique el Programa en uno de los Directorios del Support de AutoCAD."
   "\n\nSi ha cargado una versión arx, deberá descargala antes ejecutando"
   "\nla siguiente instrucción desde la línea de comandos:"
   "\n\t\t(arxunload \"" rutina "\")"
   )
 )
 )
   )
 (setq a a)
 )

;;; CONVIERTE FORMATO DE TIEMPO DEL VL-FILE-SYSTIME A FORMATO DE ACAD ;;;
;;; ENTRADA: lista= LISTA 1D DEL FORMATO VL-FILE-SYSTIME ;;;
;;; SALIDA: valor numérico real con formato ACAD ;;;
(defun time (lista / tiempo)
 (+ (* (nth 0 lista) 10000.0)
    (* (nth 1 lista) 100.0)
    (nth 3 lista)
    )
 )

;;; DETERMINA LA DIFERENCIA DE DIAS ENTRE UNA FECHA Y OTRA + UN PERIODO ;;;
;;; ENTRADA: inicio= fecha de inicio en formato CAD ;;;
;;; fin= fecha de final en formato CAD ;;;
;;; periodo=número de días de periodo ;;;
;;; SALIDA: a= # de días comprendidos entre fin-inicio+periodo ;;;
(defun opera-fecha (inicio fin periodo / a b c)
 (setq inicio (fecha->dias inicio)
fin (fecha->dias fin)
a (* 365.0 (- (nth 0 fin) (nth 0 inicio)))
b (- (nth 1 fin) (nth 1 inicio) (- periodo))
)
 (if (> a 0.0)
   (progn
     (setq c (* 4.0 (fix (/ fin 4.0))))
     (if (> c (nth 0 inicio))
(setq a (+ a (* 1 (1+ (fix (/ (- (nth 0 fin) c) 4.0))))))
)
     )
   )
 (setq a (+ a b))
 )

;;; CONVIERTE UNA FECHA EN LISTA: (AÑO DIAS) ;;;
;;; ENTRADA: valor= fecha en formato CAD ;;;
;;; SALIDA: lista= '(año días) ;;;
;;; los días se cuentan a partir de ;;;
;;; 1ro de enero del año de "VALOR" ;;;
(defun fecha->dias (valor / dia mes ano lista)
 (setq ano   (fix (/ valor 10000.0))
mes   (fix (/ (- valor (* ano 10000.0)) 100.0))
dia   (- valor (* ano 10000.0) (* mes 100.0))
lista '(0.0 ;enero
31.0 ;febrero
59.0 ;marzo
90.0 ;abril
120.0 ;mayo
151.0 ;junio
181.0 ;julio
212.0 ;agosto
243.0 ;setiembre
273.0 ;octubre
304.0 ;noviembre
334.0 ;diciembre
)
)
 (if (= ano (* 4.0 (fix (/ ano 4.0))))
   (setq dia (+ dia (nth (- mes 1) lista) 1.0))
   (setq dia (+ dia (nth (- mes 1) lista)))
   )
 (list ano dia)
 )

;;; ESCALA POR DEFECTO ;;;
(defun escala_ini ( / a)
 (setq a 1000.0); esc_formato
 )

;;; Define lista dcl con precisión de trabajo ;;;
(defun precision_ini ()
 '(2 3 0); precisión (progs coords textos)
 )

;;; MATRIZ DE CONTROL DE ENTRADA DE DATOS PARA FORMATEO DE SALIDAS ;;;
(defun carga_datos_progresivas ()
 (list '(("PROG ") "ROMAND" 2.5 "PROGS" 3 "BYLAYER"); 0 PROG INI/FIN
'("" "" 3.5 "PROGS" 256 "BYLAYER"); 1 SUBRAY PRG INI/FIN
'(""   "ROMANS" 2.0 "PROGS1" 256 "BYLAYER"); 2 TXT REGLA
'(""   "" 1.2 "REGLA1" 256 "BYLAYER"); 3 DIV PRINC
'("" "" 1.0 "REGLA2" 256 "BYLAYER"); 4 DIV SECUN
'("" "" 12.0 "MARCA" 256 "BYLAYER"); 5 MARCAS
'(("PROG= <>" "ESTE= <>" "NORTE= <>")
  "ROMANS" 2.0 "MARCA" 256 "BYLAYER"); 6 TXT MARCAS
)
 )

;;; GRABA CONFIGURACION DEL PROGRAMA ;;;
;;; ENTRADA: file= nombre del archivo de configuración ;;;
;;; SALIDA: archivo actualizado con configuración de rutina ;;;
(defun graba_cfg (file / lista i n indice x a b c)
 (setq indice (open file "w"))
 (setq a "")
 (write-line (strcat "Archivo de Configuración de Rutina " rutina) indice)
 ;;GRABA UCS
 (write-line (strcat "\n[UCS]\nucs " (itoa ucs)) indice)
 ;;GRABA PROGRESIVA INICIAL
 (write-line (strcat "\n[PROGRESIVA INICIAL]\nprog " (formato_cota prog 10)) indice)
 ;;GRABA PRECISION
 (write-line (strcat
"\n[PRECISION]\nl_precision \'"
(list1-to-string l_precision)
     ) indice)
 ;;GRABA ESCALA
 (write-line (strcat
"\n[ESCALA]\nescala " (formato_cota escala 10)
) indice)
 ;;GRABA DATOS DE REGLA
 (write-line (strcat
"\n[REGLA]\nesp_prin " (formato_cota esp_prin 10)
" esp_sec " (formato_cota esp_sec 10)
" gap " (formato_cota gap 10)
) indice)
 ;;GRABA DATOS DE MARCAS
 (write-line (strcat
"\n[MARCAS]\nmarcas \'"
(list1-to-string marcas)
     ) indice)
 ;;GRABA FORMATOS
 (write-line (strcat "\n[FORMATOS]\nfmto_progresivas\n" (list2-to-string fmto_progresivas)) indice)
 ;;GRABA CONTROL DE DCL´s
 (write-line (strcat "\n[CONTROL DE ARCHIVOS]\ntoggle_regla "
     (itoa toggle_regla)) indice)
 (write-line (strcat "radio_ubica1 "
     (itoa radio_ubica1)) indice)
 (write-line (strcat "toggle_marcas "
     (itoa toggle_marcas)) indice)
 (write-line (strcat "radio_ubica2 "
     (itoa radio_ubica2)) indice)
 ;;GRABA PUNTOS DE PRESENTACION DE DCLs
 (write-line "\n[PUNTOS DE DCLs]" indice)
 (setq i 0)
 (repeat 10
   (setq i (1+ i)
 a (strcat "(write-line (strcat \"dcl_progresivas_pto\" (itoa i)"
   "\" '\""
   "(list1-to-string dcl_progresivas_pto"
   (itoa i) ")) indice)")
 )
   (eval (read a))
   )
 (close indice)
 (setcfg cfg-name (strcat (rtos cfg-instal 2 10)
  " "
  (rtos cdate 2 10)
  " "
  (rtos periodo 2 10)))
 )

;;; CONVIERTE UNA LISTA PAR PUNTEADO UNIDIMENSIONAL EN UN STRING
;;; ENTRADA lista=lista de datos
;;; SALIDA lista1=string
(defun list3-to-string (lista / a b c x tipo)
 (setq a "")
 (foreach x lista
   (setq b (itoa (car x))
 c (cdr x)
 tipo (type c))
   (cond
     ((= tipo 'STR) (setq c (strcat "\"" c"\"")))
     ((= tipo 'INT) (setq c (itoa c)))
     ((= tipo 'REAL) (setq c (formato_cota c 10)))
     )
   (setq a (strcat a "(" b " . " c ")"))
   )
 (if lista
   (setq a (strcat "'(" a ")"))
   (setq a "nil")
   )
 )


;;; CONVIERTE UNA LISTA UNIDIMENSIONAL EN UN STRING PARA GRABARSE EN ARCHIVO CFG
;;; ENTRADA lista=lista de datos
;;; SALIDA lista1=string
(defun list1-to-string (lista / a d e celda tipo lista1 lista2 separ)
 (setq lista1 ""
separ "\\,*\\,*\\*,\\*")
 (foreach celda lista
   (setq tipo (type celda))
   (cond
((= tipo 'INT) (setq lista1 (strcat lista1 " " (itoa celda))))
((= tipo 'REAL) (setq lista1 (strcat lista1 " " (formato_cota celda 10))))
((= tipo 'STR) (progn
(if (wcmatch celda separ)
  (progn
    (setq d (lee celda "\\")
  celda "")
    (foreach a d
      (setq celda (strcat celda a "\\\\"))
      )
    (setq a (- (strlen celda) 2)
  celda (substr celda 1 a))
    ))
(setq lista1 (strcat lista1 " \"" celda "\""))
))
((= tipo 'LIST) (progn
 (setq lista2 "")
 (foreach a celda
   (if (wcmatch a separ)
     (progn
(setq d (lee a "\\")
     a "")
(foreach e d
 (setq a (strcat a e "\\\\"))
 )
(setq d (- (strlen a) 2)
     a (substr a 1 d))
)
     )
   (setq lista2 (strcat lista2 " \"" a "\""))
   )
 (setq lista1 (strcat lista1 " (" lista2 ")"))
 ))
)
   )
 (if lista
   (setq lista1 (strcat "(" lista1 ")"))
   (setq lista1 "nil")
   )
 )

;;; CONVIERTE UNA LISTA BIDIMENSIONAL EN UN STRING PARA GRABARSE EN ARCHIVO CFG
;;; ENTRADA lista=lista de datos
;;; SALIDA lista1=string
(defun list2-to-string ( lista / a i n m fila celda tipo lista1 lista2)
 (setq n (length lista)
i -1
lista1 "")
 (repeat n
   (setq i (1+ i)
 fila (nth i lista)
 lista2 (list1-to-string fila))
   (setq lista1 (strcat lista1 "\n" lista2))
   )
 (if lista
   (setq lista1 (strcat "'(" lista1 "\n)"))
   (setq lista1 "nil")
   )
 )

;;->->->->->->->->->->-> INICIO DE PROCESAMIENTO DE DATOS ->->->->->->->->->->->;;


;;; CONTROL GENERAL DE GRAFICAS DE MARCAS DE DIVISIONES PRINCIPALES/SECUNDARIAS ;;;
;;; ENTRADA: obj=  nombre CAD del alineamiento ;;;
;;; prog=  progresiva inicial ;;;
;;; formato=  lista 2D con formatos gráficos totales ;;;
;;; esp_prin= espaciamiento principal de divisiones ;;;
;;; esp_sec=  espaciamiento secundario de divisiones ;;;
;;; s_regla=  ubicación de la graduación -1/1 = izq/der ;;;
;;; marcas=  lista 1D con progresivas de marcas a colocar ;;;
;;; s_marcas= ubicación marcas -1/1 = izq/der ;;;
;;; prec=  lista precisión '(progs coord textos) ;;;
;;; SALIDA: gráfica de divisiones principales y secundarias ;;;
(defun grafica-progs (obj prog  formato esp_prin  esp_sec
 s_regla marcas  s_marcas  prec
 /  p  p1  p2  p3
 u  v  long  prec1  prec2
 prec3  p_ini  f_fin  lista1  lista2)
 (if obj
   (progn
     (command "_AREA" "E" obj)
     (command "osmode""1") ;;Referencia a objeto Punto Final   xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
     (initget 0)

   (setq p   (getpoint "\nSeleccione Inicio de Progresivas:")
   long   (getvar "PERIMETER")
   lista1 (lista-prog prog long esp_prin esp_sec)
   lista2 (nth 1 lista1)
   lista1 (nth 0 lista1)
   p_ini  (trans (vlax-curve-getStartPoint obj) 0 1)
   p_fin  (trans (vlax-curve-getEndPoint obj) 0 1)
   p3   (progs->ptos p prog marcas p_ini p_fin long 1)
   prec1  (nth 0 prec)
   prec2  (nth 1 prec)
   prec3  (nth 2 prec))
     (if (= toggle_regla 1)
     
(progn
 (setq p1 (progs->ptos p prog lista1 p_ini p_fin long 1)
p2 (progs->ptos p prog lista2 p_ini p_fin long 1))



 ; DIBUJA GRID PRINCIPAL
 (if p1
   (progn
     (setq u  (nth 1 p1)
   v  (nth 2 p1)
   p1 (nth 0 p1))
     (dibuja-regla
lista1
p1
v
s_regla
(list (nth 3 formato)
     (nth 2 formato))
prec3
gap)
     )
   )





 ; DIBUJA GRID SECUNDARIO ORIGINAL  XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXxxxxxxxxx
 ;(if p2
   ;(progn
     ;(setq u  (nth 1 p2)
;    v  (nth 2 p2)
;    p2 (nth 0 p2))
     ;(dibuja-regla
lista2
;p2
v
;s_regla
;(list (nth 4 formato))
;0
;gap)
     ;)
   ;)



; DIBUJA GRID SECUNDARIO MODIFICADO  Para Configurar el Mismo Largo de Linea que la Prog.XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
   
          (if p2
            (progn
     (setq u  (nth 1 p2)
   v  (nth 2 p2)
   p2 (nth 0 p2))
     (dibuja-regla
lista2
p2
v
s_regla
(list (nth 4 formato)
     (nth 4 formato))
0
gap)
     )
   )


         (command "osmode""0")  ;;;xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

Luis Alberto Benitez

Mensajes : 82
Fecha de inscripción : 29/03/2016

Volver arriba Ir abajo

lisp-para-generar-progresivas-de-un-alineamiento Empty Re: lisp-para-generar-progresivas-de-un-alineamiento

Mensaje por Luis Alberto Benitez el Mar Sep 24, 2019 3:48 pm

Continua

; DIBUJA EXTREMOS DE ALINEAMIENTO
 (setq p1 (progs->ptos
    p
    0.0
    (list (+ 0.0 1.0e-5)
  (- long 1.0e-5)
; longitud alineam. con tolerancia
    )
    p_ini
    p_fin
    long
    1))
 (if p1
   (progn
     (setq v  (nth 2 p1)
   p1  (nth 0 p1)
   progs (list prog (+ prog long)))
     (if (= (length v) 2)
(if (< (distance p p_ini) (distance p p_fin))
 (setq p1 (list p_ini p_fin))
 (setq p1 (list p_fin p_ini))
 )
)
     (dibuja-extremos
p1
progs
v
(list (nth 0 formato) (nth 1 formato))
prec1
s_regla)
     )
   );end if p1
 
 )
     ); end if de regla

     
     ; DIBUJA GRID MARCAS
     (if (= toggle_marcas 1)
(progn
 (setq p3 (progs->ptos p prog marcas p_ini p_fin long 1))
 (if p3
   (progn
     (setq u   (nth 1 p3)
   v   (nth 2 p3)
   marcas (nth 3 p3)
   p3   (nth 0 p3))
     (dibuja-marcas
marcas
p3
u
v
p
p_ini
p_fin
(nth 6 formato)
(nth 5 formato)
s_marcas
prec1
prec2
ucs)
     )
   ); end if p3
 )
); end if marcas
     )
   ); end if obj
 )


;;; PREPARA LISTA CON PROGRESIVAS PRINCIPALES Y SECUNDARIAS ;;;
;;; ENTRADA: prog=progresiva inicial ;;;
;;; long=longitud de la curva ;;;
;;; esp1=espaciamiento principal ;;;
;;; esp2=espaciamiento secundario ;;;
;;; SALIDA: lista2d=((progs princ) (progs sec)) ;;;
(defun lista-prog (prog long esp1 esp2 / x1 x2 lista1 lista2)
 (setq tolerancia 1.0e-10
long (+ long prog))
 (if (<= esp2 tolerancia);; verifica si esp2=0.0 con tolerancia
   (setq esp2 esp1)
   )
 (if (>= esp1 tolerancia);; ejecuta grilla si esp1<>0.0, con tolerancia
   (progn
     (setq x1 (* esp1 (fix (/ prog esp1)))
   x2 (* esp2 (fix (/ prog esp2))))
     (if (<= x1 prog)
(setq x1 (+ x1 esp1))
)
     (if (<= x2 prog)
(setq x2 (+ x2 esp2))
)
     (while (< x2 long)
(if (<= (abs (- x1 x2)) tolerancia); verifica si x1<=x2 con tolerancia
 (setq lista1 (append lista1 (list x1))
x1 (+ x1 esp1))
 (setq lista2 (append lista2 (list x2)))
 )
(setq x2 (+ x2 esp2))
); end while
     )
   ); end if x1=0.0
 (if (<= (abs (- esp1 esp2 )) tolerancia)
   (list lista1 nil)
   (list lista1 lista2)
   )
 )

;;; UBICA PUNTOS SEGUN PROGRESIVAS MEDIDAS SOBRE UNA CURVA CUALESQUIERA ;;;
;;; ENTRADA: p= punto de referencia para definir extremo inicial;;;
;;; prog= valor de progresiva inicial ;;;
;;; lista= lista de progresivas a calcular ;;;
;;; p1= punto inicial del alineamiento ;;;
;;; p2= punto final del alineamiento ;;;
;;; long= longitud del alineamiento ;;;
;;; ucs= ucs de referencia 1/0 = vista actual/ World ;;;
;;; SALIDA: lista 3D con '((puntos) (vect_unit) (vect_normales)) ;;;
(defun progs->ptos (p prog   lista  p1   p2  long ucs /
     x     x1    p1   p2  u v long
     ptos   param  u_list v_list sentido lista1)
 (if long
   (progn
     (if (< (distance p1 p)
    (distance p2 p))
(setq sentido 1
     a 0.0)
(setq sentido -1
     a long))
     (foreach x lista
(setq x1 (+ a (* sentido (- x prog))))
(if (and (>= (- x prog) 0.0)
(<= (- x prog) long))
 (progn
   (setq p1 (vlax-curve-getPointAtDist obj x1))
   (if p1
     (setq param  (vlax-curve-getParamAtPoint obj p1)
   u   (trans (vlax-curve-getFirstDeriv obj param) 0 ucs)
   u   (vect_unitario (trans '(0.0 0.0 0.0) 0 ucs) u)
   u   (list (* sentido (nth 0 u))
(* sentido (nth 1 u))
(* sentido (nth 2 u)))
   v   (list (- (nth 1 u)) (nth 0 u))
   ptos   (append ptos (list (trans p1 0 ucs)))
   u_list (append u_list (list u))
   v_list (append v_list (list v))
   lista1 (append lista1 (list x)))
     ); end if p1
   )
 )
); end foreach
     (if ptos
(list ptos u_list v_list lista1)
(setq ptos nil)
)
     ); end progn
   ); end if
 )

;;; DIBUJA DIVISIONES PRINCIPALES Y SECUNDARIAS EN UN ALINEAMIENTO ;;;
;;; ENTRADA: lista= lista 1D con las progresivas de los puntos ;;;
;;; pto= lista 2D con las coordenadas de los puntos ;;;
;;; v= lista 2D con los vectores normales de los ptos ;;;
;;; ind= sentido de ubicación de textos -1/1=izq/der ;;;
;;; formato=lista 2D de formato gráfico ;;;
;;; prec= precisión numérica ;;;
;;; gap= espacio libre entre grid_princ y texto de prog ;;;
;;; SALIDA: gráfica de divisiones principales y secundarias ;;;
(defun dibuja-regla (lista pto  v ind formato      prec
  gap  / i k      n      p
  p0  p1 p2 p3     ang    fmto1
  fmto2  texto long_txt)
 (setq fmto1 (nth 0 formato); fmto de línea
fmto2 (nth 1 formato); fmto de texto
i -1)
 (if fmto2
   (setq k 1)
   (setq k 0)
   )
 (foreach p pto
   (setq i (1+ i)
 texto (format_prog (nth i lista) prec)
 long_txt (strlen texto)
 p1 (opera_vector p "+" (* ind (nth 2 fmto1)) (nth i v))
 p2 (opera_vector p "-" (* k ind (nth 2 fmto1)) (nth i v))
 )
   (dib_linea (nth 3 fmto1) ; layer
      p1
      p2
      (nth 5 fmto1) ; linea
      (nth 4 fmto1) ; color
     )
   (if fmto2
     (progn
(setq p3 (opera_vector
  p1
  "+"
  (* ind (+ gap (* 0.5 char_width long_txt (nth 2 fmto2))))
  (nth i v)
)
     ang (angle '(0.0 0.0 0.0) (nth i v)))

(esc_texto (nth 3 fmto2) ; layer
  (nth 1 fmto2) ; estilo
  1 ; justif 72
  2 ; justif 73
  (nth 2 fmto2) ; Htxt
  p3 ; punto
  texto ; texto
  ang ; inclinacion
  1.0 ; ancho de texto
  (nth 4 fmto2) ; color
  (nth 5 fmto2) ; tipo de línea
 )
)
     ); end if
   ); end foreach
 )

;;; GRAFICA PUNTOS DE REFERENCIA (MARCAS) SOBRE ALINEAMIENTO ;;;
;;; ENTRADA: lista= lista 1D con progresivas ;;;
;;; pto= lista 2D con coordenadas de las marcas ;;;
;;; u= lista 2D de vectores de sentido del alineamiento;;;
;;; v= lista 2D de vector normales al alineamiento ;;;
;;; p= pto referencial para definir inicio de alineam. ;;;
;;; p_ini= pto inicial del alineamiento ;;;
;;; p_fin= pto final del alineamiento ;;;
;;; fmto1= lista con formato de textos ;;;
;;; fmto2= lista con formato de marcas ;;;
;;; sentido=sentido de ubicación de marcas 1/-1=izq/der ;;;
;;; prec1= precisión de progresivas ;;;
;;; prec2= precisión de coordenadas ;;;
;;; ucs= ucs de presentación de coordenadas ;;;
(defun dibuja-marcas (lista pto    u    v    p    p_ini
   p_fin   fmto1   fmto2   sentido prec1
   prec2   ucs    /    p    p1
   p2    i    ang    v-n    txt_prog
   txt_x   txt_y   pref_x  pref_y  pref_prog
   subf_x  subf_y  subf_prog    txt1
   txt2    dir)
 (setq i  -1
pref_prog (lee (nth 0 (nth 0 fmto1)) "<>")
pref_x  (lee (nth 1 (nth 0 fmto1)) "<>")
pref_y  (lee (nth 2 (nth 0 fmto1)) "<>")
subf_prog (ver_file (nth 1 pref_prog))
pref_prog (nth 0 pref_prog)
subf_x  (ver_file (nth 1 pref_x))
pref_x  (nth 0 pref_x)
subf_y  (ver_file (nth 1 pref_y))
pref_y  (nth 0 pref_y)
)
 (if (< (distance p p_ini)
(distance p p_fin))
   (setq dir 1)
   (setq dir -1)
   )
 (foreach p pto
   (setq i   (1+ i)
 ang   (angle '(0.0 0.0 0.0) (nth i u))
 v-n   (nth i v)
 txt_prog (format_prog (nth i lista) prec1)
 p1   (opera_vector p "+" (* sentido (nth 2 fmto2)) v-n)
 p2   (opera_vector p1 "+" (* 1.0 sentido (nth 2 fmto1)) v-n)
 txt_x   (format (nth 0 (trans p 1 ucs)) prec2 nil)
 txt_y   (format (nth 1 (trans p 1 ucs)) prec2 nil)
 )
   (if (= dir 1)
     (setq txt1 (strcat pref_prog txt_prog subf_prog)
   txt2 (strcat pref_y txt_y subf_y))
     (setq txt2 (strcat pref_prog txt_prog subf_prog)
   txt1 (strcat pref_y txt_y subf_y))
     )
   ; DIBUJA CIRCULO REFERENCIAL
   (dib_circulo
     p ; centro de circunf
     (* 0.25 (nth 2 fmto1)) ; radio    
     (nth 3 fmto2) ; layer
     (nth 5 fmto2) ; linetype
     (nth 4 fmto2) ; color
     )
   ; DIBUJA RECTA
   (dib_linea (nth 3 fmto2) ; layer
      p ; pto inicial
      p1 ; pto final
      (nth 5 fmto2) ; linea
      (nth 4 fmto2) ; color
     )
   ; ESCRIBE PROGRESIVA                                                   xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
   (esc_texto (nth 3 fmto1) ; layer
      (nth 1 fmto1) ; estilo
      2 ; justif 72 ;1
      2 ; Original 2;Modif, 1  ; justif 73
      (nth 2 fmto1) ; Htxt
      p2 ; punto
      txt1 ; texto
      (+ ang 1.57) ; Original : ang  ; Modif.: (+ ang 1.57) ;inclinacion   xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
      1.0 ; ancho de texto
      (nth 4 fmto1) ; color
      (nth 5 fmto1) ; tipo de línea
     )
   ; ESCRIBE COORDENADA X                                                  xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
   (setq p2 (opera_vector p2 "+" (* sentido esp_inter (nth 2 fmto1)) v-n))
   (esc_texto (nth 3 fmto1) ; layer
      (nth 1 fmto1) ; estilo
      2 ; justif 72 ;1
      2 ; Original 2;Modif, 1  ;justif 73
      (nth 2 fmto1) ; Htxt
      p2 ; punto
      (strcat pref_x
      txt_x
      subf_x) ; texto
      (+ ang 1.57) ;Original : ang ; inclinacion              xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
      1.0 ; ancho de texto
      (nth 4 fmto1) ; color
      (nth 5 fmto1) ; tipo de línea
     )
   ; ESCRIBE COORDENADA Y                                                     xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
   (setq p2 (opera_vector p2 "+" (* sentido esp_inter (nth 2 fmto1)) v-n))
   (esc_texto (nth 3 fmto1) ; layer
      (nth 1 fmto1) ; estilo
      2 ; justif 72;1
      2 ; Original 2;Modif, 1  ; justif 73
      (nth 2 fmto1) ; Htxt
      p2 ; punto
      txt2 ; texto
      (+ ang 1.57) ;Original : ang  ;inclinacion         xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
      1.0 ; ancho de texto
      (nth 4 fmto1) ; color
      (nth 5 fmto1) ; tipo de línea
     )
   ); end foreach
 (setq p2 p2)
 )


;;; DIBUJA PROGRESIVAS EXTREMAS (INICIAL Y FINAL) SEGUN LISTA ;;;
;;; ENTRADA: ptos= lista de puntos de inserción ;;;
;;; progs= lista de progresivas de los puntos "ptos" ;;;
;;; u= lista de vectores unitarios ;;;
;;; v= lista de vectores normales ;;;
;;; fmto= lista 2d formatos '((fmto_text) (fmto_lineas)) ;;;
;;; prec= precisión de presentación ;;;
;;; sentido=sentido de ubicación de las inserciones ;;;
(defun dibuja-extremos (ptos progs   v     fmto    prec    sentido
    /     i     p     p1     p2
    ang     v_i     txt     txt_long
    fmto1   fmto2   pref_prog     subf_prog)
 (setq i  -1
fmto1  (nth 0 fmto) ; textos
fmto2  (nth 1 fmto) ; líneas
pref_prog (lee (nth 0 (nth 0 fmto1)) "<>")
subf_prog (ver_file (nth 1 pref_prog))
pref_prog (nth 0 pref_prog)
)
 (foreach p ptos
   (setq i   (1+ i)
 v_i   (nth i v)
 txt   (strcat pref_prog (format_prog (nth i progs) prec) subf_prog)
 txt_long (strlen txt)
 p1   (opera_vector
    p
    "+"
    (* sentido
(+ (* txt_long char_width (nth 2 fmto1))
  (nth 2 fmto2)))
    v_i)
 p2   (opera_vector
    p1
    "-"
    (* 0.5 sentido txt_long char_width (nth 2 fmto1))
    v_i)
 ang      (angle '(0.0 0.0 0.0) v_i)
 )
   ;DIBUJA LINEA
   (dib_linea (nth 3 fmto2) ; layer
      p ; pto inicial
      p1 ; pto final
      (nth 5 fmto2) ; linea
      (nth 4 fmto2) ; color
     )
   ;ESCRIBE TEXTO
   (esc_texto (nth 3 fmto1) ; layer
      (nth 1 fmto1) ; estilo
      1 ; justif 72
      1 ; justif 73
      (nth 2 fmto1) ; Htxt
      p2 ; punto
      txt ; texto
      ang ; inclinacion
      1.0 ; ancho de texto
      (nth 4 fmto1) ; color
      (nth 5 fmto1) ; tipo de línea
     )
   )
 )

;;; CONVIERTE UN PUNTO 3D A 2D
;;; ENTRADA: pto (punto en 2D o 3D)
;;; SALIDA: pto=punto con coordenadas 2D (X,y)
(defun trans-2dpoint (pto )
 (if (= (length pto) 3)
   (setq pto (reverse (cdr (reverse pto))))
   (setq pto pto)
   )
 )

;; VECTOR UNITARIO uv
;; ENTRADA: PUNTOS P1, P2 (EN 3D)
;; SALIDA:  LISTA CON COMPONENTES EN 3D
(defun vect_unitario ( p1 p2 / x y z d)
 (setq d (distance p1 p2)
x (/ (- (nth 0 p2) (nth 0 p1)) d)
y (/ (- (nth 1 p2) (nth 1 p1)) d)
)
 (if (and (> (length p1) 2)
  (> (length p2) 2)
  )
   (setq z (/ (- (nth 2 p2) (nth 2 p1)) d))
   (setq z 0)
   )
 (setq x (list x y z))
 )

;; VECTOR NORMAL AL ALINEAMIENTO P1,P2
;; ENTRADA: P1, P2 (PUNTOS 3D)
;; SALIDA: VECTOR NORMAL EN 2D
(defun vect_normal ( p1 p2 / x)
 (setq x (vect_unitario p1 p2)
x (list (- (nth 1 x)) (nth 0 x) (nth 2 x))
)
 )
;; PRODUCTO VECTORIAL DE VECTORES u v
(defun prod_vect (u v / a1 b1 c1 a2 b2 c2)
 (setq a1 (nth 0 u)
b1 (nth 1 u)
c1 (nth 2 u)
a2 (nth 0 v)
b2 (nth 1 v)
c2 (nth 2 v)
u (list (- (* b1 c2) (* b2 c1))
(- (* a2 c1) (* a1 c2))
(- (* a1 b2) (* a2 b1))
)
)
 )

;; OPERACION VECTORIAL
;; REALIZA OPERACIONES BASICAS +, - , *, / CON PUNTOS 3D
;; ENTRADA: P (PUNTO 3D)
;;    OPERADOR (STRING QUE DEFINE LA OPERACION)
;;    Q (VECTOR 3D - OPERNADO)
;; SALIDA:  LISTA 3D CON RESULTADO DE OPERACION. SI LA OPERACION CAE FUERA DEL
;;    RANGO, LA SALIDA SERA NULA
(defun opera_vector (p operador k q / a b c)
 (if (not (nth 2 p))
   (setq p (list (nth 0 p) (nth 1 p) 0.0))
   )
 (if (not (nth 2 q))
   (setq q (list (nth 0 q) (nth 1 q) 0.0))
   )
 (setq a (strcat "(" operador " (nth 0 p) (* k (nth 0 q)))")
b (strcat "(" operador " (nth 1 p) (* k (nth 1 q)))")
c (strcat "(" operador " (nth 2 p) (* k (nth 2 q)))")
a (strcat "(setq a (list " a " " b " " c " ))")
)
 (if (wcmatch operador "+,-,`*,/")
   (setq a (eval (read a)))
   (setq a nil)
   )
 )
;; FUNCION SIGNO
(defun signo ( a )
 (if (/= a 0.0)
   (setq a (/ a (abs a)))
   (setq a 0.0)
   )
 )

;;; ENTMAKE DE TEXTOS PROGRESIVAS ;;;
;;; DATOS: layer (string con nombre del layer) ;;;
;;;   font (string con nombre del estilo de texto) ;;;
;;;   just72 (entero left->0, center->1, right->2,middle center->1, etc) ;;;
;;;   just73 (entero left->0, center->1, right->2,middle center->1, etc) ;;;
(defun esc_texto (layer font  just72    just73    h_txt
p  txt    inclinacion
ancho_letra    color     linetype
/  lista    angdir
)
 (if (and (> inclinacion (/ pi 1.5 )) (< inclinacion (* 1.5 pi)));;;;Original :(/ pi 2.0)) (< inclinacion (* 1.5 pi)))  Para Sentido de Texto xxxxxxxxxxxxxxxxxxxxxx
   (setq inclinacion (- inclinacion pi))
   )
 (setq angdir (angle '(0 0 0) (getvar "UCSXDIR"))
inclinacion ( - (+ inclinacion angdir) 1.57);;;;;;Original:(+ inclinacion angdir)  Modif - 1.57 Para Girar 90º El Texto de Prog. xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
)
 (if (not txt)
   (setq txt "")
   )
 (setq lista
(list '(0 . "TEXT")
      '(100 . "AcDbEntity")
      '(100 . "AcDbText")
      (cons 8 layer)
      (cons 6 linetype)
      (cons 62 color)
      (cons 10 (trans p1 1 0));;Original:(cons 10 (trans p 1 0)) Modif.:Segundo punto base de Texto  xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
      (cons 40 h_txt)
      (cons 1 txt)
      (cons 50 inclinacion)
      (cons 41 ancho_letra)
      (cons 7 font)
      (cons 72 1) ;;;;;Original : Medio Centro (cons 72 just72);  Modif.Inferior Centro (cons 72 1)xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
      (cons 73 1);;;Original : Medio Centro (cons 73 just73) ;    Modif.Inferior Centro (cons 73 1)xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
      (cons 11 (trans p1 1 0));;;Original : (cons 11 (trans p 1 0))  Modif. Texto primer punto base xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
)
 )
 (entmake lista)
 (entlast)
)
;;; ENTMAKE DE LINEA
(defun dib_linea (layer p0 p1 linetype color / lista)
 (setq lista
(list '(0 . "LINE")
      '(100 . "AcDbEntity")
      '(100 . "AcDbLine")
      (cons 8 layer)
      (cons 6 linetype)
      (cons 62 color)
      (cons 10 (trans p0 1 0))
      (cons 11 (trans p1 1 0))
)
 )
 (entmake lista)
 (entlast)
)
;;; ENTMAKE DE POLILINEA
(defun polilinea (layer puntos x_esc y_esc linetype color / lista n i p)
 (setq n (length puntos)
i 0
lista (list '(0 . "LWPOLYLINE")
   '(100 . "AcDbEntity")
   '(100 . "AcDbPolyline")
   (cons 8 layer)
   (cons 6 linetype)
   (cons 62 color)
   (cons 90 n))
)
 (repeat n
   (setq p (trans (nth i puntos) 1 0)
 p (list (* x_esc (nth 0 p)) (* y_esc (nth 1 p)))
 lista (append lista (list (cons 10 p) (cons 42 0.0)))
 i (1+ i)
 )
 )
 (entmake lista)
 (entlast)
)

;;; ENTMAKE DE DONUT
(defun dib_donut (p r1 r2 layer linetype color / lista x y)
 (setq x (nth 0 p)
y (nth 1 p)
r1 (abs (- r1 r2))
lista (list '(0 . "LWPOLYLINE")
   '(100 . "AcDbEntity")
   '(100 . "AcDbPolyline")
   (cons 8 layer)
   (cons 6 linetype)
   (cons 62 color)
   (cons 90 2)
   (cons 70 1)
   (cons 10 (list (- x (/ r1 2)) y))
   (cons 40 r1)
   (cons 41 r1)
   (cons 42 1.0)
   (cons 10 (list (- x (/ r1 2)) y))
   (cons 40 r1)
   (cons 41 r1)
   (cons 42 1.0)    
   )
)
 (entmake lista)
 (entlast)
)

;ENTITY MAKE DE CIRCULOS
(defun dib_circulo (p r layer linetype color / lista)
 (setq lista (list (cons 0 "CIRCLE")
   (cons 100 "AcDbEntity")
   (cons 100 "AcDbCircle")
   (cons 8 layer)
   (cons 6 linetype)
   (cons 62 color)
   (cons 10 (trans p 1 0))
   (cons 40 r)
   )
 )
 (entmake lista)
 (entlast)
)

;;; ENTMAKE DE RECTANGULO
(defun rectang (layer p1 p2 x_esc y_esc linetype color / p3 p4 puntos)
 (setq p1 (list (nth 0 p1) (nth 1 p1))
p2 (list (nth 0 p2) (nth 1 p2))
p3 (list (nth 0 p2) (nth 1 p1))
p4 (list (nth 0 p1) (nth 1 p2))
puntos (list p1 p3 p2 p4 p1)
)
 (polilinea layer puntos x_esc y_esc linetype color)
)

;DA FORMATO A PROGRESIVAS PARA IMPRESION: 0+250.36   xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
(defun format_prog (numero prec / a dec)
 (setq a (fix (/ numero 1000.0));;;;(/ numero 1000.0)) xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
dec (formato_cota (- numero (* a 1)) prec);;;;;(- numero (* a 1000.0)) prec) xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
a (strcat  dec);               Original PARA IMPRESION: 0+250.36 : (strcat (format a prec 0) "+" dec)    xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
)
 )

Luis Alberto Benitez

Mensajes : 82
Fecha de inscripción : 29/03/2016

Volver arriba Ir abajo

lisp-para-generar-progresivas-de-un-alineamiento Empty Re: lisp-para-generar-progresivas-de-un-alineamiento

Mensaje por Luis Alberto Benitez el Mar Sep 24, 2019 3:50 pm


;; FORMATO DE COTAS
;;; ENTRADA: cota: número real a formatear
;;; prec: presición (# de decimales)
;;; SALIDA: string con # de decimales segun prec
(defun formato_cota (cota prec / n a)
(setq cota (rtos cota 2 prec)
n (strlen cota)
a (vl-string-position (ascii ".") cota nil t)
)
(if a
(setq a (+ a 2)
a (substr cota a (- n a -1))
n (- prec (strlen a)))
(progn
(if (> prec 0)
(setq cota (strcat cota ".")
n prec)
(setq n 0)
)
)
)

(repeat n
(setq cota (strcat cota "0"))
)
(setq cota cota)
)


;;; DA FORMATO A NUMEROS, CON SEPARADORES DE CAMPO (miles, millones, etc) ;;;
;;; ENTRADA: numero= real a formatear ;;;
;;; prec= precisión ;;;
;;; ind= fuerza a presentación entera t/nil=entero/decimal ;;;
;;; SALIDA: string del número formateado ;;;
(defun format (numero prec ind / a b i j control n srtnum decimal apost
signo)
(setq apost ""
a ""
i 0
control 1
)
(if (< numero 0.0)
(setq signo "-")
(setq signo "")
)
(setq numero (formato_cota (abs numero) prec)
n (strlen numero)
)
(while control
(setq i (+ i 1)
b (substr numero i 1)
)
(if (or (= b ".") (> i n))
(setq control nil)
)
)
(setq strnum (substr numero 1 (- i 1))
decimal (substr numero i (+ prec 1))
)
(if (or (> i n) ind)
(setq decimal "")
)
(setq n (strlen strnum)
i n
j 0)
(repeat n
(setq j (+ j 1)
b (substr strnum i 1)
)
(if (= j 4)
(setq b (strcat b ","))
)
(if (= j 7)

(setq apost (strcat "'" apost)
b (strcat b apost)
j 1)

)
(setq i (- i 1)
a (strcat b a)
)
)
(setq a (strcat signo a decimal))
)

;;; RUTINA PARA CONVERTIR UN TEXTO NIL EN "", SI NO ES NIL, DEVOLVERA
;;; EL VALOR DEL TEXTO
(defun ver_file (texto)
(if (not texto)
(setq texto "")
)
(setq texto texto)
)
;; Extrae lista de atributos de la base de datos: ejm layers, styles, vports, etc
;; entrada: atributo= TIPO DE DATO A BUSCAR EN TABLA DE DATOS ejm "LAYER", "STILE"
;; ind= indice de datos de la tabla de lista. Si esta es nula, el ind
; por defecto es 2, osea el nombre de los elementos en la tabla
(defun stilo (atributo ind / a a1 font)
(if (not ind)
(setq ind 2)
)
(setq a1 (cdr (assoc ind (tblnext atributo 0))))
(setq font (list (strcase a1)))
(while (setq a (cdr (assoc ind (tblnext atributo))))
(if (/= a "")
(setq font (cons (strcase a) font))
)
)
(if a1
(setq font (reverse font))
(setq font nil)
)
)
;;; SUBRUTINA PARA CONVERTIR LINEAS EXTRAIDAS DE UN ARCHIVO SECUENCIAL ;;;
;;; A DATOS SEPARADOS POR CAMPOS DEFINIDOS EN UNA VARIABLE ;;;
;;; ARGUMENTOS: LINEA: LINEA DE LECTURA SECUENCIAL ;;;
;;; SEPAR: CARACTER DE SEPARACION DE CAMPOS ;;;
;;; CAMPO: LISTA DE ANCHOS DE CAMPO DE ENTRADA DE DATOS ;;;
;;; si campo es nil evalua segun separador "separ" ;;;
;;; SALIDA: VARS: LISTA CON LOS DATOS EXTRAIDOS EN FORMATO STRING ;;;
(defun lee (linea separ / i dato n char vars long)
(setq i 0
dato "")
(setq long (strlen separ))
(setq n (strlen linea))
(repeat n
(setq i (+ i 1))
(setq char (substr linea i long))
(if (/= char separ)
(setq dato (strcat dato (substr char 1 1)))
(progn
(if (or (/= separ " ") (/= dato ""))
(setq vars (cons dato vars))
)
(setq dato ""
i (+ i long -1))
)
)
)
(setq vars (cons dato vars))
(setq vars (reverse vars))
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CONTROL DEL 1er DCL;;;
;;; CONTROL DE DCL's ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dcl_control_progresivas1 (/ control dcl_id indice ok b h slide)
;;; INICIALIZA VALORES POR DEFECTO DE VARIABLES DE CONTROL
(setq control nil
dcl_id (load_dialog "progresivas.dcl")
slide "progresivas.sld"
ok 0)
(while (not control)
(if (not (new_dialog "progresivas_principal" dcl_id "" dcl_progresivas_pto1))
(exit)
)
(set_tile "nombre_dcl" manlio)

(start_image "dcl_progresivas")
(setq b (dimx_tile "dcl_progresivas"))
(setq h (dimy_tile "dcl_progresivas"))
(fill_image 0 0 b h -2)
(slide_image 0 0 b h slide)
(end_image)

(action_tile "cancel" "(setq dcl_progresivas_pto1 (done_dialog 0))")
(action_tile "accept" "(setq dcl_progresivas_pto1 (done_dialog 1))")
(action_tile "dcl_datos" "(setq dcl_progresivas_pto1 (done_dialog 2))")
(action_tile "dcl_formato" "(setq dcl_progresivas_pto1 (done_dialog 3))")
(action_tile "dcl_ucs" "(setq dcl_progresivas_pto1 (done_dialog 4))")
(action_tile "dcl_selec" "(setq dcl_progresivas_pto1 (done_dialog 5))")

(mode_tile "accept" (- 1 ok))

(setq indice (start_dialog))
(cond
((= indice 0) (setq control 1))
((= indice 1) (progn
(setq control 1)

))
((= indice 2) (dcl_control_progresivas2)); datos
((= indice 3) (dcl_control_progresivas3)); formatos
((= indice 4) (dcl_control_progresivas7)); ucs/escala/prec
((= indice 5) (progn
(setq obj (car (entsel"\nSeleccione Alineamiento: ")))
(if obj
(setq ok 1)
(setq ok 0)
)
); selec objeto
)
)
)
(unload_dialog dcl_id)
(if (= indice 0)
(setq indice nil)
(setq indice t)
)
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CONTROL DEL 2do DCL: DATOS DE ENTRADA ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dcl_control_progresivas2 (/ control dcl_id indice lista1 lista2)
(setq control nil
dcl_id (load_dialog "progresivas.dcl")
lista1 '("dcl_esp_prin" "dcl_esp_sec" "dcl_radio_ubica1")
lista2 '("dcl_lista" "dcl_radio_ubica2")
)
(while (not control)
(if (not (new_dialog "progresivas_datos" dcl_id "" dcl_progresivas_pto2))
(exit)
)
(set_tile "nombre_dcl" manlio)
;;; CONTROL DE EDIT_BOXES
(set_tile "dcl_esp_prin" (rtos esp_prin 2 prec_dcl))
(edita_box "dcl_esp_prin" esp_prin "esp_prin" ">" 0.0)
(set_tile "dcl_esp_sec" (rtos esp_sec 2 prec_dcl))
(edita_box "dcl_esp_sec" esp_sec "esp_sec" ">=" 0.0)
(set_tile "dcl_prog" (rtos prog 2 prec_dcl))
(edita_box "dcl_prog" prog "prog" ">=" 0.0)
;;; CONTROL DE TOGGLES
(activa-dcl lista1 toggle_regla)
(set_tile "dcl_toggle_regla" (itoa toggle_regla))
(action_tile "dcl_toggle_regla" "(setq toggle_regla (atoi $value)) (activa-dcl lista1 toggle_regla)")
(activa-dcl lista2 toggle_marcas)
(set_tile "dcl_toggle_marcas" (itoa toggle_marcas))
(action_tile "dcl_toggle_marcas" "(setq toggle_marcas (atoi $value)) (activa-dcl lista2 toggle_marcas)")
;;; CONTROL DE RADIO_BOXES
(set_tile "dcl_radio_izq1" (itoa (- 1 radio_ubica1)))
(set_tile "dcl_radio_der1" (itoa radio_ubica1))
(set_tile "dcl_radio_izq2" (itoa (- 1 radio_ubica2)))
(set_tile "dcl_radio_der2" (itoa radio_ubica2))
(action_tile "dcl_radio_ubica1" "(setq radio_ubica1 (activa-radios $value))")
(action_tile "dcl_radio_ubica2" "(setq radio_ubica2 (activa-radios $value))")
;;; CONTROL DE BOTONES
(action_tile "cancel" "(setq dcl_progresivas_pto2 (done_dialog 0))")
(action_tile "accept" "(setq dcl_progresivas_pto2 (done_dialog 1))")
(action_tile "dcl_lista" "(setq dcl_progresivas_pto2 (done_dialog 2))")
;;; INICIA DIALOGO
(setq indice (start_dialog))
(cond
((= indice 0) (setq control 1))
((= indice 1) (progn
(setq control 1)
(if (or eje
datos)
(setq indice 1)
(setq indice 0)
)))
((= indice 2) (setq marcas (dcl_control_progresivas8 marcas prec_dcl "LISTA DE MARCAS") ))
)
)
(unload_dialog dcl_id)
(setq indice indice)
)

;;; ACTIVA O DESACTIVA dcl's DE ACUERDO A LISTA ;;;
;;; ENTRADA lista= lista C/nombre dcl's a activar/desactivar;;;
;;; valor= 0/1 = desactiva/activa dcl´s ;;;
;;; SALIDA: activación/desactivación de dcl´s ;;;
(defun activa-dcl (lista valor / dcl )
(cond
((= (type valor) 'STR) (setq valor (- 1 (atoi valor))))
((= (type valor) 'LIST) (setq valor (- 1 (car valor))))
(t (setq valor (- 1 (fix valor))))
)
(if (> valor 0)
(setq valor 1)
(setq valor 0)
)
(foreach dcl lista
(mode_tile dcl valor)
)
)

;;; FORMATEA RUTA Y NOMBRE DE ARCHIVO ;;;
;;; ENTRADA: long= Número de caracteres a presentar ;;;
;;; si long=nil, a=file sin recortarlo;;;
;;; file= Nombre del archivo ;;;
;;; SALIDA: a= nombre del archivo formateado ;;;
(defun format-file (long file / j i n separ)
(setq n (strlen file))
(if (not long)
(setq long n)
)
(setq i (- n long -4)
j 3
separ "...")
(if (< i 5)
(setq i 1
separ ""
j 0)
)
(strcat separ (substr file i (- long j)))
)

;;; CONTROL DE ACTIVACION DE BOTONES SEGUN SELECCION DE RADIO_BUTTONS ;;;
;;; ENTRADA: op=Nombre del key del radio button seleccionado ;;;
;;; SALIDA: 0/1 izq/der ;;;
(defun activa-radios (op / ubica)
(cond
((= (substr op 1 13) "dcl_radio_izq") (setq ubica 0))
((= (substr op 1 13) "dcl_radio_der") (setq ubica 1))
)
)


;;; TRABAJA EDIT_BOXES Y OBTIENE VALORES EN FUNCION A RESTRICCIONES
;;; ENTRADA: tile = Nombre de key del edit_box
;;; valor = Valor de la variable a colocar en el edit_box
;;; variable = Nombre de la variable a cambiar por edit_box
;;; a = condición lógica (ejm <, >, =, >=, <=
;;; valor2=compara valor con valor2 segun condición
;;; SALIDA: valor editado en el edit_box, asignado en "variable"
(defun edita_box (tile valor variable a valor2 / valor1)
(set_tile tile (rtos valor 2 prec_dcl))
(action_tile
tile
(strcat
"(progn (setq valor1 (atof (get_tile \"" tile "\")))
(if ( " a " valor1 " (rtos valor2 2 prec_dcl) " )
(setq " variable " valor1)"
"(progn "
"(alert \"Error: Valor Numérico no permitido\")"
"(mode_tile \"" tile "\" 2)"
")"
")"
")"
)
)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CONTROL DEL 3er DCL: CONTROL DE FORMATOS ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dcl_control_progresivas3 (/ control dcl_id indice tabla
i j k n
datos datos1 titulos dcl_texto
)
(setq control nil
datos1 fmto_progresivas
dcl_id (load_dialog "progresivas.dcl")
titulos '("FORMATO: PROGRESIVAS"
"FORMATO: LINEA PROGS."
"FORMATO: TEXTOS REGLA"
"FORMATO: DIV.PRINCIPAL"
"FORMATO: DIV.SECUNDARIA"
"FORMATO: TEXTO MARCAS"
"FORMATO: LINEA MARCAS"
)
k 0
tabla "FORMATO GRAFICO"
)
(while (not control)
(if (not (new_dialog "progresivas_modos" dcl_id "" dcl_progresivas_pto3))
(exit)
)
(set_tile "nombre_dcl" manlio)
(set_tile "dcl_modos" tabla)
;MODE_TILE DE FORMATOS
(mode_tile "dcl_toggle_regla" (- 1 toggle_regla))
(mode_tile "dcl_toggle_marcas" (- 1 toggle_marcas))
;CONTROL DE EDIT BOXES PARA TEXTOS
(set_tile "dcl_gap" (rtos gap 2 prec_dcl))
(edita_box "dcl_gap" gap "gap" ">=" 0.0)
(setq i -6
k 0)
(repeat 2
(setq i (+ i 6)
datos (nth i fmto_progresivas)
n (length (nth 0 datos))
j -1)
(repeat n
(setq j (1+ j)
k (1+ k)
dcl_texto (strcat "dcl_texto" (itoa k)))
(set_tile dcl_texto (nth j (nth 0 datos)))
(action_tile
dcl_texto
(strcat "(setq datos (nth "
(itoa i)
" fmto_progresivas)"
"fmto_progresivas (cambia1 "
(itoa i)
" (setq datos (cambia 0 "
(itoa j)
" (get_tile \""
dcl_texto
"\") datos)) "
"fmto_progresivas))"
)
)
)
)
(action_tile "cancel" "(setq dcl_progresivas_pto3 (done_dialog 0))")
(action_tile "accept" "(setq dcl_progresivas_pto3 (done_dialog 1))")
;CONTROL DE BOTONES DE FORMATOS
(setq i 0)
(repeat 7
(setq i (1+ i)
dcl_texto (strcat "dcl_formato" (itoa i))
)
(action_tile dcl_texto (strcat "(setq dcl_progresivas_pto3 "
"(done_dialog " (itoa (1+ i))
"))"))
)
;CONTROL DE BOTONES DE RESETEO
(setq i 0)
(repeat 4
(setq i (1- i)
dcl_texto (strcat "dcl_reset" (itoa (- 1 i))))
(action_tile dcl_texto (strcat "(setq dcl_progresivas_pto3 "
"(done_dialog " (itoa i)
"))"))
)
;INICIALIZA INDICE DE DIALOG
(setq indice (start_dialog))
(cond
((= indice -1) (setq datos1 fmto_progresivas
fmto_progresivas (reinicia
0
2
fmto_progresivas
(carga_datos_progresivas)
escala)
)
)
((= indice -2) (setq datos1 fmto_progresivas
fmto_progresivas (reinicia
2
3
fmto_progresivas
(carga_datos_progresivas)
escala)
)
)
((= indice -3) (setq datos1 fmto_progresivas
fmto_progresivas (reinicia
5
2
fmto_progresivas
(carga_datos_progresivas)
escala)
)
)
((= indice -4) (setq datos1 fmto_progresivas
fmto_progresivas (reinicia
0
7
fmto_progresivas
(carga_datos_progresivas)
escala)
)
)
((= indice 0) (setq control 1
fmto_progresivas datos1)
)
((= indice 1) (setq control 1))
((or
(= indice 2)
(= indice 4)
(= indice 8)) (setq datos (dcl_control_progresivas4
(nth (- indice 2) titulos)
(nth (- indice 2) fmto_progresivas)
"Htexto"
0
0
(- indice 2)
)
datos (cambia1 0 (car (nth (- indice 2) fmto_progresivas)) datos)
fmto_progresivas (cambia1 (- indice 2) datos fmto_progresivas)
)
)
((or
(= indice 3)
(= indice 7)) (setq datos (dcl_control_progresivas4
(nth (- indice 2) titulos)
(nth (- indice 2) fmto_progresivas)
"Espac."
0
1
(- indice 2)
)
datos (cambia1 0 (car (nth (- indice 2) fmto_progresivas)) datos)
fmto_progresivas (cambia1 (- indice 2) datos fmto_progresivas)
)
)
((or
(= indice 5)
(= indice 6)) (setq datos (dcl_control_progresivas4
(nth (- indice 2) titulos)
(nth (- indice 2) fmto_progresivas)
"Long."
0
1
(- indice 2)
)
datos (cambia1 0 (car (nth (- indice 2) fmto_progresivas)) datos)
fmto_progresivas (cambia1 (- indice 2) datos fmto_progresivas)
)
)
)
)
(unload_dialog dcl_id)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CONTROL DEL 4to DCL: FORMATOS ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dcl_control_progresivas4 (tile datos dcl_htxt_label
mode_htxt mode_font i
/ control dcl_id
indice l_layer l_font
tipo_linea lista h_txt
font layer color
datos datos1 d
a)
(setq l_layer (acad_strlsort (append (stilo "LAYER" nil) '("BYLAYER")))
l_font (acad_strlsort (stilo "STYLE" nil))
tipo_linea (acad_strlsort (append (stilo "LTYPE" nil) '("BYLAYER")))
lista (list (nth 0 datos))
control nil
dcl_id (load_dialog "progresivas.dcl")
datos1 datos
)
(while (not control)
(if (not (new_dialog "progresivas_formatos" dcl_id "" dcl_progresivas_pto4))
(exit)
)
(set_tile "dcl_progresivas_formatos" tile)
(set_tile "nombre_dcl" manlio)

;CONTROL EDIT BOX H_txt
(mode_tile "dcl_htxt1" mode_htxt)
(set_tile "dcl_htxt1" dcl_htxt_label)
(mode_tile "dcl_htxt2" mode_htxt)
(set_tile "dcl_htxt2" (rtos (nth 2 datos) 2 prec_dcl))
(action_tile "dcl_htxt2" "(setq datos (cambia1 2 (abs (atof (get_tile \"dcl_htxt2\" ))) datos))")

;CONTROL POPUPLIST DE LOS FONTS
(mode_tile "dcl_font" mode_font)
(start_list "dcl_font" 3)
(mapcar 'add_list l_font)
(end_list)
(set_tile "dcl_font" (itoa (busca (nth 1 datos) l_font)))
(action_tile "dcl_font"
"(setq datos (cambia1 1 (nth (atoi (get_tile \"dcl_font\")) l_font) datos))")
;CONTROL EDIT_BOX DE LAYERS
(set_tile "dcl_layer1" (nth 3 datos))
(action_tile "dcl_layer1" "(setq datos (cambia1 3 (verifica_layer \"dcl_layer1\") datos))")
;CONTROL DE BUTTON PARA RESETEO
(action_tile "dcl_reset" "(setq dcl_progresivas_pto4 (done_dialog -1))")
(action_tile "cancel" "(setq dcl_progresivas_pto4 (done_dialog 0))")
(action_tile "accept" "(setq dcl_progresivas_pto4 (done_dialog 1))")
; CONTROL DEL BUTTON PARA LAYERS
(action_tile "dcl_layer2" "(setq dcl_progresivas_pto4 (done_dialog 2))")
; CONTROL DEL BUTTON PARA TIPOS DE LINEA
(action_tile "dcl_linea" "(setq dcl_progresivas_pto4 (done_dialog 3))")
; INICIA DCL DE BOTONES PARA PALETA DE COLORES
(colorea "dcl_color" (nth 4 datos))
(action_tile "dcl_color" "(setq dcl_progresivas_pto4 (done_dialog 4))")
; CONTROL DE PICK PARA DETERMINAR DIMENSIONES GRAFICAMENTE
(mode_tile "dcl_pick" mode_htxt)
(action_tile "dcl_pick" "(setq dcl_progresivas_pto4 (done_dialog 5))")
; CONTROL DE SELECCION DE Htxt DE TEXTOS EXISTENTES
(mode_tile "dcl_selec" mode_htxt)
(action_tile "dcl_selec" "(setq dcl_progresivas_pto4 (done_dialog 6))")
(setq indice (start_dialog))
(cond
((= indice -1) (setq datos1 datos
datos (reinicia 1 5 datos (nth i (carga_datos_progresivas)) escala)
)
)
((= indice 0) (setq control 1
datos datos1
)
)
((= indice 1) (setq control 1))
((= indice 2) (setq datos (cambia1 3
(dcl_control_progresivas5 "LAYER" (nth 3 datos) l_layer 1 nil)
datos)
)
)
((= indice 3) (setq datos (cambia1 5
(dcl_control_progresivas5 "LINEAS" (nth 5 datos) tipo_linea 0 nil)
datos)
)
)
((= indice 4) (if (setq color (acad_colordlg (nth 4 datos)))
(setq datos (cambia1 4 color datos))
)
)
((= indice 5) (setq color (initget 3)
datos (cambia1 2 (getdist "\nSeleccione Distancia ") datos)
)
)
((= indice 6) (progn
(while (not (setq d (car (entsel "\nSeleccione Texto ")))))
(setq color (cdr (assoc 0 (entget d))))
(cond
((or (= color "TEXT")
(= color "MTEXT")
)
(setq color (cdr (assoc 40 (entget d))))
)
((or (= color "LWPOLYLINE")
(= color "POLYLINE")
(= color "CIRCLE")
)
(setq color (command "_area" "ob" d)
color (getvar "perimeter"))
)
((= color "ARC") (setq color (command "_pedit" d "y" "")
color (command "_area" "ob" "last")
color (getvar "perimeter"))
)
((= color "LINE") (setq color (entget d)
d (cdr (assoc 10 color))
color (cdr (assoc 11 color))
color (distance color d))
)
(t (color (nth 2 datos)))
)
(setq datos (cambia1 2 color datos))
)
)
)
)
(unload_dialog dcl_id)
(setq datos datos)
)

; CREA TABLA DE TIPOS DE LETRAS Y ACTUALIZA
(defun crea_font_layer ( datos ind / n i nombre a b clayer)
(setq clayer (getvar "clayer"))
(setq n (length datos))
(setq i 0)
(repeat n
(setq nombre (nth 1 (nth i datos)))
(if nombre
(progn
(setq a (cdr (assoc ind (tblsearch "STYLE" nombre))))
(if (not a)
(command "_style" nombre nombre 0 1 0 "n" "n" "n")
)
)
)
(setq i (1+ i))
)
;(actualiza_layer datos)
)

(defun actualiza_layer (datos / n i nombre ltype a b clayer celtype)
(setq clayer (getvar "clayer"))
(setq celtype (getvar "celtype"))
(setq n (length datos))
(setq i 0)
(repeat n
(setq nombre (nth 3 (nth i datos)))
(setq ltype (nth 5 (nth i datos)))
(setq a (cdr (assoc 70 (tblsearch "LAYER" nombre))))
(setq b (cdr (assoc 2 (tblsearch "LTYPE" ltype))))
(if (not b)
(command "_linetype" "LOAD" ltype "" "")
)
(if (/= a 0)
(command "_layer" "t" nombre "on" nombre "")
)
(command "_layer"
"m"
nombre
"c"
(nth 4 (nth i datos))
""
"LTYPE"
ltype
""
""
)
(setq i (1+ i))
)
(setvar "clayer" clayer)
(setvar "celtype" celtype)
)

; SUBRUTINA CAMBIA: SELECCIONA LOS DATOS DE UNA LISTA BIDIMENSIONAL Y
; CAMBIA LOS CAMBIA SIN ALTERAR LOS OTROS DATOS
; ALMACENADOS ENTRADA: i= INDICE DE 1ra DIMENSION (Ubica el orden de la sublista)
; j= INDICE DE 2da DIMENSION (Ubica el orden del elemento
; de la sublista a cambiar)
; nombre= DATOS A CAMBIAR
(defun cambia (i j nombre datos / data)
(setq data (cambia1 j nombre (nth i datos))
data (cambia1 i data datos)
)
)

(defun cambia1 (i nombre lista / a b n)
(setq n (- (length lista) i))
(setq b lista)
(repeat (1+ i)
(setq b (cdr b))
)
(setq a (reverse lista))
(repeat n
(setq a (cdr a))
)
(setq a (append (reverse a) (list nombre) b))
)

;;; FUNCION DE BUSQUE DE DATOS EN LISTA
;;; ARGUMENTO: nombre= elemento de lista a buscar
;;; lista= lista donde se buscará el elemento "nombre"
;;; SALIDA: j= POSICION DEL ELEMENTO ENCONTRADO. SI NO SE LE
;;; UBICA, J=0

(defun busca (nombre lista / n j)
(setq n (length lista))
(setq j 0)
(while (and (not (equal nombre (nth j lista)))
(< j n))
(setq j (1+ j))
)
(if (= j n)
(setq j 0)
)
(setq j j)
)

;; COLOREA BOTON DE IMAGEN DE COLOR
(defun colorea (tile color)
(start_image tile)
(fill_image 0 0 (dimx_tile tile) (dimy_tile tile) color)
(end_image)
)

;;CAMBIA LAYER SELECCIONADO EN DCL EN LISTA LAYER Y ACTUALIZA VALORES
(defun verifica_layer (tile / nombre)
(setq nombre (get_tile tile))
(if (or (wcmatch nombre nombre_layer_no_permitido)
(= nombre "")
)
(progn
(mode_tile tile 2)
(alert
"Caracteres no permitidos para nombres de archivos ni layers!!
\nLos siguientes caracteres no son válidos
< > / \\ \" : ? * | , = '"
)
)
)
(setq nombre nombre)
)

Luis Alberto Benitez

Mensajes : 82
Fecha de inscripción : 29/03/2016

Volver arriba Ir abajo

lisp-para-generar-progresivas-de-un-alineamiento Empty Re: lisp-para-generar-progresivas-de-un-alineamiento

Mensaje por Luis Alberto Benitez el Mar Sep 24, 2019 3:52 pm

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CONTROL DEL 5to DCL: LISTA DESPLEGABLE DEL BOTON LAYER ;;;
;;; ENTRADA: dcl_label= título del cuadro de diálogo ;;;
;;; n_layer= lista 1D con los datos a desplegar ;;;
;;; mode_carga=modo del botón de carga de linetypes ;;;
;;; tipo_sel= tipo de seleccion: nil/t=simple/múltiple ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dcl_control_progresivas5 (dcl_label n_layer l_layer mode_carga
tipo_sel / j
control dcl_id indice
layer x dialogo)
(setq control nil
dcl_id (load_dialog "progresivas.dcl")
dialogo "progresivas_layers")
(if tipo_sel
(setq dialogo (strcat dialogo "_multiples"))
)
(while (not control)
(if (not (new_dialog dialogo dcl_id "" dcl_progresivas_pto5))
(exit)
)
(if (= (type n_layer) 'LIST)
(progn
(setq j "")
(foreach x n_layer
(setq j (strcat j " " (itoa (busca x l_layer))))
)
)
(setq j (itoa (busca j l_layer)))
)
(set_tile "dcl_label" dcl_label)
(start_list "dcl_layer" 3) ;list_box
(mapcar 'add_list l_layer) ;list_box
(end_list) ;list_box
(set_tile "dcl_layer" j)
(action_tile "dcl_layer" "(setq j $value )")
(action_tile "cancel" "(setq dcl_progresivas_pto5 (done_dialog 0))")
(action_tile "accept" "(setq dcl_progresivas_pto5 (done_dialog 1))")
(mode_tile "dcl_carga" mode_carga)
(action_tile "dcl_carga" "(setq dcl_progresivas_pto5 (done_dialog 2))")
(set_tile "nombre_dcl" manlio)
(setq indice (start_dialog))
(cond
((= indice 0) (setq control 1))
((= indice 1) (progn
(setq control 1
j (eval (read (strcat "'(" j ")")))
layer nil)
(foreach x j
(setq layer (append layer (list (nth x l_layer))))
)
)
)
((= indice 2) (setq j (dcl_control_progresivas6 "TIPOS DE LINEA" 5))
)
)
)
(unload_dialog dcl_id)
(if layer
(setq n_layer layer)
(setq n_layer n_layer)
)
(if tipo_sel
(setq n_layer n_layer)
(if (= (type n_layer) 'LIST)
(setq n_layer (car n_layer))
(setq n_layer n_layer)
)
)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CONTROL DEL 6to DCL: LISTA DESPLEGABLE DEL TIPOS DE LINEA ;;;
;;; dcl_label= Nombre que adoptará el Título del dcl ;;;
;;; i= índice del 1er nivel de la lista de datos "DATOS" ;;;
;;; ind= índice del 2do nivel en la lista "DATOS" ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dcl_control_progresivas6 (dcl_label i / n j
control dcl_id indice
lista a file1 n_linea
file ltype b l_linea x
)
(setq file "acad.lin")
(busca_linea file)
(setq control nil
dcl_id (load_dialog "progresivas.dcl")
)
(while (not control)
(if (not (new_dialog "progresivas_linea" dcl_id "" dcl_progresivas_pto6))
(exit)
)
(set_tile "dcl_file" file)
(set_tile "dcl_label" dcl_label)
(start_list "dcl_t_line" 3) ;list_box
(mapcar 'add_list lista) ;list_box
(end_list) ;list_box
(set_tile "dcl_t_line" (itoa j))
(action_tile "dcl_t_line" "(setq j $value)")
(action_tile "cancel" "(setq dcl_progresivas_pto6 (done_dialog 0))")
(action_tile "accept" "(setq dcl_progresivas_pto6 (done_dialog 1))")
(action_tile "dcl_buscar" "(setq dcl_progresivas_pto6 (done_dialog 2))")
(set_tile "nombre_dcl" manlio)
(setq indice (start_dialog))
(cond
((= indice 0) (setq control 1))
((= indice 1)
(progn
(setq control 1
j (eval (read (strcat "'(" j ")"))))
(foreach x j
(setq ltype (nth x l_linea)
b (cdr (assoc 2 (tblsearch "LTYPE" ltype))))
(if (not b)
(progn
(command "_linetype" "LOAD" ltype file "")
(setq tipo_linea (acad_strlsort (cons ltype tipo_linea))
l_layer tipo_linea)
)
)
)
)
)
((= indice 2)
(progn
(setq file1 (getfiled "Cargar o Recargar Tipo de Línea"
file
"lin"
8
)
)
(if file1
(setq file (nth 0 (reverse (lee file1 "\\"))))
)
(busca_linea file)
)
)
)
)
(unload_dialog dcl_id)
;(setq ltype ltype)
(busca ltype l_layer)
)

; BUSCA TIPO DE LINEA EN ARCHIVO *.LIN
(defun busca_linea (file)
(setq lista (lee_archivos_lin file))
(setq l_linea (nth 0 lista))
(setq lista (nth 1 lista))
(setq n_linea (nth i datos))
(setq j (busca n_linea l_linea))
)



;;; BUSCA EN EL SUPPORT DE AUTOCAD EL ARCHIVO *.lin Y LEE LOS TIPOS DE ;;;
;;; TIPOS DE LINEAS A CARGAR ;;;
;;; DATOS: file = NOMBRE DEL ARCHIVO DE BUSQUEDA ejm ACAD.LIN ;;;
;;; SALIDA: LISTA DE 2 DIMENSIONES QUE CONTIENE ;;;
;;; 1er CAMPO: NOMBRES DE LOS TIPOS DE LINEA ;;;
;;; 2do CAMPO: DESCRIPCION DE LOS TIPOS DE LINEAS ;;;
(defun lee_archivos_lin (file / linea file vars lista1 lista2 lista a b)
(setq separ ","
vars nil
lista1 nil
lista2 nil
lista nil
)
(setq file (findfile file))
(setq punt (open file "r"))
(while (/= (setq linea (read-line punt)) nil)
(setq vars (lee linea separ))
(if (= (substr (nth 0 vars) 1 1) "*")
(progn
(setq a (nth 0 vars))
(setq a (substr a 2 (- (strlen a) 1)))
(setq b (nth 1 vars))
(setq lista1 (cons a lista1))
(setq lista2 (cons (strcat a " " b) lista2))
)
)
)
(close punt)
(if lista1
(progn
(setq lista1 (reverse lista1))
(setq lista2 (reverse lista2))
(setq lista (list lista1 lista2))
)
(setq lista nil)
)
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CONTROL DEL 7mo DCL: CONTROL DE PRECISION & UCS ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dcl_control_progresivas7 (/ i n k
celda control dcl_id
indice escala1 dcl_texto
datos list_prec l_precision1)
(setq control nil
dcl_id (load_dialog "progresivas.dcl")
escala1 escala
l_precision1 l_precision
datos (carga_datos_progresivas)
list_prec '("0" "0.1" "0.01"
"0.001" "0.0001" "0.00001"
"0.000001" "0.0000001" "0.00000001"
))
(while (not control)
(if (not (new_dialog "progresivas_ucs" dcl_id "" dcl_progresivas_pto7))
(exit)
)
(set_tile "nombre_dcl" manlio)
;CONTROL DE EDIT_BOX DE ESCALA
(edita_box "dcl_escala" escala "escala" ">" 0.0)
;CONTROL DEL TOGGLE UCS
(set_tile "dcl_ucs" (itoa (- 1 ucs)))
(action_tile "dcl_ucs" "(setq ucs (- 1 (atoi $value)))")
;POPUP_LIST DE PRECISION
(setq i 0)
(repeat 3
(setq i (1+ i)
dcl_texto (strcat "dcl_prec" (itoa i)))
(start_list dcl_texto 3)
(mapcar 'add_list list_prec)
(end_list)
(set_tile dcl_texto (itoa (nth (- i 1) l_precision)))
(action_tile dcl_texto (strcat "(setq l_precision (cambia1 "
(itoa (1- i))
" (atoi (get_tile \""
dcl_texto
"\")) l_precision))"
))
)
;CONTROL DE BOTONES
(action_tile "dcl_reset6" "(setq dcl_progresivas_pto7 (done_dialog -1))")
(action_tile "cancel" "(setq dcl_progresivas_pto7 (done_dialog 0))")
(action_tile "accept" "(setq dcl_progresivas_pto7 (done_dialog 1))")

(setq indice (start_dialog))
(cond
((= indice -1) (setq l_precision1 l_precision
l_precision (precision_ini)
escala1 escala
escala (escala_ini)
)
)
((= indice 0) (setq control 1
escala escala1
l_precision l_precision1
))
((= indice 1) (setq control 1
escala1 (escala_ini)
l_precision1 (precision_ini)
))
)
)
(unload_dialog dcl_id)
(setq i -1
k (/ escala escala1)
n (length fmto_progresivas)
)
(repeat n
(setq i (1+ i)
celda (nth 2 (nth i datos))
)
(if (/= (type celda) "STR")
(setq celda (atof (rtos (* k celda) 2 6))
fmto_progresivas (cambia i 2 celda fmto_progresivas))
)
)
(list escala ucs)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CONTROL DEL 8vo DCL: CONTROL DE EDICION DE LISTA DE MARCAS ;;;
;;; ENTRADA: datos= lista 2d con coords. x,y de los puntos a editar ;;;
;;; prec= precisión de presentación ;;;
;;; dcl_label= label o título de caja de diálogo ;;;
;;; SALIDA: datos= lista de marcas de rutina ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dcl_control_progresivas8 (datos prec dcl_label /
data data1 i j k
control dcl_id indice layer
celda lista1 datos1 lista e1 e2)
(setq control nil
dcl_id (load_dialog "progresivas.dcl")
datos (vl-sort datos (function (lambda (e1 e2) (< e1 e2))))
datos1 datos)
(while (not control)
(if (not (new_dialog "edita_progresivas" dcl_id "" dcl_progresivas_pto8))
(exit)
)
(set_tile "dcl_edita_progresivas" dcl_label); ACTUALIZA TITULO DEL DCL
;; CONTROL DE LIST_BOX
(actualiza-list-box datos1 "dcl_lista" prec)
(action_tile "dcl_lista" "(actualiza (setq i $value) data1 prec \"dcl_prog1\")");list_box
;; CONTROL DE BOTONES
(action_tile "cancel" "(setq dcl_progresivas_pto8 (done_dialog 0))");cancel
(action_tile "accept" "(setq dcl_progresivas_pto8 (done_dialog 1))");accept
(action_tile "dcl_cambia" "(setq datos1 (modifica-lista-dcl datos1 prec \"dcl_lista\" \"dcl_prog1\"))");edita list_box
(action_tile "dcl_add" "(setq datos1 (adiciona-lista-dcl datos1 prec \"dcl_lista\" \"dcl_prog1\"))");adiciona pto
(action_tile "dcl_del" "(setq datos1 (borra-lista-dcl datos1 prec \"dcl_lista\" \"dcl_prog1\"))");adiciona pto

(set_tile "nombre_dcl" manlio)
(setq indice (start_dialog))
(cond
((= indice 0) (setq control 1))
((= indice 1) (setq control 1
datos datos1))
)
)
(unload_dialog dcl_id)
(setq datos datos)
)

;;; MODIFICA/EDITA LIST-BOX ;;;
;;; ENTRADA: data2= lista1D con datos originales del dcl-list;;;
;;; prec= precisión de valores numéricos ;;;
;;; dcl1= dcl-key del list-box ;;;
;;; dcl2= dcl-key del edit_box asociado a dcl1 ;;;
;;; SALIDA: LIST-BOX MODIFICADO Y ACTUALIZADO ;;;
(defun modifica-lista-dcl (data2 prec dcl1 dcl2 / i
j k a b n
m e1 e2 data2 prec
dcl1 dcl2 valor valor1 tolerancia)
(setq i (get_tile dcl1)
valor (lee (get_tile dcl2) ","))
(if (and (/= i "")
(/= (car valor) ""))
(progn
(setq i (eval (read (strcat "'(" i ")")))
k -1
n (length valor)
tolerancia 1e-10)
(foreach j i
(setq k (1+ k))
(if (>= k n)
(setq k (- n 1))
)
(setq valor1 (lee (nth k valor) "+")
m (length valor1))
(if (< m 2)
(setq valor1 (atof (nth 0 valor1)))
(setq valor1 (+ (* 1000.0 (atof (nth 0 valor1)))
(atof (nth 1 valor1)))
)
)
(if (/= (car valor) "")
(setq data2 (cambia1 j valor1 data2))
)
); end foreach
(setq data2 (depura-lista data2)) ; VERIFICA DUPLICIDAD DE MARCAS
(actualiza-list-box data2 dcl1 prec)
(set_tile dcl2 "")
)
); end if i <> "" y valor<> ""
(setq data2 data2)
)

;;; ELIMINA DUPLICIDAD EN LISTA 1D SEGUN TOLERANCIA ;;;
;;; ENTRADA: lista = lista 1D ;;;
;;; SALIDA: lista = lista 1D depurada y ordenada ;;;
(defun depura-lista (lista / lista n a i j e1 e2 tolerancia)
(if lista
(progn
(setq lista (vl-sort lista (function (lambda (e1 e2) (< e1 e2))))
n (- (length lista) 1)
a (car lista)
i 1
j 0
tolerancia 1.0e-10)
(repeat n
(setq j (1+ j))
(if (< (abs (- (nth i lista) a)) tolerancia)
(setq lista (borra_lista lista i))
(setq a (nth i lista)
i (1+ i))
)
)
)
)
(setq lista lista)
)

;;; ELIMINA UN ELEMENTO DE UNA LISTA SEGUN SU UBICACION ;;;
;;; ENTRADA: lista= lista de datos ;;;
;;; i:ubicación del elemento en lista (inicia en 0) ;;;
;;; SALIDA: lista con elemento eliminado ;;;
(defun borra_lista (lista i / lista1 n a)
(setq n (- (length lista) 1)
i (fix (abs i)))
(if (> i n)
(setq i n)
)
(repeat (1+ i)
(setq lista1 (append lista1 a)
a (list (car lista))
lista (cdr lista)
)
)
(setq lista (append lista1 lista))
)

;;; ACTUALIZA LIST-BOX CON DATOS CONTENIDOS EN UNA LISTA CUALQUIERA ;;;
;;; ENTRADA: lista= lista 1D con datos a actualizar ;;;
;;; dcl= nombre del dcl a actualizar ;;;
;;; SALIDA: list-box con datos actualizados ;;;
(defun actualiza-list-box (lista dcl prec / lista dcl)
(setq data1 (formatea_lista lista prec)
data (nth 0 data1)
data1 (nth 1 data1))
;; CONTROL DE LIST_BOX
(start_list dcl 3) ;list_box
(mapcar 'add_list data) ;list_box
(end_list) ;list_box
)

;;; ACTUALIZA Y CONTROLA EDIT_BOX´s DEL DCL_CONTROL_progresivas10
;;; ENTRADA: i=ubicación de la fila de datos almacenada en data1
;;; data1=lista de strings, con los datos formateados de
;;; presentación '(x y distH distV pend)
;;; datos=lista de coordenadas '(x y)
;;; prec=precisión de presentación de resultados
(defun actualiza (i data1 prec dcl / n i j celda data1 dcl
lista lista1 separ prec)
(if data1
(progn
(setq i (eval (read (strcat "'(" i ")")))
celda ""
separ "")
(foreach j i
(setq celda (strcat celda separ (car (nth j data1)))
separ ", ")
)
)
(setq celda "")
)
;; CONTROL DE EDIT_BOXES
(set_tile dcl celda)
)

;;; CONVIERTE LISTA DE COORDENADAS x, y EN LISTA DE STRINGS: x, y, Dist.H ,Dist.V, Pend
;;; ENTRADA: data= lista de corrdenadas x,y
;;; prec= precisión de presentación de resultados
;;; SALIDA: lista con strings formateados, con los valores x, sy, DistH, DistV, Pend
(defun formatea_lista (data prec / a b p p0 lista lista1 celda ancho
ancho1 largo)
(if (not data)
(setq lista '(("")))
(progn
(foreach p data
(setq lista (append lista (list (list (format_prog p prec)))))
)
(list (tabula_lista lista '(2)) lista)
)
)
)


;;; TABULA UNA LISTA DE STRINGS EN 2D A 1D, CON SALTOS DE TABULADOR ;;;
;;; ENTRADA: lista=lista 2D con strings ;;;
;;; l_tab=lista 1D de enteros, con control de tabulaciones ;;;
;;; (ejm '(.... 0 2 5 ), el tabulador se cuenta desde;;;
;;; el 2do elemento de c/fila en "lista" 2D de entrada;;;
;;; ancho2=ancho de campos designados en el dcl ;;;
;;; SALIDA: lista1=lista formateada con tabuladores ;;;
(defun tabula_lista (lista l_tab / lista1 i j x y a m n l_tab1 ancho)
(setq i -1
j 0
m (strlen (itoa (length lista))))
;; Convierte lista de enteros de tabulación en símbolos de tabulación
(foreach x l_tab
(setq a ""
i (1+ i)
n (abs (fix (nth i l_tab))))
(repeat n
(setq a (strcat a "\t"))
)
(setq l_tab1 (append l_tab1 (list a)))
)
;; Completa espacios vacios en la izquierda
(if l_tab1
(setq ancho (ancho_campo lista 1.0 1.0)
i -1)
)
(foreach x lista
(setq i -1
j (1+ j)
a (strcat "\t" (completa_texto (itoa j) m)))
(foreach y x
(setq i (1+ i)
a (strcat a (nth i l_tab1) (completa_texto y (nth i ancho))))
)
(setq lista1 (append lista1 (list a)))
)
)

;;; ADICIONA VALORES EN DCL LIST-BOX ;;;
;;; ENTRADA: lista= lista con valores originales ;;;
;;; prec= precisión de presentación en dcl ;;;
;;; dcl1= key del list-box ;;;
;;; dcl2= key del edit-box asociado a dcl1 ;;;
;;; SALIDA: lista= valores actualizados del dcl ;;;
(defun adiciona-lista-dcl (lista prec dcl1 dcl2 / dcl1 dcl2 lista x a n prec )
(setq a (get_tile dcl2))
(if (/= a "")
(progn
(setq a (lee a ","))
(foreach x a
(setq x (lee x "+")
n (length x))
(if (< n 2)
(setq x (atof (nth 0 x)))
(setq x (+ (* 1000.0 (atof (nth 0 x))) (atof (nth 1 x))))
)
(setq lista (append lista (list x)))
)
(setq lista (depura-lista lista))
(actualiza-list-box lista dcl1 prec)
(set_tile dcl2 "")
)
)
(setq lista lista)
)

;;; BORRA LIST-BOX SEGUN SELECCION DE ITEMS ;;;
;;; ENTRADA: lista = lista 1D con valores ;;;
;;; prec = precisión de presentación ;;;
;;; dcl1 = key de list-box ;;;
;;; dcl2 = key de edit-box asociado a dcl1 ;;;
;;; SALIDA: lista con items borrados ;;;

(defun borra-lista-dcl (lista prec dcl1 dcl2 / i j k n lista prec dcl1 dcl2 lista1)
(setq i (get_tile dcl1))
(if (/= i "")
(progn
(setq i (eval (read (strcat "'(" i ")")))
n (length lista)
k 0
j 0)
(repeat n
(if (/= j (nth k i))
(setq lista1 (append lista1 (list (nth j lista))))
(setq k (1+ k))
)
(setq j (1+ j))
)
(actualiza-list-box lista1 dcl1 prec)
(set_tile dcl2 "")
)
)
(setq lista lista1)
)

;;;(defun borra-lista-dcl (lista prec dcl1 dcl2 / i j n lista prec dcl1 dcl2)
;;; (setq i (get_tile dcl1))
;;; (if (/= i "")
;;; (progn
;;; (setq i (eval (read (strcat "'(" i ")")))
;;; n (length lista))
;;; (foreach j i
;;; (if (or (> j -1)
;;; (< j n))
;;; (setq lista (borra_lista lista j))
;;; )
;;; )
;;; (actualiza-list-box lista dcl1 prec)
;;; (set_tile dcl2 "")
;;; )
;;; )
;;; (setq lista lista)
;;; )



;;; SUBRUTINA CALCULO DE ANCHOS DE CAMPO PARA IMPRESION DE CUADROS GRAFICOS SEGUN ;;;
;;; DATOS ALMACENADOS EN UNA LISTA CUALESQUIERA DE FORMATO: ;;;
;;; ((ELEMENTO1) (ELEMENTO2) (ELEMTO3)....(ELEMENTOn)) ;;;
(defun ancho_campo (lista h w / i j n m ancho1 ancho campo)
(setq w (* w h)
j -1
ancho (* 6.0 w)
m (length lista)
n 0
)
(if (> m 0)
(setq n (length (nth 0 lista)))
)
(repeat n
(setq i -1
j (1+ j)
)
(repeat m
(setq i (1+ i)
ancho1 (nth j (nth i lista)))
(if ancho1
(setq ancho1 (* (+ (strlen ancho1) 1.5) w))
(setq ancho1 0.0)
)
(setq ancho (max ancho ancho1)
)
)
(setq campo (append campo (list ancho)))
)
)

;;; RUTINA QUE COMPLETA CON ESPACIOS VACIOS EN LA IZQUIERDA DE UN TEXTO
;;; SEGUN ANCHO DE CAMPO PREDEFINDO
;;; ENTRADA: texto= string que define el texto de entrada
;;; espacio= ancho del campo de texto
;;; SALIDA: string con espacios en blanco a la izquierda del texto
;;; (si el espacio es menor que el ancho del texto, la
;;; rutina devolverá el texto inicial sin modificaciones)
(defun completa_texto (texto espacio / n)
(setq n (fix (- espacio (strlen texto))))
(repeat n
(setq texto (strcat " " texto))
)
(setq texto texto)
)



;;; RUTINA PARA CONVERTIR UN TEXTO NIL EN "", SI NO ES NIL, DEVOLVERA
;;; EL VALOR DEL TEXTO
(defun ver_file (texto)
(if (not texto)
(setq texto "")
)
(setq texto texto)
)

;;; RUTINA QUE EXTRAE LAS COORDENADAS GRABADAS EN UN ARCHIVO ASCII Y LAS
;;; ALMACENA EN UNA LISTA DATOS
;;; ENTRADA: file=Ruta y nombre del archivo ASCII
;;; SALIDA: datos=Lista con las coordenadas extraidas de file
(defun lee_file (file / indice datos linea vars a lista)
(if file
(progn
(setq indice (open file "r")
datos nil)
(while (/= (setq linea (read-line indice)) nil)
(setq vars (lee linea ",")
lista nil)
(foreach a vars (setq lista (append lista (list (atof a)))))
(setq datos (append datos (list lista)))
)
(close indice)
)
)
(setq datos datos)
)


;;; RUTINA PARA GRABAR COORDENADAS X,Y EN ARCHIVO ASCII
;;; ENTRADA: file=ruta y nombre completo del archivo a crear
;;; datos=lista con coordenadas
;;; SALIDA: Archivo ASCII
(defun graba (file datos / indice n m i j linea a separ)
(if (and file datos)
(progn
(setq n (length datos)
indice (open file "w")
i -1)
(repeat n
(setq i (1+ i)
j -1
a (nth i datos)
m (length a)
linea "")
(repeat m
(setq j (1+ j)
linea (strcat linea (rtos (nth j a) 2 20) ",")
)
)
(setq a (strlen linea)
linea (substr linea 1 (1- a)))
(write-line linea indice)
)
(close indice)
(setq file file)
)
)
)

;;; CONTROL DE CAJA DE DIALOGO ACEPTA_CANCELA
;;; ENTRADA: tile = Título del dcl
;;; texto=string. Texto
;;; SALIDA: true/nil
(defun dcl_control_progresivas10 (tile texto / control dcl_id indice val)
(setq control nil
dcl_id (load_dialog "progresivas.dcl")
texto (lee texto "\n"))
(while (not control)
(if (not (new_dialog "acepta_cancela" dcl_id "" dcl_progresivas_pto10))
(exit)
)
(set_tile "dcl_acepta" tile)
(set_tile "nombre_dcl" manlio)
(set_tile "dcl_txt" (nth 0 texto))
(set_tile "dcl_txt1" (nth 1 texto))
(action_tile "cancel" "(setq dcl_progresivas_pto10 (done_dialog 0))")
(action_tile "accept" "(setq dcl_progresivas_pto10 (done_dialog 1))")
(setq indice (start_dialog))
(cond
((= indice 0) (setq val nil
control 1))
((= indice 1) (setq val t
control 1))
)
)
(unload_dialog dcl_id)
(setq val val)
)

;;; CONVIERTE UNA LISTA 1D EN UN STRING, UTILIZANDO SUS COMPONENTES SEPARADOS POR COMAS ;;;
;;; ENTRADA: lista = LISTA 1D, ejm '("GOTA" "8" "J"...) ;;;
;;; SALIDA: lista1= STRING, ejm "GOTA, 8, j" ;;;
(defun separa-lista (lista / separ lista1 x)
(setq separ ""
lista1 "")
(foreach x lista
(setq lista1 (strcat lista1 separ x)
separ ",")
)
(setq lista lista1)
)

;; FUNCION SIGNO
(defun signo ( a )
(if (/= a 0.0)
(setq a (/ a (abs a)))
(setq a 0.0)
)
)

;;; RUTINA DE INSTALACION DE PROGRAMA ;;;
;;; DETERMINA TIEMPO DE DURACION DE RUTINA ;;;
(defun c:install (/ obj dia
#dias prog
ucs cdate
gap prec_dcl
font_list manlio
escala esp_prin
esp_sec cmdecho
char_width dwgprefix
dwgname file_progresivas
esp_inter radio_ubica1
radio_ubica2 toggle_progs
toggle_marcas fmto_progresivas
progresivas_cfg l_precision
cfg-name cfg-instal
f_rutina periodo
periodo1 dcl_progresivas_pto1
dcl_progresivas_pto2
dcl_progresivas_pto3
dcl_progresivas_pto4
dcl_progresivas_pto5
dcl_progresivas_pto6
dcl_progresivas_pto7
dcl_progresivas_pto8
dcl_progresivas_pto9
dcl_progresivas_pto10
nombre_layer_no_permitido)
(variables)
(setq control nil
dcl_id (load_dialog "progresivas.dcl")
cfg-instal (eval (read (strcat "'(" (getcfg cfg-name) ")")))
periodo1 (nth 2 cfg-instal))
(while (not control)
(if (not (new_dialog "manlio_code" dcl_id "" dcl_progresivas_pto9))
(exit)
)
; CONTROLA EDIT_BOX DEL PERIODO DE USO DE RUTINA
(set_tile "dcl_periodo" (rtos periodo 2 prec_dcl))
(edita_box "dcl_periodo" periodo "periodo" ">=" 0.0)
; ACTUALIZA NOMBRE
(set_tile "nombre_dcl" manlio)
; CONTROL DE BOTONES
(action_tile "dcl_code" "(setq code (get_tile \"dcl_code\"))")
(action_tile "cancel" "(setq dcl_progresivas_pto9 (done_dialog 0))")
(action_tile "accept" "(setq dcl_progresivas_pto9 (done_dialog 1))")
(setq indice (start_dialog))
(cond
((= indice 0) (setq control 1))
((= indice 1) (setq control 1))
)
)
(unload_dialog dcl_id)
(if (= indice 1)
(progn
(cond
((= code "MASI860443A") (setq periodo periodo))
((= code "PAPAPULI") (setq periodo 365))
((= code "ALBERTO") (setq periodo 60))
((= code "AMIGO") (setq periodo 30))
(t (setq code (alert "Clave Incorrecta!!!")))
)
(if code
(if (or
(and (/= code "MASI860443A")
(/= periodo1 periodo))
(= code "MASI860443A")
(= code "AMIGO"))
(progn
(setq cfg-instal cdate
cfg-fecha cdate)
(setcfg cfg-name (strcat (rtos cfg-instal 2 10)
" "
(rtos cfg-fecha 2 10)
" "
(rtos periodo 2 10)))
(alert "El programa ha sido instalado correctamente")
)
(alert "El programa sólo puede ser instalado una vez")
)
)
)
)
(princ)
)

;; FUNCION DE REINICIACION DE VALORES POR DEFECTO DE LA VARIABLE DE SISTEMA
;; DATOS, LA CUAL CONTROLA LOS FORMATOS Y LAYERS DEL PROGRAMA PRINCIPAL
;; ENTRADA: i= indice inicial de la matriz "datos" donde comienza reseteo
;; n= número de veces que se resetearán los valores de "datos"
;; datos = matriz con formatos, modificada por el dcl
;; data = matriz original con formatos por defecto, de ancho total
;; SALIDA: lista con matriz de datos por defecto, modificada segun i y n
(defun reinicia (i n datos data escala / k j)
(setq j i)
(repeat n
(setq datos (cambia1 j (nth j data) datos)
j (1+ j)
)
)
(setq k (/ escala (escala_ini))
j (- i 1)
)

(if (/= (type (nth 2 datos)) 'LIST)
(setq datos (cambia1 2 (* (nth 2 datos) k) datos))
(repeat n
(setq j (1+ j)
datos (cambia j 2 (* k (nth 2 (nth j data))) datos)
)
)
)
)

;;; FUNCION QUE REINICIA EL VALOR DE LA VARIABLE DE CONTROL "INDICADOR"
;;; "INDICADOR" CONTROLA EL VALOR POR DEFECTO DE LAS VARIABLES DE CONTROL
;;; DEL PROGRAMA. SI INDICADOR <> 1, SE TOMARAN LOS VALORES DE VARIABLES
;;; POR DEFECTO EN EL PROGRAMA
(defun c:reset_progresivas ( / file)
(if (setq file (findfile "progresivas.ini"))
(vl-file-delete file)
)
(alert
(strcat "Variable de control \"seccion_cfg\" descargada."
"\nPara seguir operando esta rutina escriba \"SECCION\""
"\n\n\t\t\t*** M.Santillán ***"
)
)
(princ)
)

Luis Alberto Benitez

Mensajes : 82
Fecha de inscripción : 29/03/2016

Volver arriba Ir abajo

lisp-para-generar-progresivas-de-un-alineamiento Empty Re: lisp-para-generar-progresivas-de-un-alineamiento

Mensaje por Luis Alberto Benitez el Mar Sep 24, 2019 3:52 pm

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CONTROL DEL 5to DCL: LISTA DESPLEGABLE DEL BOTON LAYER ;;;
;;; ENTRADA: dcl_label= título del cuadro de diálogo ;;;
;;; n_layer= lista 1D con los datos a desplegar ;;;
;;; mode_carga=modo del botón de carga de linetypes ;;;
;;; tipo_sel= tipo de seleccion: nil/t=simple/múltiple ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dcl_control_progresivas5 (dcl_label n_layer l_layer mode_carga
tipo_sel / j
control dcl_id indice
layer x dialogo)
(setq control nil
dcl_id (load_dialog "progresivas.dcl")
dialogo "progresivas_layers")
(if tipo_sel
(setq dialogo (strcat dialogo "_multiples"))
)
(while (not control)
(if (not (new_dialog dialogo dcl_id "" dcl_progresivas_pto5))
(exit)
)
(if (= (type n_layer) 'LIST)
(progn
(setq j "")
(foreach x n_layer
(setq j (strcat j " " (itoa (busca x l_layer))))
)
)
(setq j (itoa (busca j l_layer)))
)
(set_tile "dcl_label" dcl_label)
(start_list "dcl_layer" 3) ;list_box
(mapcar 'add_list l_layer) ;list_box
(end_list) ;list_box
(set_tile "dcl_layer" j)
(action_tile "dcl_layer" "(setq j $value )")
(action_tile "cancel" "(setq dcl_progresivas_pto5 (done_dialog 0))")
(action_tile "accept" "(setq dcl_progresivas_pto5 (done_dialog 1))")
(mode_tile "dcl_carga" mode_carga)
(action_tile "dcl_carga" "(setq dcl_progresivas_pto5 (done_dialog 2))")
(set_tile "nombre_dcl" manlio)
(setq indice (start_dialog))
(cond
((= indice 0) (setq control 1))
((= indice 1) (progn
(setq control 1
j (eval (read (strcat "'(" j ")")))
layer nil)
(foreach x j
(setq layer (append layer (list (nth x l_layer))))
)
)
)
((= indice 2) (setq j (dcl_control_progresivas6 "TIPOS DE LINEA" 5))
)
)
)
(unload_dialog dcl_id)
(if layer
(setq n_layer layer)
(setq n_layer n_layer)
)
(if tipo_sel
(setq n_layer n_layer)
(if (= (type n_layer) 'LIST)
(setq n_layer (car n_layer))
(setq n_layer n_layer)
)
)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CONTROL DEL 6to DCL: LISTA DESPLEGABLE DEL TIPOS DE LINEA ;;;
;;; dcl_label= Nombre que adoptará el Título del dcl ;;;
;;; i= índice del 1er nivel de la lista de datos "DATOS" ;;;
;;; ind= índice del 2do nivel en la lista "DATOS" ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dcl_control_progresivas6 (dcl_label i / n j
control dcl_id indice
lista a file1 n_linea
file ltype b l_linea x
)
(setq file "acad.lin")
(busca_linea file)
(setq control nil
dcl_id (load_dialog "progresivas.dcl")
)
(while (not control)
(if (not (new_dialog "progresivas_linea" dcl_id "" dcl_progresivas_pto6))
(exit)
)
(set_tile "dcl_file" file)
(set_tile "dcl_label" dcl_label)
(start_list "dcl_t_line" 3) ;list_box
(mapcar 'add_list lista) ;list_box
(end_list) ;list_box
(set_tile "dcl_t_line" (itoa j))
(action_tile "dcl_t_line" "(setq j $value)")
(action_tile "cancel" "(setq dcl_progresivas_pto6 (done_dialog 0))")
(action_tile "accept" "(setq dcl_progresivas_pto6 (done_dialog 1))")
(action_tile "dcl_buscar" "(setq dcl_progresivas_pto6 (done_dialog 2))")
(set_tile "nombre_dcl" manlio)
(setq indice (start_dialog))
(cond
((= indice 0) (setq control 1))
((= indice 1)
(progn
(setq control 1
j (eval (read (strcat "'(" j ")"))))
(foreach x j
(setq ltype (nth x l_linea)
b (cdr (assoc 2 (tblsearch "LTYPE" ltype))))
(if (not b)
(progn
(command "_linetype" "LOAD" ltype file "")
(setq tipo_linea (acad_strlsort (cons ltype tipo_linea))
l_layer tipo_linea)
)
)
)
)
)
((= indice 2)
(progn
(setq file1 (getfiled "Cargar o Recargar Tipo de Línea"
file
"lin"
8
)
)
(if file1
(setq file (nth 0 (reverse (lee file1 "\\"))))
)
(busca_linea file)
)
)
)
)
(unload_dialog dcl_id)
;(setq ltype ltype)
(busca ltype l_layer)
)

; BUSCA TIPO DE LINEA EN ARCHIVO *.LIN
(defun busca_linea (file)
(setq lista (lee_archivos_lin file))
(setq l_linea (nth 0 lista))
(setq lista (nth 1 lista))
(setq n_linea (nth i datos))
(setq j (busca n_linea l_linea))
)



;;; BUSCA EN EL SUPPORT DE AUTOCAD EL ARCHIVO *.lin Y LEE LOS TIPOS DE ;;;
;;; TIPOS DE LINEAS A CARGAR ;;;
;;; DATOS: file = NOMBRE DEL ARCHIVO DE BUSQUEDA ejm ACAD.LIN ;;;
;;; SALIDA: LISTA DE 2 DIMENSIONES QUE CONTIENE ;;;
;;; 1er CAMPO: NOMBRES DE LOS TIPOS DE LINEA ;;;
;;; 2do CAMPO: DESCRIPCION DE LOS TIPOS DE LINEAS ;;;
(defun lee_archivos_lin (file / linea file vars lista1 lista2 lista a b)
(setq separ ","
vars nil
lista1 nil
lista2 nil
lista nil
)
(setq file (findfile file))
(setq punt (open file "r"))
(while (/= (setq linea (read-line punt)) nil)
(setq vars (lee linea separ))
(if (= (substr (nth 0 vars) 1 1) "*")
(progn
(setq a (nth 0 vars))
(setq a (substr a 2 (- (strlen a) 1)))
(setq b (nth 1 vars))
(setq lista1 (cons a lista1))
(setq lista2 (cons (strcat a " " b) lista2))
)
)
)
(close punt)
(if lista1
(progn
(setq lista1 (reverse lista1))
(setq lista2 (reverse lista2))
(setq lista (list lista1 lista2))
)
(setq lista nil)
)
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CONTROL DEL 7mo DCL: CONTROL DE PRECISION & UCS ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dcl_control_progresivas7 (/ i n k
celda control dcl_id
indice escala1 dcl_texto
datos list_prec l_precision1)
(setq control nil
dcl_id (load_dialog "progresivas.dcl")
escala1 escala
l_precision1 l_precision
datos (carga_datos_progresivas)
list_prec '("0" "0.1" "0.01"
"0.001" "0.0001" "0.00001"
"0.000001" "0.0000001" "0.00000001"
))
(while (not control)
(if (not (new_dialog "progresivas_ucs" dcl_id "" dcl_progresivas_pto7))
(exit)
)
(set_tile "nombre_dcl" manlio)
;CONTROL DE EDIT_BOX DE ESCALA
(edita_box "dcl_escala" escala "escala" ">" 0.0)
;CONTROL DEL TOGGLE UCS
(set_tile "dcl_ucs" (itoa (- 1 ucs)))
(action_tile "dcl_ucs" "(setq ucs (- 1 (atoi $value)))")
;POPUP_LIST DE PRECISION
(setq i 0)
(repeat 3
(setq i (1+ i)
dcl_texto (strcat "dcl_prec" (itoa i)))
(start_list dcl_texto 3)
(mapcar 'add_list list_prec)
(end_list)
(set_tile dcl_texto (itoa (nth (- i 1) l_precision)))
(action_tile dcl_texto (strcat "(setq l_precision (cambia1 "
(itoa (1- i))
" (atoi (get_tile \""
dcl_texto
"\")) l_precision))"
))
)
;CONTROL DE BOTONES
(action_tile "dcl_reset6" "(setq dcl_progresivas_pto7 (done_dialog -1))")
(action_tile "cancel" "(setq dcl_progresivas_pto7 (done_dialog 0))")
(action_tile "accept" "(setq dcl_progresivas_pto7 (done_dialog 1))")

(setq indice (start_dialog))
(cond
((= indice -1) (setq l_precision1 l_precision
l_precision (precision_ini)
escala1 escala
escala (escala_ini)
)
)
((= indice 0) (setq control 1
escala escala1
l_precision l_precision1
))
((= indice 1) (setq control 1
escala1 (escala_ini)
l_precision1 (precision_ini)
))
)
)
(unload_dialog dcl_id)
(setq i -1
k (/ escala escala1)
n (length fmto_progresivas)
)
(repeat n
(setq i (1+ i)
celda (nth 2 (nth i datos))
)
(if (/= (type celda) "STR")
(setq celda (atof (rtos (* k celda) 2 6))
fmto_progresivas (cambia i 2 celda fmto_progresivas))
)
)
(list escala ucs)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CONTROL DEL 8vo DCL: CONTROL DE EDICION DE LISTA DE MARCAS ;;;
;;; ENTRADA: datos= lista 2d con coords. x,y de los puntos a editar ;;;
;;; prec= precisión de presentación ;;;
;;; dcl_label= label o título de caja de diálogo ;;;
;;; SALIDA: datos= lista de marcas de rutina ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dcl_control_progresivas8 (datos prec dcl_label /
data data1 i j k
control dcl_id indice layer
celda lista1 datos1 lista e1 e2)
(setq control nil
dcl_id (load_dialog "progresivas.dcl")
datos (vl-sort datos (function (lambda (e1 e2) (< e1 e2))))
datos1 datos)
(while (not control)
(if (not (new_dialog "edita_progresivas" dcl_id "" dcl_progresivas_pto8))
(exit)
)
(set_tile "dcl_edita_progresivas" dcl_label); ACTUALIZA TITULO DEL DCL
;; CONTROL DE LIST_BOX
(actualiza-list-box datos1 "dcl_lista" prec)
(action_tile "dcl_lista" "(actualiza (setq i $value) data1 prec \"dcl_prog1\")");list_box
;; CONTROL DE BOTONES
(action_tile "cancel" "(setq dcl_progresivas_pto8 (done_dialog 0))");cancel
(action_tile "accept" "(setq dcl_progresivas_pto8 (done_dialog 1))");accept
(action_tile "dcl_cambia" "(setq datos1 (modifica-lista-dcl datos1 prec \"dcl_lista\" \"dcl_prog1\"))");edita list_box
(action_tile "dcl_add" "(setq datos1 (adiciona-lista-dcl datos1 prec \"dcl_lista\" \"dcl_prog1\"))");adiciona pto
(action_tile "dcl_del" "(setq datos1 (borra-lista-dcl datos1 prec \"dcl_lista\" \"dcl_prog1\"))");adiciona pto

(set_tile "nombre_dcl" manlio)
(setq indice (start_dialog))
(cond
((= indice 0) (setq control 1))
((= indice 1) (setq control 1
datos datos1))
)
)
(unload_dialog dcl_id)
(setq datos datos)
)

;;; MODIFICA/EDITA LIST-BOX ;;;
;;; ENTRADA: data2= lista1D con datos originales del dcl-list;;;
;;; prec= precisión de valores numéricos ;;;
;;; dcl1= dcl-key del list-box ;;;
;;; dcl2= dcl-key del edit_box asociado a dcl1 ;;;
;;; SALIDA: LIST-BOX MODIFICADO Y ACTUALIZADO ;;;
(defun modifica-lista-dcl (data2 prec dcl1 dcl2 / i
j k a b n
m e1 e2 data2 prec
dcl1 dcl2 valor valor1 tolerancia)
(setq i (get_tile dcl1)
valor (lee (get_tile dcl2) ","))
(if (and (/= i "")
(/= (car valor) ""))
(progn
(setq i (eval (read (strcat "'(" i ")")))
k -1
n (length valor)
tolerancia 1e-10)
(foreach j i
(setq k (1+ k))
(if (>= k n)
(setq k (- n 1))
)
(setq valor1 (lee (nth k valor) "+")
m (length valor1))
(if (< m 2)
(setq valor1 (atof (nth 0 valor1)))
(setq valor1 (+ (* 1000.0 (atof (nth 0 valor1)))
(atof (nth 1 valor1)))
)
)
(if (/= (car valor) "")
(setq data2 (cambia1 j valor1 data2))
)
); end foreach
(setq data2 (depura-lista data2)) ; VERIFICA DUPLICIDAD DE MARCAS
(actualiza-list-box data2 dcl1 prec)
(set_tile dcl2 "")
)
); end if i <> "" y valor<> ""
(setq data2 data2)
)

;;; ELIMINA DUPLICIDAD EN LISTA 1D SEGUN TOLERANCIA ;;;
;;; ENTRADA: lista = lista 1D ;;;
;;; SALIDA: lista = lista 1D depurada y ordenada ;;;
(defun depura-lista (lista / lista n a i j e1 e2 tolerancia)
(if lista
(progn
(setq lista (vl-sort lista (function (lambda (e1 e2) (< e1 e2))))
n (- (length lista) 1)
a (car lista)
i 1
j 0
tolerancia 1.0e-10)
(repeat n
(setq j (1+ j))
(if (< (abs (- (nth i lista) a)) tolerancia)
(setq lista (borra_lista lista i))
(setq a (nth i lista)
i (1+ i))
)
)
)
)
(setq lista lista)
)

;;; ELIMINA UN ELEMENTO DE UNA LISTA SEGUN SU UBICACION ;;;
;;; ENTRADA: lista= lista de datos ;;;
;;; i:ubicación del elemento en lista (inicia en 0) ;;;
;;; SALIDA: lista con elemento eliminado ;;;
(defun borra_lista (lista i / lista1 n a)
(setq n (- (length lista) 1)
i (fix (abs i)))
(if (> i n)
(setq i n)
)
(repeat (1+ i)
(setq lista1 (append lista1 a)
a (list (car lista))
lista (cdr lista)
)
)
(setq lista (append lista1 lista))
)

;;; ACTUALIZA LIST-BOX CON DATOS CONTENIDOS EN UNA LISTA CUALQUIERA ;;;
;;; ENTRADA: lista= lista 1D con datos a actualizar ;;;
;;; dcl= nombre del dcl a actualizar ;;;
;;; SALIDA: list-box con datos actualizados ;;;
(defun actualiza-list-box (lista dcl prec / lista dcl)
(setq data1 (formatea_lista lista prec)
data (nth 0 data1)
data1 (nth 1 data1))
;; CONTROL DE LIST_BOX
(start_list dcl 3) ;list_box
(mapcar 'add_list data) ;list_box
(end_list) ;list_box
)

;;; ACTUALIZA Y CONTROLA EDIT_BOX´s DEL DCL_CONTROL_progresivas10
;;; ENTRADA: i=ubicación de la fila de datos almacenada en data1
;;; data1=lista de strings, con los datos formateados de
;;; presentación '(x y distH distV pend)
;;; datos=lista de coordenadas '(x y)
;;; prec=precisión de presentación de resultados
(defun actualiza (i data1 prec dcl / n i j celda data1 dcl
lista lista1 separ prec)
(if data1
(progn
(setq i (eval (read (strcat "'(" i ")")))
celda ""
separ "")
(foreach j i
(setq celda (strcat celda separ (car (nth j data1)))
separ ", ")
)
)
(setq celda "")
)
;; CONTROL DE EDIT_BOXES
(set_tile dcl celda)
)

;;; CONVIERTE LISTA DE COORDENADAS x, y EN LISTA DE STRINGS: x, y, Dist.H ,Dist.V, Pend
;;; ENTRADA: data= lista de corrdenadas x,y
;;; prec= precisión de presentación de resultados
;;; SALIDA: lista con strings formateados, con los valores x, sy, DistH, DistV, Pend
(defun formatea_lista (data prec / a b p p0 lista lista1 celda ancho
ancho1 largo)
(if (not data)
(setq lista '(("")))
(progn
(foreach p data
(setq lista (append lista (list (list (format_prog p prec)))))
)
(list (tabula_lista lista '(2)) lista)
)
)
)


;;; TABULA UNA LISTA DE STRINGS EN 2D A 1D, CON SALTOS DE TABULADOR ;;;
;;; ENTRADA: lista=lista 2D con strings ;;;
;;; l_tab=lista 1D de enteros, con control de tabulaciones ;;;
;;; (ejm '(.... 0 2 5 ), el tabulador se cuenta desde;;;
;;; el 2do elemento de c/fila en "lista" 2D de entrada;;;
;;; ancho2=ancho de campos designados en el dcl ;;;
;;; SALIDA: lista1=lista formateada con tabuladores ;;;
(defun tabula_lista (lista l_tab / lista1 i j x y a m n l_tab1 ancho)
(setq i -1
j 0
m (strlen (itoa (length lista))))
;; Convierte lista de enteros de tabulación en símbolos de tabulación
(foreach x l_tab
(setq a ""
i (1+ i)
n (abs (fix (nth i l_tab))))
(repeat n
(setq a (strcat a "\t"))
)
(setq l_tab1 (append l_tab1 (list a)))
)
;; Completa espacios vacios en la izquierda
(if l_tab1
(setq ancho (ancho_campo lista 1.0 1.0)
i -1)
)
(foreach x lista
(setq i -1
j (1+ j)
a (strcat "\t" (completa_texto (itoa j) m)))
(foreach y x
(setq i (1+ i)
a (strcat a (nth i l_tab1) (completa_texto y (nth i ancho))))
)
(setq lista1 (append lista1 (list a)))
)
)

;;; ADICIONA VALORES EN DCL LIST-BOX ;;;
;;; ENTRADA: lista= lista con valores originales ;;;
;;; prec= precisión de presentación en dcl ;;;
;;; dcl1= key del list-box ;;;
;;; dcl2= key del edit-box asociado a dcl1 ;;;
;;; SALIDA: lista= valores actualizados del dcl ;;;
(defun adiciona-lista-dcl (lista prec dcl1 dcl2 / dcl1 dcl2 lista x a n prec )
(setq a (get_tile dcl2))
(if (/= a "")
(progn
(setq a (lee a ","))
(foreach x a
(setq x (lee x "+")
n (length x))
(if (< n 2)
(setq x (atof (nth 0 x)))
(setq x (+ (* 1000.0 (atof (nth 0 x))) (atof (nth 1 x))))
)
(setq lista (append lista (list x)))
)
(setq lista (depura-lista lista))
(actualiza-list-box lista dcl1 prec)
(set_tile dcl2 "")
)
)
(setq lista lista)
)

;;; BORRA LIST-BOX SEGUN SELECCION DE ITEMS ;;;
;;; ENTRADA: lista = lista 1D con valores ;;;
;;; prec = precisión de presentación ;;;
;;; dcl1 = key de list-box ;;;
;;; dcl2 = key de edit-box asociado a dcl1 ;;;
;;; SALIDA: lista con items borrados ;;;

(defun borra-lista-dcl (lista prec dcl1 dcl2 / i j k n lista prec dcl1 dcl2 lista1)
(setq i (get_tile dcl1))
(if (/= i "")
(progn
(setq i (eval (read (strcat "'(" i ")")))
n (length lista)
k 0
j 0)
(repeat n
(if (/= j (nth k i))
(setq lista1 (append lista1 (list (nth j lista))))
(setq k (1+ k))
)
(setq j (1+ j))
)
(actualiza-list-box lista1 dcl1 prec)
(set_tile dcl2 "")
)
)
(setq lista lista1)
)

;;;(defun borra-lista-dcl (lista prec dcl1 dcl2 / i j n lista prec dcl1 dcl2)
;;; (setq i (get_tile dcl1))
;;; (if (/= i "")
;;; (progn
;;; (setq i (eval (read (strcat "'(" i ")")))
;;; n (length lista))
;;; (foreach j i
;;; (if (or (> j -1)
;;; (< j n))
;;; (setq lista (borra_lista lista j))
;;; )
;;; )
;;; (actualiza-list-box lista dcl1 prec)
;;; (set_tile dcl2 "")
;;; )
;;; )
;;; (setq lista lista)
;;; )



;;; SUBRUTINA CALCULO DE ANCHOS DE CAMPO PARA IMPRESION DE CUADROS GRAFICOS SEGUN ;;;
;;; DATOS ALMACENADOS EN UNA LISTA CUALESQUIERA DE FORMATO: ;;;
;;; ((ELEMENTO1) (ELEMENTO2) (ELEMTO3)....(ELEMENTOn)) ;;;
(defun ancho_campo (lista h w / i j n m ancho1 ancho campo)
(setq w (* w h)
j -1
ancho (* 6.0 w)
m (length lista)
n 0
)
(if (> m 0)
(setq n (length (nth 0 lista)))
)
(repeat n
(setq i -1
j (1+ j)
)
(repeat m
(setq i (1+ i)
ancho1 (nth j (nth i lista)))
(if ancho1
(setq ancho1 (* (+ (strlen ancho1) 1.5) w))
(setq ancho1 0.0)
)
(setq ancho (max ancho ancho1)
)
)
(setq campo (append campo (list ancho)))
)
)

;;; RUTINA QUE COMPLETA CON ESPACIOS VACIOS EN LA IZQUIERDA DE UN TEXTO
;;; SEGUN ANCHO DE CAMPO PREDEFINDO
;;; ENTRADA: texto= string que define el texto de entrada
;;; espacio= ancho del campo de texto
;;; SALIDA: string con espacios en blanco a la izquierda del texto
;;; (si el espacio es menor que el ancho del texto, la
;;; rutina devolverá el texto inicial sin modificaciones)
(defun completa_texto (texto espacio / n)
(setq n (fix (- espacio (strlen texto))))
(repeat n
(setq texto (strcat " " texto))
)
(setq texto texto)
)



;;; RUTINA PARA CONVERTIR UN TEXTO NIL EN "", SI NO ES NIL, DEVOLVERA
;;; EL VALOR DEL TEXTO
(defun ver_file (texto)
(if (not texto)
(setq texto "")
)
(setq texto texto)
)

;;; RUTINA QUE EXTRAE LAS COORDENADAS GRABADAS EN UN ARCHIVO ASCII Y LAS
;;; ALMACENA EN UNA LISTA DATOS
;;; ENTRADA: file=Ruta y nombre del archivo ASCII
;;; SALIDA: datos=Lista con las coordenadas extraidas de file
(defun lee_file (file / indice datos linea vars a lista)
(if file
(progn
(setq indice (open file "r")
datos nil)
(while (/= (setq linea (read-line indice)) nil)
(setq vars (lee linea ",")
lista nil)
(foreach a vars (setq lista (append lista (list (atof a)))))
(setq datos (append datos (list lista)))
)
(close indice)
)
)
(setq datos datos)
)


;;; RUTINA PARA GRABAR COORDENADAS X,Y EN ARCHIVO ASCII
;;; ENTRADA: file=ruta y nombre completo del archivo a crear
;;; datos=lista con coordenadas
;;; SALIDA: Archivo ASCII
(defun graba (file datos / indice n m i j linea a separ)
(if (and file datos)
(progn
(setq n (length datos)
indice (open file "w")
i -1)
(repeat n
(setq i (1+ i)
j -1
a (nth i datos)
m (length a)
linea "")
(repeat m
(setq j (1+ j)
linea (strcat linea (rtos (nth j a) 2 20) ",")
)
)
(setq a (strlen linea)
linea (substr linea 1 (1- a)))
(write-line linea indice)
)
(close indice)
(setq file file)
)
)
)

;;; CONTROL DE CAJA DE DIALOGO ACEPTA_CANCELA
;;; ENTRADA: tile = Título del dcl
;;; texto=string. Texto
;;; SALIDA: true/nil
(defun dcl_control_progresivas10 (tile texto / control dcl_id indice val)
(setq control nil
dcl_id (load_dialog "progresivas.dcl")
texto (lee texto "\n"))
(while (not control)
(if (not (new_dialog "acepta_cancela" dcl_id "" dcl_progresivas_pto10))
(exit)
)
(set_tile "dcl_acepta" tile)
(set_tile "nombre_dcl" manlio)
(set_tile "dcl_txt" (nth 0 texto))
(set_tile "dcl_txt1" (nth 1 texto))
(action_tile "cancel" "(setq dcl_progresivas_pto10 (done_dialog 0))")
(action_tile "accept" "(setq dcl_progresivas_pto10 (done_dialog 1))")
(setq indice (start_dialog))
(cond
((= indice 0) (setq val nil
control 1))
((= indice 1) (setq val t
control 1))
)
)
(unload_dialog dcl_id)
(setq val val)
)

;;; CONVIERTE UNA LISTA 1D EN UN STRING, UTILIZANDO SUS COMPONENTES SEPARADOS POR COMAS ;;;
;;; ENTRADA: lista = LISTA 1D, ejm '("GOTA" "8" "J"...) ;;;
;;; SALIDA: lista1= STRING, ejm "GOTA, 8, j" ;;;
(defun separa-lista (lista / separ lista1 x)
(setq separ ""
lista1 "")
(foreach x lista
(setq lista1 (strcat lista1 separ x)
separ ",")
)
(setq lista lista1)
)

;; FUNCION SIGNO
(defun signo ( a )
(if (/= a 0.0)
(setq a (/ a (abs a)))
(setq a 0.0)
)
)

;;; RUTINA DE INSTALACION DE PROGRAMA ;;;
;;; DETERMINA TIEMPO DE DURACION DE RUTINA ;;;
(defun c:install (/ obj dia
#dias prog
ucs cdate
gap prec_dcl
font_list manlio
escala esp_prin
esp_sec cmdecho
char_width dwgprefix
dwgname file_progresivas
esp_inter radio_ubica1
radio_ubica2 toggle_progs
toggle_marcas fmto_progresivas
progresivas_cfg l_precision
cfg-name cfg-instal
f_rutina periodo
periodo1 dcl_progresivas_pto1
dcl_progresivas_pto2
dcl_progresivas_pto3
dcl_progresivas_pto4
dcl_progresivas_pto5
dcl_progresivas_pto6
dcl_progresivas_pto7
dcl_progresivas_pto8
dcl_progresivas_pto9
dcl_progresivas_pto10
nombre_layer_no_permitido)
(variables)
(setq control nil
dcl_id (load_dialog "progresivas.dcl")
cfg-instal (eval (read (strcat "'(" (getcfg cfg-name) ")")))
periodo1 (nth 2 cfg-instal))
(while (not control)
(if (not (new_dialog "manlio_code" dcl_id "" dcl_progresivas_pto9))
(exit)
)
; CONTROLA EDIT_BOX DEL PERIODO DE USO DE RUTINA
(set_tile "dcl_periodo" (rtos periodo 2 prec_dcl))
(edita_box "dcl_periodo" periodo "periodo" ">=" 0.0)
; ACTUALIZA NOMBRE
(set_tile "nombre_dcl" manlio)
; CONTROL DE BOTONES
(action_tile "dcl_code" "(setq code (get_tile \"dcl_code\"))")
(action_tile "cancel" "(setq dcl_progresivas_pto9 (done_dialog 0))")
(action_tile "accept" "(setq dcl_progresivas_pto9 (done_dialog 1))")
(setq indice (start_dialog))
(cond
((= indice 0) (setq control 1))
((= indice 1) (setq control 1))
)
)
(unload_dialog dcl_id)
(if (= indice 1)
(progn
(cond
((= code "MASI860443A") (setq periodo periodo))
((= code "PAPAPULI") (setq periodo 365))
((= code "ALBERTO") (setq periodo 60))
((= code "AMIGO") (setq periodo 30))
(t (setq code (alert "Clave Incorrecta!!!")))
)
(if code
(if (or
(and (/= code "MASI860443A")
(/= periodo1 periodo))
(= code "MASI860443A")
(= code "AMIGO"))
(progn
(setq cfg-instal cdate
cfg-fecha cdate)
(setcfg cfg-name (strcat (rtos cfg-instal 2 10)
" "
(rtos cfg-fecha 2 10)
" "
(rtos periodo 2 10)))
(alert "El programa ha sido instalado correctamente")
)
(alert "El programa sólo puede ser instalado una vez")
)
)
)
)
(princ)
)

;; FUNCION DE REINICIACION DE VALORES POR DEFECTO DE LA VARIABLE DE SISTEMA
;; DATOS, LA CUAL CONTROLA LOS FORMATOS Y LAYERS DEL PROGRAMA PRINCIPAL
;; ENTRADA: i= indice inicial de la matriz "datos" donde comienza reseteo
;; n= número de veces que se resetearán los valores de "datos"
;; datos = matriz con formatos, modificada por el dcl
;; data = matriz original con formatos por defecto, de ancho total
;; SALIDA: lista con matriz de datos por defecto, modificada segun i y n
(defun reinicia (i n datos data escala / k j)
(setq j i)
(repeat n
(setq datos (cambia1 j (nth j data) datos)
j (1+ j)
)
)
(setq k (/ escala (escala_ini))
j (- i 1)
)

(if (/= (type (nth 2 datos)) 'LIST)
(setq datos (cambia1 2 (* (nth 2 datos) k) datos))
(repeat n
(setq j (1+ j)
datos (cambia j 2 (* k (nth 2 (nth j data))) datos)
)
)
)
)

;;; FUNCION QUE REINICIA EL VALOR DE LA VARIABLE DE CONTROL "INDICADOR"
;;; "INDICADOR" CONTROLA EL VALOR POR DEFECTO DE LAS VARIABLES DE CONTROL
;;; DEL PROGRAMA. SI INDICADOR <> 1, SE TOMARAN LOS VALORES DE VARIABLES
;;; POR DEFECTO EN EL PROGRAMA
(defun c:reset_progresivas ( / file)
(if (setq file (findfile "progresivas.ini"))
(vl-file-delete file)
)
(alert
(strcat "Variable de control \"seccion_cfg\" descargada."
"\nPara seguir operando esta rutina escriba \"SECCION\""
"\n\n\t\t\t*** M.Santillán ***"
)
)
(princ)
)

Luis Alberto Benitez

Mensajes : 82
Fecha de inscripción : 29/03/2016

Volver arriba Ir abajo

lisp-para-generar-progresivas-de-un-alineamiento Empty Re: lisp-para-generar-progresivas-de-un-alineamiento

Mensaje por Contenido patrocinado


Contenido patrocinado


Volver arriba Ir abajo

Volver arriba

- Temas similares

 
Permisos de este foro:
No puedes responder a temas en este foro.