Autolisp - UTM para LatLon e viceversa

Bom, hoje vou voltar um pouco às origens do blog!!! Um pouco de autolisp pra relembrar os velhos tempos de programação em POG!!! A lisp abaixo na verdade são algumas subrotinas para conversão de coordenadas geográficas em UTM e viceversa. É bem fácil de usar se você souber o que é UTM e coordenada geográfica e está familiarizado com Georeferenciamento. Muitas pessoas me perguntam se eu tenho uma rotina pra converter e.... Bem, tenho!! Está aí!!

---

;| Conversão de UTM para GEOGRAFICA
baseado em http://recursos.gabrielortiz.com/index.asp?Info=058a
metodo: Coticchia-Surace
ay:     coorenada do semi eixo maior (m)
bx:     coorenada do semi eixo menor (m)
pt:     (cord_X coord_Y coord_Z)
fuso:   fuso, inteiro
hmsf:   hemisferio, "N" para norte e "S" para sul
se for conhecido f, temos: bx=(1-f)*ay
sad69 ->          ay = 6.378.160,000m e f = 1/298,25
corrego alegre -> ay = 6.378.388,000m e f = 1/297,00
(utm2geo (GETPOINT) 6378160.0  298.25 22 "S") => 25º25'51"15216  49º17'02"51881
|;
(defun utm2geo (pt ay f fuso hmsf / tmp e el el² c alpha lo phil nu A1 A2 J2 J4 re
                J6 beta gama Bo zeta xi eta sinhxi dl tau lat lon x y x1 y1 fe bx)
  (setq ay     (float ay)
        bx     (* ay (- 1 (/ 1.0 f)))
        x      (car pt)
        y      (cadr pt)
        re     6366197.724 ;raio da terra
        fe     0.9996      ;fator de escala
        tmp    (sqrt (- (expt ay 2) (expt bx 2)))
        e      (/ tmp ay) ;excentricidade
        el     (/ tmp bx) ;2ª excentricidade
        el²    (expt el 2)
        c      (/ (expt ay 2) bx);raio polar de curvatura
        x1     (- x 500000.0)
        y1     (if (or (= hmsf 'N) (= hmsf "N")) y (- y 10000000.0))
        phil   (/ y1 (* re fe))
        lo     (- (* 6 fuso) 183)
        nu     (/ (* c fe) (sqrt (1+ (* el² (expt (cos phil) 2)))))
        a      (/ x1 nu)
        A1     (sin (* 2 phil))
        A2     (* A1 (expt (cos phil) 2))
        J2     (+ phil (/ A1 2.0))
        J4     (/ (+ (* J2 3.0) A2) 4.0)
        J6     (/ (+ (* 5.0 J4) (* A2 (expt (cos phil) 2))) 3.0)
        alpha  (/ (* 3.0 el²) 4.0)
        beta   (* (/ 5.0 3.0) (expt alpha 2))
        gama   (* (/ 35.0 27.0) (expt alpha 3))
        Bo     (* fe c (+ phil (* (- alpha) J2) (* beta J4) (* (- gama) J6)))
        b      (/ (- y1 Bo) nu)
        zeta   (* (/ (* el² (expt a 2)) 2.0) (expt (cos phil) 2))
        xi     (* a (- 1.0 (/ zeta 3.0)))
        eta    (+ (* b (- 1.0 zeta)) phil)
        sinhxi (/ (- (exp xi) (exp (- xi))) 2.0)
        dl     (atan (/ sinhxi (cos eta)))
        tau    (atan (* (cos dl) (tan eta)))
        lon    (+ (* (/ 180.0 pi) dl) lo)
        lat    (* (/ 180.0 pi)
                  (+ phil (* (+ 1.0
                                (* el² (expt (cos phil) 2.0))
                                (* (/ -3.0 2.0) el² (sin phil) (cos phil) (- tau phil)))
                             (- tau phil)))))
  (if (caddr pt)
    (list lon lat (caddr pt))
    (list lon lat 0.0)))


;pt -> long lat
;a  -> semi eixo maior
;f  -> achatamento
(defun geo2utm (pt a f / b e el el² c lamb fi fuso lo deltal Am eps n v
                S A1 A2 J2 J4 J6 alfa beta gama bo)
  (setq a      (float a)
        b      (- a (/ a f))
        el     (/ (sqrt (- (expt a 2) (expt b 2))) b)
        el²    (expt el 2)
        c      (/ (expt a 2) b)
        fuso   (fix (+ (/ (car pt) 6.0) 31))
        lamb   (/ (* (car pt) pi) 180.0)
        fi     (/ (* (cadr pt) pi) 180.0)
        lo     (- (* fuso 6) 183) ;meridiano central
        deltal (- lamb (/ (* lo pi) 180.0))
        Am     (* (cos fi) (sin deltal))
        eps    (* 0.5 (log (/ (+ 1 Am) (- 1 Am))))
        n      (- (atan (/ (tan fi) (cos deltal))) fi)
        v      (/ (* c 0.9996) (sqrt (+ 1 (* el² (expt (cos fi) 2)))))
        S      (/ (expt (* el eps (cos fi)) 2) 2.0)
        A1     (sin (* 2.0 fi))
        A2     (* A1 (expt (cos fi) 2.0))
        J2     (+ fi (/ A1 2.0))
        J4     (/ (+ (* 3.0 J2) A2) 4.0)
        J6     (/ (+ (* 5 J4) (* A2 (expt (cos fi) 2))) 3.0)
        alfa   (/ (* 3.0 el²) 4.0)
        beta   (* (/ 5.0 3.0) (expt alfa 2))
        gama   (* (/ 35.0 27.0) (expt alfa 3))
        bo     (* 0.9996 c (+ fi (* (- alfa) J2) (* beta J4) (* (- gama) J6))))
  (list  (+ 500000.0 (* eps v (1+ (/ S 3.0)))) ;x
         (+ bo (* n v (1+ S)) (if (< lat 0.0) 10000000.0 0.0));y
         (caddr pt)
         ))

(defun LLA_wgs84->sad69 (pt)
   (geo2geo pt 6378137.0 298.257223563 6378160.0 298.25 66.87 -4.37  38.52))

(defun LLA_sad69->wgs84 (pt)
   (geo2geo pt 6378160.0 298.25  6378137.0 298.257223563 -66.87  4.37 -38.52))


      
(defun geo2geo (pt ;long_from lat_from h_from ;coordenadas geodesicas de origem
                a_from f_from             ;parametros geodesicos de origem
                a_to   f_to               ;parametros geodesicos de destino
                dx dy dz                  ;translação origem->destino
                / lat1 long1 f1 f2 a1 a2 e²1 e²2 N1 N2 Xw Yw Zw b2 p teta fi lamb hb ep²)
  (setq lat1   (/ (* (cadr pt) pi) 180.0)
        long1  (/ (* (car pt) pi) 180.0)
        f1     (/ 1.0 f_from)        ;wgs
        a1     a_from                ;wgs
        e²1    (* f1 (- 2.0 f1))
        N1     (/ a1 (sqrt (- 1.0 (* e²1 (expt (sin lat1) 2.0)))))
        ;coord carteziana no sistema de origem:
        Xw     (* (+ N1 (caddr pt)) (cos lat1) (cos long1))
        Yw     (* (+ N1 (caddr pt)) (cos lat1) (sin long1))
        Zw     (* (+ (* N1 (- 1.0 e²1)) (caddr pt)) (sin lat1))
        ;coord carteziana do ponto no novo sistema:
        Xb     (+ Xw dx)
        Yb     (+ Yw dy)
        Zb     (+ Zw dz)
        ;converter carteziana para geodesica:
        f2     (/ 1.0 f_to)
        a2     a_to
        e²2    (* f2 (- 2.0 f2))
        b2     (* a2 (- 1.0 f2))
        p      (sqrt (+ (expt Xb 2) (expt Yb 2)))
        teta   (atan (/ (* Zb a2) (* p b2)))
        ep²    (/ (- (expt a2 2.0) (expt b2 2.0)) (expt b2 2.0))
        fi     (atan (/ (+ Zb (* ep² b2 (expt (sin teta) 3.0))) (- p (* e²2 a2 (expt (cos teta) 3.0)))))
        lamb   (atan (/ Yb Xb))
        N2     (/ a2 (sqrt (- 1.0 (* e²2 (expt (sin fi) 2.0)))))
        hb     (- (/ p (cos fi)) N2))
  (list (/ (* 180.0 lamb) pi);long
        (/ (* 180.0 fi) pi)  ;lat
        hb)                  ;altitude
  )


Link(s) da(s) subrotina(s) usada(s): tan

---

A dificuldade nem está nos cálculos em si, mas na sintaxe das fórmulas, não acham??

ASIN

Função arco-seno, usada na rotina "Trajetória"

---

(defun asin (x) (/ x (sqrt (- 1.0 (expt x 2)))))

Visualizar arquivos SLD ou SLB

Dando continuidade ao post anterior, sobre slides e bibliotecas, vamos ver um visualizador de slides, bem útil quando se tem vários slides, seja em arquivos separados, ou numa SLB.

Você pode usar o Slideviewer, também se preferir.

Este programa,
;função para escolher um slide de um biblioteca
;(choose_sld "F:/autocad/drenagem e esgoto/Drenagem/de_fonts.slb")
;(choose_sld "c:/temp/")
(defun choose_sld (local / dcl dir tmp n offset slds num_col
                   num_lin img_witdh img_height img_bkgr img_off
                   key_prf key_scroll key_dlg index)
  (setq num_col    2   ;numero de colunas a mostrar no dcl
        num_lin    2   ;numero de linhas
        img_witdh  28  ;largura dos slides (em caracteres)
        img_height 10  ;altura dos slides (em nº de linhas)
        img_bkgr   -16 ;background color quando ativo
        img_off    -2  ;background color quando inativo
        key_prf    "S" ;prefixo das KEY das imagens
        key_scroll "SCROLL"  ;KEY do slide
        key_dlg    "exemplo" ;KEY do dialogo
;obtem a lista de slides, do diretorio, ou SLB:
        slds       (if (vl-filename-extension local);SLB?
                     (mapcar '(lambda (x) (strcat local "(" x ")"))
                             (slb2list local))
                     (mapcar '(lambda (x) (strcat local x))
                             (vl-directory-files local "*.sld")))
;valor maximo do slider
        maxval     (* num_lin num_col
                      (/ (length slds) (* num_lin num_col)))
        offset     maxval
        dcl        (choose:make_and_load_dcl))

;mostra o dcl na tela:
  (new_dialog key_dlg dcl)
;desenhas as imagens nele:
  (choose:popula_slides offset)
;inicia o dialog
  (if (/= 0 (start_dialog))
    (setq index (nth index slds)))
;descarrega da memoria
  (unload_dialog dcl)
  index)

(defun choose:make_and_load_dcl (/ filename file j dcl)
;cria um arquivo temporario
  (setq filename (vl-filename-mktemp "x.dcl")
        file     (open filename "w")
        j        0)
;escreve um dcl nele:
  (write-line
    (strcat key_dlg ": dialog { label = \"escolha a figura\";\n"
            ":row {\n"
            "  :column {// 1 coluna de " (itoa num_lin) " linhas visiveis\n")
    file)
  
;escreva uma matriz (linhas/colunas) de imagens
  (repeat num_lin
    (write-line (strcat "   :row {//uma linha de " (itoa num_col) " imagens")
      file)
    (repeat num_col
      (write-line
        (strcat
          ":image_button {\n"
          "key = \"" key_prf (itoa j) "\";\n" ;ID da imagem
          "height = " (itoa img_height) ";\n" ;altura, em nº de linhas de texto
          "width = " (itoa img_witdh) ";\n"   ;largura, en nº de caracteres\n
          "action = \"(choose:seleciona_img " (itoa j) ")\";}";acao
          )
        file)
      (Setq j   (1+ j)))
    (write-line "}" file))
  
;adiciona o slider:
  (write-line
    (strcat "}\n"
            ":slider {\n";barra deslizante a direita
            "layout = vertical;\n" ;barra na vertical
            "key = \"" key_scroll "\";\n"  ;ID da barrinha
            "max_value = " (itoa maxval) ";\n"
            "min_value = 0;\n" ;sempre zero
            "small_increment = " (itoa num_col) ";\n"
            "big_increment= " (itoa (* num_lin num_col))";\n"
            "action = \"(choose:popula_slides (atoi $value))\";\n"
            "value = " (itoa maxval) ";\n"
            "}}\n"
            ":column {:text{key=\"texto\";} ok_cancel;}}")
    file)
;fecha o arquivo, carrega o dcl na memoria e apaga o arquivo
  (close file)
  (setq dcl (load_dialog filename))
  (vl-file-delete filename)
;devolve o ID do dcl
  dcl)

;função que preenche as imagens com os slides
(defun choose:popula_slides (val / i w h nome)
  (setq    i 0
    offset  val)
  (repeat (* num_lin num_col)
;obtem as props do slide
    (setq nome (nth (+ i (- maxval offset)) slds)
          w (dimx_tile (strcat key_prf (itoa i)))
      h (dimy_tile (strcat key_prf (itoa i))))
    
;limpe de (re)desenha o slide
    (start_image (strcat key_prf (itoa i)))
    (if nome
      (progn ;desenha
        (fill_image 0 0 w h img_bkgr)
        (slide_image 0 0 w h nome))
      (fill_image 0 0 w h img_off));desabilita img
    (end_image)
;desabilita imagens nao preenchidas
    (mode_tile (strcat key_prf (itoa i))
      (if nome 0 1))
    (setq i (1+ i))))

;função que seleciona o nome do slide
(defun choose:seleciona_img (val)
  (setq index (+ val (- maxval offset)))
  (set_tile "texto" (nth index  slds)))

---

Link(s) da(s) subrotina(s) usada(s):
slb2list
pode ser usado em programas lisp, para que você possa escolher blocos por exemplo, basta ter os slides deles, já vi vários programinhas fazerem isso.
O problema é justamente quando se tem um número elevado de blocos, fica impossível mostrar todos numa única tela, veja como funciona neste:
digamos que você tenha esta biblioteca

, para visualizar ela no autocad, faríamos:
(choose_sld "F:/autocad/drenagem e esgoto/Drenagem/de_fonts.slb")
e teríamos esta tela:

Ao clicar uma imagem em seguida pressionar o botão "OK", o dcl encerra e nos devolve o caminho completo para ele, por exemplo:
"F:/autocad/drenagem e esgoto/Drenagem/de_fonts.slb(112)"

Agora suponha que tenhamos EXTRÍDO os slides dessa SLB (sim é possível) na pasta "C:\temp\"
faríamos:
(choose_sld "c:/temp/")
E obteríamos a mesma tela!!

A resposta seria:
"c:/temp/66.sld"
neste caso.

Analise a lisp, veja que é possível alterar o número de imagens visíveis facilmente apenas alterando o valor de algumas variáveis. Está bem comentado o código, você não deverá ter dificuldades!!!

Bibliotecas de Slides SLB

Você chegou ler aquele post sobre a dimensão dos slides? Cosneguiu usar pra alguma coisa? espero que sim, hehehe

Agora suponha que tenhamos uma biblioteca de slides (*.SLB), e queremos mostrar alguns deles... você sabe os nomes dos slides que que compõe a biblioteca? Se sabe, ótimo, se não sabe, bem, use esta lisp:

---

;extrai a lista de slides de uma biblioteca de slides SLB

(defun slb2list (filename / file lst str)
  (setq file (open filename "r")) ;abre o arquivo para leitura
  (repeat 31 (read-char file))    ;pula a informação da SLB
;enquanto nao lê caractere zero:
  (while (/= 0 (setq char (read-char file)))
;leu um caractere diferente de zero:
    (setq str (chr char))
;lê mais 31 então, para formar o nome completo:
    (repeat 31
      (setq str (strcat str (chr (read-char file)))))
;pula o lixo:
    (repeat 4 (read-char file))
;armazena o nome criado na lista:
    (setq lst (cons str lst)))
;fecha o arquivo:
  (close file)
;devolve a lista:
  (reverse lst))

---

Para usar é simples:
(slb2list "F:/autocad/drenagem e esgoto/Drenagem/de_fonts.slb")
Deverá retornar uma lista parecida com isso:
("65" "66" "teste" "slide")

Permutações

Uma subrotina para permutações.

Ver...

(defun permuteme (lst / global recursive subst2 swap)
  (setq
    ;função que substitui um elemento por outro numa lista:
    subst2 (lambda (lst pos elm / tmp)
         (repeat pos
           (Setq tmp (cons (car lst) tmp)
             lst (cdr lst)))
         (append (reverse tmp) (list elm) (cdr lst)))

    ;função que inverte as posições de 2 elementosnuma lista:
    swap   (lambda (lst p1 p2)
         (subst2 (subst2 lst p2 (nth p1 lst)) p1 (nth p2 lst)))

    ;função recursiva que cria as permutações
    recursive (lambda ( k / i len)
        (setq len (length lst))
        (if (= k len)
          (setq global (cons lst global))
          (progn
            (setq i k)
            (repeat (- len k)
              (setq lst (swap lst i k))
              (recursive  (1+ k))
              (setq lst (swap lst i k)
                i   (1+ i)))))))
  ;inicia a função recursiva, ela cria a lista global:
  (recursive 0)
  
  ;devolve a lista de permutações:
  global)

Com ela é possível criar uma lista com todas as permutações possíveis de uma lista, exemplo: (permuteme '(a b c d)) retorna:
((D A B C) (D A C B) (D C A B) (D C B A) (D B A C) (D B C A) (C D B A) (C D A B) (C A D B) (C A B D) (C B D A) (C B A D) (B D A C) (B D C A) (B C D A) (B C A D) (B A D C) (B A C D) (A D B C) (A D C B) (A C D B) (A C B D) (A B D C) (A B C D))

inivars

Este trecho de código abaixo, que não é bem uma subrotina, criar algumas variaveis globais que uso nos meus programas e carrega a TLB do civil 3d (2007 e 2008) e deve ser usada sempre que aparecer funções começando com "cvl*". para facilitar, elas estão destatacadas assim: "cvl*", pode parecer estranho, mas se você escreve programas grandes e complicados, deve estar separando o código em varios arquivos e depois junta tudo num VLX... se nao está, deveria, hehehe

mais...

(vl-load-com) ;2008-05-16
(setq acadapp     (vlax-get-acad-object)
      thisdrawing (vla-get-activedocument acadapp))

(setq aec-ver     (vla-get-version acadapp)
      aec-ver     (vl-position t
                    (list (= aec-ver "17.0s (LMS Tech)");2007
                          (= aec-ver "17.1s (LMS Tech)");2008
                          (= aec-ver "17.2s (LMS Tech)");2009
                        )))
(IF  aec-ver
  (PROGN
    (SETQ aec-tlb (strcat (vl-filename-directory (findfile "acad.exe"))
              "\\Civil\\AeccXLand"
              (nth aec-ver '("40" "" ""))
              ".tlb"))
    (if (not (vl-catch-all-error-p
           (Setq aec-app (vl-catch-all-apply
                   'vla-GetInterfaceObject
                   (list acadapp
                     (strcat "AeccXUiLand.AeccApplication."
                         (nth aec-ver
                          '("4.0" "5.0" "6.0"))))))))
      (setq aec-rod     (vla-GetInterfaceObject acadapp
              (strcat "AeccXUiRoadway.AeccRoadwayApplication."
                  (nth aec-ver '("4.0" "5.0" "6.0"))))
        aec-roaddoc (vla-get-activedocument aec-rod)
        aec-adoc    (vla-get-activedocument aec-app)
        aec-db      (vla-get-database aec-adoc)))

    (if (findfile aec-tlb)
      (vlax-import-type-library
    :tlb-filename aec-tlb
    :methods-prefix "cvlm-"
    :properties-prefix "cvlp-"
    :constants-prefix "cvlc-"))))

multi_set_action_tile

a subrotina abaixo serve para facilitar a criação de rotinas que usam DCLs, e será útil nas rotinas que estão por vir. Pode parecer meio estranhas no inicio, mas com um exemplo que postarei as coisas irão clarear... mas pelo título do post, dá pra imaginar o que é, não dá?

---

;vars: lista de strings com as "key" das tiles
;vals: lista dos valores que cada tile irá assumir, tanto na dcl como na variavel
;act:  "string" com a "action" que cada tile irá receber
(defun multi_set_action_tile (vars vals act / m tmp)
  (setq m "")
  (setq tmp (vl-catch-all-apply
              '(lambda (vars vals)
                (if (not vals) (setq vals (mapcar 'eval (mapcar 'read vars))))
                (mapcar '(lambda (k v / val p)
                           (if act (action_tile k act))
                           (setq m k)
                           (setset_tile2 k v))
                        vars vals))
             (list  vars vals)))
  (if (vl-catch-all-error-p tmp)
    (alert (strcat m "\n" (vl-catch-all-error-message tmp)))))

;|k :key
  v :valor a ser atribuido
      v pode ser:
        real
        int
        str
        nil
        ( "opn" [ou n]        ;valor que a variavel (READ K) irá receber
          ("op1" "op2" "opn") ;lista que polula a popup_list
          "key-popup_list")   ;key da popup_list que será populada
        (0 1 2 3)               ;indices a serem selecionados na popup_list
|;
(defun setset_tile2 (k v / val str l p)
  (setq val (if v v (eval (read k)))
    str (cond ((= 'real (type val))  (rtos val 2 3))
          ((= 'int (type val))   (itoa val))
          ((= 'str (type val))  val)
          ((null val)  "")
          ((and (listp val) (listp (setq l (cadr val))))
           (setq p   (vl-position (type (car val)) '(str int nil))
             tmp (if (= p 0)
                   (vl-position (car val) l)
                   (if (= p 1)
                 (if (< (car val) (length l))
                   (car val)))))
           (if (caddr v)
             (progn
               (start_list (caddr v) 3)
               (mapcar 'add_list l)
               (add_list " ")
               (end_list)))
           (setq val (if tmp (nth tmp l)))
           (itoa (if tmp tmp (length l))))
          (t (if (listp val)
                       (if (vl-every '(lambda (x) (= 'int (type x))) val)
                         (l2s val)
                         (vl-princ-to-string val))
                       (vl-princ-to-string val)))))
  (set (read k) val)
  (set_tile k str))

;transforma lista para string, se forem só numeros
(defun l2s (l /)
  (setq l (vl-princ-to-string l))
  (substr l 2 (- (strlen l) 2)))

Link(s) da(s) subrotina(s) usada(s):
setset_tile2, l2s, multi_set_action_tile